Bug 16044: Add an unsafe flag to Koha::Cache->get_from_cache
[koha.git] / misc / translator / TmplTokenizer.pm
blob98ec61a866abb265ee0565f999ef1f5433eff842
1 package TmplTokenizer;
3 use strict;
4 #use warnings; FIXME - Bug 2505
5 use C4::TmplTokenType;
6 use C4::TmplToken;
7 use C4::TTParser;
8 use VerboseWarnings qw( pedantic_p error_normal warn_normal warn_pedantic );
9 require Exporter;
11 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
13 ###############################################################################
15 =head1 NAME
17 TmplTokenizer.pm - Simple-minded wrapper class for TTParser
19 =head1 DESCRIPTION
21 A wrapper for the functionality found in TTParser to allow an easier transition to Template Toolkit
23 =cut
25 ###############################################################################
28 @ISA = qw(Exporter);
29 @EXPORT_OK = qw();
31 use vars qw( $pedantic_attribute_error_in_nonpedantic_mode_p );
32 use vars qw( $pedantic_tmpl_var_use_in_nonpedantic_mode_p );
33 use vars qw( $pedantic_error_markup_in_pcdata_p );
35 ###############################################################################
37 # Hideous stuff
38 use vars qw( $re_xsl $re_end_entity $re_tmpl_var);
39 BEGIN {
40 $re_tmpl_var = q{\[%\s*[get|set|default]?\s*[\w\.]+\s*[|.*?]?\s*%\]};
41 $re_xsl = q{<\/?(?:xsl:)(?:[\s\-a-zA-Z0-9"'\/\.\[\]\@\(\):=,$]+)\/?>};
42 $re_end_entity = '(?:;|$|(?=\s))'; # semicolon or before-whitespace
44 # End of the hideous stuff
46 use vars qw( $serial );
48 ###############################################################################
50 sub FATAL_P () {'fatal-p'}
51 sub SYNTAXERROR_P () {'syntaxerror-p'}
53 sub FILENAME () {'input'}
54 #sub HANDLE () {'handle'}
56 #sub READAHEAD () {'readahead'}
57 sub LINENUM_START () {'lc_0'}
58 sub LINENUM () {'lc'}
59 sub CDATA_MODE_P () {'cdata-mode-p'}
60 sub CDATA_CLOSE () {'cdata-close'}
61 #sub PCDATA_MODE_P () {'pcdata-mode-p'} # additional submode for CDATA
62 sub JS_MODE_P () {'js-mode-p'} # cdata-mode-p must also be true
64 sub ALLOW_CFORMAT_P () {'allow-cformat-p'}
66 sub new {
67 shift;
68 my ($filename) = @_;
69 #open my $handle,$filename or die "can't open $filename";
70 my $parser = C4::TTParser->new;
71 $parser->build_tokens( $filename );
72 bless {
73 filename => $filename,
74 _parser => $parser
75 # , handle => $handle
76 # , readahead => []
77 } , __PACKAGE__;
80 ###############################################################################
82 # Simple getters
84 sub filename {
85 my $this = shift;
86 return $this->{filename};
89 sub fatal_p {
90 my $this = shift;
91 return $this->{+FATAL_P};
94 # work around, currently not implemented
95 sub syntaxerror_p {
96 # my $this = shift;
97 # return $this->{+SYNTAXERROR_P};
98 return 0;
101 sub js_mode_p {
102 my $this = shift;
103 return $this->{+JS_MODE_P};
106 sub allow_cformat_p {
107 my $this = shift;
108 return $this->{+ALLOW_CFORMAT_P};
111 # Simple setters
113 sub _set_fatal {
114 my $this = shift;
115 $this->{+FATAL_P} = $_[0];
116 return $this;
119 sub _set_js_mode {
120 my $this = shift;
121 $this->{+JS_MODE_P} = $_[0];
122 return $this;
125 #used in xgettext, tmpl_process3 and text-extract2
126 sub set_allow_cformat {
127 my $this = shift;
128 $this->{+ALLOW_CFORMAT_P} = $_[0];
129 return $this;
132 ###############################################################################
134 use vars qw( $js_EscapeSequence );
135 BEGIN {
136 # Perl quoting is really screwed up, but this common subexp is way too long
137 $js_EscapeSequence = q{\\\\(?:['"\\\\bfnrt]|[^0-7xu]|[0-3]?[0-7]{1,2}|x[\da-fA-F]{2}|u[\da-fA-F]{4})};
139 sub parenleft () { '(' }
140 sub parenright () { ')' }
142 sub _split_js ($) {
143 my ($s0) = @_;
144 my @it = ();
145 while (length $s0) {
146 if ($s0 =~ /^\s+/s) { # whitespace
147 push @it, $&;
148 $s0 = $';
149 } elsif ($s0 =~ /^\/\/[^\r\n]*(?:[\r\n]|$)/s) { # C++-style comment
150 push @it, $&;
151 $s0 = $';
152 } elsif ($s0 =~ /^\/\*(?:(?!\*\/).)*\*\//s) { # C-style comment
153 push @it, $&;
154 $s0 = $';
155 # Keyword or identifier, ECMA-262 p.13 (section 7.5)
156 } elsif ($s0 =~ /^[A-Z_\$][A-Z\d_\$]*/is) { # IdentifierName
157 push @it, $&;
158 $s0 = $';
159 # Punctuator, ECMA-262 p.13 (section 7.6)
160 } elsif ($s0 =~ /^(?:[\(\){}\[\];]|>>>=|<<=|>>=|[-\+\*\/\&\|\^\%]=|>>>|<<|>>|--|\+\+|\|\||\&\&|==|<=|>=|!=|[=><,!~\?:\.\-\+\*\/\&\|\^\%])/s) {
161 push @it, $&;
162 $s0 = $';
163 # DecimalLiteral, ECMA-262 p.14 (section 7.7.3); note: bug in the spec
164 } elsif ($s0 =~ /^(?:0|[1-9]\d+(?:\.\d*(?:[eE][-\+]?\d+)?)?)/s) {
165 push @it, $&;
166 $s0 = $';
167 # HexIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
168 } elsif ($s0 =~ /^0[xX][\da-fA-F]+/s) {
169 push @it, $&;
170 $s0 = $';
171 # OctalIntegerLiteral, ECMA-262 p.15 (section 7.7.3)
172 } elsif ($s0 =~ /^0[\da-fA-F]+/s) {
173 push @it, $&;
174 $s0 = $';
175 # StringLiteral, ECMA-262 p.17 (section 7.7.4)
176 # XXX SourceCharacter doesn't seem to be defined (?)
177 } elsif ($s0 =~ /^(?:"(?:(?!["\\\r\n]).|$js_EscapeSequence)*"|'(?:(?!['\\\r\n]).|$js_EscapeSequence)*')/os) {
178 push @it, $&;
179 $s0 = $';
180 } elsif ($s0 =~ /^./) { # UNKNOWN TOKEN !!!
181 push @it, $&;
182 $s0 = $';
185 return @it;
188 sub STATE_UNDERSCORE () { 1 }
189 sub STATE_PARENLEFT () { 2 }
190 sub STATE_STRING_LITERAL () { 3 }
192 # XXX This is a crazy hack. I don't want to write an ECMAScript parser.
193 # XXX A scanner is one thing; a parser another thing.
194 sub _identify_js_translatables (@) {
195 my @input = @_;
196 my @output = ();
197 # We mark a JavaScript translatable string as in C, i.e., _("literal")
198 # For simplicity, we ONLY look for "_" "(" StringLiteral ")"
199 for (my $i = 0, my $state = 0, my($j, $q, $s); $i <= $#input; $i += 1) {
200 # warn $input[$i];
201 my $reset_state_p = 0;
202 push @output, [0, $input[$i]];
203 if ($input[$i] !~ /\S/s) {
205 } elsif ($state == 0) {
206 $state = STATE_UNDERSCORE if $input[$i] eq '_';
207 } elsif ($state == STATE_UNDERSCORE) {
208 $state = $input[$i] eq parenleft ? STATE_PARENLEFT : 0;
209 } elsif ($state == STATE_PARENLEFT) {
210 if ($input[$i] =~ /^(['"])(.*)\1$/s) {
211 ($state, $j, $q, $s) = (STATE_STRING_LITERAL, $#output, $1, $2);
212 } else {
213 $state = 0;
215 } elsif ($state == STATE_STRING_LITERAL) {
216 if ($input[$i] eq parenright) {
217 $output[$j] = [1, $output[$j]->[1], $q, $s];
219 $state = 0;
220 } else {
221 die "identify_js_translatables internal error: Unknown state $state"
224 # use Data::Dumper;
225 # warn Dumper \@output;
226 return \@output;
229 ###############################################################################
231 sub string_canon ($) {
232 my $s = shift;
233 # Fold all whitespace into single blanks
234 $s =~ s/\s+/ /g;
235 $s =~ s/^\s+//g;
236 return $s;
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;
248 sub _quote_cformat{
249 my $s = shift;
250 $s =~ s/%/%%/g;
251 return $s;
254 sub _formalize_string_cformat{
255 my $s = shift;
256 return _quote_cformat( string_canon_safe $s );
259 sub _formalize{
260 my $t = shift;
261 if( $t->type == C4::TmplTokenType::DIRECTIVE ){
262 return '%s';
263 } elsif( $t->type == C4::TmplTokenType::TEXT ){
264 return _formalize_string_cformat( $t->string );
265 } elsif( $t->type == C4::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';
274 } else{
275 return _quote_cformat $t->string;
277 } else{
278 return _quote_cformat $t->string;
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 C4::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 == C4::TmplTokenType::TEXT ){
290 # $s .= $item->string;
291 # } else {
292 # #must be a variable directive
293 # $s .= "%s";
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 = C4::TmplToken->new( $s, C4::TmplTokenType::TEXT_PARAMETRIZED, $parts[0]->line_number, $this->filename );
300 $t->set_children(@parts);
301 $t->set_form($s);
302 return $t;
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);
317 else {
318 return undef;
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 == C4::TmplTokenType::TEXT ){
324 push @parts, $next;
326 # elsif( $next->type == C4::TmplTokenType::DIRECTIVE && $next->string =~ m/\[%\s*\w+\s*%\]/ ){
327 elsif( $next->type == C4::TmplTokenType::DIRECTIVE ){
328 push @parts, $next;
330 elsif ( $next->type == C4::TmplTokenType::CDATA){
331 $self->_set_js_mode(1);
332 my $s0 = $next->string;
333 my @head = ();
334 my @tail = ();
336 if ($s0 =~ /^(\s*\[%\s*)(.*)(\s%=]\s*)$/s) {
337 push @head, $1;
338 push @tail, $3;
339 $s0 = $2;
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);
347 else {
348 # if there is nothing in parts, return this token
349 return $next unless @parts;
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);
359 ###############################################################################
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) {
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 != C4::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;
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 = $';
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 == C4::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';
415 } else {
416 warn_normal "$&: Expected an INPUT, but found a "
417 . $param->type->to_string . "\n", undef
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;
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 -- msgid: $fmt_0\n";#XXX
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
450 return $it;
454 # Other simple functions (These are not methods)
456 sub blank_p ($) {
457 my($s) = @_;
458 return $s =~ /^(?:\s|\&nbsp$re_end_entity|$re_tmpl_var|$re_xsl)*$/osi;
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;
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\"";
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;
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" );
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
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;
521 return $s;
524 ###############################################################################
526 =pod
528 In addition to the basic scanning, this class will also perform
529 the following:
531 =over
533 =item -
535 Emulation of c-format strings (see below)
537 =item -
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.
543 =item -
545 Automatic correction of some of the things warned about
546 (e.g., SGML "closed start tag" notation).
548 =back
550 =head2 c-format strings emulation
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.
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.
567 Because this is an incompatible change, this mode must be explicitly
568 turned on using the set_allow_cformat(1) method call.
570 =head2 The flag characters
572 The character % is followed by zero or more of the following flags:
574 =over
576 =item #
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.
582 =back
584 =head2 The field width and precision
586 An optional 0.0 can be specified for %s to specify
587 that the <TMPL_VAR> should be suppressed.
589 =head2 The conversion specifier
591 =over
593 =item p
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.
600 =item S
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.
607 =item s
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.
614 =back
616 =head1 BUGS
618 There is no code to save the tag name anywhere in the scanned token.
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.
624 =head1 HISTORY
626 This tokenizer is mostly based
627 on Ambrose's hideous Perl script known as subst.pl.
629 =cut