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 _handle {
 124     my $this = shift;
 125     return $this->{+HANDLE};
 126 }
 127
 128 sub fatal_p {
 129     my $this = shift;
 130     return $this->{+FATAL_P};
 131 }
 132
 133 sub syntaxerror_p {
 134     my $this = shift;
 135     return $this->{+SYNTAXERROR_P};
 136 }
 137
 138 sub has_readahead_p {
 139     my $this = shift;
 140     return @{$this->{+READAHEAD}};
 141 }
 142
 143 sub _peek_readahead {
 144     my $this = shift;
 145     return $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}];
 146 }
 147
 148 sub line_number_start {
 149     my $this = shift;
 150     return $this->{+LINENUM_START};
 151 }
 152
 153 sub line_number {
 154     my $this = shift;
 155     return $this->{+LINENUM};
 156 }
 157
 158 sub cdata_mode_p {
 159     my $this = shift;
 160     return $this->{+CDATA_MODE_P};
 161 }
 162
 163 sub cdata_close {
 164     my $this = shift;
 165     return $this->{+CDATA_CLOSE};
 166 }
 167
 168 # Simple setters
 169
 170 sub _set_fatal {
 171     my $this = shift;
 172     $this->{+FATAL_P} = $_[0];
 173     return $this;
 174 }
 175
 176 sub _set_syntaxerror {
 177     my $this = shift;
 178     $this->{+SYNTAXERROR_P} = $_[0];
 179     return $this;
 180 }
 181
 182 sub _push_readahead {
 183     my $this = shift;
 184     push @{$this->{+READAHEAD}}, $_[0];
 185     return $this;
 186 }
 187
 188 sub _pop_readahead {
 189     my $this = shift;
 190     return pop @{$this->{+READAHEAD}};
 191 }
 192
 193 sub _append_readahead {
 194     my $this = shift;
 195     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] .= $_[0];
 196     return $this;
 197 }
 198
 199 sub _set_readahead {
 200     my $this = shift;
 201     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] = $_[0];
 202     return $this;
 203 }
 204
 205 sub _increment_line_number {
 206     my $this = shift;
 207     $this->{+LINENUM} += 1;
 208     return $this;
 209 }
 210
 211 sub _set_line_number_start {
 212     my $this = shift;
 213     $this->{+LINENUM_START} = $_[0];
 214     return $this;
 215 }
 216
 217 sub _set_cdata_mode {
 218     my $this = shift;
 219     $this->{+CDATA_MODE_P} = $_[0];
 220     return $this;
 221 }
 222
 223 sub _set_cdata_close {
 224     my $this = shift;
 225     $this->{+CDATA_CLOSE} = $_[0];
 226     return $this;
 227 }
 228
 229 ###############################################################################
 230
 231 sub _extract_attributes ($;$) {
 232     my $this = shift;
 233     my($s, $lc) = @_;
 234     my %attr;
 235     $s = $1 if $s =~ /^<\S+(.*)\/\S$/s  # XML-style self-closing tags
 236             || $s =~ /^<\S+(.*)\S$/s;   # SGML-style tags
 237
 238     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;) {
 239         my($key, $val, $val_orig, $rest)
 240                 = ($1, (defined $3? $3: defined $4? $4: $5), $2, $');
 241         $i += 1;
 242         $attr{+lc($key)} = [$key, $val, $val_orig, $i];
 243         $s = $rest;
 244         if ($val =~ /$re_tmpl_include/os) {
 245             warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc;
 246         } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) {
 247             # XXX: we probably should not warn if key is "onclick" etc
 248             # XXX: there's just no reasonable thing to suggest
 249             my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML');
 250             undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i;
 251             warn_pedantic
 252                     "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
 253                         . ": $val_orig",
 254                     $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p
 255                 if defined $suggest && (pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p);
 256         } elsif ($val_orig !~ /^['"]/) {
 257             my $t = $val; $t =~ s/$re_directive_control//os;
 258             warn_pedantic
 259                 "Unquoted attribute contains character(s) that should be quoted"
 260                     . ": $val_orig",
 261                 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
 262                 if $t =~ /[^-\.A-Za-z0-9]/s;
 263         }
 264     }
 265     my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check
 266     if ($s2 =~ /\S/s) { # should never happen
 267         if ($s =~ /^([^\n]*)\n/s) { # this is even worse
 268             error_normal("Completely confused while extracting attributes: $1", $lc);
 269             error_normal((scalar(split(/\n/, $s)) - 1) . " more line(s) not shown.", undef);
 270             $this->_set_fatal( 1 );
 271         } else {
 272             warn_normal "Strange attribute syntax: $s\n", $lc;
 273         }
 274     }
 275     return \%attr;
 276 }
 277
 278 sub _next_token_internal {
 279     my $this = shift;
 280     my($h) = @_;
 281     my($it, $kind);
 282     my $eof_p = 0;
 283     $this->_pop_readahead if $this->has_readahead_p
 284             && !ref $this->_peek_readahead
 285             && !length $this->_peek_readahead;
 286     if (!$this->has_readahead_p) {
 287         my $next = scalar <$h>;
 288         $eof_p = !defined $next;
 289         if (!$eof_p) {
 290             $this->_increment_line_number;
 291             $this->_push_readahead( $next );
 292         }
 293     }
 294     $this->_set_line_number_start( $this->line_number ); # remember 1st line num
 295     if ($this->has_readahead_p && ref $this->_peek_readahead) { # TmplToken obj.
 296         ($it, $kind) = ($this->_pop_readahead, undef);
 297     } elsif ($eof_p && !$this->has_readahead_p) {       # nothing left to do
 298         ;
 299     } elsif ($this->_peek_readahead =~ /^\s+/s) {       # whitespace
 300         ($kind, $it) = (TmplTokenType::TEXT, $&);
 301         $this->_set_readahead( $' );
 302     # FIXME the following (the [<\s] part) is an unreliable HACK :-(
 303     } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])+/s) {  # non-space normal text
 304         ($kind, $it) = (TmplTokenType::TEXT, $&);
 305         $this->_set_readahead( $' );
 306         warn_normal "Unescaped < in $it\n", $this->line_number_start
 307                 if !$this->cdata_mode_p && $it =~ /</s;
 308     } else {                            # tag/declaration/processing instruction
 309         my $ok_p = 0;
 310         for (my $cdata_close = $this->cdata_close;;) {
 311             if ($this->cdata_mode_p) {
 312                 if ($this->_peek_readahead =~ /^$cdata_close/) {
 313                     ($kind, $it) = (TmplTokenType::TAG, $&);
 314                     $this->_set_readahead( $' );
 315                     $ok_p = 1;
 316                 } else {
 317                     ($kind, $it) = (TmplTokenType::TEXT, $this->_pop_readahead);
 318                     $ok_p = 1;
 319                 }
 320             } elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
 321                 ($kind, $it) = (TmplTokenType::TAG, "$1>");
 322                 $this->_set_readahead( $3 );
 323                 $ok_p = 1;
 324                 warn_normal "SGML \"closed start tag\" notation: $1<\n", $this->line_number_start if $2 eq '';
 325             } elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->).)*-->/s) {
 326                 ($kind, $it) = (TmplTokenType::COMMENT, $&);
 327                 $this->_set_readahead( $' );
 328                 $ok_p = 1;
 329                 warn_normal "Syntax error in comment: $&\n", $this->line_number_start;
 330                 $this->_set_syntaxerror( 1 );
 331             }
 332         last if $ok_p;
 333             my $next = scalar <$h>;
 334             $eof_p = !defined $next;
 335         last if $eof_p;
 336             $this->_increment_line_number;
 337             $this->_append_readahead( $next );
 338         }
 339         if ($kind ne TmplTokenType::TAG) {
 340             ;
 341         } elsif ($it =~ /^<!/) {
 342             $kind = TmplTokenType::DECL;
 343             $kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
 344         } elsif ($it =~ /^<\?/) {
 345             $kind = TmplTokenType::PI;
 346         }
 347         if ($it =~ /^$re_directive/ios && !$this->cdata_mode_p) {
 348             $kind = TmplTokenType::DIRECTIVE;
 349         }
 350         if (!$ok_p && $eof_p) {
 351             ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
 352             $this->_set_readahead, undef;
 353             $this->_set_syntaxerror( 1 );
 354         }
 355     }
 356     warn_normal "Unrecognizable token found: $it\n", $this->line_number_start
 357             if $kind eq TmplTokenType::UNKNOWN;
 358     return defined $it? (ref $it? $it: TmplToken->new($it, $kind, $this->line_number)): undef;
 359 }
 360
 361 sub next_token {
 362     my $this = shift;
 363     my $h = $this->_handle;
 364     my $it;
 365     if (!$this->cdata_mode_p) {
 366         $it = $this->_next_token_internal($h);
 367         if (defined $it && $it->type eq TmplTokenType::TAG) {
 368             if ($it->string =~ /^<(script|style|textarea)\b/i) {
 369                 $this->_set_cdata_mode( 1 );
 370                 $this->_set_cdata_close( "</$1\\s*>" );
 371             }
 372             $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
 373         }
 374     } else {
 375         for ($it = '', my $cdata_close = $this->cdata_close;;) {
 376             my $next = $this->_next_token_internal($h);
 377         last if !defined $next;
 378             if (defined $next && $next->string =~ /$cdata_close/i) {
 379                 $this->_push_readahead( $next ); # push entire TmplToken object
 380                 $this->_set_cdata_mode( 0 );
 381             }
 382         last unless $this->cdata_mode_p;
 383             $it .= $next->string;
 384         }
 385         $it = TmplToken->new( $it, TmplTokenType::CDATA, $this->line_number );
 386         $this->_set_cdata_close, undef;
 387     }
 388     return $it;
 389 }
 390
 391 ###############################################################################
 392
 393 # Other easy functions
 394
 395 sub blank_p ($) {
 396     my($s) = @_;
 397     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var)*$/os;
 398 }
 399
 400 sub trim ($) {
 401     my($s) = @_;
 402     $s =~ s/^(?:\s|\&nbsp$re_end_entity)+//os;
 403     $s =~ s/(?:\s|\&nbsp$re_end_entity)+$//os;
 404     return $s;
 405 }
 406
 407 ###############################################################################
 408
 409 =head1 FUTURE PLANS
 410
 411 Code could be written to detect template variables and
 412 construct gettext-c-format-string-like meta-strings (e.g., "Results %s
 413 through %s of %s records" that will be more likely to be translatable
 414 to languages where word order is very unlike English word order.
 415 This will be relatively major rework, requiring corresponding
 416 rework in tmpl_process.pl
 417
 418 Gettext-style line number references would also be very helpful in
 419 disambiguating the strings. Ultimately, we should generate and work
 420 with gettext-style po files, so that translators are able to use
 421 tools designed for gettext.
 422
 423 An example of a string untranslatable to Chinese is "Accounts for";
 424 "Accounts for %s", however, would be translatable. Short words like
 425 "in" would also be untranslatable, not only to Chinese, but also to
 426 languages requiring declension of nouns.
 427
 428 =cut
 429
 430 1;