misc/translator/TmplTokenizer.pm

   1 package TmplTokenizer;
   2
   3 use strict;
   4 #use warnings; FIXME - Bug 2505
   5 use TmplTokenType;
   6 use TmplToken;
   7 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
   8 require Exporter;
   9
  10 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  11
  12 ###############################################################################
  13
  14 =head1 NAME
  15
  16 TmplTokenizer.pm - Simple-minded tokenizer class for HTML::Template .tmpl files
  17
  18 =head1 DESCRIPTION
  19
  20 Because .tmpl files contains HTML::Template directives
  21 that tend to confuse real parsers (e.g., HTML::Parse),
  22 it might be better to create a customized scanner
  23 to scan the template files for tokens.
  24 This module is a simple-minded attempt at such a scanner.
  25
  26 =cut
  27
  28 ###############################################################################
  29
  30 $VERSION = 0.02;
  31
  32 @ISA = qw(Exporter);
  33 @EXPORT_OK = qw();
  34
  35 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
  36 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
  37 use vars qw( $pedantic_error_markup_in_pcdata_p );
  38
  39 ###############################################################################
  40
  41 # Hideous stuff
  42 use vars qw( $re_directive $re_tmpl_var $re_tmpl_var_escaped $re_tmpl_include );
  43 use vars qw( $re_directive_control $re_tmpl_endif_endloop $re_xsl);
  44 BEGIN {
  45     # $re_directive must not do any backreferences
  46     $re_directive = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:VAR|LOOP|INCLUDE|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  47     # TMPL_VAR or TMPL_INCLUDE
  48     $re_tmpl_var = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  49     $re_tmpl_include = q{<(?:(?i)(?:!--\s*)?TMPL_(?:INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  50     # TMPL_VAR ESCAPE=1/HTML/URL
  51     $re_xsl = q{<\/?(?:xsl:)(?:[\s\-a-zA-Z0-9"'\/\.\[\]\@\(\):=,$]+)\/?>};
  52     $re_tmpl_var_escaped = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR|INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))\s+ESCAPE=(?:1|HTML|URL)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  53     # Any control flow directive
  54     $re_directive_control = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:LOOP|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  55     # /LOOP or /IF or /UNLESS
  56     $re_tmpl_endif_endloop = q{<(?:(?i)(?:!--\s*)?\/TMPL_(?:LOOP|IF|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  57 }
  58
  59 # Hideous stuff from subst.pl, slightly modified to use the above hideous stuff
  60 # Note: The $re_tag's set $1 (<tag), $2 (>), and $3 (rest of string)
  61 use vars qw( $re_comment $re_entity_name $re_end_entity $re_etag );
  62 use vars qw( $re_tag_strict $re_tag_compat @re_tag );
  63 sub re_tag ($) {
  64    my($compat) = @_;
  65    my $etag = $compat? '>': '<>\/';
  66    # This is no longer similar to the original regexp in subst.pl :-(
  67    # Note that we don't want <> in compat mode; Mozilla knows about <
  68    q{(<\/?(?:|(?:"(?:} . $re_directive . q{|[^"])*"|'(?:} . $re_directive . q{|[^'])*'|--(?:(?!--)(?:$re_directive)*.)*--|(?:}
  69    . $re_directive
  70    . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)};
  71 }
  72 BEGIN {
  73     $re_comment = '(?:--(?:[^-]|-[^-])*--)';
  74     $re_entity_name = '(?:[^&%#;<>\s]+)'; # NOTE: not really correct SGML
  75     $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace
  76     $re_etag = q{(?:<\/?(?:"[^"]*"|'[^']*'|[^"'>\/])*[>\/])}; # end-tag
  77     @re_tag = ($re_tag_strict, $re_tag_compat) = (re_tag(0), re_tag(1));
  78 }
  79
  80 # End of the hideous stuff
  81
  82 use vars qw( $serial );
  83
  84 ###############################################################################
  85
  86 sub FATAL_P             () {'fatal-p'}
  87 sub SYNTAXERROR_P       () {'syntaxerror-p'}
  88
  89 sub FILENAME            () {'input'}
  90 sub HANDLE              () {'handle'}
  91
  92 sub READAHEAD           () {'readahead'}
  93 sub LINENUM_START       () {'lc_0'}
  94 sub LINENUM             () {'lc'}
  95 sub CDATA_MODE_P        () {'cdata-mode-p'}
  96 sub CDATA_CLOSE         () {'cdata-close'}
  97 sub PCDATA_MODE_P       () {'pcdata-mode-p'}    # additional submode for CDATA
  98 sub JS_MODE_P           () {'js-mode-p'}        # cdata-mode-p must also be true
  99
 100 sub ALLOW_CFORMAT_P     () {'allow-cformat-p'}
 101
 102 sub new {
 103     shift;
 104     my ($filename) = @_;
 105     open my $handle,$filename or die "can't open $filename";
 106     bless {
 107             filename => $filename
 108             , handle => $handle
 109             , readahead => []
 110     } , __PACKAGE__;
 111 }
 112
 113 ###############################################################################
 114
 115 # Simple getters
 116
 117 sub filename {
 118     my $this = shift;
 119     return $this->{filename};
 120 }
 121
 122 sub _handle {
 123     my $this = shift;
 124     return $this->{handle};
 125 }
 126
 127 sub fatal_p {
 128     my $this = shift;
 129     return $this->{+FATAL_P};
 130 }
 131
 132 sub syntaxerror_p {
 133     my $this = shift;
 134     return $this->{+SYNTAXERROR_P};
 135 }
 136
 137 sub has_readahead_p {
 138     my $this = shift;
 139     return @{$this->{readahead}};
 140 }
 141
 142 sub _peek_readahead {
 143     my $this = shift;
 144     return $this->{readahead}->[$#{$this->{readahead}}];
 145 }
 146
 147 sub line_number_start {
 148     my $this = shift;
 149     return $this->{+LINENUM_START};
 150 }
 151
 152 sub line_number {
 153     my $this = shift;
 154     return $this->{+LINENUM};
 155 }
 156
 157 sub cdata_mode_p {
 158     my $this = shift;
 159     return $this->{+CDATA_MODE_P};
 160 }
 161
 162 sub pcdata_mode_p {
 163     my $this = shift;
 164     return $this->{+PCDATA_MODE_P};
 165 }
 166
 167 sub js_mode_p {
 168     my $this = shift;
 169     return $this->{+JS_MODE_P};
 170 }
 171
 172 sub cdata_close {
 173     my $this = shift;
 174     return $this->{+CDATA_CLOSE};
 175 }
 176
 177 sub allow_cformat_p {
 178     my $this = shift;
 179     return $this->{+ALLOW_CFORMAT_P};
 180 }
 181
 182 # Simple setters
 183
 184 sub _set_fatal {
 185     my $this = shift;
 186     $this->{+FATAL_P} = $_[0];
 187     return $this;
 188 }
 189
 190 sub _set_syntaxerror {
 191     my $this = shift;
 192     $this->{+SYNTAXERROR_P} = $_[0];
 193     return $this;
 194 }
 195
 196 sub _push_readahead {
 197     my $this = shift;
 198     push @{$this->{readahead}}, $_[0];
 199     return $this;
 200 }
 201
 202 sub _pop_readahead {
 203     my $this = shift;
 204     return pop @{$this->{readahead}};
 205 }
 206
 207 sub _append_readahead {
 208     my $this = shift;
 209     $this->{readahead}->[$#{$this->{readahead}}] .= $_[0];
 210     return $this;
 211 }
 212
 213 sub _set_readahead {
 214     my $this = shift;
 215     $this->{readahead}->[$#{$this->{readahead}}] = $_[0];
 216     return $this;
 217 }
 218
 219 sub _increment_line_number {
 220     my $this = shift;
 221     $this->{+LINENUM} += 1;
 222     return $this;
 223 }
 224
 225 sub _set_line_number_start {
 226     my $this = shift;
 227     $this->{+LINENUM_START} = $_[0];
 228     return $this;
 229 }
 230
 231 sub _set_cdata_mode {
 232     my $this = shift;
 233     $this->{+CDATA_MODE_P} = $_[0];
 234     return $this;
 235 }
 236
 237 sub _set_pcdata_mode {
 238     my $this = shift;
 239     $this->{+PCDATA_MODE_P} = $_[0];
 240     return $this;
 241 }
 242
 243 sub _set_js_mode {
 244     my $this = shift;
 245     $this->{+JS_MODE_P} = $_[0];
 246     return $this;
 247 }
 248
 249 sub _set_cdata_close {
 250     my $this = shift;
 251     $this->{+CDATA_CLOSE} = $_[0];
 252     return $this;
 253 }
 254
 255 sub set_allow_cformat {
 256     my $this = shift;
 257     $this->{+ALLOW_CFORMAT_P} = $_[0];
 258     return $this;
 259 }
 260
 261 ###############################################################################
 262
 263 use vars qw( $js_EscapeSequence );
 264 BEGIN {
 265     # Perl quoting is really screwed up, but this common subexp is way too long
 266     $js_EscapeSequence = q{\\\\(?:['"\\\\bfnrt]|[^0-7xu]|[0-3]?[0-7]{1,2}|x[\da-fA-F]{2}|u[\da-fA-F]{4})};
 267 }
 268 sub parenleft  () { '(' }
 269 sub parenright () { ')' }
 270
 271 sub split_js ($) {
 272     my ($s0) = @_;
 273     my @it = ();
 274     while (length $s0) {
 275         if ($s0 =~ /^\s+/s) {                           # whitespace
 276             push @it, $&;
 277             $s0 = $';
 278         } elsif ($s0 =~ /^\/\/[^\r\n]*(?:[\r\n]|$)/s) { # C++-style comment
 279             push @it, $&;
 280             $s0 = $';
 281         } elsif ($s0 =~ /^\/\*(?:(?!\*\/).)*\*\//s) {   # C-style comment
 282             push @it, $&;
 283             $s0 = $';
 284         # Keyword or identifier, ECMA-262 p.13 (section 7.5)
 285         } elsif ($s0 =~ /^[A-Z_\$][A-Z\d_\$]*/is) {     # IdentifierName
 286             push @it, $&;
 287             $s0 = $';
 288         # Punctuator, ECMA-262 p.13 (section 7.6)
 289         } elsif ($s0 =~ /^(?:[\(\){}\[\];]|>>>=|<<=|>>=|[-\+\*\/\&\|\^\%]=|>>>|<<|>>|--|\+\+|\|\||\&\&|==|<=|>=|!=|[=><,!~\?:\.\-\+\*\/\&\|\^\%])/s) {
 290             push @it, $&;
 291             $s0 = $';
 292         # DecimalLiteral, ECMA-262 p.14 (section 7.7.3); note: bug in the spec
 293         } elsif ($s0 =~ /^(?:0|[1-9]\d+(?:\.\d*(?:[eE][-\+]?\d+)?)?)/s) {
 294             push @it, $&;
 295             $s0 = $';
 296         # HexIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
 297         } elsif ($s0 =~ /^0[xX][\da-fA-F]+/s) {
 298             push @it, $&;
 299             $s0 = $';
 300         # OctalIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
 301         } elsif ($s0 =~ /^0[\da-fA-F]+/s) {
 302             push @it, $&;
 303             $s0 = $';
 304         # StringLiteral, ECMA-262 p.17 (section 7.7.4)
 305         # XXX SourceCharacter doesn't seem to be defined (?)
 306         } elsif ($s0 =~ /^(?:"(?:(?!["\\\r\n]).|$js_EscapeSequence)*"|'(?:(?!['\\\r\n]).|$js_EscapeSequence)*')/os) {
 307             push @it, $&;
 308             $s0 = $';
 309         } elsif ($s0 =~ /^./) {                         # UNKNOWN TOKEN !!!
 310             push @it, $&;
 311             $s0 = $';
 312         }
 313     }
 314     return @it;
 315 }
 316
 317 sub STATE_UNDERSCORE     () { 1 }
 318 sub STATE_PARENLEFT      () { 2 }
 319 sub STATE_STRING_LITERAL () { 3 }
 320
 321 # XXX This is a crazy hack. I don't want to write an ECMAScript parser.
 322 # XXX A scanner is one thing; a parser another thing.
 323 sub identify_js_translatables (@) {
 324     my @input = @_;
 325     my @output = ();
 326     # We mark a JavaScript translatable string as in C, i.e., _("literal")
 327     # For simplicity, we ONLY look for "_" "(" StringLiteral ")"
 328     for (my $i = 0, my $state = 0, my($j, $q, $s); $i <= $#input; $i += 1) {
 329         my $reset_state_p = 0;
 330         push @output, [0, $input[$i]];
 331         if ($input[$i] !~ /\S/s) {
 332             ;
 333         } elsif ($state == 0) {
 334             $state = STATE_UNDERSCORE if $input[$i] eq '_';
 335         } elsif ($state == STATE_UNDERSCORE) {
 336             $state = $input[$i] eq parenleft ? STATE_PARENLEFT : 0;
 337         } elsif ($state == STATE_PARENLEFT) {
 338             if ($input[$i] =~ /^(['"])(.*)\1$/s) {
 339                 ($state, $j, $q, $s) = (STATE_STRING_LITERAL, $#output, $1, $2);
 340             } else {
 341                 $state = 0;
 342             }
 343         } elsif ($state == STATE_STRING_LITERAL) {
 344             if ($input[$i] eq parenright) {
 345                 $output[$j] = [1, $output[$j]->[1], $q, $s];
 346             }
 347             $state = 0;
 348         } else {
 349             die "identify_js_translatables internal error: Unknown state $state"
 350         }
 351     }
 352     return \@output;
 353 }
 354
 355 ###############################################################################
 356
 357 sub _extract_attributes ($;$) {
 358     my $this = shift;
 359     my($s, $lc) = @_;
 360     my %attr;
 361     $s = $1 if $s =~ /^<(?:(?!$re_directive_control)\S)+(.*)\/\S$/s     # XML-style self-closing tags
 362             || $s =~ /^<(?:(?!$re_directive_control)\S)+(.*)\S$/s;      # SGML-style tags
 363
 364     for (my $i = 0; $s =~ /^(?:$re_directive_control)?\s+(?:$re_directive_control)?(?:([a-zA-Z][-a-zA-Z0-9]*)\s*=\s*)?('((?:$re_directive|[^'])*)'|"((?:$re_directive|[^"])*)"|((?:$re_directive|[^\s<>])+))/os;) {
 365         my($key, $val, $val_orig, $rest)
 366                 = ($1, (defined $3? $3: defined $4? $4: $5), $2, $');
 367         $i += 1;
 368         $attr{+lc($key)} = [$key, $val, $val_orig, $i];
 369         $s = $rest;
 370         if ($val =~ /$re_tmpl_include/os) {
 371             warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc;
 372         } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) {
 373             # XXX: we probably should not warn if key is "onclick" etc
 374             # XXX: there's just no reasonable thing to suggest
 375             my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML');
 376             undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i;
 377             warn_pedantic
 378                     "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
 379                         . ": $val_orig",
 380                     $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p
 381                 if defined $suggest && (pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p);
 382         } elsif ($val_orig !~ /^['"]/) {
 383             my $t = $val; $t =~ s/$re_directive_control//os;
 384             warn_pedantic
 385                 "Unquoted attribute contains character(s) that should be quoted"
 386                     . ": $val_orig",
 387                 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
 388                 if $t =~ /[^-\.A-Za-z0-9]/s;
 389         }
 390     }
 391     my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check
 392     if ($s2 =~ /\S/s) { # should never happen
 393         if ($s =~ /^([^\n]*)\n/s) { # this is even worse
 394             error_normal("Completely confused while extracting attributes: $1", $lc);
 395             error_normal((scalar(split(/\n/, $s)) - 1) . " more line(s) not shown.", undef);
 396             $this->_set_fatal( 1 );
 397         } else {
 398             # There's something wrong with the attribute syntax.
 399             # We might be able to deduce a likely cause by looking more.
 400             if ($s =~ /^[a-z0-9]/is && "<foo $s>" =~ /^$re_tag_compat$/s) {
 401                 warn_normal "Probably missing whitespace before or missing quotation mark near: $s\n", $lc;
 402             } else {
 403                 warn_normal "Strange attribute syntax: $s\n", $lc;
 404             }
 405         }
 406     }
 407     return \%attr;
 408 }
 409
 410 sub _next_token_internal {
 411     my $this = shift;
 412     my($h) = @_;
 413     my($it, $kind);
 414     my $eof_p = 0;
 415     $this->_pop_readahead if $this->has_readahead_p
 416             && !ref $this->_peek_readahead
 417             && !length $this->_peek_readahead;
 418     if (!$this->has_readahead_p) {
 419         my $next = scalar <$h>;
 420         $eof_p = !defined $next;
 421         if (!$eof_p) {
 422             $this->_increment_line_number;
 423             $this->_push_readahead( $next );
 424         }
 425     }
 426     $this->_set_line_number_start( $this->line_number ); # remember 1st line num
 427     if ($this->has_readahead_p && ref $this->_peek_readahead) { # TmplToken obj.
 428         ($it, $kind) = ($this->_pop_readahead, undef);
 429     } elsif ($eof_p && !$this->has_readahead_p) {       # nothing left to do
 430         ;
 431     } elsif ($this->_peek_readahead =~ /^\s+/s) {       # whitespace
 432         ($kind, $it) = (TmplTokenType::TEXT, $&);
 433         $this->_set_readahead( $' );
 434     # FIXME the following (the [<\s] part) is an unreliable HACK :-(
 435     } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])*(?:[^<\s])/s) {        # non-space normal text
 436         ($kind, $it) = (TmplTokenType::TEXT, $&);
 437         $this->_set_readahead( $' );
 438         warn_normal "Unescaped < in $it\n", $this->line_number_start
 439                 if !$this->cdata_mode_p && $it =~ /</s;
 440     } else {                            # tag/declaration/processing instruction
 441         my $ok_p = 0;
 442         my $bad_comment_p = 0;
 443         for (my $cdata_close = $this->cdata_close;;) {
 444             if ($this->cdata_mode_p) {
 445                 my $next = $this->_pop_readahead;
 446                 if ($next =~ /^$cdata_close/is) {
 447                     ($kind, $it) = (TmplTokenType::TAG, $&);
 448                     $this->_push_readahead( $' );
 449                     $ok_p = 1;
 450                 } elsif ($next =~ /^((?:(?!$cdata_close).)+)($cdata_close)/is) {
 451                     ($kind, $it) = (TmplTokenType::TEXT, $1);
 452                     $this->_push_readahead( "$2$'" );
 453                     $ok_p = 1;
 454                 } else {
 455                     ($kind, $it) = (TmplTokenType::TEXT, $next);
 456                     $ok_p = 1;
 457                 }
 458             } elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
 459                 # If we detect a "closed start tag" but we know that the
 460                 # following token looks like a TMPL_VAR, don't stop
 461                 my($head, $tail, $post) = ($1, $2, $3);
 462                 if ($tail eq '' && $post =~ $re_tmpl_var) {
 463                     # Don't bother to show the warning if we're too confused
 464                     # FIXME. There's no method for _closed_start_tag_warning
 465                     if (!defined $this->{'_closed_start_tag_warning'}
 466                         || ($this->{'_closed_start_tag_warning'}->[0] eq $head
 467                         && $this->{'_closed_start_tag_warning'}->[1] != $this->line_number - 1)) {
 468                     warn_normal "Possible SGML \"closed start tag\" notation: $head<\n", $this->line_number
 469                             if split(/\n/, $head) < 10;
 470                     }
 471                     $this->{'_closed_start_tag_warning'} = [$head, $this->line_number];
 472                 } else {
 473                     ($kind, $it) = (TmplTokenType::TAG, "$head>");
 474                     $this->_set_readahead( $post );
 475                     $ok_p = 1;
 476                     warn_normal "SGML \"closed start tag\" notation: $head<\n", $this->line_number if $tail eq ''
 477                 and $head ne '<!DOCTYPE stylesheet ['; # another bit of temporary ugliness for bug 4472
 478                 }
 479             } elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->)$re_directive*.)*-->/os) {
 480                 ($kind, $it) = (TmplTokenType::COMMENT, $&);
 481                 $this->_set_readahead( $' );
 482                 $ok_p = 1;
 483                 $bad_comment_p = 1;
 484             }
 485         last if $ok_p;
 486             my $next = scalar <$h>;
 487             $eof_p = !defined $next;
 488         last if $eof_p;
 489             $this->_increment_line_number;
 490             $this->_append_readahead( $next );
 491         }
 492         if ($kind ne TmplTokenType::TAG) {
 493             ;
 494         } elsif ($it =~ /^<!/) {
 495             $kind = TmplTokenType::DECL;
 496             $kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
 497             if ($kind == TmplTokenType::COMMENT && $it =~ /^<!--\s*#include/s) {
 498                 warn_normal "Apache #include directive found instead of HTML::Template <TMPL_INCLUDE> directive", $this->line_number_start;
 499             }
 500         } elsif ($it =~ /^<\?/) {
 501             $kind = TmplTokenType::PI;
 502         }
 503         if ($it =~ /^$re_directive/ios && !$this->cdata_mode_p) {
 504             $kind = TmplTokenType::DIRECTIVE;
 505         } elsif ($bad_comment_p) {
 506             warn_normal sprintf("Syntax error in comment: %s\n", $it),
 507                     $this->line_number_start;
 508             $this->_set_syntaxerror( 1 );
 509         }
 510         if (!$ok_p && $eof_p) {
 511             ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
 512             $this->_set_readahead, undef;
 513             $this->_set_syntaxerror( 1 );
 514         }
 515     }
 516     warn_normal "Unrecognizable token found: "
 517             . (split(/\n/, $it) < 10? $it: '(too confused to show details)')
 518             . "\n", $this->line_number_start
 519         if $kind == TmplTokenType::UNKNOWN;
 520     return defined $it? (ref $it? $it: TmplToken->new($it, $kind, $this->line_number, $this->filename)): undef;
 521 }
 522
 523 sub _next_token_intermediate {
 524     my $this = shift;
 525     my $h = $this->_handle;
 526     my $it;
 527     if (!$this->cdata_mode_p) {
 528         $it = $this->_next_token_internal($h);
 529         if (defined $it && $it->type == TmplTokenType::TAG) {
 530             if ($it->string =~ /^<(script|style|textarea)\b/is ||
 531             ($this->filename =~ /opensearch/ && $it->string =~ /^<(description)\b/) # FIXME special case to handle
 532                                                                                     # a CDATA in opac-opensearch.tmpl
 533            ) {
 534                 $this->_set_cdata_mode( 1 );
 535                 $this->_set_cdata_close( "</$1\\s*>" );
 536                 $this->_set_pcdata_mode( 0 );
 537                 $this->_set_js_mode( lc($1) eq 'script' );
 538 #           } elsif ($it->string =~ /^<(title)\b/is) {
 539 #               $this->_set_cdata_mode( 1 );
 540 #               $this->_set_cdata_close( "</$1\\s*>" );
 541 #               $this->_set_pcdata_mode( 1 );
 542             }
 543             $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
 544         }
 545     } else {
 546         my $eof_p = 0;
 547         for ($it = '', my $cdata_close = $this->cdata_close;;) {
 548             my $next = $this->_next_token_internal($h);
 549             $eof_p = !defined $next;
 550         last if $eof_p;
 551             if (defined $next && $next->string =~ /$cdata_close/is) {
 552                 $this->_push_readahead( $next ); # push entire TmplToken object
 553                 $this->_set_cdata_mode( 0 );
 554             }
 555         last unless $this->cdata_mode_p;
 556             $it .= $next->string;
 557         }
 558         if ($eof_p) {
 559             $it = undef;
 560             error_normal "Unexpected end of file while looking for "
 561                     . $this->cdata_close
 562                     . "\n", $this->line_number_start;
 563             $this->_set_fatal( 1 );
 564             $this->_set_syntaxerror( 1 );
 565         }
 566         if ($this->pcdata_mode_p) {
 567             my $check = $it;
 568             $check =~ s/$re_directive//gos;
 569             warn_pedantic "Markup found in PCDATA\n", $this->line_number,
 570                             \$pedantic_error_markup_in_pcdata_p
 571                     if $check =~ /$re_tag_compat/s;
 572         }
 573         # PCDATA should be treated as text, not CDATA
 574         # Actually it should be treated as TEXT_PARAMETRIZED :-(
 575         $it = TmplToken->new( $it,
 576                         ($this->pcdata_mode_p?
 577                             TmplTokenType::TEXT: TmplTokenType::CDATA),
 578                         $this->line_number, $this->filename )
 579                 if defined $it;
 580         if ($this->js_mode_p) {
 581             my $s0 = $it->string;
 582             my @head = ();
 583             my @tail = ();
 584             if ($s0 =~ /^(\s*<!--\s*)(.*)(\s*--\s*>\s*)$/s) {
 585                 push @head, $1;
 586                 push @tail, $3;
 587                 $s0 = $2;
 588             }
 589             push @head, split_js $s0;
 590             $it->set_js_data( identify_js_translatables(@head, @tail) );
 591         }
 592         $this->_set_pcdata_mode, 0;
 593         $this->_set_cdata_close, undef unless !defined $it;
 594     }
 595     return $it;
 596 }
 597
 598 sub _token_groupable1_p ($) { # as first token, groupable into TEXT_PARAMETRIZED
 599     my($t) = @_;
 600     return ($t->type == TmplTokenType::TEXT && $t->string !~ /^[,\.:\|\s]+$/is)
 601         || ($t->type == TmplTokenType::DIRECTIVE
 602                 && $t->string =~ /^(?:$re_tmpl_var)$/os)
 603         || ($t->type == TmplTokenType::TAG
 604                 && ($t->string =~ /^<(?:a|b|em|h[123456]|i|u)\b/is
 605                 || ($t->string =~ /^<input\b/is
 606                     && $t->attributes->{'type'}->[1] =~ /^(?:radio|text)$/is)
 607                     ))
 608 }
 609
 610 sub _token_groupable2_p ($) { # as other token, groupable into TEXT_PARAMETRIZED
 611     my($t) = @_;
 612     return ($t->type == TmplTokenType::TEXT && ($t->string =~ /^\s*$/s || $t->string !~ /^[\|\s]+$/is))
 613         || ($t->type == TmplTokenType::DIRECTIVE
 614                 && $t->string =~ /^(?:$re_tmpl_var)$/os)
 615         || ($t->type == TmplTokenType::TAG
 616                 && ($t->string =~ /^<\/?(?:a|b|em|h[123456]|i|u)\b/is
 617                 || ($t->string =~ /^<input\b/is
 618                     && $t->attributes->{'type'}->[1] =~ /^(?:radio|text)$/is)))
 619 }
 620
 621 sub _quote_cformat ($) {
 622     my($s) = @_;
 623     $s =~ s/%/%%/g;
 624     return $s;
 625 }
 626
 627 sub string_canon ($) {
 628     my($s) = @_;
 629     if (1) { # FIXME
 630         # Fold all whitespace into single blanks
 631         $s =~ s/\s+/ /gs;
 632     }
 633     return $s;
 634 }
 635
 636 sub _formalize_string_cformat ($) {
 637     my($s) = @_;
 638     return _quote_cformat string_canon $s;
 639 }
 640
 641 sub _formalize ($) {
 642     my($t) = @_;
 643     return $t->type == TmplTokenType::DIRECTIVE? '%s':
 644            $t->type == TmplTokenType::TEXT?
 645                    _formalize_string_cformat($t->string):
 646            $t->type == TmplTokenType::TAG?
 647                    ($t->string =~ /^<a\b/is? '<a>':
 648                     $t->string =~ /^<input\b/is? (
 649                             lc $t->attributes->{'type'}->[1] eq 'text' ? '%S':
 650                             '%p'):
 651                     _quote_cformat($t->string)):
 652                _quote_cformat($t->string);
 653 }
 654
 655 sub _optimize {
 656     my $this = shift;
 657     my @structure = @_;
 658     my $undo_trailing_blanks = sub {
 659                 for (my $i = $#structure; $i >= 0; $i -= 1) {
 660                 last unless ($structure[$i]->type == TmplTokenType::TEXT && blank_p($structure[$i]->string)) ;#|| ($structure[$i]->type == TmplTokenType::TAG && $structure[$i]->string =~ /^<br\b/is);
 661                     # Queue element structure: [reanalysis-p, token]
 662                     push @{$this->{_queue}}, [1, pop @structure];
 663                 }
 664             };
 665     &$undo_trailing_blanks;
 666     while (@structure >= 2) {
 667         my $something_done_p = 0;
 668         # FIXME: If the last token is a close tag but there are no tags
 669         # FIXME: before it, drop the close tag back into the queue. This
 670         # FIXME: is an ugly hack to get rid of "foo %s</h1>" type mess.
 671         if (@structure >= 2
 672                 && $structure[$#structure]->type == TmplTokenType::TAG
 673                 && $structure[$#structure]->string =~ /^<\//s) {
 674             my $has_other_tags_p = 0;
 675             for (my $i = 0; $i < $#structure; $i += 1) {
 676                 $has_other_tags_p = 1
 677                         if $structure[$i]->type == TmplTokenType::TAG;
 678             last if $has_other_tags_p;
 679             }
 680             if (!$has_other_tags_p) {
 681                 push @{$this->{_queue}}, [0, pop @structure]
 682                 &$undo_trailing_blanks;
 683                 $something_done_p = 1;
 684             }
 685         }
 686         # FIXME: Do the same ugly hack for the last token being a ( or [
 687         if (@structure >= 2
 688                 && $structure[$#structure]->type == TmplTokenType::TEXT
 689                 && $structure[$#structure]->string =~ /^[\(\[]$/) { # not )]
 690             push @{$this->{_queue}}, [1, pop @structure];
 691             &$undo_trailing_blanks;
 692             $something_done_p = 1;
 693         }
 694         # FIXME: If the first token is an open tag, but there is no
 695         # FIXME: corresponding close tag, "drop the open tag", i.e.,
 696         # FIXME: requeue everything for reanalysis, except the frist tag. :-(
 697         if (@structure >= 2
 698                 && $structure[0]->type == TmplTokenType::TAG
 699                 && $structure[0]->string =~ /^<([a-z0-9]+)/is
 700                 && (my $tag = $1) !~ /^(?:br|hr|img|input)\b/is
 701         ) {
 702             my $tag_open_count = 1;
 703             for (my $i = 1; $i <= $#structure; $i += 1) {
 704                 if ($structure[$i]->type == TmplTokenType::TAG) {
 705                     if ($structure[$i]->string =~ /^<(\/?)$tag\b/is) {
 706                         $tag_open_count += ($1? -1: +1);
 707                     }
 708                 }
 709             }
 710             if ($tag_open_count > 0) {
 711                 for (my $i = $#structure; $i; $i -= 1) {
 712                     push @{$this->{_queue}}, [1, pop @structure];
 713                 }
 714                 $something_done_p = 1;
 715             }
 716         }
 717         # FIXME: If the first token is an open tag, the last token is the
 718         # FIXME: corresponding close tag, and there are no other close tags
 719         # FIXME: inbetween, requeue the tokens from the second token on,
 720         # FIXME: flagged as ok for re-analysis
 721         if (@structure >= 3
 722                 && $structure[0]->type == TmplTokenType::TAG
 723                 && $structure[0]->string =~ /^<([a-z0-9]+)/is && (my $tag = $1)
 724                 && $structure[$#structure]->type == TmplTokenType::TAG
 725                 && $structure[$#structure]->string =~ /^<\/$1\s*>$/is) {
 726             my $has_other_open_or_close_tags_p = 0;
 727             for (my $i = 1; $i < $#structure; $i += 1) {
 728                 $has_other_open_or_close_tags_p = 1
 729                         if $structure[$i]->type == TmplTokenType::TAG
 730                         && $structure[$i]->string =~ /^<\/?$tag\b/is;
 731             last if $has_other_open_or_close_tags_p;
 732             }
 733             if (!$has_other_open_or_close_tags_p) {
 734                 for (my $i = $#structure; $i; $i -= 1) {
 735                     push @{$this->{_queue}}, [1, pop @structure];
 736                 }
 737                 $something_done_p = 1;
 738             }
 739         }
 740     last if !$something_done_p;
 741     }
 742     return @structure;
 743 }
 744
 745 sub looks_plausibly_like_groupable_text_p (@) {
 746     my @structure = @_;
 747     # The text would look plausibly groupable if all open tags are also closed.
 748     my @tags = ();
 749     my $error_p = 0;
 750     for (my $i = 0; $i <= $#structure; $i += 1) {
 751         if ($structure[$i]->type == TmplTokenType::TAG) {
 752             my $form = $structure[$i]->string;
 753             if ($form =~ /^<([A-Z0-9]+)/is) {
 754                 my $tag = lc($1);
 755                 if ($tag !~ /^(?:br|input)$/is && $form !~ /\/>$/is) {
 756                     push @tags, $tag;
 757                 }
 758             } elsif ($form =~ /^<\/([A-Z0-9]+)/is) {
 759                 if (@tags && lc($1) eq $tags[$#tags]) {
 760                     pop @tags;
 761                 } else {
 762                     $error_p = 1;
 763                 }
 764             }
 765         } elsif ($structure[$i]->type != TmplTokenType::TEXT) {
 766             $error_p = 1;
 767         }
 768     last if $error_p;
 769     }
 770     return !$error_p && !@tags;
 771 }
 772
 773 sub next_token {
 774     my $this = shift;
 775     my $h = $this->_handle;
 776     my $it;
 777     $this->{_queue} = [] unless defined $this->{_queue};
 778
 779     # Elements in the queue are ordered pairs. The first in the ordered pair
 780     # specifies whether we are allowed to reanalysis; the second is the token.
 781     if (@{$this->{_queue}} && !$this->{_queue}->[$#{$this->{_queue}}]->[0]) {
 782         $it = (pop @{$this->{_queue}})->[1];
 783     } else {
 784         if (@{$this->{_queue}}) {
 785             $it = (pop @{$this->{_queue}})->[1];
 786         } else {
 787             $it = $this->_next_token_intermediate($h);
 788         }
 789         if (!$this->cdata_mode_p && $this->allow_cformat_p && defined $it
 790             && ($it->type == TmplTokenType::TEXT?
 791                 !blank_p( $it->string ): _token_groupable1_p( $it ))) {
 792             my @structure = ( $it );
 793             my @tags = ();
 794             my $next = undef;
 795             my($nonblank_text_p, $parametrized_p, $with_anchor_p, $with_input_p) = (0, 0, 0, 0);
 796             if ($it->type == TmplTokenType::TEXT) {
 797                 $nonblank_text_p = 1 if !blank_p( $it->string );
 798             } elsif ($it->type == TmplTokenType::DIRECTIVE) {
 799                 $parametrized_p = 1;
 800             } elsif ($it->type == TmplTokenType::TAG && $it->string =~ /^<([A-Z0-9]+)/is) {
 801                 my $tag = lc($1);
 802                 push @tags, $tag if $tag !~ /^(?:br|input)$/i;
 803                 $with_anchor_p = 1 if $tag eq 'a';
 804                 $with_input_p = 1 if $tag eq 'input';
 805             }
 806             # We hate | and || in msgid strings, so we try to avoid them
 807             for (my $i = 1, my $quit_p = 0, my $quit_next_p = ($it->type == TmplTokenType::TEXT && $it->string =~ /^\|+$/s);; $i += 1) {
 808                 if (@{$this->{_queue}}) {
 809                     $next = (pop @{$this->{_queue}})->[1];
 810                 } else {
 811                     $next = $this->_next_token_intermediate($h);
 812                 }
 813                 push @structure, $next; # for consistency (with initialization)
 814             last unless defined $next && _token_groupable2_p( $next );
 815             last if $quit_next_p;
 816                 if ($next->type == TmplTokenType::TEXT) {
 817                     $nonblank_text_p = 1 if !blank_p( $next->string );
 818                     $quit_p = 1 if $next->string =~ /^\|+$/s; # We hate | and ||
 819                 } elsif ($next->type == TmplTokenType::DIRECTIVE) {
 820                     $parametrized_p = 1;
 821                 } elsif ($next->type == TmplTokenType::TAG) {
 822                     if ($next->string =~ /^<([A-Z0-9]+)/is) {
 823                         my $tag = lc($1);
 824                         push @tags, $tag if $tag !~ /^(?:br|input)$/i;
 825                         $with_anchor_p = 1 if $tag eq 'a';
 826                         $with_input_p = 1 if $tag eq 'input';
 827                     } elsif ($next->string =~ /^<\/([A-Z0-9]+)/is) {
 828                         my $close = lc($1);
 829                         $quit_p = 1 unless @tags && $close eq $tags[$#tags];
 830                         $quit_next_p = 1 if $close =~ /^h\d$/;
 831                         pop @tags;
 832                     }
 833                 }
 834             last if $quit_p;
 835             }
 836             # Undo the last token, allowing reanalysis
 837             push @{$this->{_queue}}, [1, pop @structure];
 838             # Simply it a bit more
 839             @structure = $this->_optimize( @structure );
 840             if (@structure < 2) {
 841                 # Nothing to do
 842                 ;
 843             } elsif ($nonblank_text_p && ($parametrized_p || $with_anchor_p || $with_input_p)) {
 844                 # Create the corresponding c-format string
 845                 my $string = join('', map { $_->string } @structure);
 846                 my $form = join('', map { _formalize $_ } @structure);
 847                 my($a_counter, $input_counter) = (0, 0);
 848                 $form =~ s/<a>/ $a_counter += 1, "<a$a_counter>" /egs;
 849                 $form =~ s/<input>/ $input_counter += 1, "<input$input_counter>" /egs;
 850                 $it = TmplToken->new($string, TmplTokenType::TEXT_PARAMETRIZED,
 851                         $it->line_number, $it->pathname);
 852                 $it->set_form( $form );
 853                 $it->set_children( @structure );
 854             } elsif ($nonblank_text_p
 855                     && looks_plausibly_like_groupable_text_p( @structure )
 856                     && $structure[$#structure]->type == TmplTokenType::TEXT) {
 857                 # Combine the strings
 858                 my $string = join('', map { $_->string } @structure);
 859                 $it = TmplToken->new($string, TmplTokenType::TEXT,
 860                         $it->line_number, $it->pathname);;
 861             } else {
 862                 # Requeue the tokens thus seen for re-emitting, allow reanalysis
 863                 for (;;) {
 864                     push @{$this->{_queue}}, [1, pop @structure];
 865                 last if !@structure;
 866                 }
 867                 $it = (pop @{$this->{_queue}})->[1];
 868             }
 869         }
 870     }
 871     if (defined $it && $it->type == TmplTokenType::TEXT) {
 872         my $form = string_canon $it->string;
 873         $it->set_form( $form );
 874     }
 875     return $it;
 876 }
 877
 878 ###############################################################################
 879
 880 # Other simple functions (These are not methods)
 881
 882 sub blank_p ($) {
 883     my($s) = @_;
 884     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/os;
 885 }
 886
 887 sub trim ($) {
 888     my($s0) = @_;
 889     my $l0 = length $s0;
 890     my $s = $s0;
 891     $s =~ s/^(\s|\&nbsp$re_end_entity)+//os; my $l1 = $l0 - length $s;
 892     $s =~ s/(\s|\&nbsp$re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
 893     return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
 894 }
 895
 896 sub quote_po ($) {
 897     my($s) = @_;
 898     # Locale::PO->quote is buggy, it doesn't quote newlines :-/
 899     $s =~ s/([\\"])/\\\1/gs;
 900     $s =~ s/\n/\\n/g;
 901     #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
 902     return "\"$s\"";
 903 }
 904
 905 # Some functions that shouldn't be here... should be moved out some time
 906 sub parametrize ($$$$) {
 907     my($fmt_0, $cformat_p, $t, $f) = @_;
 908     my $it = '';
 909     if ($cformat_p) {
 910         my @params = $t->parameters_and_fields;
 911         for (my $n = 0, my $fmt = $fmt_0; length $fmt;) {
 912             if ($fmt =~ /^[^%]+/) {
 913                 $fmt = $';
 914                 $it .= $&;
 915             } elsif ($fmt =~ /^%%/) {
 916                 $fmt = $';
 917                 $it .= '%';
 918             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/s) {
 919                 $n += 1;
 920                 my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
 921                 $fmt = $';
 922                 if (defined $width && defined $prec && !$width && !$prec) {
 923                     ;
 924                 } elsif (defined $params[$i - 1]) {
 925                     my $param = $params[$i - 1];
 926                     warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
 927                             . $param->type->to_string . "\n", undef
 928                             if $param->type != TmplTokenType::DIRECTIVE;
 929                     warn_normal "$fmt_0: $&: Unsupported "
 930                                 . "field width or precision\n", undef
 931                             if defined $width || defined $prec;
 932                     warn_normal "$fmt_0: $&: Parameter $i not known", undef
 933                             unless defined $param;
 934                     $it .= defined $f? &$f( $param ): $param->string;
 935                 }
 936             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?([pS])/s) {
 937                 $n += 1;
 938                 my($i, $width, $prec, $conv) = ((defined $1? $1: $n), $2, $3, $4);
 939                 $fmt = $';
 940
 941                 my $param = $params[$i - 1];
 942                 if (!defined $param) {
 943                     warn_normal "$fmt_0: $&: Parameter $i not known", undef;
 944                 } else {
 945                     if ($param->type == TmplTokenType::TAG
 946                             && $param->string =~ /^<input\b/is) {
 947                         my $type = defined $param->attributes?
 948                                 lc($param->attributes->{'type'}->[1]): undef;
 949                         if ($conv eq 'S') {
 950                             warn_normal "$fmt_0: $&: Expected type=text, "
 951                                         . "but found type=$type", undef
 952                                     unless $type eq 'text';
 953                         } elsif ($conv eq 'p') {
 954                             warn_normal "$fmt_0: $&: Expected type=radio, "
 955                                         . "but found type=$type", undef
 956                                     unless $type eq 'radio';
 957                         }
 958                     } else {
 959                         warn_normal "$&: Expected an INPUT, but found a "
 960                                 . $param->type->to_string . "\n", undef
 961                     }
 962                     warn_normal "$fmt_0: $&: Unsupported "
 963                                 . "field width or precision\n", undef
 964                             if defined $width || defined $prec;
 965                     $it .= defined $f? &$f( $param ): $param->string;
 966                 }
 967             } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
 968                 $fmt = $';
 969                 $it .= $&;
 970                 die "$&: Unknown or unsupported format specification\n"; #XXX
 971             } else {
 972                 die "$&: Completely confused parametrizing\n";#XXX
 973             }
 974         }
 975     }
 976     my @anchors = $t->anchors;
 977     for (my $n = 0, my $fmt = $it, $it = ''; length $fmt;) {
 978         if ($fmt =~ /^(?:(?!<a\d+>).)+/is) {
 979             $fmt = $';
 980             $it .= $&;
 981         } elsif ($fmt =~ /^<a(\d+)>/is) {
 982             $n += 1;
 983             my $i  = $1;
 984             $fmt = $';
 985             my $anchor = $anchors[$i - 1];
 986             warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
 987                     unless defined $anchor;
 988             $it .= $anchor->string;
 989         } else {
 990             die "Completely confused decoding anchors: $fmt\n";#XXX
 991         }
 992     }
 993     return $it;
 994 }
 995
 996 sub charset_canon ($) {
 997     my($charset) = @_;
 998     $charset = uc($charset);
 999     $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
1000     $charset = 'Big5' if $charset eq 'BIG5'; # "Big5" must be in mixed case
1001     return $charset;
1002 }
1003
1004 use vars qw( @latin1_utf8 );
1005 @latin1_utf8 = (
1006     "\302\200", "\302\201", "\302\202", "\302\203", "\302\204", "\302\205",
1007     "\302\206", "\302\207", "\302\210", "\302\211", "\302\212", "\302\213",
1008     "\302\214", "\302\215",   undef,      undef,    "\302\220", "\302\221",
1009     "\302\222", "\302\223", "\302\224", "\302\225", "\302\226", "\302\227",
1010     "\302\230", "\302\231", "\302\232", "\302\233", "\302\234", "\302\235",
1011     "\302\236", "\302\237", "\302\240", "\302\241", "\302\242", "\302\243",
1012     "\302\244", "\302\245", "\302\246", "\302\247", "\302\250", "\302\251",
1013     "\302\252", "\302\253", "\302\254", "\302\255", "\302\256", "\302\257",
1014     "\302\260", "\302\261", "\302\262", "\302\263", "\302\264", "\302\265",
1015     "\302\266", "\302\267", "\302\270", "\302\271", "\302\272", "\302\273",
1016     "\302\274", "\302\275", "\302\276", "\302\277", "\303\200", "\303\201",
1017     "\303\202", "\303\203", "\303\204", "\303\205", "\303\206", "\303\207",
1018     "\303\210", "\303\211", "\303\212", "\303\213", "\303\214", "\303\215",
1019     "\303\216", "\303\217", "\303\220", "\303\221", "\303\222", "\303\223",
1020     "\303\224", "\303\225", "\303\226", "\303\227", "\303\230", "\303\231",
1021     "\303\232", "\303\233", "\303\234", "\303\235", "\303\236", "\303\237",
1022     "\303\240", "\303\241", "\303\242", "\303\243", "\303\244", "\303\245",
1023     "\303\246", "\303\247", "\303\250", "\303\251", "\303\252", "\303\253",
1024     "\303\254", "\303\255", "\303\256", "\303\257", "\303\260", "\303\261",
1025     "\303\262", "\303\263", "\303\264", "\303\265", "\303\266", "\303\267",
1026     "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
1027     "\303\276", "\303\277" );
1028
1029 sub charset_convert ($$$) {
1030     my($s, $charset_in, $charset_out) = @_;
1031     if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
1032         ;
1033     } elsif ($charset_in eq 'ISO-8859-1' && $charset_out eq 'UTF-8') {
1034         $s =~ s/[\200-\377]/ $latin1_utf8[ord($&) - 128] /egs;
1035     } elsif ($charset_in ne $charset_out) {
1036         VerboseWarnings::warn_normal "conversion from $charset_in to $charset_out is not supported\n", undef;
1037     }
1038     return $s;
1039 }
1040
1041 ###############################################################################
1042
1043 =pod
1044
1045 In addition to the basic scanning, this class will also perform
1046 the following:
1047
1048 =over
1049
1050 =item -
1051
1052 Emulation of c-format strings (see below)
1053
1054 =item -
1055
1056 Display of warnings for certain things that affects either the
1057 ability of this class to yield correct output, or things that
1058 are known to cause the original template to cause trouble.
1059
1060 =item -
1061
1062 Automatic correction of some of the things warned about
1063 (e.g., SGML "closed start tag" notation).
1064
1065 =back
1066
1067 =head2 c-format strings emulation
1068
1069 Because English word order is not universal, a simple extraction
1070 of translatable strings may yield some strings like "Accounts for"
1071 or ambiguous strings like "in". This makes the resulting strings
1072 difficult to translate, but does not affect all languages alike.
1073 For example, Chinese (with a somewhat different word order) would
1074 be hit harder, but French would be relatively unaffected.
1075
1076 To overcome this problem, the scanner can be configured to detect
1077 patterns with <TMPL_VAR> directives (as well as certain HTML tags),
1078 and try to construct a larger pattern that will appear in the PO
1079 file as c-format strings with %s placeholders. This additional
1080 step allows the translator to deal with cases where word order
1081 is different (replacing %s with %1$s, %2$s, etc.), or when certain
1082 words will require certain inflectional suffixes in sentences.
1083
1084 Because this is an incompatible change, this mode must be explicitly
1085 turned on using the set_cformat(1) method call.
1086
1087 =head2 The flag characters
1088
1089 The character % is followed by zero or more of the following flags:
1090
1091 =over
1092
1093 =item #
1094
1095 The value comes from HTML <INPUT> elements.
1096 This abuse of the flag character is somewhat reasonable,
1097 since TMPL_VAR and INPUT are both variables, but of different kinds.
1098
1099 =back
1100
1101 =head2 The field width and precision
1102
1103 An optional 0.0 can be specified for %s to specify
1104 that the <TMPL_VAR> should be suppressed.
1105
1106 =head2 The conversion specifier
1107
1108 =over
1109
1110 =item p
1111
1112 Specifies any input field that is neither text nor hidden
1113 (which currently mean radio buttons).
1114 The p conversion specifier is chosen because this does not
1115 evoke any certain sensible data type.
1116
1117 =item S
1118
1119 Specifies a text input field (<INPUT TYPE=TEXT>).
1120 This use of the S conversion specifier is somewhat reasonable,
1121 since text input fields contain values of undeterminable type,
1122 which can be treated as strings.
1123
1124 =item s
1125
1126 Specifies a <TMPL_VAR>.
1127 This use of the o conversion specifier is somewhat reasonable,
1128 since <TMPL_VAR> denotes values of undeterminable type, which
1129 can be treated as strings.
1130
1131 =back
1132
1133 =head1 BUGS
1134
1135 There is no code to save the tag name anywhere in the scanned token.
1136
1137 The use of <AI<i>> to stand for the I<i>th anchor
1138 is not very well thought out.
1139 Some abuse of c-format specifies might have been more appropriate.
1140
1141 =head1 HISTORY
1142
1143 This tokenizer is mostly based
1144 on Ambrose's hideous Perl script known as subst.pl.
1145
1146 =cut
1147
1148 1;