Merge remote branch 'kc/new/bug_3072' into kcmaster
[koha.git] / misc / translator / TmplTokenizer.pm
1 package TmplTokenizer;
2
3 use strict;
4 #use warnings; FIXME - Bug 2505
5 use TmplTokenType;
6 use TmplToken;
7 use TTParser;
8 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
9 require Exporter;
10
11 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
12
13 ###############################################################################
14
15 =head1 NAME
16
17 TmplTokenizer.pm - Simple-minded wrapper class for TTParser
18
19 =head1 DESCRIPTION
20
21 A wrapper for the functionality found in TTParser to allow an easier transition to Template Toolkit
22
23 =cut
24
25 ###############################################################################
26
27 $VERSION = 0.02;
28
29 @ISA = qw(Exporter);
30 @EXPORT_OK = qw();
31
32 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
33 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
34 use vars qw( $pedantic_error_markup_in_pcdata_p );
35
36 ###############################################################################
37
38 # Hideous stuff
39 use vars qw( $re_xsl $re_end_entity $re_tmpl_var);
40 BEGIN {
41     $re_tmpl_var = q{\[%\s*[get|set|default]?\s*[\w\.]+\s*[|.*?]?\s*%\]};
42     $re_xsl = q{<\/?(?:xsl:)(?:[\s\-a-zA-Z0-9"'\/\.\[\]\@\(\):=,$]+)\/?>};
43     $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace
44 }
45 # End of the hideous stuff
46
47 use vars qw( $serial );
48
49 ###############################################################################
50
51 sub FATAL_P             () {'fatal-p'}
52 sub SYNTAXERROR_P       () {'syntaxerror-p'}
53
54 sub FILENAME            () {'input'}
55 #sub HANDLE             () {'handle'}
56
57 #sub READAHEAD          () {'readahead'}
58 sub LINENUM_START       () {'lc_0'}
59 sub LINENUM             () {'lc'}
60 sub CDATA_MODE_P        () {'cdata-mode-p'}
61 sub CDATA_CLOSE         () {'cdata-close'}
62 #sub PCDATA_MODE_P      () {'pcdata-mode-p'}    # additional submode for CDATA
63 sub JS_MODE_P           () {'js-mode-p'}        # cdata-mode-p must also be true
64
65 sub ALLOW_CFORMAT_P     () {'allow-cformat-p'}
66
67 sub new {
68     shift;
69     my ($filename) = @_;
70     #open my $handle,$filename or die "can't open $filename";
71     my $parser = TTParser->new;
72     $parser->build_tokens( $filename );
73     bless {
74       filename => $filename,
75       _parser => $parser
76 #     , handle => $handle
77 #     , readahead => []
78     } , __PACKAGE__;
79 }
80
81 ###############################################################################
82
83 # Simple getters
84
85 sub filename {
86     my $this = shift;
87     return $this->{filename};
88 }
89
90 sub fatal_p {
91     my $this = shift;
92     return $this->{+FATAL_P};
93 }
94
95 # work around, currently not implemented
96 sub syntaxerror_p {
97 #    my $this = shift;
98 #    return $this->{+SYNTAXERROR_P};
99     return 0;
100 }
101
102 sub js_mode_p {
103     my $this = shift;
104     return $this->{+JS_MODE_P};
105 }
106
107 sub allow_cformat_p {
108     my $this = shift;
109     return $this->{+ALLOW_CFORMAT_P};
110 }
111
112 # Simple setters
113
114 sub _set_fatal {
115     my $this = shift;
116     $this->{+FATAL_P} = $_[0];
117     return $this;
118 }
119
120 sub _set_js_mode {
121     my $this = shift;
122     $this->{+JS_MODE_P} = $_[0];
123     return $this;
124 }
125
126 #used in xgettext, tmpl_process3 and text-extract2
127 sub set_allow_cformat {
128     my $this = shift;
129     $this->{+ALLOW_CFORMAT_P} = $_[0];
130     return $this;
131 }
132
133 ###############################################################################
134
135 use vars qw( $js_EscapeSequence );
136 BEGIN {
137     # Perl quoting is really screwed up, but this common subexp is way too long
138     $js_EscapeSequence = q{\\\\(?:['"\\\\bfnrt]|[^0-7xu]|[0-3]?[0-7]{1,2}|x[\da-fA-F]{2}|u[\da-fA-F]{4})};
139 }
140 sub parenleft  () { '(' }
141 sub parenright () { ')' }
142
143 sub _split_js ($) {
144     my ($s0) = @_;
145     my @it = ();
146     while (length $s0) {
147         if ($s0 =~ /^\s+/s) {                           # whitespace
148           push @it, $&;
149           $s0 = $';
150         } elsif ($s0 =~ /^\/\/[^\r\n]*(?:[\r\n]|$)/s) { # C++-style comment
151         push @it, $&;
152         $s0 = $';
153         } elsif ($s0 =~ /^\/\*(?:(?!\*\/).)*\*\//s) {   # C-style comment
154             push @it, $&;
155             $s0 = $';
156         # Keyword or identifier, ECMA-262 p.13 (section 7.5)
157         } elsif ($s0 =~ /^[A-Z_\$][A-Z\d_\$]*/is) {     # IdentifierName
158             push @it, $&;
159             $s0 = $';
160         # Punctuator, ECMA-262 p.13 (section 7.6)
161         } elsif ($s0 =~ /^(?:[\(\){}\[\];]|>>>=|<<=|>>=|[-\+\*\/\&\|\^\%]=|>>>|<<|>>|--|\+\+|\|\||\&\&|==|<=|>=|!=|[=><,!~\?:\.\-\+\*\/\&\|\^\%])/s) {
162             push @it, $&;
163             $s0 = $';
164         # DecimalLiteral, ECMA-262 p.14 (section 7.7.3); note: bug in the spec
165         } elsif ($s0 =~ /^(?:0|[1-9]\d+(?:\.\d*(?:[eE][-\+]?\d+)?)?)/s) {
166             push @it, $&;
167             $s0 = $';
168         # HexIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
169         } elsif ($s0 =~ /^0[xX][\da-fA-F]+/s) {
170             push @it, $&;
171             $s0 = $';
172         # OctalIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
173         } elsif ($s0 =~ /^0[\da-fA-F]+/s) {
174             push @it, $&;
175             $s0 = $';
176         # StringLiteral, ECMA-262 p.17 (section 7.7.4)
177         # XXX SourceCharacter doesn't seem to be defined (?)
178         } elsif ($s0 =~ /^(?:"(?:(?!["\\\r\n]).|$js_EscapeSequence)*"|'(?:(?!['\\\r\n]).|$js_EscapeSequence)*')/os) {
179             push @it, $&;
180             $s0 = $';
181         } elsif ($s0 =~ /^./) {                         # UNKNOWN TOKEN !!!
182             push @it, $&;
183             $s0 = $';
184         }
185     }
186     return @it;
187 }
188
189 sub STATE_UNDERSCORE     () { 1 }
190 sub STATE_PARENLEFT      () { 2 }
191 sub STATE_STRING_LITERAL () { 3 }
192
193 # XXX This is a crazy hack. I don't want to write an ECMAScript parser.
194 # XXX A scanner is one thing; a parser another thing.
195 sub _identify_js_translatables (@) {
196     my @input = @_;
197     my @output = ();
198     # We mark a JavaScript translatable string as in C, i.e., _("literal")
199     # For simplicity, we ONLY look for "_" "(" StringLiteral ")"
200     for (my $i = 0, my $state = 0, my($j, $q, $s); $i <= $#input; $i += 1) {
201 #        warn $input[$i];
202         my $reset_state_p = 0;
203         push @output, [0, $input[$i]];
204         if ($input[$i] !~ /\S/s) {
205           ;
206         } elsif ($state == 0) {
207           $state = STATE_UNDERSCORE if $input[$i] eq '_';
208         } elsif ($state == STATE_UNDERSCORE) {
209           $state = $input[$i] eq parenleft ? STATE_PARENLEFT : 0;
210         } elsif ($state == STATE_PARENLEFT) {
211           if ($input[$i] =~ /^(['"])(.*)\1$/s) {
212             ($state, $j, $q, $s) = (STATE_STRING_LITERAL, $#output, $1, $2);
213           } else {
214             $state = 0;
215           }
216         } elsif ($state == STATE_STRING_LITERAL) {
217           if ($input[$i] eq parenright) {
218             $output[$j] = [1, $output[$j]->[1], $q, $s];
219           }
220           $state = 0;
221         } else {
222           die "identify_js_translatables internal error: Unknown state $state"
223         }
224     }
225 #    use Data::Dumper;
226 #    warn Dumper \@output;
227     return \@output;
228 }
229
230 ###############################################################################
231
232 sub string_canon ($) {
233   my $s = shift;
234   # Fold all whitespace into single blanks
235   $s =~ s/\s+/ /g;
236   $s =~ s/^\s+//g;
237   return $s;
238 }
239
240 # safer version used internally, preserves new lines
241 sub string_canon_safe ($) {
242   my $s = shift;
243   # fold tabs and spaces into single spaces
244   $s =~ s/[\ \t]+/ /gs;
245   return $s;
246 }
247
248
249 sub _quote_cformat{
250   my $s = shift;
251   $s =~ s/%/%%/g;
252   return $s;
253 }
254
255 sub _formalize_string_cformat{
256   my $s = shift;
257   return _quote_cformat( string_canon_safe $s );
258 }
259
260 sub _formalize{
261   my $t = shift;
262   if( $t->type == TmplTokenType::DIRECTIVE ){
263     return '%s';
264   } elsif( $t->type == TmplTokenType::TEXT ){
265     return _formalize_string_cformat( $t->string );
266   } elsif( $t->type == TmplTokenType::TAG ){
267     if( $t->string =~ m/^a\b/is ){
268       return '<a>';
269     } elsif( $t->string =~ m/^input\b/is ){
270       if( lc $t->attributes->{'type'}->[1] eq 'text' ){
271         return '%S';
272       } else{
273         return '%p';
274       }
275     } else{
276       return _quote_cformat $t->string;
277     }     
278   } else{
279     return _quote_cformat $t->string;
280   }
281 }
282
283 # internal parametization, used within next_token
284 # method that takes in an array of TEXT and DIRECTIVE tokens (DIRECTIVEs must be GET) and return a TmplTokenType::TEXT_PARAMETRIZED
285 sub _parametrize_internal{
286     my $this = shift;
287     my @parts = @_;
288     # my $s = "";
289     # for my $item (@parts){
290     #     if( $item->type == TmplTokenType::TEXT ){
291     #         $s .= $item->string;
292     #     } else {
293     #         #must be a variable directive
294     #         $s .= "%s";
295     #     }
296     # }
297     my $s = join( "", map { _formalize $_ } @parts );
298     # should both the string and form be $s? maybe only the later? posibly the former....
299     # used line number from first token, should suffice
300     my $t = TmplToken->new( $s, TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );
301     $t->set_children(@parts);
302     $t->set_form($s);
303     return $t;
304 }
305
306 sub next_token {
307     my $self = shift;
308     my $next;
309 #    warn "in next_token";
310     # parts that make up a text_parametrized (future children of the token)
311     my @parts = ();
312     while(1){
313         $next = $self->{_parser}->next_token;
314         if (! $next){
315             if (@parts){
316                 return $self->_parametrize_internal(@parts);
317             }
318             else {
319                 return undef;
320             }
321         }
322         # if cformat mode is off, dont bother parametrizing, just return them as they come
323         return $next unless $self->allow_cformat_p;
324         if( $next->type == TmplTokenType::TEXT ){
325             push @parts, $next;
326         } 
327         elsif( $next->type == TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s*\w+\s*%\]/ ){
328             push @parts, $next;
329         } 
330         elsif ( $next->type == TmplTokenType::CDATA){
331             $self->_set_js_mode(1);
332             my $s0 = $next->string;
333             my @head = ();
334             my @tail = ();
335
336             if ($s0 =~ /^(\s*\[%\s*)(.*)(\s%=]\s*)$/s) {
337                 push @head, $1;
338                  push @tail, $3;
339                 $s0 = $2;
340             }
341             push @head, _split_js $s0;
342             $next->set_js_data(_identify_js_translatables(@head, @tail) );
343             return $next unless @parts;     
344             $self->{_parser}->unshift_token($next);
345             return $self->_parametrize_internal(@parts);
346         }
347         else {
348             # if there is nothing in parts, return this token
349             return $next unless @parts;
350
351             # OTHERWISE, put this token back and return the parametrized string of @parts
352             $self->{_parser}->unshift_token($next);
353             return $self->_parametrize_internal(@parts);
354         }
355
356     }
357 }
358
359 ###############################################################################
360
361 # function taken from old version
362 # used by tmpl_process3
363 sub parametrize ($$$$) {
364     my($fmt_0, $cformat_p, $t, $f) = @_;
365     my $it = '';
366     if ($cformat_p) {
367         my @params = $t->parameters_and_fields;
368         for (my $n = 0, my $fmt = $fmt_0; length $fmt;) {
369             if ($fmt =~ /^[^%]+/) {
370                 $fmt = $';
371                 $it .= $&;
372             } elsif ($fmt =~ /^%%/) {
373                 $fmt = $';
374                 $it .= '%';
375             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/s) {
376                 $n += 1;
377                 my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
378                 $fmt = $';
379                 if (defined $width && defined $prec && !$width && !$prec) {
380                     ;
381                 } elsif (defined $params[$i - 1]) {
382                     my $param = $params[$i - 1];
383                     warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
384                             . $param->type->to_string . "\n", undef
385                             if $param->type != TmplTokenType::DIRECTIVE;
386                     warn_normal "$fmt_0: $&: Unsupported "
387                                 . "field width or precision\n", undef
388                             if defined $width || defined $prec;
389                     warn_normal "$fmt_0: $&: Parameter $i not known", undef
390                             unless defined $param;
391                     $it .= defined $f? &$f( $param ): $param->string;
392                 }
393             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?([pS])/s) {
394                 $n += 1;
395                 my($i, $width, $prec, $conv) = ((defined $1? $1: $n), $2, $3, $4);
396                 $fmt = $';
397
398                 my $param = $params[$i - 1];
399                 if (!defined $param) {
400                     warn_normal "$fmt_0: $&: Parameter $i not known", undef;
401                 } else {
402                     if ($param->type == TmplTokenType::TAG
403                             && $param->string =~ /^<input\b/is) {
404                         my $type = defined $param->attributes?
405                                 lc($param->attributes->{'type'}->[1]): undef;
406                         if ($conv eq 'S') {
407                             warn_normal "$fmt_0: $&: Expected type=text, "
408                                         . "but found type=$type", undef
409                                     unless $type eq 'text';
410                         } elsif ($conv eq 'p') {
411                             warn_normal "$fmt_0: $&: Expected type=radio, "
412                                         . "but found type=$type", undef
413                                     unless $type eq 'radio';
414                         }
415                     } else {
416                         warn_normal "$&: Expected an INPUT, but found a "
417                                 . $param->type->to_string . "\n", undef
418                     }
419                     warn_normal "$fmt_0: $&: Unsupported "
420                                 . "field width or precision\n", undef
421                             if defined $width || defined $prec;
422                     $it .= defined $f? &$f( $param ): $param->string;
423                 }
424             } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
425                 $fmt = $';
426                 $it .= $&;
427                 die "$&: Unknown or unsupported format specification\n"; #XXX
428             } else {
429                 die "$&: Completely confused parametrizing\n";#XXX
430             }
431         }
432     }
433     my @anchors = $t->anchors;
434     for (my $n = 0, my $fmt = $it, $it = ''; length $fmt;) {
435         if ($fmt =~ /^(?:(?!<a\d+>).)+/is) {
436             $fmt = $';
437             $it .= $&;
438         } elsif ($fmt =~ /^<a(\d+)>/is) {
439             $n += 1;
440             my $i  = $1;
441             $fmt = $';
442             my $anchor = $anchors[$i - 1];
443             warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
444                     unless defined $anchor;
445             $it .= $anchor->string;
446         } else {
447             die "Completely confused decoding anchors: $fmt\n";#XXX
448         }
449     }
450     return $it;
451 }
452
453
454 # Other simple functions (These are not methods)
455
456 sub blank_p ($) {
457     my($s) = @_;
458     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
459 }
460
461 sub trim ($) {
462     my($s0) = @_;
463     my $l0 = length $s0;
464     my $s = $s0;
465     $s =~ s/^(\s|\&nbsp$re_end_entity)+//os; my $l1 = $l0 - length $s;
466     $s =~ s/(\s|\&nbsp$re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
467     return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
468 }
469
470 sub quote_po ($) {
471     my($s) = @_;
472     # Locale::PO->quote is buggy, it doesn't quote newlines :-/
473     $s =~ s/([\\"])/\\\1/gs;
474     $s =~ s/\n/\\n/g;
475     #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
476     return "\"$s\"";
477 }
478
479 sub charset_canon ($) {
480     my($charset) = @_;
481     $charset = uc($charset);
482     $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
483     $charset = 'Big5' if $charset eq 'BIG5'; # "Big5" must be in mixed case
484     return $charset;
485 }
486
487 use vars qw( @latin1_utf8 );
488 @latin1_utf8 = (
489     "\302\200", "\302\201", "\302\202", "\302\203", "\302\204", "\302\205",
490     "\302\206", "\302\207", "\302\210", "\302\211", "\302\212", "\302\213",
491     "\302\214", "\302\215",   undef,      undef,    "\302\220", "\302\221",
492     "\302\222", "\302\223", "\302\224", "\302\225", "\302\226", "\302\227",
493     "\302\230", "\302\231", "\302\232", "\302\233", "\302\234", "\302\235",
494     "\302\236", "\302\237", "\302\240", "\302\241", "\302\242", "\302\243",
495     "\302\244", "\302\245", "\302\246", "\302\247", "\302\250", "\302\251",
496     "\302\252", "\302\253", "\302\254", "\302\255", "\302\256", "\302\257",
497     "\302\260", "\302\261", "\302\262", "\302\263", "\302\264", "\302\265",
498     "\302\266", "\302\267", "\302\270", "\302\271", "\302\272", "\302\273",
499     "\302\274", "\302\275", "\302\276", "\302\277", "\303\200", "\303\201",
500     "\303\202", "\303\203", "\303\204", "\303\205", "\303\206", "\303\207",
501     "\303\210", "\303\211", "\303\212", "\303\213", "\303\214", "\303\215",
502     "\303\216", "\303\217", "\303\220", "\303\221", "\303\222", "\303\223",
503     "\303\224", "\303\225", "\303\226", "\303\227", "\303\230", "\303\231",
504     "\303\232", "\303\233", "\303\234", "\303\235", "\303\236", "\303\237",
505     "\303\240", "\303\241", "\303\242", "\303\243", "\303\244", "\303\245",
506     "\303\246", "\303\247", "\303\250", "\303\251", "\303\252", "\303\253",
507     "\303\254", "\303\255", "\303\256", "\303\257", "\303\260", "\303\261",
508     "\303\262", "\303\263", "\303\264", "\303\265", "\303\266", "\303\267",
509     "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
510     "\303\276", "\303\277" );
511
512 sub charset_convert ($$$) {
513     my($s, $charset_in, $charset_out) = @_;
514     if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
515         ;
516     } elsif ($charset_in eq 'ISO-8859-1' && $charset_out eq 'UTF-8') {
517         $s =~ s/[\200-\377]/ $latin1_utf8[ord($&) - 128] /egs;
518     } elsif ($charset_in ne $charset_out) {
519         VerboseWarnings::warn_normal "conversion from $charset_in to $charset_out is not supported\n", undef;
520     }
521     return $s;
522 }
523
524 ###############################################################################
525
526 =pod
527
528 In addition to the basic scanning, this class will also perform
529 the following:
530
531 =over
532
533 =item -
534
535 Emulation of c-format strings (see below)
536
537 =item -
538
539 Display of warnings for certain things that affects either the
540 ability of this class to yield correct output, or things that
541 are known to cause the original template to cause trouble.
542
543 =item -
544
545 Automatic correction of some of the things warned about
546 (e.g., SGML "closed start tag" notation).
547
548 =back
549
550 =head2 c-format strings emulation
551
552 Because English word order is not universal, a simple extraction
553 of translatable strings may yield some strings like "Accounts for"
554 or ambiguous strings like "in". This makes the resulting strings
555 difficult to translate, but does not affect all languages alike.
556 For example, Chinese (with a somewhat different word order) would
557 be hit harder, but French would be relatively unaffected.
558
559 To overcome this problem, the scanner can be configured to detect
560 patterns with <TMPL_VAR> directives (as well as certain HTML tags),
561 and try to construct a larger pattern that will appear in the PO
562 file as c-format strings with %s placeholders. This additional
563 step allows the translator to deal with cases where word order
564 is different (replacing %s with %1$s, %2$s, etc.), or when certain
565 words will require certain inflectional suffixes in sentences.
566
567 Because this is an incompatible change, this mode must be explicitly
568 turned on using the set_allow_cformat(1) method call.
569
570 =head2 The flag characters
571
572 The character % is followed by zero or more of the following flags:
573
574 =over
575
576 =item #
577
578 The value comes from HTML <INPUT> elements.
579 This abuse of the flag character is somewhat reasonable,
580 since TMPL_VAR and INPUT are both variables, but of different kinds.
581
582 =back
583
584 =head2 The field width and precision
585
586 An optional 0.0 can be specified for %s to specify
587 that the <TMPL_VAR> should be suppressed.
588
589 =head2 The conversion specifier
590
591 =over
592
593 =item p
594
595 Specifies any input field that is neither text nor hidden
596 (which currently mean radio buttons).
597 The p conversion specifier is chosen because this does not
598 evoke any certain sensible data type.
599
600 =item S
601
602 Specifies a text input field (<INPUT TYPE=TEXT>).
603 This use of the S conversion specifier is somewhat reasonable,
604 since text input fields contain values of undeterminable type,
605 which can be treated as strings.
606
607 =item s
608
609 Specifies a <TMPL_VAR>.
610 This use of the o conversion specifier is somewhat reasonable,
611 since <TMPL_VAR> denotes values of undeterminable type, which
612 can be treated as strings.
613
614 =back
615
616 =head1 BUGS
617
618 There is no code to save the tag name anywhere in the scanned token.
619
620 The use of <AI<i>> to stand for the I<i>th anchor
621 is not very well thought out.
622 Some abuse of c-format specifies might have been more appropriate.
623
624 =head1 HISTORY
625
626 This tokenizer is mostly based
627 on Ambrose's hideous Perl script known as subst.pl.
628
629 =cut
630
631 1;