[Koha-cvs] CVS: koha/misc/translator TmplTokenizer.pm,NONE,1.1 VerboseWarnings.pm,NONE,1.1 text-extract2.pl,1.33,1.34
Ambrose Li
acli at users.sourceforge.net
Tue Feb 17 00:42:59 CET 2004
Update of /cvsroot/koha/koha/misc/translator
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4517
Modified Files:
text-extract2.pl
Added Files:
TmplTokenizer.pm VerboseWarnings.pm
Log Message:
Pulled the tokenizer out into a module. Hope this has been done right.
--- NEW FILE ---
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
--- NEW FILE ---
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";
}
###############################################################################
Index: text-extract2.pl
===================================================================
RCS file: /cvsroot/koha/koha/misc/translator/text-extract2.pl,v
retrieving revision 1.33
retrieving revision 1.34
diff -C2 -r1.33 -r1.34
*** text-extract2.pl 16 Feb 2004 22:50:34 -0000 1.33
--- text-extract2.pl 16 Feb 2004 23:42:57 -0000 1.34
***************
*** 16,266 ****
use Getopt::Long;
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;
! }
###############################################################################
--- 16,26 ----
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 );
###############################################################################
***************
*** 268,274 ****
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);
--- 28,34 ----
sub debug_dump (*) { # for testing only
my($h) = @_;
! print "re_tag_compat is /$TmplTokenizer::re_tag_compat/\n";
for (;;) {
! my $s = TmplTokenizer::next_token $h;
last unless defined $s;
printf "%s\n", ('-' x 79);
***************
*** 277,281 ****
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) {
--- 37,41 ----
printf "%4dH%s\n", length($t),
join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $t));
! if ($kind eq TmplTokenizer::KIND_TAG && %$attr) {
printf "Attributes:\n";
for my $a (keys %$attr) {
***************
*** 293,298 ****
sub trim ($) {
my($s) = @_;
! $s =~ s/^(?:\s|\ $re_end_entity)+//os;
! $s =~ s/(?:\s|\ $re_end_entity)+$//os;
return $s;
}
--- 53,58 ----
sub trim ($) {
my($s) = @_;
! $s =~ s/^(?:\s|\ $TmplTokenizer::re_end_entity)+//os;
! $s =~ s/(?:\s|\ $TmplTokenizer::re_end_entity)+$//os;
return $s;
}
***************
*** 304,314 ****
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;
--- 64,74 ----
my %text = ();
for (;;) {
! my $s = TmplTokenizer::next_token $h;
last unless defined $s;
my($kind, $t, $attr) = @$s; # FIXME
! if ($kind eq TmplTokenizer::KIND_TEXT) {
$t = trim $t;
$text{$t} = 1 if $t =~ /\S/s;
! } elsif ($kind eq TmplTokenizer::KIND_TAG && %$attr) {
# value [tag=input], meta
my $tag = lc($1) if $t =~ /^<(\S+)/s;
***************
*** 329,333 ****
for my $t (keys %text) {
printf "%s\n", $t
! unless $t =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var)*$/os || $t =~ /^\d+$/;
}
}
--- 89,93 ----
for my $t (keys %text) {
printf "%s\n", $t
! unless $t =~ /^(?:\s|\ $TmplTokenizer::re_end_entity|$TmplTokenizer::re_tmpl_var)*$/os || $t =~ /^\d+$/;
}
}
***************
*** 367,371 ****
'help' => sub { usage(0) },
) || usage_error;
! $pedantic_tag = $pedantic_p? '': ' (negligible)';
usage_error('Missing mandatory option -f') unless defined $input;
--- 127,135 ----
'help' => sub { usage(0) },
) || usage_error;
!
! 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;
***************
*** 378,384 ****
warn "This input will not work with Mozilla standards-compliant mode\n", undef
! if $syntaxerror_p;
close INPUT;
! exit(-1) if $fatal_p;
--- 142,148 ----
warn "This input will not work with Mozilla standards-compliant mode\n", undef
! if TmplTokenizer::syntaxerror_p;
close INPUT;
! exit(-1) if TmplTokenizer::fatal_p;
More information about the Koha-cvs
mailing list