X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=misc%2Ftranslator%2Ftext-extract2.pl;h=452fd896660186664e16961351df1f73ec759402;hb=de7a174ddc1f5b0efa5de933d49a2b1577acc243;hp=f335145fe9d955a56952fe968f792bf1dab962dc;hpb=f7b649f41b97f9a84a05db38255344ceba24dba7;p=koha.git diff --git a/misc/translator/text-extract2.pl b/misc/translator/text-extract2.pl index f335145fe9..452fd89666 100755 --- a/misc/translator/text-extract2.pl +++ b/misc/translator/text-extract2.pl @@ -14,292 +14,98 @@ # --> This will be relatively major rework, and requires corresponding # rework in tmpl_process.pl -use Getopt::Long; use strict; +#use warnings; FIXME - Bug 2505 +use Getopt::Long; +use TmplTokenizer; +use VerboseWarnings; 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 (), 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 ); - -############################################################################### - -sub warn_pedantic ($$) { - my($flag, $msg) = @_; - warn "Warning$pedantic_tag: $msg\n" if $pedantic_p || !$$flag; - if (!$pedantic_p) { - warn "Warning$pedantic_tag: Further similar negligible warnings will not be reported, use --pedantic for details\n" unless $$flag; - $$flag = 1; - } -} +use vars qw( $pedantic_p ); +use vars qw( $allow_cformat_p ); # FOR TESTING PURPOSES ONLY!! ############################################################################### -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 "Warning: TMPL_INCLUDE in attribute" - . (defined $lc? " near line $lc": '') . ": $val_orig\n"; - } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) { - my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/? 'URL': 'HTML'); - warn_pedantic \$pedantic_tmpl_var_use_in_nonpedantic_mode_p, - "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\"" - . (defined $lc? " near line $lc": '') . ": $val_orig" - if $pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p; - } elsif ($val_orig !~ /^['"]/) { - warn_pedantic \$pedantic_attribute_error_in_nonpedantic_mode_p, - "Unquoted attribute contains character(s) that should be quoted" - . (defined $lc? " near line $lc": '') . ": $val_orig" - if $val =~ /[^-\.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 - warn "Error: Completely confused while extracting attributes" - . (defined $lc? " near line $lc": '') . ": $1\n"; - warn "Error: " . (scalar split(/\n/, $s) - 1) . " more line(s) not shown.\n"; - $fatal_p = 1; - } else { - warn "Warning: Strange attribute syntax" - . (defined $lc? " near line $lc": '') . ": $s\n"; - } - } - 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 < near line $lc_0: $it\n" - if !$cdata_mode_p && $it =~ /", $3); - $ok_p = 1; - warn "Warning: SGML \"closed start tag\" notation near line $lc_0: $1<\n" if $2 eq ''; - } elsif ($readahead =~ /^).)*-->/s) { - ($kind, $it, $readahead) = (KIND_COMMENT, $&, $'); - $ok_p = 1; - warn "Warning: Syntax error in comment at line $lc_0: $&\n"; - $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 "Warning: Unrecognizable token found near line $lc_0: $it\n" - 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 underline ($) { # for testing only + my($s) = @_; + join('', map {/[\0-\37]/? $_: "$_\b$_"} split(//, $s)); } -############################################################################### - -sub debug_dump (*) { # for testing only +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(1), "/\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) { + my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes); + printf "%s [line %d]:\n", $kind->to_string, $s->line_number; + printf "%4dH%s\n", length($t), underline($t); + if ($kind == TmplTokenType::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)), + printf "%s = %dH%s -- %s\n", $a, length $val, underline $val, $val_orig; } } + if ($kind == TmplTokenType::TEXT_PARAMETRIZED) { + printf "Form (c-format string):\n"; + printf "%dH%s\n", length $s->form, underline $s->form; + printf "Parameters:\n"; + my $i = 1; + for my $a ($s->parameters) { + my $t = $a->string; + printf "%%%d\$s = %dH%s\n", $i, length $t, underline $t; + $i += 1; + } + } + if ($s->has_js_data) { + printf "JavaScript translatable strings:\n"; + for my $t (@{$s->js_data}) { + printf "%dH%s\n", length $t->[3], underline $t->[3] if $t->[0]; # FIXME + } + } } } ############################################################################### -sub trim ($) { - my($s) = @_; - $s =~ s/^(?:\s|\ $re_end_entity)+//os; - $s =~ s/(?:\s|\ $re_end_entity)+$//os; - return $s; -} - -############################################################################### - -sub text_extract (*) { +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) { - $t = trim $t; + my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes); + if ($kind == TmplTokenType::TEXT) { + $t = TmplTokenizer::trim $t; $text{$t} = 1 if $t =~ /\S/s; - } elsif ($kind eq KIND_TAG && %$attr) { + } elsif ($kind == TmplTokenType::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 + || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME - $val = trim $val; + $val = TmplTokenizer::trim $val; $text{$val} = 1 if $val =~ /\S/s; } } + } elsif ($s->has_js_data) { + for my $t (@{$s->js_data}) { + remember( $s, $t->[3] ) if $t->[0]; # FIXME + } } } # 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+$/; + unless TmplTokenizer::blank_p($t) || $t =~ /^\d+$/; } } @@ -332,24 +138,30 @@ sub usage_error (;$) { ############################################################################### GetOptions( + 'enable-cformat' => \$allow_cformat_p, 'f|file=s' => \$input, 'debug-dump-only' => \$debug_dump_only_p, '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"; +my $h = TmplTokenizer->new( $input ); +$h->set_allow_cformat( 1 ) if $allow_cformat_p; if ($debug_dump_only_p) { - debug_dump(*INPUT); + debug_dump( $h ); } else { - text_extract(*INPUT); + text_extract( $h ); } -warn "Warning: This input will not work with Mozilla standards-compliant mode\n" - if $syntaxerror_p; +warn "This input will not work with Mozilla standards-compliant mode\n", undef + if TmplTokenizer::syntaxerror_p; close INPUT; -exit(-1) if $fatal_p; +exit(-1) if TmplTokenizer::fatal_p;