misc/translator/TmplTokenizer.pm

   1 package TmplTokenizer;
   2
   3 use strict;
   4 use TmplTokenType;
   5 use TmplToken;
   6 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
   7 require Exporter;
   8
   9 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  10
  11 ###############################################################################
  12
  13 =head1 NAME
  14
  15 TmplTokenizer.pm - Simple-minded tokenizer class for HTML::Template .tmpl files
  16
  17 =head1 DESCRIPTION
  18
  19 Because .tmpl files contains HTML::Template directives
  20 that tend to confuse real parsers (e.g., HTML::Parse),
  21 it might be better to create a customized scanner
  22 to scan the template files for tokens.
  23 This module is a simple-minded attempt at such a scanner.
  24
  25 =head1 HISTORY
  26
  27 This tokenizer is mostly based
  28 on Ambrose's hideous Perl script known as subst.pl.
  29
  30 =cut
  31
  32 ###############################################################################
  33
  34 $VERSION = 0.02;
  35
  36 @ISA = qw(Exporter);
  37 @EXPORT_OK = qw();
  38
  39 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
  40 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
  41
  42 ###############################################################################
  43
  44 # Hideous stuff
  45 use vars qw( $re_directive $re_tmpl_var $re_tmpl_var_escaped $re_tmpl_include );
  46 use vars qw( $re_directive_control $re_tmpl_endif_endloop );
  47 BEGIN {
  48     # $re_directive must not do any backreferences
  49     $re_directive = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:VAR|LOOP|INCLUDE|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  50     # TMPL_VAR or TMPL_INCLUDE
  51     $re_tmpl_var = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  52     $re_tmpl_include = q{<(?:(?i)(?:!--\s*)?TMPL_(?:INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  53     # TMPL_VAR ESCAPE=1/HTML/URL
  54     $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*(?:--)?)>};
  55     # Any control flow directive
  56     $re_directive_control = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:LOOP|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  57     # /LOOP or /IF or /UNLESS
  58     $re_tmpl_endif_endloop = q{<(?:(?i)(?:!--\s*)?\/TMPL_(?:LOOP|IF|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
  59 }
  60
  61 # Hideous stuff from subst.pl, slightly modified to use the above hideous stuff
  62 # Note: The $re_tag's set $1 (<tag), $2 (>), and $3 (rest of string)
  63 use vars qw( $re_comment $re_entity_name $re_end_entity $re_etag );
  64 use vars qw( $re_tag_strict $re_tag_compat @re_tag );
  65 sub re_tag ($) {
  66    my($compat) = @_;
  67    my $etag = $compat? '>': '<>\/';
  68    # This is no longer similar to the original regexp in subst.pl :-(
  69    # Note that we don't want <> in compat mode; Mozilla knows about <
  70    q{(<\/?(?:|(?:"(?:} . $re_directive . q{|[^"])*"|'(?:} . $re_directive . q{|[^'])*'|--(?:[^-]|-[^-])*--|(?:}
  71    . $re_directive
  72    . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)};
  73 }
  74 BEGIN {
  75     $re_comment = '(?:--(?:[^-]|-[^-])*--)';
  76     $re_entity_name = '(?:[^&%#;<>\s]+)'; # NOTE: not really correct SGML
  77     $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace
  78     $re_etag = q{(?:<\/?(?:"[^"]*"|'[^']*'|[^"'>\/])*[>\/])}; # end-tag
  79     @re_tag = ($re_tag_strict, $re_tag_compat) = (re_tag(0), re_tag(1));
  80 }
  81
  82 # End of the hideous stuff
  83
  84 use vars qw( $serial );
  85
  86 ###############################################################################
  87
  88 sub FATAL_P             () {'fatal-p'}
  89 sub SYNTAXERROR_P       () {'syntaxerror-p'}
  90
  91 sub FILENAME            () {'input'}
  92 sub HANDLE              () {'handle'}
  93
  94 sub READAHEAD           () {'readahead'}
  95 sub LINENUM_START       () {'lc_0'}
  96 sub LINENUM             () {'lc'}
  97 sub CDATA_MODE_P        () {'cdata-mode-p'}
  98 sub CDATA_CLOSE         () {'cdata-close'}
  99
 100 sub new {
 101     my $this = shift;
 102     my($input) = @_;
 103     my $class = ref($this) || $this;
 104     my $self = {};
 105     bless $self, $class;
 106
 107     my $handle = sprintf('TMPLTOKENIZER%d', $serial);
 108     $serial += 1;
 109
 110     no strict;
 111     open($handle, "<$input") || die "$input: $!\n";
 112     use strict;
 113     $self->{+FILENAME} = $input;
 114     $self->{+HANDLE} = $handle;
 115     $self->{+READAHEAD} = [];
 116     return $self;
 117 }
 118
 119 ###############################################################################
 120
 121 # Simple getters
 122
 123 sub filename {
 124     my $this = shift;
 125     return $this->{+FILENAME};
 126 }
 127
 128 sub _handle {
 129     my $this = shift;
 130     return $this->{+HANDLE};
 131 }
 132
 133 sub fatal_p {
 134     my $this = shift;
 135     return $this->{+FATAL_P};
 136 }
 137
 138 sub syntaxerror_p {
 139     my $this = shift;
 140     return $this->{+SYNTAXERROR_P};
 141 }
 142
 143 sub has_readahead_p {
 144     my $this = shift;
 145     return @{$this->{+READAHEAD}};
 146 }
 147
 148 sub _peek_readahead {
 149     my $this = shift;
 150     return $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}];
 151 }
 152
 153 sub line_number_start {
 154     my $this = shift;
 155     return $this->{+LINENUM_START};
 156 }
 157
 158 sub line_number {
 159     my $this = shift;
 160     return $this->{+LINENUM};
 161 }
 162
 163 sub cdata_mode_p {
 164     my $this = shift;
 165     return $this->{+CDATA_MODE_P};
 166 }
 167
 168 sub cdata_close {
 169     my $this = shift;
 170     return $this->{+CDATA_CLOSE};
 171 }
 172
 173 # Simple setters
 174
 175 sub _set_fatal {
 176     my $this = shift;
 177     $this->{+FATAL_P} = $_[0];
 178     return $this;
 179 }
 180
 181 sub _set_syntaxerror {
 182     my $this = shift;
 183     $this->{+SYNTAXERROR_P} = $_[0];
 184     return $this;
 185 }
 186
 187 sub _push_readahead {
 188     my $this = shift;
 189     push @{$this->{+READAHEAD}}, $_[0];
 190     return $this;
 191 }
 192
 193 sub _pop_readahead {
 194     my $this = shift;
 195     return pop @{$this->{+READAHEAD}};
 196 }
 197
 198 sub _append_readahead {
 199     my $this = shift;
 200     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] .= $_[0];
 201     return $this;
 202 }
 203
 204 sub _set_readahead {
 205     my $this = shift;
 206     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] = $_[0];
 207     return $this;
 208 }
 209
 210 sub _increment_line_number {
 211     my $this = shift;
 212     $this->{+LINENUM} += 1;
 213     return $this;
 214 }
 215
 216 sub _set_line_number_start {
 217     my $this = shift;
 218     $this->{+LINENUM_START} = $_[0];
 219     return $this;
 220 }
 221
 222 sub _set_cdata_mode {
 223     my $this = shift;
 224     $this->{+CDATA_MODE_P} = $_[0];
 225     return $this;
 226 }
 227
 228 sub _set_cdata_close {
 229     my $this = shift;
 230     $this->{+CDATA_CLOSE} = $_[0];
 231     return $this;
 232 }
 233
 234 ###############################################################################
 235
 236 sub _extract_attributes ($;$) {
 237     my $this = shift;
 238     my($s, $lc) = @_;
 239     my %attr;
 240     $s = $1 if $s =~ /^<\S+(.*)\/\S$/s  # XML-style self-closing tags
 241             || $s =~ /^<\S+(.*)\S$/s;   # SGML-style tags
 242
 243     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;) {
 244         my($key, $val, $val_orig, $rest)
 245                 = ($1, (defined $3? $3: defined $4? $4: $5), $2, $');
 246         $i += 1;
 247         $attr{+lc($key)} = [$key, $val, $val_orig, $i];
 248         $s = $rest;
 249         if ($val =~ /$re_tmpl_include/os) {
 250             warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc;
 251         } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) {
 252             # XXX: we probably should not warn if key is "onclick" etc
 253             # XXX: there's just no reasonable thing to suggest
 254             my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML');
 255             undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i;
 256             warn_pedantic
 257                     "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
 258                         . ": $val_orig",
 259                     $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p
 260                 if defined $suggest && (pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p);
 261         } elsif ($val_orig !~ /^['"]/) {
 262             my $t = $val; $t =~ s/$re_directive_control//os;
 263             warn_pedantic
 264                 "Unquoted attribute contains character(s) that should be quoted"
 265                     . ": $val_orig",
 266                 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
 267                 if $t =~ /[^-\.A-Za-z0-9]/s;
 268         }
 269     }
 270     my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check
 271     if ($s2 =~ /\S/s) { # should never happen
 272         if ($s =~ /^([^\n]*)\n/s) { # this is even worse
 273             error_normal("Completely confused while extracting attributes: $1", $lc);
 274             error_normal((scalar(split(/\n/, $s)) - 1) . " more line(s) not shown.", undef);
 275             $this->_set_fatal( 1 );
 276         } else {
 277             warn_normal "Strange attribute syntax: $s\n", $lc;
 278         }
 279     }
 280     return \%attr;
 281 }
 282
 283 sub _next_token_internal {
 284     my $this = shift;
 285     my($h) = @_;
 286     my($it, $kind);
 287     my $eof_p = 0;
 288     $this->_pop_readahead if $this->has_readahead_p
 289             && !ref $this->_peek_readahead
 290             && !length $this->_peek_readahead;
 291     if (!$this->has_readahead_p) {
 292         my $next = scalar <$h>;
 293         $eof_p = !defined $next;
 294         if (!$eof_p) {
 295             $this->_increment_line_number;
 296             $this->_push_readahead( $next );
 297         }
 298     }
 299     $this->_set_line_number_start( $this->line_number ); # remember 1st line num
 300     if ($this->has_readahead_p && ref $this->_peek_readahead) { # TmplToken obj.
 301         ($it, $kind) = ($this->_pop_readahead, undef);
 302     } elsif ($eof_p && !$this->has_readahead_p) {       # nothing left to do
 303         ;
 304     } elsif ($this->_peek_readahead =~ /^\s+/s) {       # whitespace
 305         ($kind, $it) = (TmplTokenType::TEXT, $&);
 306         $this->_set_readahead( $' );
 307     # FIXME the following (the [<\s] part) is an unreliable HACK :-(
 308     } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])+/s) {  # non-space normal text
 309         ($kind, $it) = (TmplTokenType::TEXT, $&);
 310         $this->_set_readahead( $' );
 311         warn_normal "Unescaped < in $it\n", $this->line_number_start
 312                 if !$this->cdata_mode_p && $it =~ /</s;
 313     } else {                            # tag/declaration/processing instruction
 314         my $ok_p = 0;
 315         for (my $cdata_close = $this->cdata_close;;) {
 316             if ($this->cdata_mode_p) {
 317                 if ($this->_peek_readahead =~ /^$cdata_close/) {
 318                     ($kind, $it) = (TmplTokenType::TAG, $&);
 319                     $this->_set_readahead( $' );
 320                     $ok_p = 1;
 321                 } else {
 322                     ($kind, $it) = (TmplTokenType::TEXT, $this->_pop_readahead);
 323                     $ok_p = 1;
 324                 }
 325             } elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
 326                 ($kind, $it) = (TmplTokenType::TAG, "$1>");
 327                 $this->_set_readahead( $3 );
 328                 $ok_p = 1;
 329                 warn_normal "SGML \"closed start tag\" notation: $1<\n", $this->line_number_start if $2 eq '';
 330             } elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->).)*-->/s) {
 331                 ($kind, $it) = (TmplTokenType::COMMENT, $&);
 332                 $this->_set_readahead( $' );
 333                 $ok_p = 1;
 334                 warn_normal "Syntax error in comment: $&\n", $this->line_number_start;
 335                 $this->_set_syntaxerror( 1 );
 336             }
 337         last if $ok_p;
 338             my $next = scalar <$h>;
 339             $eof_p = !defined $next;
 340         last if $eof_p;
 341             $this->_increment_line_number;
 342             $this->_append_readahead( $next );
 343         }
 344         if ($kind ne TmplTokenType::TAG) {
 345             ;
 346         } elsif ($it =~ /^<!/) {
 347             $kind = TmplTokenType::DECL;
 348             $kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
 349             if ($kind == TmplTokenType::COMMENT && $it =~ /^<!--\s*#include/s) {
 350                 warn_normal "Apache #include directive found instead of HTML::Template directive <TMPL_INCLUDE>", $this->line_number_start;
 351             }
 352         } elsif ($it =~ /^<\?/) {
 353             $kind = TmplTokenType::PI;
 354         }
 355         if ($it =~ /^$re_directive/ios && !$this->cdata_mode_p) {
 356             $kind = TmplTokenType::DIRECTIVE;
 357         }
 358         if (!$ok_p && $eof_p) {
 359             ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
 360             $this->_set_readahead, undef;
 361             $this->_set_syntaxerror( 1 );
 362         }
 363     }
 364     warn_normal "Unrecognizable token found: $it\n", $this->line_number_start
 365             if $kind eq TmplTokenType::UNKNOWN;
 366     return defined $it? (ref $it? $it: TmplToken->new($it, $kind, $this->line_number, $this->filename)): undef;
 367 }
 368
 369 sub next_token {
 370     my $this = shift;
 371     my $h = $this->_handle;
 372     my $it;
 373     if (!$this->cdata_mode_p) {
 374         $it = $this->_next_token_internal($h);
 375         if (defined $it && $it->type eq TmplTokenType::TAG) {
 376             if ($it->string =~ /^<(script|style|textarea)\b/i) {
 377                 $this->_set_cdata_mode( 1 );
 378                 $this->_set_cdata_close( "</$1\\s*>" );
 379             }
 380             $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
 381         }
 382     } else {
 383         for ($it = '', my $cdata_close = $this->cdata_close;;) {
 384             my $next = $this->_next_token_internal($h);
 385         last if !defined $next;
 386             if (defined $next && $next->string =~ /$cdata_close/i) {
 387                 $this->_push_readahead( $next ); # push entire TmplToken object
 388                 $this->_set_cdata_mode( 0 );
 389             }
 390         last unless $this->cdata_mode_p;
 391             $it .= $next->string;
 392         }
 393         $it = TmplToken->new( $it, TmplTokenType::CDATA, $this->line_number );
 394         $this->_set_cdata_close, undef;
 395     }
 396     return $it;
 397 }
 398
 399 ###############################################################################
 400
 401 # Other easy functions
 402
 403 sub blank_p ($) {
 404     my($s) = @_;
 405     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var)*$/os;
 406 }
 407
 408 sub trim ($) {
 409     my($s0) = @_;
 410     my $l0 = length $s0;
 411     my $s = $s0;
 412     $s =~ s/^(\s|\&nbsp$re_end_entity)+//os; my $l1 = $l0 - length $s;
 413     $s =~ s/(\s|\&nbsp$re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
 414     return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
 415 }
 416
 417 ###############################################################################
 418
 419 =head1 FUTURE PLANS
 420
 421 Code could be written to detect template variables and
 422 construct gettext-c-format-string-like meta-strings (e.g., "Results %s
 423 through %s of %s records" that will be more likely to be translatable
 424 to languages where word order is very unlike English word order.
 425 This will be relatively major rework, requiring corresponding
 426 rework in tmpl_process.pl
 427
 428 Gettext-style line number references would also be very helpful in
 429 disambiguating the strings. Ultimately, we should generate and work
 430 with gettext-style po files, so that translators are able to use
 431 tools designed for gettext.
 432
 433 An example of a string untranslatable to Chinese is "Accounts for";
 434 "Accounts for %s", however, would be translatable. Short words like
 435 "in" would also be untranslatable, not only to Chinese, but also to
 436 languages requiring declension of nouns.
 437
 438 =cut
 439
 440 1;