4 #use warnings; FIXME - Bug 2505
7 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
10 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
12 ###############################################################################
16 TmplTokenizer.pm - Simple-minded tokenizer class for HTML::Template .tmpl files
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.
28 ###############################################################################
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 );
39 ###############################################################################
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);
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*(?:--)?)>};
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 );
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)*.)*--|(?:}
70 . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)};
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));
80 # End of the hideous stuff
82 use vars qw( $serial );
84 ###############################################################################
86 sub FATAL_P () {'fatal-p'}
87 sub SYNTAXERROR_P () {'syntaxerror-p'}
89 sub FILENAME () {'input'}
90 sub HANDLE () {'handle'}
92 sub READAHEAD () {'readahead'}
93 sub LINENUM_START () {'lc_0'}
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
100 sub ALLOW_CFORMAT_P () {'allow-cformat-p'}
105 open my $handle,$filename or die "can't open $filename";
107 filename => $filename
113 ###############################################################################
119 return $this->{filename};
124 return $this->{handle};
129 return $this->{+FATAL_P};
134 return $this->{+SYNTAXERROR_P};
137 sub has_readahead_p {
139 return @{$this->{readahead}};
142 sub _peek_readahead {
144 return $this->{readahead}->[$#{$this->{readahead}}];
147 sub line_number_start {
149 return $this->{+LINENUM_START};
154 return $this->{+LINENUM};
159 return $this->{+CDATA_MODE_P};
164 return $this->{+PCDATA_MODE_P};
169 return $this->{+JS_MODE_P};
174 return $this->{+CDATA_CLOSE};
177 sub allow_cformat_p {
179 return $this->{+ALLOW_CFORMAT_P};
186 $this->{+FATAL_P} = $_[0];
190 sub _set_syntaxerror {
192 $this->{+SYNTAXERROR_P} = $_[0];
196 sub _push_readahead {
198 push @{$this->{readahead}}, $_[0];
204 return pop @{$this->{readahead}};
207 sub _append_readahead {
209 $this->{readahead}->[$#{$this->{readahead}}] .= $_[0];
215 $this->{readahead}->[$#{$this->{readahead}}] = $_[0];
219 sub _increment_line_number {
221 $this->{+LINENUM} += 1;
225 sub _set_line_number_start {
227 $this->{+LINENUM_START} = $_[0];
231 sub _set_cdata_mode {
233 $this->{+CDATA_MODE_P} = $_[0];
237 sub _set_pcdata_mode {
239 $this->{+PCDATA_MODE_P} = $_[0];
245 $this->{+JS_MODE_P} = $_[0];
249 sub _set_cdata_close {
251 $this->{+CDATA_CLOSE} = $_[0];
255 sub set_allow_cformat {
257 $this->{+ALLOW_CFORMAT_P} = $_[0];
261 ###############################################################################
263 use vars qw( $js_EscapeSequence );
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})};
268 sub parenleft () { '(' }
269 sub parenright () { ')' }
275 if ($s0 =~ /^\s+/s) { # whitespace
278 } elsif ($s0 =~ /^\/\/[^\r\n]*(?:[\r\n]|$)/s) { # C++-style comment
281 } elsif ($s0 =~ /^\/\*(?:(?!\*\/).)*\*\//s) { # C-style comment
284 # Keyword or identifier, ECMA-262 p.13 (section 7.5)
285 } elsif ($s0 =~ /^[A-Z_\$][A-Z\d_\$]*/is) { # IdentifierName
288 # Punctuator, ECMA-262 p.13 (section 7.6)
289 } elsif ($s0 =~ /^(?:[\(\){}\[\];]|>>>=|<<=|>>=|[-\+\*\/\&\|\^\%]=|>>>|<<|>>|--|\+\+|\|\||\&\&|==|<=|>=|!=|[=><,!~\?:\.\-\+\*\/\&\|\^\%])/s) {
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) {
296 # HexIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
297 } elsif ($s0 =~ /^0[xX][\da-fA-F]+/s) {
300 # OctalIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
301 } elsif ($s0 =~ /^0[\da-fA-F]+/s) {
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) {
309 } elsif ($s0 =~ /^./) { # UNKNOWN TOKEN !!!
317 sub STATE_UNDERSCORE () { 1 }
318 sub STATE_PARENLEFT () { 2 }
319 sub STATE_STRING_LITERAL () { 3 }
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 (@) {
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) {
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);
343 } elsif ($state == STATE_STRING_LITERAL) {
344 if ($input[$i] eq parenright) {
345 $output[$j] = [1, $output[$j]->[1], $q, $s];
349 die "identify_js_translatables internal error: Unknown state $state"
355 ###############################################################################
357 sub _extract_attributes ($;$) {
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
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, $');
368 $attr{+lc($key)} = [$key, $val, $val_orig, $i];
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;
378 "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
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;
385 "Unquoted attribute contains character(s) that should be quoted"
387 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
388 if $t =~ /[^-\.A-Za-z0-9]/s;
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 );
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;
403 warn_normal "Strange attribute syntax: $s\n", $lc;
410 sub _next_token_internal {
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;
422 $this->_increment_line_number;
423 $this->_push_readahead( $next );
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
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
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( $' );
450 } elsif ($next =~ /^((?:(?!$cdata_close).)+)($cdata_close)/is) {
451 ($kind, $it) = (TmplTokenType::TEXT, $1);
452 $this->_push_readahead( "$2$'" );
455 ($kind, $it) = (TmplTokenType::TEXT, $next);
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;
471 $this->{'_closed_start_tag_warning'} = [$head, $this->line_number];
473 ($kind, $it) = (TmplTokenType::TAG, "$head>");
474 $this->_set_readahead( $post );
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
479 } elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->)$re_directive*.)*-->/os) {
480 ($kind, $it) = (TmplTokenType::COMMENT, $&);
481 $this->_set_readahead( $' );
486 my $next = scalar <$h>;
487 $eof_p = !defined $next;
489 $this->_increment_line_number;
490 $this->_append_readahead( $next );
492 if ($kind ne TmplTokenType::TAG) {
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;
500 } elsif ($it =~ /^<\?/) {
501 $kind = TmplTokenType::PI;
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 );
510 if (!$ok_p && $eof_p) {
511 ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
512 $this->_set_readahead, undef;
513 $this->_set_syntaxerror( 1 );
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;
523 sub _next_token_intermediate {
525 my $h = $this->_handle;
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)|(opac-showreviews-rss)/ && $it->string =~ /^<(description)\b/) # FIXME special case to handle
532 # a CDATA in opac-opensearch.tmpl and opac-showreviews-rss.tmpl
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 );
543 $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
547 for ($it = '', my $cdata_close = $this->cdata_close;;) {
548 my $next = $this->_next_token_internal($h);
549 $eof_p = !defined $next;
551 if (defined $next && $next->string =~ /$cdata_close/is) {
552 $this->_push_readahead( $next ); # push entire TmplToken object
553 $this->_set_cdata_mode( 0 );
555 last unless $this->cdata_mode_p;
556 $it .= $next->string;
560 error_normal "Unexpected end of file while looking for "
562 . "\n", $this->line_number_start;
563 $this->_set_fatal( 1 );
564 $this->_set_syntaxerror( 1 );
566 if ($this->pcdata_mode_p) {
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;
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 )
580 if ($this->js_mode_p) {
581 my $s0 = $it->string;
584 if ($s0 =~ /^(\s*<!--\s*)(.*)(\s*--\s*>\s*)$/s) {
589 push @head, split_js $s0;
590 $it->set_js_data( identify_js_translatables(@head, @tail) );
592 $this->_set_pcdata_mode, 0;
593 $this->_set_cdata_close, undef unless !defined $it;
598 sub _token_groupable1_p ($) { # as first token, groupable into TEXT_PARAMETRIZED
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)
610 sub _token_groupable2_p ($) { # as other token, groupable into TEXT_PARAMETRIZED
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)))
621 sub _quote_cformat ($) {
627 sub string_canon ($) {
630 # Fold all whitespace into single blanks
636 sub _formalize_string_cformat ($) {
638 return _quote_cformat string_canon $s;
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':
651 _quote_cformat($t->string)):
652 _quote_cformat($t->string);
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];
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.
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;
680 if (!$has_other_tags_p) {
681 push @{$this->{_queue}}, [0, pop @structure]
682 &$undo_trailing_blanks;
683 $something_done_p = 1;
686 # FIXME: Do the same ugly hack for the last token being a ( or [
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;
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. :-(
698 && $structure[0]->type == TmplTokenType::TAG
699 && $structure[0]->string =~ /^<([a-z0-9]+)/is
700 && (my $tag = $1) !~ /^(?:br|hr|img|input)\b/is
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);
710 if ($tag_open_count > 0) {
711 for (my $i = $#structure; $i; $i -= 1) {
712 push @{$this->{_queue}}, [1, pop @structure];
714 $something_done_p = 1;
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
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;
733 if (!$has_other_open_or_close_tags_p) {
734 for (my $i = $#structure; $i; $i -= 1) {
735 push @{$this->{_queue}}, [1, pop @structure];
737 $something_done_p = 1;
740 last if !$something_done_p;
745 sub looks_plausibly_like_groupable_text_p (@) {
747 # The text would look plausibly groupable if all open tags are also closed.
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) {
755 if ($tag !~ /^(?:br|input)$/is && $form !~ /\/>$/is) {
758 } elsif ($form =~ /^<\/([A-Z0-9]+)/is) {
759 if (@tags && lc($1) eq $tags[$#tags]) {
765 } elsif ($structure[$i]->type != TmplTokenType::TEXT) {
770 return !$error_p && !@tags;
775 my $h = $this->_handle;
777 $this->{_queue} = [] unless defined $this->{_queue};
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];
784 if (@{$this->{_queue}}) {
785 $it = (pop @{$this->{_queue}})->[1];
787 $it = $this->_next_token_intermediate($h);
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 );
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) {
800 } elsif ($it->type == TmplTokenType::TAG && $it->string =~ /^<([A-Z0-9]+)/is) {
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';
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];
811 $next = $this->_next_token_intermediate($h);
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) {
821 } elsif ($next->type == TmplTokenType::TAG) {
822 if ($next->string =~ /^<([A-Z0-9]+)/is) {
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) {
829 $quit_p = 1 unless @tags && $close eq $tags[$#tags];
830 $quit_next_p = 1 if $close =~ /^h\d$/;
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) {
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);;
862 # Requeue the tokens thus seen for re-emitting, allow reanalysis
864 push @{$this->{_queue}}, [1, pop @structure];
867 $it = (pop @{$this->{_queue}})->[1];
871 if (defined $it && $it->type == TmplTokenType::TEXT) {
872 my $form = string_canon $it->string;
873 $it->set_form( $form );
878 ###############################################################################
880 # Other simple functions (These are not methods)
884 return $s =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var|$re_xsl)*$/os;
891 $s =~ s/^(\s|\ $re_end_entity)+//os; my $l1 = $l0 - length $s;
892 $s =~ s/(\s|\ $re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
893 return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
898 # Locale::PO->quote is buggy, it doesn't quote newlines :-/
899 $s =~ s/([\\"])/\\\1/gs;
901 #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
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) = @_;
910 my @params = $t->parameters_and_fields;
911 for (my $n = 0, my $fmt = $fmt_0; length $fmt;) {
912 if ($fmt =~ /^[^%]+/) {
915 } elsif ($fmt =~ /^%%/) {
918 } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/s) {
920 my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
922 if (defined $width && defined $prec && !$width && !$prec) {
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;
936 } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?([pS])/s) {
938 my($i, $width, $prec, $conv) = ((defined $1? $1: $n), $2, $3, $4);
941 my $param = $params[$i - 1];
942 if (!defined $param) {
943 warn_normal "$fmt_0: $&: Parameter $i not known", undef;
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;
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';
959 warn_normal "$&: Expected an INPUT, but found a "
960 . $param->type->to_string . "\n", undef
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;
967 } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
970 die "$&: Unknown or unsupported format specification\n"; #XXX
972 die "$&: Completely confused parametrizing\n";#XXX
976 my @anchors = $t->anchors;
977 for (my $n = 0, my $fmt = $it, $it = ''; length $fmt;) {
978 if ($fmt =~ /^(?:(?!<a\d+>).)+/is) {
981 } elsif ($fmt =~ /^<a(\d+)>/is) {
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;
990 die "Completely confused decoding anchors: $fmt\n";#XXX
996 sub charset_canon ($) {
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
1004 use vars qw( @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" );
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
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;
1041 ###############################################################################
1045 In addition to the basic scanning, this class will also perform
1052 Emulation of c-format strings (see below)
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.
1062 Automatic correction of some of the things warned about
1063 (e.g., SGML "closed start tag" notation).
1067 =head2 c-format strings emulation
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.
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.
1084 Because this is an incompatible change, this mode must be explicitly
1085 turned on using the set_cformat(1) method call.
1087 =head2 The flag characters
1089 The character % is followed by zero or more of the following flags:
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.
1101 =head2 The field width and precision
1103 An optional 0.0 can be specified for %s to specify
1104 that the <TMPL_VAR> should be suppressed.
1106 =head2 The conversion specifier
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.
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.
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.
1135 There is no code to save the tag name anywhere in the scanned token.
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.
1143 This tokenizer is mostly based
1144 on Ambrose's hideous Perl script known as subst.pl.