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
###############################################################################
sub CDATA_MODE_P () {'cdata-mode-p'}
sub CDATA_CLOSE () {'cdata-close'}
+sub ALLOW_CFORMAT_P () {'allow-cformat-p'}
+
sub new {
my $this = shift;
my($input) = @_;
return $this->{+CDATA_CLOSE};
}
+sub allow_cformat_p {
+ my $this = shift;
+ return $this->{+ALLOW_CFORMAT_P};
+}
+
# Simple setters
sub _set_fatal {
return $this;
}
+sub set_allow_cformat {
+ my $this = shift;
+ $this->{+ALLOW_CFORMAT_P} = $_[0];
+ return $this;
+}
+
###############################################################################
sub _extract_attributes ($;$) {
($kind, $it) = (TmplTokenType::TEXT, $&);
$this->_set_readahead( $' );
# FIXME the following (the [<\s] part) is an unreliable HACK :-(
- } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])+/s) { # non-space normal text
+ } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])*(?:[^<\s])/s) { # non-space normal text
($kind, $it) = (TmplTokenType::TEXT, $&);
$this->_set_readahead( $' );
warn_normal "Unescaped < in $it\n", $this->line_number_start
my $ok_p = 0;
for (my $cdata_close = $this->cdata_close;;) {
if ($this->cdata_mode_p) {
- if ($this->_peek_readahead =~ /^$cdata_close/) {
+ my $next = $this->_pop_readahead;
+ if ($next =~ /^$cdata_close/) {
($kind, $it) = (TmplTokenType::TAG, $&);
- $this->_set_readahead( $' );
+ $this->_push_readahead( $' );
+ $ok_p = 1;
+ } elsif ($next =~ /^((?:(?!$cdata_close).)+)($cdata_close)/) {
+ ($kind, $it) = (TmplTokenType::TEXT, $1);
+ $this->_push_readahead( "$2$'" );
$ok_p = 1;
} else {
- ($kind, $it) = (TmplTokenType::TEXT, $this->_pop_readahead);
+ ($kind, $it) = (TmplTokenType::TEXT, $next);
$ok_p = 1;
}
} elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
- ($kind, $it) = (TmplTokenType::TAG, "$1>");
- $this->_set_readahead( $3 );
- $ok_p = 1;
- warn_normal "SGML \"closed start tag\" notation: $1<\n", $this->line_number_start if $2 eq '';
+ # If we detect a "closed start tag" but we know that the
+ # following token looks like a TMPL_VAR, don't stop
+ my($head, $tail, $post) = ($1, $2, $3);
+ if ($tail eq '' && $post =~ $re_tmpl_var) {
+ # Don't bother to show the warning if we're too confused
+ warn_normal "Possible SGML \"closed start tag\" notation: $head<\n", $this->line_number
+ if split(/\n/, $head) < 10;
+ } else {
+ ($kind, $it) = (TmplTokenType::TAG, "$head>");
+ $this->_set_readahead( $post );
+ $ok_p = 1;
+ warn_normal "SGML \"closed start tag\" notation: $head<\n", $this->line_number if $tail eq '';
+ }
} elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->).)*-->/s) {
($kind, $it) = (TmplTokenType::COMMENT, $&);
$this->_set_readahead( $' );
} elsif ($it =~ /^<!/) {
$kind = TmplTokenType::DECL;
$kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
+ if ($kind == TmplTokenType::COMMENT && $it =~ /^<!--\s*#include/s) {
+ warn_normal "Apache #include directive found instead of HTML::Template <TMPL_INCLUDE> directive", $this->line_number_start;
+ }
} elsif ($it =~ /^<\?/) {
$kind = TmplTokenType::PI;
}
$this->_set_syntaxerror( 1 );
}
}
- warn_normal "Unrecognizable token found: $it\n", $this->line_number_start
- if $kind eq TmplTokenType::UNKNOWN;
+ warn_normal "Unrecognizable token found: "
+ . (split(/\n/, $it) < 10? $it: '(too confused to show details)')
+ . "\n", $this->line_number_start
+ if $kind == TmplTokenType::UNKNOWN;
return defined $it? (ref $it? $it: TmplToken->new($it, $kind, $this->line_number, $this->filename)): undef;
}
-sub next_token {
+sub _next_token_intermediate {
my $this = shift;
my $h = $this->_handle;
my $it;
if (!$this->cdata_mode_p) {
$it = $this->_next_token_internal($h);
- if (defined $it && $it->type eq TmplTokenType::TAG) {
+ if (defined $it && $it->type == TmplTokenType::TAG) {
if ($it->string =~ /^<(script|style|textarea)\b/i) {
$this->_set_cdata_mode( 1 );
$this->_set_cdata_close( "</$1\\s*>" );
return $it;
}
+sub _token_groupable_p ($) { # groupable into a TEXT_PARAMETRIZED token
+ my($t) = @_;
+ return $t->type == TmplTokenType::TEXT
+ || ($t->type == TmplTokenType::DIRECTIVE
+ && $t->string =~ /^(?:$re_tmpl_var)$/os)
+ || ($t->type == TmplTokenType::TAG
+ && ($t->string =~ /^<\/?(?:b|em|h[123456]|i|u)\b/is
+ || ($t->string =~ /^<input/i
+ && $t->attributes->{'type'} =~ /^(?:text)$/i)))
+}
+
+sub _quote_cformat ($) {
+ my($s) = @_;
+ $s =~ s/%/%%/g;
+ return $s;
+}
+
+sub _formalize ($) {
+ my($t) = @_;
+ return $t->type == TmplTokenType::DIRECTIVE? '%s': _quote_cformat($t->string);
+}
+
+sub next_token {
+ my $this = shift;
+ my $h = $this->_handle;
+ my $it;
+ $this->{_queue} = [] unless defined $this->{_queue};
+ if (@{$this->{_queue}}) {
+ $it = pop @{$this->{_queue}};
+ } else {
+ $it = $this->_next_token_intermediate($h);
+ if (!$this->cdata_mode_p && $this->allow_cformat_p && defined $it
+ && ($it->type == TmplTokenType::TEXT?
+ !blank_p( $it->string ): _token_groupable_p( $it ))) {
+ my @structure = ( $it );
+ my($n_trailing_spaces, $next) = (0, undef);
+ my($nonblank_text_p, $parametrized_p, $next) = (0, 0);
+ if ($it->type == TmplTokenType::TEXT) {
+ $nonblank_text_p = 1 if !blank_p( $it->string );
+ } elsif ($it->type == TmplTokenType::DIRECTIVE) {
+ $parametrized_p = 1;
+ }
+ for (my $i = 1, $n_trailing_spaces = 0;; $i += 1) {
+ $next = $this->_next_token_intermediate($h);
+ push @structure, $next; # for consistency (with initialization)
+ last unless defined $next && _token_groupable_p( $next );
+ if ($next->type == TmplTokenType::TEXT) {
+ if (blank_p( $next->string )) {
+ $n_trailing_spaces += 1;
+ } else {
+ ($n_trailing_spaces, $nonblank_text_p) = (0, 1);
+ }
+ } elsif ($next->type == TmplTokenType::DIRECTIVE) {
+ $n_trailing_spaces = 0;
+ $parametrized_p = 1;
+ } else {
+ $n_trailing_spaces = 0;
+ }
+ }
+ # Undo the last token
+ push @{$this->{_queue}}, pop @structure;
+ # Undo trailing blank tokens
+ for (my $i = 0; $i < $n_trailing_spaces; $i += 1) {
+ push @{$this->{_queue}}, pop @structure;
+ }
+ # FIXME: If the last token is a close tag but there are no tags
+ # FIXME: before it, drop the close tag back into the queue. This
+ # FIXME: is an ugly hack to get rid of "foo %s</h1>" type mess.
+ if (@structure >= 2
+ && $structure[$#structure]->type == TmplTokenType::TAG
+ && $structure[$#structure]->string =~ /^<\//) {
+ my $has_other_tags_p = 0;
+ for (my $i = 0; $i < $#structure; $i += 1) {
+ $has_other_tags_p = 1
+ if $structure[$i]->type == TmplTokenType::TAG;
+ last if $has_other_tags_p;
+ }
+ push @{$this->{_queue}}, pop @structure unless $has_other_tags_p
+ }
+ if (@structure < 2) {
+ # Nothing to do
+ ;
+ } elsif ($nonblank_text_p && $parametrized_p) {
+ # Create the corresponding c-format string
+ my $string = join('', map { $_->string } @structure);
+ my $form = join('', map { _formalize $_ } @structure);
+ $it = TmplToken->new($string, TmplTokenType::TEXT_PARAMETRIZED, $it->line_number, $it->pathname);
+ $it->set_form( $form );
+ $it->set_children( @structure );
+ } elsif ($nonblank_text_p && $structure[0]->type == TmplTokenType::TEXT && $structure[$#structure]->type == TmplTokenType::TEXT) {
+ # Combine the strings
+ my $string = join('', map { $_->string } @structure);
+ $it = TmplToken->new($string, TmplTokenType::TEXT, $it->line_number, $it->pathname);;
+ } else {
+ # Requeue the tokens thus seen for re-emitting
+ for (;;) {
+ push @{$this->{_queue}}, pop @structure;
+ last if !@structure;
+ }
+ $it = pop @{$this->{_queue}};
+ }
+ }
+ }
+ return $it;
+}
+
###############################################################################
-# Other easy functions
+# Other simple functions (These are not methods)
sub blank_p ($) {
my($s) = @_;
}
sub trim ($) {
+ my($s0) = @_;
+ my $l0 = length $s0;
+ my $s = $s0;
+ $s =~ s/^(\s|\ $re_end_entity)+//os; my $l1 = $l0 - length $s;
+ $s =~ s/(\s|\ $re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
+ return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
+}
+
+sub quote_po ($) {
my($s) = @_;
- $s =~ /^(\s|\ $re_end_entity)*(.*)(\s|\ $re_end_entity)*$/os;
- return wantarray? ($2, $1, $3): $2;
+ # Locale::PO->quote is buggy, it doesn't quote newlines :-/
+ $s =~ s/([\\"])/\\\1/gs;
+ $s =~ s/\n/\\n/g;
+ #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
+ return "\"$s\"";
+}
+
+# Some functions that shouldn't be here... should be moved out some time
+sub parametrize ($@) {
+ my($fmt, @params) = @_;
+ my $it = '';
+ for (my $n = 0; length $fmt;) {
+ if ($fmt =~ /^[^%]+/) {
+ $fmt = $';
+ $it .= $&;
+ } elsif ($fmt =~ /^%%/) {
+ $fmt = $';
+ $it .= '%';
+ } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/) {
+ $n += 1;
+ my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
+ $fmt = $';
+ if (!defined $width && !defined $prec) {
+ $it .= $params[$i]
+ } elsif (defined $width && defined $prec && !$width && !$prec) {
+ ;
+ } else {
+ die "Unsupported precision specification in format: $&\n"; #XXX
+ }
+ } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
+ $fmt = $';
+ $it .= $&;
+ die "Unknown or unsupported format specification: $&\n"; #XXX
+ } else {
+ die "Completely confused parametrizing: $fmt\n";#XXX
+ }
+ }
+ return $it;
+}
+
+sub charset_canon ($) {
+ my($charset) = @_;
+ $charset = uc($charset);
+ $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
+ $charset = 'Big5' if $charset eq 'BIG5'; # "Big5" must be in mixed case
+ return $charset;
+}
+
+use vars qw( @latin1_utf8 );
+@latin1_utf8 = (
+ "\302\200", "\302\201", "\302\202", "\302\203", "\302\204", "\302\205",
+ "\302\206", "\302\207", "\302\210", "\302\211", "\302\212", "\302\213",
+ "\302\214", "\302\215", undef, undef, "\302\220", "\302\221",
+ "\302\222", "\302\223", "\302\224", "\302\225", "\302\226", "\302\227",
+ "\302\230", "\302\231", "\302\232", "\302\233", "\302\234", "\302\235",
+ "\302\236", "\302\237", "\302\240", "\302\241", "\302\242", "\302\243",
+ "\302\244", "\302\245", "\302\246", "\302\247", "\302\250", "\302\251",
+ "\302\252", "\302\253", "\302\254", "\302\255", "\302\256", "\302\257",
+ "\302\260", "\302\261", "\302\262", "\302\263", "\302\264", "\302\265",
+ "\302\266", "\302\267", "\302\270", "\302\271", "\302\272", "\302\273",
+ "\302\274", "\302\275", "\302\276", "\302\277", "\303\200", "\303\201",
+ "\303\202", "\303\203", "\303\204", "\303\205", "\303\206", "\303\207",
+ "\303\210", "\303\211", "\303\212", "\303\213", "\303\214", "\303\215",
+ "\303\216", "\303\217", "\303\220", "\303\221", "\303\222", "\303\223",
+ "\303\224", "\303\225", "\303\226", "\303\227", "\303\230", "\303\231",
+ "\303\232", "\303\233", "\303\234", "\303\235", "\303\236", "\303\237",
+ "\303\240", "\303\241", "\303\242", "\303\243", "\303\244", "\303\245",
+ "\303\246", "\303\247", "\303\250", "\303\251", "\303\252", "\303\253",
+ "\303\254", "\303\255", "\303\256", "\303\257", "\303\260", "\303\261",
+ "\303\262", "\303\263", "\303\264", "\303\265", "\303\266", "\303\267",
+ "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
+ "\303\276", "\303\277" );
+
+sub charset_convert ($$$) {
+ my($s, $charset_in, $charset_out) = @_;
+ if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
+ ;
+ } elsif ($charset_in eq 'ISO-8859-1' && $charset_out eq 'UTF-8') {
+ $s =~ s/[\200-\377]/ $latin1_utf8[ord($&) - 128] /egs;
+ } elsif ($charset_in ne $charset_out) {
+ VerboseWarnings::warn_normal "conversion from $charset_in to $charset_out is not supported\n", undef;
+ }
+ return $s;
}
###############################################################################
-=head1 FUTURE PLANS
+=pod
+
+In addition to the basic scanning, this class will also perform
+the following:
+
+=over
+
+=item -
+
+Emulation of c-format strings (see below)
+
+=item -
+
+Display of warnings for certain things that affects either the
+ability of this class to yield correct output, or things that
+are known to cause the original template to cause trouble.
-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
+=item -
-Gettext-style line number references would also be very helpful in
-disambiguating the strings. Ultimately, we should generate and work
-with gettext-style po files, so that translators are able to use
-tools designed for gettext.
+Automatic correction of some of the things warned about
+(e.g., SGML "closed start tag" notation).
-An example of a string untranslatable to Chinese is "Accounts for";
-"Accounts for %s", however, would be translatable. Short words like
-"in" would also be untranslatable, not only to Chinese, but also to
-languages requiring declension of nouns.
+=back
+
+=head2 c-format strings emulation
+
+Because English word order is not universal, a simple extraction
+of translatable strings may yield some strings like "Accounts for"
+or ambiguous strings like "in". This makes the resulting strings
+difficult to translate, but does not affect all languages alike.
+For example, Chinese (with a somewhat different word order) would
+be hit harder, but French would be relatively unaffected.
+
+To overcome this problem, the scanner can be configured to detect
+patterns with <TMPL_VAR> directives (as well as certain HTML tags),
+and try to construct a larger pattern that will appear in the PO
+file as c-format strings with %s placeholders. This additional
+step allows the translator to deal with cases where word order
+is different (replacing %s with %1$s, %2$s, etc.), or when certain
+words will require certain inflectional suffixes in sentences.
+
+Because this is an incompatible change, this mode must be explicitly
+turned on using the set_cformat(1) method call.
+
+=head1 HISTORY
+
+This tokenizer is mostly based
+on Ambrose's hideous Perl script known as subst.pl.
=cut
projects / koha.git / blobdiff