Preliminary support for "analysis" of strings with <a> tags.
[koha.git] / 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 =cut
26
27 ###############################################################################
28
29 $VERSION = 0.02;
30
31 @ISA = qw(Exporter);
32 @EXPORT_OK = qw();
33
34 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
35 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
36
37 ###############################################################################
38
39 # Hideous stuff
40 use vars qw( $re_directive $re_tmpl_var $re_tmpl_var_escaped $re_tmpl_include );
41 use vars qw( $re_directive_control $re_tmpl_endif_endloop );
42 BEGIN {
43     # $re_directive must not do any backreferences
44     $re_directive = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:VAR|LOOP|INCLUDE|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
45     # TMPL_VAR or TMPL_INCLUDE
46     $re_tmpl_var = q{<(?:(?i)(?:!--\s*)?TMPL_(?:VAR)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
47     $re_tmpl_include = q{<(?:(?i)(?:!--\s*)?TMPL_(?:INCLUDE)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
48     # TMPL_VAR ESCAPE=1/HTML/URL
49     $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*(?:--)?)>};
50     # Any control flow directive
51     $re_directive_control = q{<(?:(?i)(?:!--\s*)?\/?TMPL_(?:LOOP|IF|ELSE|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
52     # /LOOP or /IF or /UNLESS
53     $re_tmpl_endif_endloop = q{<(?:(?i)(?:!--\s*)?\/TMPL_(?:LOOP|IF|UNLESS)(?:\s+(?:[a-zA-Z][-a-zA-Z0-9]*=)?(?:'[^']*'|"[^"]*"|[^\s<>]+))*\s*(?:--)?)>};
54 }
55
56 # Hideous stuff from subst.pl, slightly modified to use the above hideous stuff
57 # Note: The $re_tag's set $1 (<tag), $2 (>), and $3 (rest of string)
58 use vars qw( $re_comment $re_entity_name $re_end_entity $re_etag );
59 use vars qw( $re_tag_strict $re_tag_compat @re_tag );
60 sub re_tag ($) {
61    my($compat) = @_;
62    my $etag = $compat? '>': '<>\/';
63    # This is no longer similar to the original regexp in subst.pl :-(
64    # Note that we don't want <> in compat mode; Mozilla knows about <
65    q{(<\/?(?:|(?:"(?:} . $re_directive . q{|[^"])*"|'(?:} . $re_directive . q{|[^'])*'|--(?:[^-]|-[^-])*--|(?:}
66    . $re_directive
67    . q{|(?!--)[^"'<>} . $etag . q{]))+))([} . $etag . q{]|(?=<))(.*)};
68 }
69 BEGIN {
70     $re_comment = '(?:--(?:[^-]|-[^-])*--)';
71     $re_entity_name = '(?:[^&%#;<>\s]+)'; # NOTE: not really correct SGML
72     $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace
73     $re_etag = q{(?:<\/?(?:"[^"]*"|'[^']*'|[^"'>\/])*[>\/])}; # end-tag
74     @re_tag = ($re_tag_strict, $re_tag_compat) = (re_tag(0), re_tag(1));
75 }
76
77 # End of the hideous stuff
78
79 use vars qw( $serial );
80
81 ###############################################################################
82
83 sub FATAL_P             () {'fatal-p'}
84 sub SYNTAXERROR_P       () {'syntaxerror-p'}
85
86 sub FILENAME            () {'input'}
87 sub HANDLE              () {'handle'}
88
89 sub READAHEAD           () {'readahead'}
90 sub LINENUM_START       () {'lc_0'}
91 sub LINENUM             () {'lc'}
92 sub CDATA_MODE_P        () {'cdata-mode-p'}
93 sub CDATA_CLOSE         () {'cdata-close'}
94
95 sub ALLOW_CFORMAT_P     () {'allow-cformat-p'}
96
97 sub new {
98     my $this = shift;
99     my($input) = @_;
100     my $class = ref($this) || $this;
101     my $self = {};
102     bless $self, $class;
103
104     my $handle = sprintf('TMPLTOKENIZER%d', $serial);
105     $serial += 1;
106
107     no strict;
108     open($handle, "<$input") || die "$input: $!\n";
109     use strict;
110     $self->{+FILENAME} = $input;
111     $self->{+HANDLE} = $handle;
112     $self->{+READAHEAD} = [];
113     return $self;
114 }
115
116 ###############################################################################
117
118 # Simple getters
119
120 sub filename {
121     my $this = shift;
122     return $this->{+FILENAME};
123 }
124
125 sub _handle {
126     my $this = shift;
127     return $this->{+HANDLE};
128 }
129
130 sub fatal_p {
131     my $this = shift;
132     return $this->{+FATAL_P};
133 }
134
135 sub syntaxerror_p {
136     my $this = shift;
137     return $this->{+SYNTAXERROR_P};
138 }
139
140 sub has_readahead_p {
141     my $this = shift;
142     return @{$this->{+READAHEAD}};
143 }
144
145 sub _peek_readahead {
146     my $this = shift;
147     return $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}];
148 }
149
150 sub line_number_start {
151     my $this = shift;
152     return $this->{+LINENUM_START};
153 }
154
155 sub line_number {
156     my $this = shift;
157     return $this->{+LINENUM};
158 }
159
160 sub cdata_mode_p {
161     my $this = shift;
162     return $this->{+CDATA_MODE_P};
163 }
164
165 sub cdata_close {
166     my $this = shift;
167     return $this->{+CDATA_CLOSE};
168 }
169
170 sub allow_cformat_p {
171     my $this = shift;
172     return $this->{+ALLOW_CFORMAT_P};
173 }
174
175 # Simple setters
176
177 sub _set_fatal {
178     my $this = shift;
179     $this->{+FATAL_P} = $_[0];
180     return $this;
181 }
182
183 sub _set_syntaxerror {
184     my $this = shift;
185     $this->{+SYNTAXERROR_P} = $_[0];
186     return $this;
187 }
188
189 sub _push_readahead {
190     my $this = shift;
191     push @{$this->{+READAHEAD}}, $_[0];
192     return $this;
193 }
194
195 sub _pop_readahead {
196     my $this = shift;
197     return pop @{$this->{+READAHEAD}};
198 }
199
200 sub _append_readahead {
201     my $this = shift;
202     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] .= $_[0];
203     return $this;
204 }
205
206 sub _set_readahead {
207     my $this = shift;
208     $this->{+READAHEAD}->[$#{$this->{+READAHEAD}}] = $_[0];
209     return $this;
210 }
211
212 sub _increment_line_number {
213     my $this = shift;
214     $this->{+LINENUM} += 1;
215     return $this;
216 }
217
218 sub _set_line_number_start {
219     my $this = shift;
220     $this->{+LINENUM_START} = $_[0];
221     return $this;
222 }
223
224 sub _set_cdata_mode {
225     my $this = shift;
226     $this->{+CDATA_MODE_P} = $_[0];
227     return $this;
228 }
229
230 sub _set_cdata_close {
231     my $this = shift;
232     $this->{+CDATA_CLOSE} = $_[0];
233     return $this;
234 }
235
236 sub set_allow_cformat {
237     my $this = shift;
238     $this->{+ALLOW_CFORMAT_P} = $_[0];
239     return $this;
240 }
241
242 ###############################################################################
243
244 sub _extract_attributes ($;$) {
245     my $this = shift;
246     my($s, $lc) = @_;
247     my %attr;
248     $s = $1 if $s =~ /^<\S+(.*)\/\S$/s  # XML-style self-closing tags
249             || $s =~ /^<\S+(.*)\S$/s;   # SGML-style tags
250
251     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;) {
252         my($key, $val, $val_orig, $rest)
253                 = ($1, (defined $3? $3: defined $4? $4: $5), $2, $');
254         $i += 1;
255         $attr{+lc($key)} = [$key, $val, $val_orig, $i];
256         $s = $rest;
257         if ($val =~ /$re_tmpl_include/os) {
258             warn_normal "TMPL_INCLUDE in attribute: $val_orig\n", $lc;
259         } elsif ($val =~ /$re_tmpl_var/os && $val !~ /$re_tmpl_var_escaped/os) {
260             # XXX: we probably should not warn if key is "onclick" etc
261             # XXX: there's just no reasonable thing to suggest
262             my $suggest = ($key =~ /^(?:action|archive|background|cite|classid|codebase|data|datasrc|for|href|longdesc|profile|src|usemap)$/i? 'URL': 'HTML');
263             undef $suggest if $key =~ /^(?:onblur|onchange|onclick|ondblclick|onfocus|onkeydown|onkeypress|onkeyup|onload|onmousedown|onmousemove|onmouseout|onmouseover|onmouseup|onreset|onselect|onsubmit|onunload)$/i;
264             warn_pedantic
265                     "Suggest ESCAPE=$suggest for TMPL_VAR in attribute \"$key\""
266                         . ": $val_orig",
267                     $lc, \$pedantic_tmpl_var_use_in_nonpedantic_mode_p
268                 if defined $suggest && (pedantic_p || !$pedantic_tmpl_var_use_in_nonpedantic_mode_p);
269         } elsif ($val_orig !~ /^['"]/) {
270             my $t = $val; $t =~ s/$re_directive_control//os;
271             warn_pedantic
272                 "Unquoted attribute contains character(s) that should be quoted"
273                     . ": $val_orig",
274                 $lc, \$pedantic_attribute_error_in_nonpedantic_mode_p
275                 if $t =~ /[^-\.A-Za-z0-9]/s;
276         }
277     }
278     my $s2 = $s; $s2 =~ s/$re_tmpl_endif_endloop//g; # for the next check
279     if ($s2 =~ /\S/s) { # should never happen
280         if ($s =~ /^([^\n]*)\n/s) { # this is even worse
281             error_normal("Completely confused while extracting attributes: $1", $lc);
282             error_normal((scalar(split(/\n/, $s)) - 1) . " more line(s) not shown.", undef);
283             $this->_set_fatal( 1 );
284         } else {
285             warn_normal "Strange attribute syntax: $s\n", $lc;
286         }
287     }
288     return \%attr;
289 }
290
291 sub _next_token_internal {
292     my $this = shift;
293     my($h) = @_;
294     my($it, $kind);
295     my $eof_p = 0;
296     $this->_pop_readahead if $this->has_readahead_p
297             && !ref $this->_peek_readahead
298             && !length $this->_peek_readahead;
299     if (!$this->has_readahead_p) {
300         my $next = scalar <$h>;
301         $eof_p = !defined $next;
302         if (!$eof_p) {
303             $this->_increment_line_number;
304             $this->_push_readahead( $next );
305         }
306     }
307     $this->_set_line_number_start( $this->line_number ); # remember 1st line num
308     if ($this->has_readahead_p && ref $this->_peek_readahead) { # TmplToken obj.
309         ($it, $kind) = ($this->_pop_readahead, undef);
310     } elsif ($eof_p && !$this->has_readahead_p) {       # nothing left to do
311         ;
312     } elsif ($this->_peek_readahead =~ /^\s+/s) {       # whitespace
313         ($kind, $it) = (TmplTokenType::TEXT, $&);
314         $this->_set_readahead( $' );
315     # FIXME the following (the [<\s] part) is an unreliable HACK :-(
316     } elsif ($this->_peek_readahead =~ /^(?:[^<]|<[<\s])*(?:[^<\s])/s) {        # non-space normal text
317         ($kind, $it) = (TmplTokenType::TEXT, $&);
318         $this->_set_readahead( $' );
319         warn_normal "Unescaped < in $it\n", $this->line_number_start
320                 if !$this->cdata_mode_p && $it =~ /</s;
321     } else {                            # tag/declaration/processing instruction
322         my $ok_p = 0;
323         for (my $cdata_close = $this->cdata_close;;) {
324             if ($this->cdata_mode_p) {
325                 my $next = $this->_pop_readahead;
326                 if ($next =~ /^$cdata_close/) {
327                     ($kind, $it) = (TmplTokenType::TAG, $&);
328                     $this->_push_readahead( $' );
329                     $ok_p = 1;
330                 } elsif ($next =~ /^((?:(?!$cdata_close).)+)($cdata_close)/) {
331                     ($kind, $it) = (TmplTokenType::TEXT, $1);
332                     $this->_push_readahead( "$2$'" );
333                     $ok_p = 1;
334                 } else {
335                     ($kind, $it) = (TmplTokenType::TEXT, $next);
336                     $ok_p = 1;
337                 }
338             } elsif ($this->_peek_readahead =~ /^$re_tag_compat/os) {
339                 # If we detect a "closed start tag" but we know that the
340                 # following token looks like a TMPL_VAR, don't stop
341                 my($head, $tail, $post) = ($1, $2, $3);
342                 if ($tail eq '' && $post =~ $re_tmpl_var) {
343                     # Don't bother to show the warning if we're too confused
344                     warn_normal "Possible SGML \"closed start tag\" notation: $head<\n", $this->line_number
345                             if split(/\n/, $head) < 10;
346                 } else {
347                     ($kind, $it) = (TmplTokenType::TAG, "$head>");
348                     $this->_set_readahead( $post );
349                     $ok_p = 1;
350                     warn_normal "SGML \"closed start tag\" notation: $head<\n", $this->line_number if $tail eq '';
351                 }
352             } elsif ($this->_peek_readahead =~ /^<!--(?:(?!-->).)*-->/s) {
353                 ($kind, $it) = (TmplTokenType::COMMENT, $&);
354                 $this->_set_readahead( $' );
355                 $ok_p = 1;
356                 warn_normal "Syntax error in comment: $&\n", $this->line_number_start;
357                 $this->_set_syntaxerror( 1 );
358             }
359         last if $ok_p;
360             my $next = scalar <$h>;
361             $eof_p = !defined $next;
362         last if $eof_p;
363             $this->_increment_line_number;
364             $this->_append_readahead( $next );
365         }
366         if ($kind ne TmplTokenType::TAG) {
367             ;
368         } elsif ($it =~ /^<!/) {
369             $kind = TmplTokenType::DECL;
370             $kind = TmplTokenType::COMMENT if $it =~ /^<!--(?:(?!-->).)*-->/;
371             if ($kind == TmplTokenType::COMMENT && $it =~ /^<!--\s*#include/s) {
372                 warn_normal "Apache #include directive found instead of HTML::Template <TMPL_INCLUDE> directive", $this->line_number_start;
373             }
374         } elsif ($it =~ /^<\?/) {
375             $kind = TmplTokenType::PI;
376         }
377         if ($it =~ /^$re_directive/ios && !$this->cdata_mode_p) {
378             $kind = TmplTokenType::DIRECTIVE;
379         }
380         if (!$ok_p && $eof_p) {
381             ($kind, $it) = (TmplTokenType::UNKNOWN, $this->_peek_readahead);
382             $this->_set_readahead, undef;
383             $this->_set_syntaxerror( 1 );
384         }
385     }
386     warn_normal "Unrecognizable token found: "
387             . (split(/\n/, $it) < 10? $it: '(too confused to show details)')
388             . "\n", $this->line_number_start
389         if $kind == TmplTokenType::UNKNOWN;
390     return defined $it? (ref $it? $it: TmplToken->new($it, $kind, $this->line_number, $this->filename)): undef;
391 }
392
393 sub _next_token_intermediate {
394     my $this = shift;
395     my $h = $this->_handle;
396     my $it;
397     if (!$this->cdata_mode_p) {
398         $it = $this->_next_token_internal($h);
399         if (defined $it && $it->type == TmplTokenType::TAG) {
400             if ($it->string =~ /^<(script|style|textarea)\b/i) {
401                 $this->_set_cdata_mode( 1 );
402                 $this->_set_cdata_close( "</$1\\s*>" );
403             }
404             $it->set_attributes( $this->_extract_attributes($it->string, $it->line_number) );
405         }
406     } else {
407         for ($it = '', my $cdata_close = $this->cdata_close;;) {
408             my $next = $this->_next_token_internal($h);
409         last if !defined $next;
410             if (defined $next && $next->string =~ /$cdata_close/i) {
411                 $this->_push_readahead( $next ); # push entire TmplToken object
412                 $this->_set_cdata_mode( 0 );
413             }
414         last unless $this->cdata_mode_p;
415             $it .= $next->string;
416         }
417         $it = TmplToken->new( $it, TmplTokenType::CDATA, $this->line_number );
418         $this->_set_cdata_close, undef;
419     }
420     return $it;
421 }
422
423 sub _token_groupable1_p ($) { # as first token, groupable into TEXT_PARAMETRIZED
424     my($t) = @_;
425     return ($t->type == TmplTokenType::TEXT && $t->string !~ /^[,\.:\|\s]+$/s)
426         || ($t->type == TmplTokenType::DIRECTIVE
427                 && $t->string =~ /^(?:$re_tmpl_var)$/os)
428         || ($t->type == TmplTokenType::TAG
429                 && ($t->string =~ /^<(?:b|em|h[123456]|i|u)\b/is
430                 || ($t->string =~ /^<input/i
431                     && $t->attributes->{'type'} =~ /^(?:text)$/i)))
432 }
433
434 sub _token_groupable2_p ($) { # as other token, groupable into TEXT_PARAMETRIZED
435     my($t) = @_;
436     return ($t->type == TmplTokenType::TEXT && ($t->string =~ /^\s*$/s || $t->string !~ /^[\|\s]+$/s))
437         || ($t->type == TmplTokenType::DIRECTIVE
438                 && $t->string =~ /^(?:$re_tmpl_var)$/os)
439         || ($t->type == TmplTokenType::TAG
440                 && ($t->string =~ /^<\/?(?:a|b|em|h[123456]|i|u)\b/is
441                 || ($t->string =~ /^<input/i
442                     && $t->attributes->{'type'} =~ /^(?:text)$/i)))
443 }
444
445 sub _quote_cformat ($) {
446     my($s) = @_;
447     $s =~ s/%/%%/g;
448     return $s;
449 }
450
451 sub _formalize ($) {
452     my($t) = @_;
453     return $t->type == TmplTokenType::DIRECTIVE? '%s':
454            $t->type == TmplTokenType::TAG?
455                    ($t->string =~ /^<a\b/is? '<a>': _quote_cformat($t->string)):
456                _quote_cformat($t->string);
457 }
458
459 sub _optimize {
460     my $this = shift;
461     my @structure = @_;
462     my $undo_trailing_blanks = sub {
463                 for (my $i = $#structure; $i >= 0; $i -= 1) {
464                 last if $structure[$i]->type != TmplTokenType::TEXT;
465                 last if !blank_p($structure[$i]->string);
466                     push @{$this->{_queue}}, pop @structure;
467                 }
468             };
469     &$undo_trailing_blanks;
470     # FIXME: If the last token is a close tag but there are no tags
471     # FIXME: before it, drop the close tag back into the queue. This
472     # FIXME: is an ugly hack to get rid of "foo %s</h1>" type mess.
473     if (@structure >= 2
474             && $structure[$#structure]->type == TmplTokenType::TAG
475             && $structure[$#structure]->string =~ /^<\//s) {
476         my $has_other_tags_p = 0;
477         for (my $i = 0; $i < $#structure; $i += 1) {
478             $has_other_tags_p = 1 if $structure[$i]->type == TmplTokenType::TAG;
479         last if $has_other_tags_p;
480         }
481         push @{$this->{_queue}}, pop @structure unless $has_other_tags_p;
482         &$undo_trailing_blanks;
483     }
484     # FIXME: Do the same ugly hack for the last token being a ( or [
485     if (@structure >= 2
486             && $structure[$#structure]->type == TmplTokenType::TEXT
487             && $structure[$#structure]->string =~ /^[\(\[]$/) { # not )]
488         push @{$this->{_queue}}, pop @structure;
489         &$undo_trailing_blanks;
490     }
491     return @structure;
492 }
493
494 sub looks_plausibly_like_groupable_text_p (@) {
495     my @structure = @_;
496     # The text would look plausibly groupable if all open tags are also closed.
497     my @tags = ();
498     my $error_p = 0;
499     for (my $i = 0; $i <= $#structure; $i += 1) {
500         if ($structure[$i]->type == TmplTokenType::TAG) {
501             if ($structure[$i]->string =~ /^<([A-Z0-9]+)/i) {
502                 push @tags, lc($1);
503             } elsif ($structure[$i]->string =~ /^<\/([A-Z0-9]+)/i) {
504                 if (@tags && lc($1) eq $tags[$#tags]) {
505                     pop @tags;
506                 } else {
507                     $error_p = 1;
508                 }
509             }
510         } elsif ($structure[$i]->type != TmplTokenType::TEXT) {
511             $error_p = 1;
512         }
513     last if $error_p;
514     }
515     return !$error_p && !@tags;
516 }
517
518 sub next_token {
519     my $this = shift;
520     my $h = $this->_handle;
521     my $it;
522     $this->{_queue} = [] unless defined $this->{_queue};
523
524     # Don't reparse anything in the queue. We can put a parametrized token
525     # there if we need to, however.
526     if (@{$this->{_queue}}) {
527         $it = pop @{$this->{_queue}};
528     } else {
529         $it = $this->_next_token_intermediate($h);
530         if (!$this->cdata_mode_p && $this->allow_cformat_p && defined $it
531             && ($it->type == TmplTokenType::TEXT?
532                 !blank_p( $it->string ): _token_groupable1_p( $it ))) {
533             my @structure = ( $it );
534             my @tags = ();
535             my $next = undef;
536             my($nonblank_text_p, $parametrized_p, $with_anchor_p) = (0, 0, 0);
537             if ($it->type == TmplTokenType::TEXT) {
538                 $nonblank_text_p = 1 if !blank_p( $it->string );
539             } elsif ($it->type == TmplTokenType::DIRECTIVE) {
540                 $parametrized_p = 1;
541             } elsif ($it->type == TmplTokenType::TAG && $it->string =~ /^<([A-Z0-9]+)/is) {
542                 push @tags, lc($1);
543                 $with_anchor_p = 1 if lc($1) eq 'a';
544             }
545             # We hate | and || in msgid strings, so we try to avoid them
546             for (my $i = 1, my $quit_p = 0, my $quit_next_p = ($it->type == TmplTokenType::TEXT && $it->string =~ /^\|+$/s);; $i += 1) {
547                 $next = $this->_next_token_intermediate($h);
548                 push @structure, $next; # for consistency (with initialization)
549             last unless defined $next && _token_groupable2_p( $next );
550             last if $quit_next_p;
551                 if ($next->type == TmplTokenType::TEXT) {
552                     $nonblank_text_p = 1 if !blank_p( $next->string );
553                     $quit_p = 1 if $next->string =~ /^\|+$/s; # We hate | and ||
554                 } elsif ($next->type == TmplTokenType::DIRECTIVE) {
555                     $parametrized_p = 1;
556                 } elsif ($next->type == TmplTokenType::TAG) {
557                     if ($next->string =~ /^<([A-Z0-9]+)/is) {
558                         push @tags, lc($1);
559                         $with_anchor_p = 1 if lc($1) eq 'a';
560                     } elsif ($next->string =~ /^<\/([A-Z0-9]+)/is) {
561                         my $close = lc($1);
562                         $quit_p = 1 unless @tags && $close eq $tags[$#tags];
563                         $quit_next_p = 1 if $close =~ /^h\d$/;
564                         pop @tags;
565                     }
566                 }
567             last if $quit_p;
568             }
569             # Undo the last token
570             push @{$this->{_queue}}, pop @structure;
571             # Simply it a bit more
572             @structure = $this->_optimize( @structure );
573             if (@structure < 2) {
574                 # Nothing to do
575                 ;
576             } elsif ($nonblank_text_p && ($parametrized_p || $with_anchor_p)) {
577                 # Create the corresponding c-format string
578                 my $string = join('', map { $_->string } @structure);
579                 my $form = join('', map { _formalize $_ } @structure);
580                 my $a_counter = 0;
581                 $form =~ s/<a>/ $a_counter += 1, "<a$a_counter>" /egs;
582                 $it = TmplToken->new($string, TmplTokenType::TEXT_PARAMETRIZED, $it->line_number, $it->pathname);
583                 $it->set_form( $form );
584                 $it->set_children( @structure );
585             } elsif ($nonblank_text_p
586             && looks_plausibly_like_groupable_text_p( @structure )
587             && $structure[$#structure]->type == TmplTokenType::TEXT) {
588                 # Combine the strings
589                 my $string = join('', map { $_->string } @structure);
590                 $it = TmplToken->new($string, TmplTokenType::TEXT, $it->line_number, $it->pathname);;
591             } else {
592                 # Requeue the tokens thus seen for re-emitting
593                 for (;;) {
594                     push @{$this->{_queue}}, pop @structure;
595                 last if !@structure;
596                 }
597                 $it = pop @{$this->{_queue}};
598             }
599         }
600     }
601     return $it;
602 }
603
604 ###############################################################################
605
606 # Other simple functions (These are not methods)
607
608 sub blank_p ($) {
609     my($s) = @_;
610     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var)*$/os;
611 }
612
613 sub trim ($) {
614     my($s0) = @_;
615     my $l0 = length $s0;
616     my $s = $s0;
617     $s =~ s/^(\s|\&nbsp$re_end_entity)+//os; my $l1 = $l0 - length $s;
618     $s =~ s/(\s|\&nbsp$re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
619     return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
620 }
621
622 sub quote_po ($) {
623     my($s) = @_;
624     # Locale::PO->quote is buggy, it doesn't quote newlines :-/
625     $s =~ s/([\\"])/\\\1/gs;
626     $s =~ s/\n/\\n/g;
627     #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
628     return "\"$s\"";
629 }
630
631 # Some functions that shouldn't be here... should be moved out some time
632 sub parametrize ($$$) {
633     my($fmt_0, $params, $anchors) = @_;
634     my $it = '';
635     for (my $n = 0, my $fmt = $fmt_0; length $fmt;) {
636         if ($fmt =~ /^[^%]+/) {
637             $fmt = $';
638             $it .= $&;
639         } elsif ($fmt =~ /^%%/) {
640             $fmt = $';
641             $it .= '%';
642         } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/) {
643             $n += 1;
644             my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
645             $fmt = $';
646             if (!defined $width && !defined $prec) {
647                 $it .= $params->[$i]
648             } elsif (defined $width && defined $prec && !$width && !$prec) {
649                 ;
650             } else {
651                 die "Unsupported precision specification in format: $&\n"; #XXX
652             }
653         } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
654             $fmt = $';
655             $it .= $&;
656             die "Unknown or unsupported format specification: $&\n"; #XXX
657         } else {
658             die "Completely confused parametrizing: $fmt\n";#XXX
659         }
660     }
661     for (my $n = 0, my $fmt = $it, $it = ''; length $fmt;) {
662         if ($fmt =~ /^(?:(?!<a\d+>).)+/is) {
663             $fmt = $';
664             $it .= $&;
665         } elsif ($fmt =~ /^<a(\d+)>/is) {
666             $n += 1;
667             my $i  = $1;
668             $fmt = $';
669             my $anchor = $anchors->[$i - 1];
670             warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
671                     unless defined $anchor;
672             $it .= $anchor->string;
673         } else {
674             die "Completely confused decoding anchors: $fmt\n";#XXX
675         }
676     }
677     return $it;
678 }
679
680 sub charset_canon ($) {
681     my($charset) = @_;
682     $charset = uc($charset);
683     $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
684     $charset = 'Big5' if $charset eq 'BIG5'; # "Big5" must be in mixed case
685     return $charset;
686 }
687
688 use vars qw( @latin1_utf8 );
689 @latin1_utf8 = (
690     "\302\200", "\302\201", "\302\202", "\302\203", "\302\204", "\302\205",
691     "\302\206", "\302\207", "\302\210", "\302\211", "\302\212", "\302\213",
692     "\302\214", "\302\215",   undef,      undef,    "\302\220", "\302\221",
693     "\302\222", "\302\223", "\302\224", "\302\225", "\302\226", "\302\227",
694     "\302\230", "\302\231", "\302\232", "\302\233", "\302\234", "\302\235",
695     "\302\236", "\302\237", "\302\240", "\302\241", "\302\242", "\302\243",
696     "\302\244", "\302\245", "\302\246", "\302\247", "\302\250", "\302\251",
697     "\302\252", "\302\253", "\302\254", "\302\255", "\302\256", "\302\257",
698     "\302\260", "\302\261", "\302\262", "\302\263", "\302\264", "\302\265",
699     "\302\266", "\302\267", "\302\270", "\302\271", "\302\272", "\302\273",
700     "\302\274", "\302\275", "\302\276", "\302\277", "\303\200", "\303\201",
701     "\303\202", "\303\203", "\303\204", "\303\205", "\303\206", "\303\207",
702     "\303\210", "\303\211", "\303\212", "\303\213", "\303\214", "\303\215",
703     "\303\216", "\303\217", "\303\220", "\303\221", "\303\222", "\303\223",
704     "\303\224", "\303\225", "\303\226", "\303\227", "\303\230", "\303\231",
705     "\303\232", "\303\233", "\303\234", "\303\235", "\303\236", "\303\237",
706     "\303\240", "\303\241", "\303\242", "\303\243", "\303\244", "\303\245",
707     "\303\246", "\303\247", "\303\250", "\303\251", "\303\252", "\303\253",
708     "\303\254", "\303\255", "\303\256", "\303\257", "\303\260", "\303\261",
709     "\303\262", "\303\263", "\303\264", "\303\265", "\303\266", "\303\267",
710     "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
711     "\303\276", "\303\277" );
712
713 sub charset_convert ($$$) {
714     my($s, $charset_in, $charset_out) = @_;
715     if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
716         ;
717     } elsif ($charset_in eq 'ISO-8859-1' && $charset_out eq 'UTF-8') {
718         $s =~ s/[\200-\377]/ $latin1_utf8[ord($&) - 128] /egs;
719     } elsif ($charset_in ne $charset_out) {
720         VerboseWarnings::warn_normal "conversion from $charset_in to $charset_out is not supported\n", undef;
721     }
722     return $s;
723 }
724
725 ###############################################################################
726
727 =pod
728
729 In addition to the basic scanning, this class will also perform
730 the following:
731
732 =over
733
734 =item -
735
736 Emulation of c-format strings (see below)
737
738 =item -
739
740 Display of warnings for certain things that affects either the
741 ability of this class to yield correct output, or things that
742 are known to cause the original template to cause trouble.
743
744 =item -
745
746 Automatic correction of some of the things warned about
747 (e.g., SGML "closed start tag" notation).
748
749 =back
750
751 =head2 c-format strings emulation
752
753 Because English word order is not universal, a simple extraction
754 of translatable strings may yield some strings like "Accounts for"
755 or ambiguous strings like "in". This makes the resulting strings
756 difficult to translate, but does not affect all languages alike.
757 For example, Chinese (with a somewhat different word order) would
758 be hit harder, but French would be relatively unaffected.
759
760 To overcome this problem, the scanner can be configured to detect
761 patterns with <TMPL_VAR> directives (as well as certain HTML tags),
762 and try to construct a larger pattern that will appear in the PO
763 file as c-format strings with %s placeholders. This additional
764 step allows the translator to deal with cases where word order
765 is different (replacing %s with %1$s, %2$s, etc.), or when certain
766 words will require certain inflectional suffixes in sentences.
767
768 Because this is an incompatible change, this mode must be explicitly
769 turned on using the set_cformat(1) method call.
770
771 =head1 HISTORY
772
773 This tokenizer is mostly based
774 on Ambrose's hideous Perl script known as subst.pl.
775
776 =cut
777
778 1;