Bug 5917 : More tweaks to the translation
[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   return $s;
237 }
238
239 # safer version used internally, preserves new lines
240 sub string_canon_safe ($) {
241   my $s = shift;
242   # fold tabs and spaces into single spaces
243   $s =~ s/[\ \t]+/ /gs;
244   return $s;
245 }
246
247
248 sub _quote_cformat{
249   my $s = shift;
250   $s =~ s/%/%%/g;
251   return $s;
252 }
253
254 sub _formalize_string_cformat{
255   my $s = shift;
256   return _quote_cformat( string_canon_safe $s );
257 }
258
259 sub _formalize{
260   my $t = shift;
261   if( $t->type == TmplTokenType::DIRECTIVE ){
262     return '%s';
263   } elsif( $t->type == TmplTokenType::TEXT ){
264     return _formalize_string_cformat( $t->string );
265   } elsif( $t->type == TmplTokenType::TAG ){
266     if( $t->string =~ m/^a\b/is ){
267       return '<a>';
268     } elsif( $t->string =~ m/^input\b/is ){
269       if( lc $t->attributes->{'type'}->[1] eq 'text' ){
270         return '%S';
271       } else{
272         return '%p';
273       }
274     } else{
275       return _quote_cformat $t->string;
276     }     
277   } else{
278     return _quote_cformat $t->string;
279   }
280 }
281
282 # internal parametization, used within next_token
283 # method that takes in an array of TEXT and DIRECTIVE tokens (DIRECTIVEs must be GET) and return a TmplTokenType::TEXT_PARAMETRIZED
284 sub _parametrize_internal{
285     my $this = shift;
286     my @parts = @_;
287     # my $s = "";
288     # for my $item (@parts){
289     #     if( $item->type == TmplTokenType::TEXT ){
290     #         $s .= $item->string;
291     #     } else {
292     #         #must be a variable directive
293     #         $s .= "%s";
294     #     }
295     # }
296     my $s = join( "", map { _formalize $_ } @parts );
297     # should both the string and form be $s? maybe only the later? posibly the former....
298     # used line number from first token, should suffice
299     my $t = TmplToken->new( $s, TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );
300     $t->set_children(@parts);
301     $t->set_form($s);
302     return $t;
303 }
304
305 sub next_token {
306     my $self = shift;
307     my $next;
308 #    warn "in next_token";
309     # parts that make up a text_parametrized (future children of the token)
310     my @parts = ();
311     while(1){
312         $next = $self->{_parser}->next_token;
313         if (! $next){
314             if (@parts){
315                 return $self->_parametrize_internal(@parts);
316             }
317             else {
318                 return undef;
319             }
320         }
321         # if cformat mode is off, dont bother parametrizing, just return them as they come
322         return $next unless $self->allow_cformat_p;
323         if( $next->type == TmplTokenType::TEXT ){
324             push @parts, $next;
325         } 
326         elsif( $next->type == TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s*\w+\s*%\]/ ){
327             push @parts, $next;
328         } 
329         elsif ( $next->type == TmplTokenType::CDATA){
330             $self->_set_js_mode(1);
331             my $s0 = $next->string;
332             my @head = ();
333             my @tail = ();
334
335             if ($s0 =~ /^(\s*\[%\s*)(.*)(\s%=]\s*)$/s) {
336                 push @head, $1;
337                  push @tail, $3;
338                 $s0 = $2;
339             }
340             push @head, _split_js $s0;
341             $next->set_js_data(_identify_js_translatables(@head, @tail) );
342             return $next unless @parts;     
343             $self->{_parser}->unshift_token($next);
344             return $self->_parametrize_internal(@parts);
345         }
346         else {
347             # if there is nothing in parts, return this token
348             return $next unless @parts;
349
350             # OTHERWISE, put this token back and return the parametrized string of @parts
351             $self->{_parser}->unshift_token($next);
352             return $self->_parametrize_internal(@parts);
353         }
354
355     }
356 }
357
358 ###############################################################################
359
360 # function taken from old version
361 # used by tmpl_process3
362 sub parametrize ($$$$) {
363     my($fmt_0, $cformat_p, $t, $f) = @_;
364     my $it = '';
365     if ($cformat_p) {
366         my @params = $t->parameters_and_fields;
367         for (my $n = 0, my $fmt = $fmt_0; length $fmt;) {
368             if ($fmt =~ /^[^%]+/) {
369                 $fmt = $';
370                 $it .= $&;
371             } elsif ($fmt =~ /^%%/) {
372                 $fmt = $';
373                 $it .= '%';
374             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?s/s) {
375                 $n += 1;
376                 my($i, $width, $prec) = ((defined $1? $1: $n), $2, $3);
377                 $fmt = $';
378                 if (defined $width && defined $prec && !$width && !$prec) {
379                     ;
380                 } elsif (defined $params[$i - 1]) {
381                     my $param = $params[$i - 1];
382                     warn_normal "$fmt_0: $&: Expected a TMPL_VAR, but found a "
383                             . $param->type->to_string . "\n", undef
384                             if $param->type != TmplTokenType::DIRECTIVE;
385                     warn_normal "$fmt_0: $&: Unsupported "
386                                 . "field width or precision\n", undef
387                             if defined $width || defined $prec;
388                     warn_normal "$fmt_0: $&: Parameter $i not known", undef
389                             unless defined $param;
390                     $it .= defined $f? &$f( $param ): $param->string;
391                 }
392             } elsif ($fmt =~ /^%(?:(\d+)\$)?(?:(\d+)(?:\.(\d+))?)?([pS])/s) {
393                 $n += 1;
394                 my($i, $width, $prec, $conv) = ((defined $1? $1: $n), $2, $3, $4);
395                 $fmt = $';
396
397                 my $param = $params[$i - 1];
398                 if (!defined $param) {
399                     warn_normal "$fmt_0: $&: Parameter $i not known", undef;
400                 } else {
401                     if ($param->type == TmplTokenType::TAG
402                             && $param->string =~ /^<input\b/is) {
403                         my $type = defined $param->attributes?
404                                 lc($param->attributes->{'type'}->[1]): undef;
405                         if ($conv eq 'S') {
406                             warn_normal "$fmt_0: $&: Expected type=text, "
407                                         . "but found type=$type", undef
408                                     unless $type eq 'text';
409                         } elsif ($conv eq 'p') {
410                             warn_normal "$fmt_0: $&: Expected type=radio, "
411                                         . "but found type=$type", undef
412                                     unless $type eq 'radio';
413                         }
414                     } else {
415                         warn_normal "$&: Expected an INPUT, but found a "
416                                 . $param->type->to_string . "\n", undef
417                     }
418                     warn_normal "$fmt_0: $&: Unsupported "
419                                 . "field width or precision\n", undef
420                             if defined $width || defined $prec;
421                     $it .= defined $f? &$f( $param ): $param->string;
422                 }
423             } elsif ($fmt =~ /^%[^%a-zA-Z]*[a-zA-Z]/) {
424                 $fmt = $';
425                 $it .= $&;
426                 die "$&: Unknown or unsupported format specification\n"; #XXX
427             } else {
428                 die "$&: Completely confused parametrizing\n";#XXX
429             }
430         }
431     }
432     my @anchors = $t->anchors;
433     for (my $n = 0, my $fmt = $it, $it = ''; length $fmt;) {
434         if ($fmt =~ /^(?:(?!<a\d+>).)+/is) {
435             $fmt = $';
436             $it .= $&;
437         } elsif ($fmt =~ /^<a(\d+)>/is) {
438             $n += 1;
439             my $i  = $1;
440             $fmt = $';
441             my $anchor = $anchors[$i - 1];
442             warn_normal "$&: Anchor $1 not found for msgid \"$fmt_0\"", undef #FIXME
443                     unless defined $anchor;
444             $it .= $anchor->string;
445         } else {
446             die "Completely confused decoding anchors: $fmt\n";#XXX
447         }
448     }
449     return $it;
450 }
451
452
453 # Other simple functions (These are not methods)
454
455 sub blank_p ($) {
456     my($s) = @_;
457     return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
458 }
459
460 sub trim ($) {
461     my($s0) = @_;
462     my $l0 = length $s0;
463     my $s = $s0;
464     $s =~ s/^(\s|\&nbsp$re_end_entity)+//os; my $l1 = $l0 - length $s;
465     $s =~ s/(\s|\&nbsp$re_end_entity)+$//os; my $l2 = $l0 - $l1 - length $s;
466     return wantarray? (substr($s0, 0, $l1), $s, substr($s0, $l0 - $l2)): $s;
467 }
468
469 sub quote_po ($) {
470     my($s) = @_;
471     # Locale::PO->quote is buggy, it doesn't quote newlines :-/
472     $s =~ s/([\\"])/\\\1/gs;
473     $s =~ s/\n/\\n/g;
474     #$s =~ s/[\177-\377]/ sprintf("\\%03o", ord($&)) /egs;
475     return "\"$s\"";
476 }
477
478 sub charset_canon ($) {
479     my($charset) = @_;
480     $charset = uc($charset);
481     $charset = "$1-$2" if $charset =~ /^(ISO|UTF)(\d.*)/i;
482     $charset = 'Big5' if $charset eq 'BIG5'; # "Big5" must be in mixed case
483     return $charset;
484 }
485
486 use vars qw( @latin1_utf8 );
487 @latin1_utf8 = (
488     "\302\200", "\302\201", "\302\202", "\302\203", "\302\204", "\302\205",
489     "\302\206", "\302\207", "\302\210", "\302\211", "\302\212", "\302\213",
490     "\302\214", "\302\215",   undef,      undef,    "\302\220", "\302\221",
491     "\302\222", "\302\223", "\302\224", "\302\225", "\302\226", "\302\227",
492     "\302\230", "\302\231", "\302\232", "\302\233", "\302\234", "\302\235",
493     "\302\236", "\302\237", "\302\240", "\302\241", "\302\242", "\302\243",
494     "\302\244", "\302\245", "\302\246", "\302\247", "\302\250", "\302\251",
495     "\302\252", "\302\253", "\302\254", "\302\255", "\302\256", "\302\257",
496     "\302\260", "\302\261", "\302\262", "\302\263", "\302\264", "\302\265",
497     "\302\266", "\302\267", "\302\270", "\302\271", "\302\272", "\302\273",
498     "\302\274", "\302\275", "\302\276", "\302\277", "\303\200", "\303\201",
499     "\303\202", "\303\203", "\303\204", "\303\205", "\303\206", "\303\207",
500     "\303\210", "\303\211", "\303\212", "\303\213", "\303\214", "\303\215",
501     "\303\216", "\303\217", "\303\220", "\303\221", "\303\222", "\303\223",
502     "\303\224", "\303\225", "\303\226", "\303\227", "\303\230", "\303\231",
503     "\303\232", "\303\233", "\303\234", "\303\235", "\303\236", "\303\237",
504     "\303\240", "\303\241", "\303\242", "\303\243", "\303\244", "\303\245",
505     "\303\246", "\303\247", "\303\250", "\303\251", "\303\252", "\303\253",
506     "\303\254", "\303\255", "\303\256", "\303\257", "\303\260", "\303\261",
507     "\303\262", "\303\263", "\303\264", "\303\265", "\303\266", "\303\267",
508     "\303\270", "\303\271", "\303\272", "\303\273", "\303\274", "\303\275",
509     "\303\276", "\303\277" );
510
511 sub charset_convert ($$$) {
512     my($s, $charset_in, $charset_out) = @_;
513     if ($s !~ /[\200-\377]/s) { # FIXME: don't worry about iso2022 for now
514         ;
515     } elsif ($charset_in eq 'ISO-8859-1' && $charset_out eq 'UTF-8') {
516         $s =~ s/[\200-\377]/ $latin1_utf8[ord($&) - 128] /egs;
517     } elsif ($charset_in ne $charset_out) {
518         VerboseWarnings::warn_normal "conversion from $charset_in to $charset_out is not supported\n", undef;
519     }
520     return $s;
521 }
522
523 ###############################################################################
524
525 =pod
526
527 In addition to the basic scanning, this class will also perform
528 the following:
529
530 =over
531
532 =item -
533
534 Emulation of c-format strings (see below)
535
536 =item -
537
538 Display of warnings for certain things that affects either the
539 ability of this class to yield correct output, or things that
540 are known to cause the original template to cause trouble.
541
542 =item -
543
544 Automatic correction of some of the things warned about
545 (e.g., SGML "closed start tag" notation).
546
547 =back
548
549 =head2 c-format strings emulation
550
551 Because English word order is not universal, a simple extraction
552 of translatable strings may yield some strings like "Accounts for"
553 or ambiguous strings like "in". This makes the resulting strings
554 difficult to translate, but does not affect all languages alike.
555 For example, Chinese (with a somewhat different word order) would
556 be hit harder, but French would be relatively unaffected.
557
558 To overcome this problem, the scanner can be configured to detect
559 patterns with <TMPL_VAR> directives (as well as certain HTML tags),
560 and try to construct a larger pattern that will appear in the PO
561 file as c-format strings with %s placeholders. This additional
562 step allows the translator to deal with cases where word order
563 is different (replacing %s with %1$s, %2$s, etc.), or when certain
564 words will require certain inflectional suffixes in sentences.
565
566 Because this is an incompatible change, this mode must be explicitly
567 turned on using the set_allow_cformat(1) method call.
568
569 =head2 The flag characters
570
571 The character % is followed by zero or more of the following flags:
572
573 =over
574
575 =item #
576
577 The value comes from HTML <INPUT> elements.
578 This abuse of the flag character is somewhat reasonable,
579 since TMPL_VAR and INPUT are both variables, but of different kinds.
580
581 =back
582
583 =head2 The field width and precision
584
585 An optional 0.0 can be specified for %s to specify
586 that the <TMPL_VAR> should be suppressed.
587
588 =head2 The conversion specifier
589
590 =over
591
592 =item p
593
594 Specifies any input field that is neither text nor hidden
595 (which currently mean radio buttons).
596 The p conversion specifier is chosen because this does not
597 evoke any certain sensible data type.
598
599 =item S
600
601 Specifies a text input field (<INPUT TYPE=TEXT>).
602 This use of the S conversion specifier is somewhat reasonable,
603 since text input fields contain values of undeterminable type,
604 which can be treated as strings.
605
606 =item s
607
608 Specifies a <TMPL_VAR>.
609 This use of the o conversion specifier is somewhat reasonable,
610 since <TMPL_VAR> denotes values of undeterminable type, which
611 can be treated as strings.
612
613 =back
614
615 =head1 BUGS
616
617 There is no code to save the tag name anywhere in the scanned token.
618
619 The use of <AI<i>> to stand for the I<i>th anchor
620 is not very well thought out.
621 Some abuse of c-format specifies might have been more appropriate.
622
623 =head1 HISTORY
624
625 This tokenizer is mostly based
626 on Ambrose's hideous Perl script known as subst.pl.
627
628 =cut
629
630 1;