X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=misc%2Ftranslator%2Ftext-extract2.pl;h=452fd896660186664e16961351df1f73ec759402;hb=44a58384fe411bd9b8a58cf3821f48766c6b8b0f;hp=250ac256582842d1828b8e69b80f42b169b3147c;hpb=a10bb7062ae5ca43734cc842e4ecbb7604c30e36;p=koha.git diff --git a/misc/translator/text-extract2.pl b/misc/translator/text-extract2.pl index 250ac25658..452fd89666 100755 --- a/misc/translator/text-extract2.pl +++ b/misc/translator/text-extract2.pl @@ -7,10 +7,6 @@ # This script is meant to be a drop-in replacement of text-extract.pl -# FIXME: Strings like "<< Prev" or "Next >>" may confuse *this* filter -# TODO: Need to detect unclosed tags, empty tags, and other such stuff. -# (Why? Because Mozilla apparently knows what SGML unclosed tags are :-/ ) - # A grander plan: 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 @@ -18,250 +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 ); -use vars qw( $fatal_p ); +use vars qw( $allow_cformat_p ); # FOR TESTING PURPOSES ONLY!! ############################################################################### -# Hideous stuff -use vars qw( $re_directive ); -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*(?:--)?)>}; -} - -# 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? '>': '<>\/'; - # See the file "subst.pl.test1" for how the following mess is derived - # Unfortunately, inserting $re_directive's has made this even messier - 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 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 =~ /^\s+(?:([a-zA-Z][-a-zA-Z0-9]*)=)?('((?:$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; - warn "Warning: Attribute should be quoted" - . (defined $lc? " near line $lc": '') . ": $val_orig\n" - if $pedantic_p - && $val =~ /[^-\.A-Za-z0-9]/s && $val_orig !~ /^['"]/; - } - if ($s =~ /\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 $it =~ /).)*-->/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 or pure numbers. + # 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)*$/os || $t =~ /^\d+$/; + unless TmplTokenizer::blank_p($t) || $t =~ /^\d+$/; } } @@ -294,23 +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; + +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;