From 59d2e3518078002046cfd3046d48360c96dfed1a Mon Sep 17 00:00:00 2001 From: acli Date: Mon, 16 Feb 2004 23:42:57 +0000 Subject: [PATCH] Pulled the tokenizer out into a module. Hope this has been done right. --- misc/translator/TmplTokenizer.pm | 372 +++++++++++++++++++++++++++++ misc/translator/VerboseWarnings.pm | 102 ++++++++ misc/translator/text-extract2.pl | 274 ++------------------- 3 files changed, 493 insertions(+), 255 deletions(-) create mode 100644 misc/translator/TmplTokenizer.pm create mode 100644 misc/translator/VerboseWarnings.pm diff --git a/misc/translator/TmplTokenizer.pm b/misc/translator/TmplTokenizer.pm new file mode 100644 index 0000000000..f672dc3f4d --- /dev/null +++ b/misc/translator/TmplTokenizer.pm @@ -0,0 +1,372 @@ +package TmplTokenizer; + +use strict; +use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic ); +require Exporter; + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +############################################################################### + +=head1 NAME + +TmplTokenizer.pm - Simple-minded tokenizer for HTML::Template .tmpl files + +=head1 DESCRIPTION + +Because .tmpl files contains HTML::Template directives +that tend to confuse real parsers (e.g., HTML::Parse), +it might be better to create a customized scanner +to scan the template files for tokens. +This module is a simple-minded attempt at such a scanner. + +=head1 HISTORY + +This tokenizer is mostly based +on Ambrose's hideous Perl script known as subst.pl. + +=cut + +############################################################################### + +$VERSION = 0.01; + +@ISA = qw(Exporter); +@EXPORT_OK = qw( + &KIND_TEXT + &KIND_CDATA + &KIND_TAG + &KIND_DECL + &KIND_PI + &KIND_DIRECTIVE + &KIND_COMMENT + &KIND_UNKNOWN +); + +use vars qw( $input ); +use vars qw( $debug_dump_only_p ); +use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p ); +use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p ); +use vars qw( $fatal_p ); + +############################################################################### + +# Hideous stuff +use vars qw( $re_directive $re_tmpl_var $re_tmpl_var_escaped $re_tmpl_include ); +use vars qw( $re_directive_control $re_tmpl_endif_endloop ); +BEGIN { + # $re_directive must not do any backreferences + $re_directive = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:VAR|LOOP|INCLUDE|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; + # TMPL_VAR or TMPL_INCLUDE + $re_tmpl_var = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; + $re_tmpl_include = q{<(?:(?i)(?:!--\s*)?TMPL_(?:INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; + # TMPL_VAR ESCAPE=1/HTML/URL + $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*(?:--)?)>}; + # Any control flow directive + $re_directive_control = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:LOOP|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; + # /LOOP or /IF or /UNLESS + $re_tmpl_endif_endloop = q{<(?:(?i)(?:!--\s*)?\/TMPL_(?:LOOP|IF|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; +} + +# Hideous stuff from subst.pl, slightly modified to use the above hideous stuff +# Note: The $re_tag's set $1 (), and $3 (rest of string) +use vars qw( $re_comment $re_entity_name $re_end_entity $re_etag ); +use vars qw( $re_tag_strict $re_tag_compat @re_tag ); +sub re_tag ($) { + my($compat) = @_; + my $etag = $compat? '>': '<>\/'; + # This is no longer similar to the original regexp in subst.pl :-( + # Note that we don't want <> in compat mode; Mozilla knows about < + q{(<\/?(?:|(?:"(?:} . $re_directive . q{|[^"])*"|'(?:} . $re_directive . q{|[^'])*'|--(?:[^-]|-[^-])*--|(?:} + . $re_directive + . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)}; +} +BEGIN { + $re_comment = '(?:--(?:[^-]|-[^-])*--)'; + $re_entity_name = '(?:[^&%#;<>\s]+)'; # NOTE: not really correct SGML + $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace + $re_etag = q{(?:<\/?(?:"[^"]*"|'[^']*'|[^"'>\/])*[>\/])}; # end-tag + @re_tag = ($re_tag_strict, $re_tag_compat) = (re_tag(0), re_tag(1)); +} + +# End of the hideous stuff + +sub KIND_TEXT () { 'TEXT' } +sub KIND_CDATA () { 'CDATA' } +sub KIND_TAG () { 'TAG' } +sub KIND_DECL () { 'DECL' } +sub KIND_PI () { 'PI' } +sub KIND_DIRECTIVE () { 'HTML::Template' } +sub KIND_COMMENT () { 'COMMENT' } # empty DECL with exactly one SGML comment +sub KIND_UNKNOWN () { 'ERROR' } + +use vars qw( $readahead $lc_0 $lc $syntaxerror_p ); +use vars qw( $cdata_mode_p $cdata_close ); + +############################################################################### + +# Easy accessors + +sub fatal_p () { + return $fatal_p; +} + +sub syntaxerror_p () { + return $syntaxerror_p; +} + +############################################################################### + +sub extract_attributes ($;$) { + my($s, $lc) = @_; + my %attr; + $s = $1 if $s =~ /^<\S+(.*)\/\S$/s # XML-style self-closing tags + || $s =~ /^<\S+(.*)\S$/s; # SGML-style tags + + 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;) { + my($key, $val, $val_orig, $rest) + = ($1, (defined $3? $3: defined $4? $4: $5), $2, $'); + $i += 1; + $attr{+lc($key)} = [$key, $val, $val_orig, $i]; + $s = $rest; + if ($val =~ /$re_tmpl_include/os) { + warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc; + } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) { + # XXX: we probably should not warn if key is "onclick" etc + # XXX: there's just no reasonable thing to suggest + my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML'); + undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i; + warn_pedantic + "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\"" + . ": $val_orig", + $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p + if defined $suggest && (pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p); + } elsif ($val_orig !~ /^['"]/) { + my $t = $val; $t =~ s/$re_directive_control//os; + warn_pedantic + "Unquoted attribute contains character(s) that should be quoted" + . ": $val_orig", + $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p + if $t =~ /[^-\.A-Za-z0-9]/s; + } + } + my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check + if ($s2 =~ /\S/s) { # should never happen + if ($s =~ /^([^\n]*)\n/s) { # this is even worse + error_normal("Completely confused while extracting attributes: $1", $lc); + error_normal((scalar(split(/\n/, $s)) - 1) . " more line(s) not shown.", undef); + $fatal_p = 1; + } else { + warn_normal "Strange attribute syntax: $s\n", $lc; + } + } + return \%attr; +} + +sub next_token_internal (*) { + my($h) = @_; + my($it, $kind); + my $eof_p = 0; + if (!defined $readahead || !length $readahead) { + my $next = scalar <$h>; + $eof_p = !defined $next; + if (!$eof_p) { + $lc += 1; + $readahead .= $next; + } + } + $lc_0 = $lc; # remember line number of first line + if ($eof_p && !length $readahead) { # nothing left to do + ; + } elsif ($readahead =~ /^\s+/s) { # whitespace + ($kind, $it, $readahead) = (KIND_TEXT, $&, $'); + # FIXME the following (the [<\s] part) is an unreliable HACK :-( + } elsif ($readahead =~ /^(?:[^<]|<[<\s])+/s) { # non-space normal text + ($kind, $it, $readahead) = (KIND_TEXT, $&, $'); + warn_normal "Warning: Unescaped < $it\n", $lc_0 + if !$cdata_mode_p && $it =~ /", $3); + $ok_p = 1; + warn_normal "SGML \"closed start tag\" notation: $1<\n", $lc_0 if $2 eq ''; + } elsif ($readahead =~ /^).)*-->/s) { + ($kind, $it, $readahead) = (KIND_COMMENT, $&, $'); + $ok_p = 1; + warn_normal "Syntax error in comment: $&\n", $lc_0; + $syntaxerror_p = 1; + } + last if $ok_p; + my $next = scalar <$h>; + $eof_p = !defined $next; + last if $eof_p; + $lc += 1; + $readahead .= $next; + } + if ($kind ne KIND_TAG) { + ; + } elsif ($it =~ /^).)*-->/; + } elsif ($it =~ /^<\?/) { + $kind = KIND_PI; + } + if ($it =~ /^$re_directive/ios && !$cdata_mode_p) { + $kind = KIND_DIRECTIVE; + } + if (!$ok_p && $eof_p) { + ($kind, $it, $readahead) = (KIND_UNKNOWN, $readahead, undef); + $syntaxerror_p = 1; + } + } + warn_normal "Unrecognizable token found: $it\n", $lc_0 + if $kind eq KIND_UNKNOWN; + return defined $it? (wantarray? ($kind, $it): + [$kind, $it]): undef; +} + +sub next_token (*) { + my($h) = @_; + my $it; + if (!$cdata_mode_p) { + $it = next_token_internal($h); + if (defined $it && $it->[0] eq KIND_TAG) { # FIXME + ($cdata_mode_p, $cdata_close) = (1, "") + if $it->[1] =~ /^<(script|style|textarea)\b/i; #FIXME + push @$it, extract_attributes($it->[1], $lc_0); #FIXME + } + } else { + for ($it = '';;) { + my $lc_prev = $lc; + my $next = next_token_internal($h); + last if !defined $next; + if (defined $next && $next->[1] =~ /$cdata_close/i) { #FIXME + ($lc, $readahead) = ($lc_prev, $next->[1] . $readahead); #FIXME + $cdata_mode_p = 0; + } + last unless $cdata_mode_p; + $it .= $next->[1]; #FIXME + } + $it = [KIND_CDATA, $it]; #FIXME + $cdata_close = undef; + } + return defined $it? (wantarray? @$it: $it): undef; +} + +############################################################################### + +sub debug_dump (*) { # for testing only + my($h) = @_; + print "re_tag_compat is /$re_tag_compat/\n"; + for (;;) { + my $s = next_token $h; + last unless defined $s; + printf "%s\n", ('-' x 79); + my($kind, $t, $attr) = @$s; # FIXME + printf "%s:\n", $kind; + printf "%4dH%s\n", length($t), + join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $t)); + if ($kind eq KIND_TAG && %$attr) { + printf "Attributes:\n"; + for my $a (keys %$attr) { + my($key, $val, $val_orig, $order) = @{$attr->{$a}}; + printf "%s = %dH%s -- %s\n", $a, length $val, + join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $val)), + $val_orig; + } + } + } +} + +############################################################################### + +sub trim ($) { + my($s) = @_; + $s =~ s/^(?:\s|\ $re_end_entity)+//os; + $s =~ s/(?:\s|\ $re_end_entity)+$//os; + return $s; +} + +############################################################################### + +sub text_extract (*) { + my($h) = @_; + my %text = (); + for (;;) { + my $s = next_token $h; + last unless defined $s; + my($kind, $t, $attr) = @$s; # FIXME + if ($kind eq KIND_TEXT) { + $t = trim $t; + $text{$t} = 1 if $t =~ /\S/s; + } elsif ($kind eq KIND_TAG && %$attr) { + # value [tag=input], meta + my $tag = lc($1) if $t =~ /^<(\S+)/s; + for my $a ('alt', 'content', 'title', 'value') { + if ($attr->{$a}) { + next if $a eq 'content' && $tag ne 'meta'; + next if $a eq 'value' && ($tag ne 'input' + || (ref $attr->{'type'} && $attr->{'type'}->[1] eq 'hidden')); # FIXME + my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME + $val = trim $val; + $text{$val} = 1 if $val =~ /\S/s; + } + } + } + } + # Emit all extracted strings. + # Don't emit pure whitespace, pure numbers, or TMPL_VAR's. + for my $t (keys %text) { + printf "%s\n", $t + unless $t =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var)*$/os || $t =~ /^\d+$/; + } +} + +############################################################################### + +sub usage ($) { + my($exitcode) = @_; + my $h = $exitcode? *STDERR: *STDOUT; + print $h <]+))*\s*(?:--)?)>}; - # TMPL_VAR or TMPL_INCLUDE - $re_tmpl_var = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; - $re_tmpl_include = q{<(?:(?i)(?:!--\s*)?TMPL_(?:INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; - # TMPL_VAR ESCAPE=1/HTML/URL - $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*(?:--)?)>}; - # Any control flow directive - $re_directive_control = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:LOOP|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; - # /LOOP or /IF or /UNLESS - $re_tmpl_endif_endloop = q{<(?:(?i)(?:!--\s*)?\/TMPL_(?:LOOP|IF|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>}; -} - -# Hideous stuff from subst.pl, slightly modified to use the above hideous stuff -# Note: The $re_tag's set $1 (), and $3 (rest of string) -use vars qw( $re_comment $re_entity_name $re_end_entity $re_etag ); -use vars qw( $re_tag_strict $re_tag_compat @re_tag ); -sub re_tag ($) { - my($compat) = @_; - my $etag = $compat? '>': '<>\/'; - # This is no longer similar to the original regexp in subst.pl :-( - # Note that we don't want <> in compat mode; Mozilla knows about < - q{(<\/?(?:|(?:"(?:} . $re_directive . q{|[^"])*"|'(?:} . $re_directive . q{|[^'])*'|--(?:[^-]|-[^-])*--|(?:} - . $re_directive - . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)}; -} -BEGIN { - $re_comment = '(?:--(?:[^-]|-[^-])*--)'; - $re_entity_name = '(?:[^&%#;<>\s]+)'; # NOTE: not really correct SGML - $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace - $re_etag = q{(?:<\/?(?:"[^"]*"|'[^']*'|[^"'>\/])*[>\/])}; # end-tag - @re_tag = ($re_tag_strict, $re_tag_compat) = (re_tag(0), re_tag(1)); -} - -# End of the hideous stuff - -sub KIND_TEXT () { 'TEXT' } -sub KIND_CDATA () { 'CDATA' } -sub KIND_TAG () { 'TAG' } -sub KIND_DECL () { 'DECL' } -sub KIND_PI () { 'PI' } -sub KIND_DIRECTIVE () { 'HTML::Template' } -sub KIND_COMMENT () { 'COMMENT' } # empty DECL with exactly one SGML comment -sub KIND_UNKNOWN () { 'ERROR' } - -use vars qw( $readahead $lc_0 $lc $syntaxerror_p ); -use vars qw( $cdata_mode_p $cdata_close ); - -############################################################################### - -use vars qw( $appName $input_abbr ); - -sub construct_warn_prefix ($$) { - my($prefix, $lc) = @_; - # Construct some short but should-be-still-useful versions - # of this script's name and the input file's name - my $appName = $& if !defined $appName && $0 =~ /[^\/]+$/; - my $input_abbr = $& if !defined $input_abbr && $input =~ /[^\/]+$/; - # FIXME: The line number is not accurate, but should be "close enough" - # FIXME: This wording is worse than what was there, but it's wrong to - # FIXME: hard-code this thing in each warn statement. Need improvement. - return "$appName: $prefix: " . (defined $lc? "$input_abbr: line $lc: ": "$input_abbr: "); -} - -sub warn_normal ($$) { - my($msg, $lc) = @_; - my $prefix = construct_warn_prefix('Warning', $lc); - $msg .= "\n" unless $msg =~ /\n$/s; - warn "$prefix$msg"; -} - -sub warn_pedantic ($$$) { - my($msg, $lc, $flag) = @_; - my $prefix = construct_warn_prefix("Warning$pedantic_tag", $lc); - $msg .= "\n" unless $msg =~ /\n$/s; - warn "$prefix$msg" if $pedantic_p || !$$flag; - if (!$pedantic_p) { - $prefix = construct_warn_prefix("Warning$pedantic_tag", undef); - warn $prefix."Further similar negligible warnings will not be reported, use --pedantic for details\n" unless $$flag; - $$flag = 1; - } -} - -############################################################################### - -sub extract_attributes ($;$) { - my($s, $lc) = @_; - my %attr; - $s = $1 if $s =~ /^<\S+(.*)\/\S$/s # XML-style self-closing tags - || $s =~ /^<\S+(.*)\S$/s; # SGML-style tags - - 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;) { - my($key, $val, $val_orig, $rest) - = ($1, (defined $3? $3: defined $4? $4: $5), $2, $'); - $i += 1; - $attr{+lc($key)} = [$key, $val, $val_orig, $i]; - $s = $rest; - if ($val =~ /$re_tmpl_include/os) { - warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc; - } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) { - # XXX: we probably should not warn if key is "onclick" etc - # XXX: there's just no reasonable thing to suggest - my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML'); - undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i; - warn_pedantic - "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\"" - . ": $val_orig", - $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p - if defined $suggest && ($pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p); - } elsif ($val_orig !~ /^['"]/) { - my $t = $val; $t =~ s/$re_directive_control//os; - warn_pedantic - "Unquoted attribute contains character(s) that should be quoted" - . ": $val_orig", - $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p - if $t =~ /[^-\.A-Za-z0-9]/s; - } - } - my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check - if ($s2 =~ /\S/s) { # should never happen - if ($s =~ /^([^\n]*)\n/s) { # this is even worse - my $prefix = construct_warn_prefix('Error: ', $lc); - warn $prefix . "Completely confused while extracting attributes" - . ": $1\n"; - warn $prefix . (scalar split(/\n/, $s) - 1) . " more line(s) not shown.\n"; - $fatal_p = 1; - } else { - warn "Strange attribute syntax: $s\n", $lc; - } - } - return \%attr; -} - -sub next_token_internal (*) { - my($h) = @_; - my($it, $kind); - my $eof_p = 0; - if (!defined $readahead || !length $readahead) { - my $next = scalar <$h>; - $eof_p = !defined $next; - if (!$eof_p) { - $lc += 1; - $readahead .= $next; - } - } - $lc_0 = $lc; # remember line number of first line - if ($eof_p && !length $readahead) { # nothing left to do - ; - } elsif ($readahead =~ /^\s+/s) { # whitespace - ($kind, $it, $readahead) = (KIND_TEXT, $&, $'); - # FIXME the following (the [<\s] part) is an unreliable HACK :-( - } elsif ($readahead =~ /^(?:[^<]|<[<\s])+/s) { # non-space normal text - ($kind, $it, $readahead) = (KIND_TEXT, $&, $'); - warn "Warning: Unescaped < $it\n", $lc_0 - if !$cdata_mode_p && $it =~ /", $3); - $ok_p = 1; - warn "SGML \"closed start tag\" notation: $1<\n", $lc_0 if $2 eq ''; - } elsif ($readahead =~ /^).)*-->/s) { - ($kind, $it, $readahead) = (KIND_COMMENT, $&, $'); - $ok_p = 1; - warn "Syntax error in comment: $&\n", $lc_0; - $syntaxerror_p = 1; - } - last if $ok_p; - my $next = scalar <$h>; - $eof_p = !defined $next; - last if $eof_p; - $lc += 1; - $readahead .= $next; - } - if ($kind ne KIND_TAG) { - ; - } elsif ($it =~ /^).)*-->/; - } elsif ($it =~ /^<\?/) { - $kind = KIND_PI; - } - if ($it =~ /^$re_directive/ios && !$cdata_mode_p) { - $kind = KIND_DIRECTIVE; - } - if (!$ok_p && $eof_p) { - ($kind, $it, $readahead) = (KIND_UNKNOWN, $readahead, undef); - $syntaxerror_p = 1; - } - } - warn "Unrecognizable token found: $it\n", $lc_0 - if $kind eq KIND_UNKNOWN; - return defined $it? (wantarray? ($kind, $it): - [$kind, $it]): undef; -} - -sub next_token (*) { - my($h) = @_; - my $it; - if (!$cdata_mode_p) { - $it = next_token_internal($h); - if (defined $it && $it->[0] eq KIND_TAG) { # FIXME - ($cdata_mode_p, $cdata_close) = (1, "") - if $it->[1] =~ /^<(script|style|textarea)\b/i; #FIXME - push @$it, extract_attributes($it->[1], $lc_0); #FIXME - } - } else { - for ($it = '';;) { - my $lc_prev = $lc; - my $next = next_token_internal($h); - last if !defined $next; - if (defined $next && $next->[1] =~ /$cdata_close/i) { #FIXME - ($lc, $readahead) = ($lc_prev, $next->[1] . $readahead); #FIXME - $cdata_mode_p = 0; - } - last unless $cdata_mode_p; - $it .= $next->[1]; #FIXME - } - $it = [KIND_CDATA, $it]; #FIXME - $cdata_close = undef; - } - return defined $it? (wantarray? @$it: $it): undef; -} +use vars qw( $pedantic_p ); ############################################################################### sub debug_dump (*) { # for testing only my($h) = @_; - print "re_tag_compat is /$re_tag_compat/\n"; + print "re_tag_compat is /$TmplTokenizer::re_tag_compat/\n"; for (;;) { - my $s = next_token $h; + my $s = TmplTokenizer::next_token $h; last unless defined $s; printf "%s\n", ('-' x 79); my($kind, $t, $attr) = @$s; # FIXME printf "%s:\n", $kind; printf "%4dH%s\n", length($t), join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $t)); - if ($kind eq KIND_TAG && %$attr) { + if ($kind eq TmplTokenizer::KIND_TAG && %$attr) { printf "Attributes:\n"; for my $a (keys %$attr) { my($key, $val, $val_orig, $order) = @{$attr->{$a}}; @@ -292,8 +52,8 @@ sub debug_dump (*) { # for testing only sub trim ($) { my($s) = @_; - $s =~ s/^(?:\s|\ $re_end_entity)+//os; - $s =~ s/(?:\s|\ $re_end_entity)+$//os; + $s =~ s/^(?:\s|\ $TmplTokenizer::re_end_entity)+//os; + $s =~ s/(?:\s|\ $TmplTokenizer::re_end_entity)+$//os; return $s; } @@ -303,13 +63,13 @@ sub text_extract (*) { my($h) = @_; my %text = (); for (;;) { - my $s = next_token $h; + my $s = TmplTokenizer::next_token $h; last unless defined $s; my($kind, $t, $attr) = @$s; # FIXME - if ($kind eq KIND_TEXT) { + if ($kind eq TmplTokenizer::KIND_TEXT) { $t = trim $t; $text{$t} = 1 if $t =~ /\S/s; - } elsif ($kind eq KIND_TAG && %$attr) { + } elsif ($kind eq TmplTokenizer::KIND_TAG && %$attr) { # value [tag=input], meta my $tag = lc($1) if $t =~ /^<(\S+)/s; for my $a ('alt', 'content', 'title', 'value') { @@ -328,7 +88,7 @@ sub text_extract (*) { # Don't emit pure whitespace, pure numbers, or TMPL_VAR's. for my $t (keys %text) { printf "%s\n", $t - unless $t =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var)*$/os || $t =~ /^\d+$/; + unless $t =~ /^(?:\s|\ $TmplTokenizer::re_end_entity|$TmplTokenizer::re_tmpl_var)*$/os || $t =~ /^\d+$/; } } @@ -366,7 +126,11 @@ GetOptions( 'pedantic-warnings' => sub { $pedantic_p = 1 }, 'help' => sub { usage(0) }, ) || usage_error; -$pedantic_tag = $pedantic_p? '': ' (negligible)'; + +VerboseWarnings::set_application_name $0; +VerboseWarnings::set_input_file_name $input; +VerboseWarnings::set_pedantic_mode $pedantic_p; + usage_error('Missing mandatory option -f') unless defined $input; open(INPUT, "<$input") || die "$0: $input: $!\n"; @@ -377,8 +141,8 @@ if ($debug_dump_only_p) { } warn "This input will not work with Mozilla standards-compliant mode\n", undef - if $syntaxerror_p; + if TmplTokenizer::syntaxerror_p; close INPUT; -exit(-1) if $fatal_p; +exit(-1) if TmplTokenizer::fatal_p; -- 2.39.5