summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/mfirstuc/mfirstuc.perl
blob: 7ab863d06f4287adf0f25b6c21eaf490086d4c2f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
# File        : mfirstuc.perl
# Author      : Nicola L. C. Talbot
# Date        : 2012-09-21
# Version     : 1.0
# Description : LaTeX2HTML (limited!) implementation of mfirstuc package

# This is a LaTeX2HTML style implementing the mfirstuc package, and
# is distributed as part of the glossaries package.
# Copyright 2007 Nicola L.C. Talbot
# This work may be distributed and/or modified under the
# conditions of the LaTeX Project Public License, either version 1.3
# of this license of (at your option) any later version.
# The latest version of this license is in
#   http://www.latex-project.org/lppl.txt
# and version 1.3 or later is part of all distributions of LaTeX
# version 2005/12/01 or later.
#
# This work has the LPPL maintenance status `maintained'.
#
# The Current Maintainer of this work is Nicola Talbot.

use warnings;

package main;

sub do_cmd_makefirstuc{
   local($_) = @_;

   local($id,$text);

   $text = &missing_braces unless
      s/$next_pair_pr_rx/$id=$1;$text=$2;''/eo;

   &translate_commands("\\glsmakefirstuc $text") . $_;
}

sub do_cmd_xmakefirstuc{
   local($_) = @_;

   local($id,$text);

   $text = &missing_braces unless
      s/$next_pair_pr_rx/$id=$1;$text=$2;''/eo;

   unless ($id)
   {
      $id = ++$global{'max_id'};
   }

   &translate_commands("\\expandafter \\makefirstuc $OP$id$CP$text$OP$id$CP")
   . $_;
}

sub do_cmd_glsmakefirstuc{
   local($_) = @_;

   local($id,$text);

   $text = &get_next_object unless
      s/$next_pair_pr_rx/$id=$1;$text=$2;''/eo;

   &do_real_makefirstuc($text).$_;
}

sub do_real_makefirstuc{
   local($text) = @_;

   if ($text=~/^((?:\s*<[^>]+>\s*)+)(.*)/)
   {
      $text = $1 . ucfirst($2);
   }
   else
   {
      $text = ucfirst($text);
   }

   $text;
}

sub do_cmd_capitalisewords{
   local($_) = @_;

   local($id,$text);

   $text = &missing_braces unless
      s/$next_pair_pr_rx/$id=$1;$text=$2;''/eo;

   local($newtext) = '';

   foreach my $word (split ' ', $text)
   {
      $id = ++$global{'max_id'};

      $word = &translate_commands("\\makefirstuc $OP$id$CP$word$OP$id$CP");

      if ($newtext)
      {
         $newtext .= ' ' . $word;
      }
      else
      {
         $newtext = $word;
      }
   }

   $newtext.$_;
}

sub get_next_object{
    local($next, $revert, $thisline);
    local($this_cmd) = $cmd;
    $this_cmd =~ s/^\\// unless ($cmd eq "\\");
    if (/^[\s%]*([^\n]*)\n/ ) {
        $thisline = &revert_to_raw_tex($1)
    } else {
        $thisline = &revert_to_raw_tex($_);
    }
    s/^\s*//;
    if ($_ =~ s/$next_token_rx//) { $next = $& };
    $next =~ s/$comment_mark(\d+\n?)?//g;
    if ($next =~ /^\\(\W|\d|[a-zA-z]*\b)/) {
        $revert = $next = "\\".$1;
    } elsif ($next =~ /\W/) {
        $revert = &revert_to_raw_tex($next);
    } else { $revert = $next };
    $next;
}

1;