6 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
9 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
11 ###############################################################################
15 TmplTokenizer.pm - Simple-minded tokenizer class for HTML::Template .tmpl files
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.
27 This tokenizer is mostly based
28 on Ambrose's hideous Perl script known as subst.pl.
32 ###############################################################################
39 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
40 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
42 ###############################################################################
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 );
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*(?:--)?)>};
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 );
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{|[^'])*'|--(?:[^-]|-[^-])*--|(?:}
72 . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)};
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));
82 # End of the hideous stuff
84 use vars qw( $serial );
86 ###############################################################################
88 sub FATAL_P () {'fatal-p'}
89 sub SYNTAXERROR_P () {'syntaxerror-p'}
91 sub FILENAME () {'input'}
92 sub HANDLE () {'handle'}
94 sub READAHEAD () {'readahead'}
95 sub LINENUM_START () {'lc_0'}
97 sub CDATA_MODE_P () {'cdata-mode-p'}
98 sub CDATA_CLOSE () {'cdata-close'}
103 my $class = ref($this) || $this;
107 my $handle = sprintf('TMPLTOKENIZER%d', $serial);
111 open($handle, "<$input") || die "$input: $!\n";
113 $self->{+FILENAME} = $input;
114 $self->{+HANDLE} = $handle;
115 $self->{+READAHEAD} = [];
119 ###############################################################################
125 return $this->{+HANDLE};
130 return $this->{+FATAL_P};
135 return $this->{+SYNTAXERROR_P};
138 sub has_readahead_p {
140 return @{$this->{+READAHEAD}};
143 sub _peek_readahead {
145 return $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}];
148 sub line_number_start {
150 return $this->{+LINENUM_START};
155 return $this->{+LINENUM};
160 return $this->{+CDATA_MODE_P};
165 return $this->{+CDATA_CLOSE};
172 $this->{+FATAL_P} = $_[0];
176 sub _set_syntaxerror {
178 $this->{+SYNTAXERROR_P} = $_[0];
182 sub _push_readahead {
184 push @{$this->{+READAHEAD}}, $_[0];
190 return pop @{$this->{+READAHEAD}};
193 sub _append_readahead {
195 $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] .= $_[0];
201 $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] = $_[0];
205 sub _increment_line_number {
207 $this->{+LINENUM} += 1;
211 sub _set_line_number_start {
213 $this->{+LINENUM_START} = $_[0];
217 sub _set_cdata_mode {
219 $this->{+CDATA_MODE_P} = $_[0];
223 sub _set_cdata_close {
225 $this->{+CDATA_CLOSE} = $_[0];
229 ###############################################################################
231 sub _extract_attributes ($;$) {
235 $s = $1 if $s =~ /^<\S+(.*)\/\S$/s # XML-style self-closing tags
236 || $s =~ /^<\S+(.*)\S$/s; # SGML-style tags
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, $');
242 $attr{+lc($key)} = [$key, $val, $val_orig, $i];
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;
252 "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
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;
259 "Unquoted attribute contains character(s) that should be quoted"
261 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
262 if $t =~ /[^-\.A-Za-z0-9]/s;
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 );
272 warn_normal "Strange attribute syntax: $s\n", $lc;
278 sub _next_token_internal {
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;
290 $this->_increment_line_number;
291 $this->_push_readahead( $next );
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
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
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( $' );
317 ($kind, $it) = (TmplTokenType::TEXT, $this->_pop_readahead);
320 } elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
321 ($kind, $it) = (TmplTokenType::TAG, "$1>");
322 $this->_set_readahead( $3 );
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( $' );
329 warn_normal "Syntax error in comment: $&\n", $this->line_number_start;
330 $this->_set_syntaxerror( 1 );
333 my $next = scalar <$h>;
334 $eof_p = !defined $next;
336 $this->_increment_line_number;
337 $this->_append_readahead( $next );
339 if ($kind ne TmplTokenType::TAG) {
341 } elsif ($it =~ /^<!/) {
342 $kind = TmplTokenType::DECL;
343 $kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
344 } elsif ($it =~ /^<\?/) {
345 $kind = TmplTokenType::PI;
347 if ($it =~ /^$re_directive/ios && !$this->cdata_mode_p) {
348 $kind = TmplTokenType::DIRECTIVE;
350 if (!$ok_p && $eof_p) {
351 ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
352 $this->_set_readahead, undef;
353 $this->_set_syntaxerror( 1 );
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;
363 my $h = $this->_handle;
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*>" );
372 $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
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 );
382 last unless $this->cdata_mode_p;
383 $it .= $next->string;
385 $it = TmplToken->new( $it, TmplTokenType::CDATA, $this->line_number );
386 $this->_set_cdata_close, undef;
391 ###############################################################################
393 # Other easy functions
397 return $s =~ /^(?:\s|\ $re_end_entity|$re_tmpl_var)*$/os;
402 $s =~ s/^(?:\s|\ $re_end_entity)+//os;
403 $s =~ s/(?:\s|\ $re_end_entity)+$//os;
407 ###############################################################################
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
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.
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.