Pulled the tokenizer out into a module. Hope this has been done right.
This commit is contained in:
acli
parent
de8d0930ee
commit
59d2e35180
3 changed files with 493 additions and 255 deletions
372
misc/translator/TmplTokenizer.pm
Normal file
372
misc/translator/TmplTokenizer.pm
Normal file
|
|
@ -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 (<tag), $2 (>), 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 =~ /</s;
|
||||
} else { # tag/declaration/processing instruction
|
||||
my $ok_p = 0;
|
||||
for (;;) {
|
||||
if ($cdata_mode_p) {
|
||||
if ($readahead =~ /^$cdata_close/) {
|
||||
($kind, $it, $readahead) = (KIND_TAG, $&, $');
|
||||
$ok_p = 1;
|
||||
} else {
|
||||
($kind, $it, $readahead) = (KIND_TEXT, $readahead, undef);
|
||||
$ok_p = 1;
|
||||
}
|
||||
} elsif ($readahead =~ /^$re_tag_compat/os) {
|
||||
($kind, $it, $readahead) = (KIND_TAG, "$1>", $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 =~ /^<!/) {
|
||||
$kind = KIND_DECL;
|
||||
$kind = KIND_COMMENT if $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, "</$1\\s*>")
|
||||
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 <<EOF;
|
||||
Usage: $0 [OPTIONS]
|
||||
Extract strings from HTML file.
|
||||
|
||||
--debug-dump-only Do not extract strings; but display scanned tokens
|
||||
-f, --file=FILE Extract from the specified FILE
|
||||
--pedantic-warnings Issue warnings even for detected problems which
|
||||
are likely to be harmless
|
||||
--help Display this help and exit
|
||||
EOF
|
||||
exit($exitcode);
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
|
||||
sub usage_error (;$) {
|
||||
print STDERR "$_[0]\n" if @_;
|
||||
print STDERR "Try `$0 --help' for more information.\n";
|
||||
exit(-1);
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
|
||||
=head1 FUTURE PLANS
|
||||
|
||||
Code could be written to detect template variables and
|
||||
construct gettext-c-format-string-like meta-strings (e.g., "Results %s
|
||||
through %s of %s records" that will be more likely to be translatable
|
||||
to languages where word order is very unlike English word order.
|
||||
This will be relatively major rework, requiring corresponding
|
||||
rework in tmpl_process.pl
|
||||
|
||||
=cut
|
||||
102
misc/translator/VerboseWarnings.pm
Normal file
102
misc/translator/VerboseWarnings.pm
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
package VerboseWarnings;
|
||||
|
||||
use strict;
|
||||
require Exporter;
|
||||
|
||||
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
|
||||
|
||||
###############################################################################
|
||||
|
||||
=head1 NAME
|
||||
|
||||
VerboseWarnings.pm - Verbose warnings for Perl scripts
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Contains convenience functions to construct Unix-style informational,
|
||||
verbose warnings.
|
||||
|
||||
=cut
|
||||
|
||||
###############################################################################
|
||||
|
||||
$VERSION = 0.01;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(
|
||||
&set_application_name
|
||||
&set_input_file_name
|
||||
&set_pedantic_mode
|
||||
&pedantic_p
|
||||
&warn_normal
|
||||
&warn_pedantic
|
||||
&error_normal
|
||||
);
|
||||
|
||||
###############################################################################
|
||||
|
||||
use vars qw( $appName $input $input_abbr $pedantic_p $pedantic_tag );
|
||||
|
||||
sub set_application_name ($) {
|
||||
my($s) = @_;
|
||||
$appName = $& if !defined $appName && $s =~ /[^\/]+$/;
|
||||
}
|
||||
|
||||
sub set_input_file_name ($) {
|
||||
my($s) = @_;
|
||||
$input = $s;
|
||||
$input_abbr = $& if !defined $input && defined $s && $s =~ /[^\/]+$/;
|
||||
}
|
||||
|
||||
sub set_pedantic_mode ($) {
|
||||
my($p) = @_;
|
||||
$pedantic_p = $p;
|
||||
$pedantic_tag = $pedantic_p? '': ' (negligible)';
|
||||
}
|
||||
|
||||
sub pedantic_p () {
|
||||
return $pedantic_p;
|
||||
}
|
||||
|
||||
sub construct_warn_prefix ($$) {
|
||||
my($prefix, $lc) = @_;
|
||||
die "construct_warn_prefix called before set_application_name"
|
||||
unless defined $appName;
|
||||
die "construct_warn_prefix called before set_input_file_name"
|
||||
unless defined $input;
|
||||
die "construct_warn_prefix called before set_pedantic_mode"
|
||||
unless defined $pedantic_tag;
|
||||
|
||||
# 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 error_normal ($$) {
|
||||
my($msg, $lc) = @_;
|
||||
my $prefix = construct_warn_prefix('ERROR', $lc);
|
||||
$msg .= "\n" unless $msg =~ /\n$/s;
|
||||
warn "$prefix$msg";
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
|
|
@ -15,268 +15,28 @@
|
|||
# rework in tmpl_process.pl
|
||||
|
||||
use Getopt::Long;
|
||||
use TmplTokenizer;
|
||||
use VerboseWarnings;
|
||||
use strict;
|
||||
|
||||
use vars qw( $input );
|
||||
use vars qw( $debug_dump_only_p );
|
||||
use vars qw( $pedantic_p $pedantic_tag );
|
||||
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 (<tag), $2 (>), 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 =~ /</s;
|
||||
} else { # tag/declaration/processing instruction
|
||||
my $ok_p = 0;
|
||||
for (;;) {
|
||||
if ($cdata_mode_p) {
|
||||
if ($readahead =~ /^$cdata_close/) {
|
||||
($kind, $it, $readahead) = (KIND_TAG, $&, $');
|
||||
$ok_p = 1;
|
||||
} else {
|
||||
($kind, $it, $readahead) = (KIND_TEXT, $readahead, undef);
|
||||
$ok_p = 1;
|
||||
}
|
||||
} elsif ($readahead =~ /^$re_tag_compat/os) {
|
||||
($kind, $it, $readahead) = (KIND_TAG, "$1>", $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 =~ /^<!/) {
|
||||
$kind = KIND_DECL;
|
||||
$kind = KIND_COMMENT if $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, "</$1\\s*>")
|
||||
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;
|
||||
|
|
|
|||
Loading…
Reference in a new issue