Bug 21395: Ignore .perlcriticrc in t/Makefile.t
[koha.git] / misc / translator / tmpl_process3.pl
blob45a9b6e7a82a28d5a462fd5a2d49829e94c36dce
1 #!/usr/bin/perl
2 # This file is part of Koha
3 # Parts copyright 2003-2004 Paul Poulain
4 # Parts copyright 2003-2004 Jerome Vizcaino
5 # Parts copyright 2004 Ambrose Li
7 use FindBin;
8 use lib $FindBin::Bin;
10 =head1 NAME
12 tmpl_process3.pl - Alternative version of tmpl_process.pl
13 using gettext-compatible translation files
15 =cut
17 use strict;
18 #use warnings; FIXME - Bug 2505
19 use File::Basename;
20 use Getopt::Long;
21 use Locale::PO;
22 use File::Temp qw( :POSIX );
23 use TmplTokenizer;
24 use VerboseWarnings qw( :warn :die );
26 ###############################################################################
28 use vars qw( @in_dirs @filenames @match @nomatch $str_file $out_dir $quiet );
29 use vars qw( @excludes $exclude_regex );
30 use vars qw( $recursive_p );
31 use vars qw( $pedantic_p );
32 use vars qw( $href );
33 use vars qw( $type ); # file extension (DOS form without the dot) to match
34 use vars qw( $charset_in $charset_out );
36 ###############################################################################
38 sub find_translation {
39 my($s) = @_;
40 my $key = $s;
41 if ($s =~ /\S/s) {
42 $key = TmplTokenizer::string_canon($key);
43 $key = TmplTokenizer::charset_convert($key, $charset_in, $charset_out);
44 $key = TmplTokenizer::quote_po($key);
46 if (defined $href->{$key} && !$href->{$key}->fuzzy && length Locale::PO->dequote($href->{$key}->msgstr)){
47 if ($s =~ /^(\s+)/){
48 return $1 . Locale::PO->dequote($href->{$key}->msgstr);
50 else {
51 return Locale::PO->dequote($href->{$key}->msgstr);
54 else {
55 return $s;
59 sub text_replace_tag {
60 my($t, $attr) = @_;
61 my $it;
62 my @ttvar;
64 # value [tag=input], meta
65 my $tag = ($t =~ /^<(\S+)/s) ? lc($1) : undef;
66 my $translated_p = 0;
67 for my $a ('alt', 'content', 'title', 'value', 'label', 'placeholder') {
68 if ($attr->{$a}) {
69 next if $a eq 'label' && $tag ne 'optgroup';
70 next if $a eq 'content' && $tag ne 'meta';
71 next if $a eq 'value' && ($tag ne 'input' || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:checkbox|hidden|radio)$/)); # FIXME
73 my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
74 if ($val =~ /\S/s) {
75 # for selected attributes replace '[%..%]' with '%s' and remember matches
76 if ( $a =~ /title|value|alt|content|placeholder/ ) {
77 while ( $val =~ s/(\[\%.*?\%\])/\%s/ ) {
78 my $var = $1;
79 push @ttvar, $1;
82 # find translation for transformed attributes
83 my $s = find_translation($val);
84 # replace '%s' with original content (in order) on translated string, this is fragile!
85 if ( $a =~ /title|value|alt|content|placeholder/ and @ttvar ) {
86 while ( @ttvar ) {
87 my $var = shift @ttvar;
88 $s =~ s/\%s/$var/;
91 if ($attr->{$a}->[1] ne $s) { #FIXME
92 $attr->{$a}->[1] = $s; # FIXME
93 $attr->{$a}->[2] = ($s =~ /"/s)? "'$s'": "\"$s\""; #FIXME
94 $translated_p = 1;
99 if ($translated_p) {
100 $it = "<$tag"
101 . join('', map { if ($_ ne '/'){
102 sprintf(' %s="%s"', $_, $attr->{$_}->[1]);
104 else {
105 sprintf(' %s',$_);
108 } sort {
109 $attr->{$a}->[3] <=> $attr->{$b}->[3] #FIXME
110 || $a cmp $b # Sort attributes BZ 22236
111 } keys %$attr);
112 $it .= '>';
114 else {
115 $it = $t;
117 return $it;
120 sub text_replace {
121 my($h, $output) = @_;
122 for (;;) {
123 my $s = TmplTokenizer::next_token($h);
124 last unless defined $s;
125 my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
126 if ($kind eq C4::TmplTokenType::TEXT) {
127 print $output find_translation($t);
128 } elsif ($kind eq C4::TmplTokenType::TEXT_PARAMETRIZED) {
129 my $fmt = find_translation($s->form);
130 print $output TmplTokenizer::parametrize($fmt, 1, $s, sub {
131 $_ = $_[0];
132 my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
133 $kind == C4::TmplTokenType::TAG && %$attr?
134 text_replace_tag($t, $attr): $t });
135 } elsif ($kind eq C4::TmplTokenType::TAG && %$attr) {
136 print $output text_replace_tag($t, $attr);
137 } elsif ($s->has_js_data) {
138 for my $t (@{$s->js_data}) {
139 # FIXME for this whole block
140 if ($t->[0]) {
141 printf $output "%s%s%s", $t->[2], find_translation($t->[3]),
142 $t->[2];
143 } else {
144 print $output $t->[1];
147 } elsif (defined $t) {
148 # Quick fix to bug 4472
149 $t = "<!DOCTYPE stylesheet [" if $t =~ /DOCTYPE stylesheet/ ;
150 print $output $t;
155 sub listfiles {
156 my($dir, $type, $action) = @_;
157 my $filenames = join ('|', @filenames); # used to update strings from this file
158 my $match = join ('|', @match); # use only this files
159 my $nomatch = join ('|', @nomatch); # do no use this files
160 my @it = ();
161 if (opendir(DIR, $dir)) {
162 my @dirent = readdir DIR; # because DIR is shared when recursing
163 closedir DIR;
164 for my $dirent (@dirent) {
165 my $path = "$dir/$dirent";
166 if ($dirent =~ /^\./ || $dirent eq 'CVS' || $dirent eq 'RCS'
167 || (defined $exclude_regex && $dirent =~ /^(?:$exclude_regex)$/)) {
169 } elsif (-f $path) {
170 my $basename = fileparse( $path );
171 push @it, $path
172 if ( not @filenames or $basename =~ /($filenames)/i )
173 and ( not @match or $basename =~ /($match)/i ) # files to include
174 and ( not @nomatch or $basename !~ /($nomatch)/i ) # files not to include
175 and (!defined $type || $dirent =~ /\.(?:$type)$/) || $action eq 'install';
176 } elsif (-d $path && $recursive_p) {
177 push @it, listfiles($path, $type, $action);
180 } else {
181 warn_normal("$dir: $!", undef);
183 return @it;
186 ###############################################################################
188 sub mkdir_recursive {
189 my($dir) = @_;
190 local($`, $&, $', $1);
191 $dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
192 my ($prefix, $basename) = ($dir =~ /\/([^\/]+)$/s)? ($`, $1): ('.', $dir);
193 mkdir_recursive($prefix) if $prefix ne '.' && !-d $prefix;
194 if (!-d $dir) {
195 print STDERR "Making directory $dir...\n" unless $quiet;
196 # creates with rwxrwxr-x permissions
197 mkdir($dir, 0775) || warn_normal("$dir: $!", undef);
201 ###############################################################################
203 sub usage {
204 my($exitcode) = @_;
205 my $h = $exitcode? *STDERR: *STDOUT;
206 print $h <<EOF;
207 Usage: $0 create [OPTION]
208 or: $0 update [OPTION]
209 or: $0 install [OPTION]
210 or: $0 --help
211 Create or update PO files from templates, or install translated templates.
213 -i, --input=SOURCE Get or update strings from SOURCE directory(s).
214 On create or update can have multiple values.
215 On install only one value.
216 -o, --outputdir=DIRECTORY Install translation(s) to specified DIRECTORY
217 --pedantic-warnings Issue warnings even for detected problems
218 which are likely to be harmless
219 -r, --recursive SOURCE in the -i option is a directory
220 -f, --filename=FILE FILE is a specific filename or part of it.
221 If given, only these files will be processed.
222 On update only relevant strings will be updated.
223 -m, --match=FILE FILE is a specific filename or part of it.
224 If given, only these files will be processed.
225 -n, --nomatch=FILE FILE is a specific filename or part of it.
226 If given, these files will not be processed.
227 -s, --str-file=FILE Specify FILE as the translation (po) file
228 for input (install) or output (create, update)
229 -x, --exclude=REGEXP Exclude dirs matching the given REGEXP
230 --help Display this help and exit
231 -q, --quiet no output to screen (except for errors)
233 The -o option is ignored for the "create" and "update" actions.
234 Try `perldoc $0` for perhaps more information.
236 exit($exitcode);
239 ###############################################################################
241 sub usage_error {
242 for my $msg (split(/\n/, $_[0])) {
243 print STDERR "$msg\n";
245 print STDERR "Try `$0 --help for more information.\n";
246 exit(-1);
249 ###############################################################################
251 GetOptions(
252 'input|i=s' => \@in_dirs,
253 'filename|f=s' => \@filenames,
254 'match|m=s' => \@match,
255 'nomatch|n=s' => \@nomatch,
256 'outputdir|o=s' => \$out_dir,
257 'recursive|r' => \$recursive_p,
258 'str-file|s=s' => \$str_file,
259 'exclude|x=s' => \@excludes,
260 'quiet|q' => \$quiet,
261 'pedantic-warnings|pedantic' => sub { $pedantic_p = 1 },
262 'help' => \&usage,
263 ) || usage_error();
265 VerboseWarnings::set_application_name($0);
266 VerboseWarnings::set_pedantic_mode($pedantic_p);
268 # keep the buggy Locale::PO quiet if it says stupid things
269 $SIG{__WARN__} = sub {
270 my($s) = @_;
271 print STDERR $s unless $s =~ /^Strange line in [^:]+: #~/s
274 my $action = shift or usage_error('You must specify an ACTION.');
275 usage_error('You must at least specify input and string list filenames.')
276 if !@in_dirs || !defined $str_file;
278 # Type match defaults to *.tt plus *.inc if not specified
279 $type = "tt|inc|xsl|xml|def" if !defined($type);
281 # Check the inputs for being directories
282 for my $in_dir ( @in_dirs ) {
283 usage_error("$in_dir: Input must be a directory.\n"
284 . "(Symbolic links are not supported at the moment)")
285 unless -d $in_dir;
288 # Generates the global exclude regular expression
289 $exclude_regex = '(?:'.join('|', @excludes).')' if @excludes;
291 my @in_files;
292 # Generate the list of input files if a directory is specified
293 # input is a directory, generates list of files to process
295 for my $fn ( @filenames ) {
296 die "You cannot specify input files and directories at the same time.\n"
297 if -d $fn;
299 for my $in_dir ( @in_dirs ) {
300 $in_dir =~ s/\/$//; # strips the trailing / if any
301 @in_files = ( @in_files, listfiles($in_dir, $type, $action));
304 # restores the string list from file
305 $href = Locale::PO->load_file_ashash($str_file, 'utf-8');
307 # guess the charsets. HTML::Templates defaults to iso-8859-1
308 if (defined $href) {
309 die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
310 $charset_out = TmplTokenizer::charset_canon($2) if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
311 $charset_in = $charset_out;
312 # for my $msgid (keys %$href) {
313 # if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
314 # my $candidate = TmplTokenizer::charset_canon $2;
315 # die "Conflicting charsets in msgid: $charset_in vs $candidate => $msgid\n"
316 # if defined $charset_in && $charset_in ne $candidate;
317 # $charset_in = $candidate;
321 # BUG6464: check consistency of PO messages
322 # - count number of '%s' in msgid and msgstr
323 for my $msg ( values %$href ) {
324 my $id_count = split(/%s/, $msg->{msgid}) - 1;
325 my $str_count = split(/%s/, $msg->{msgstr}) - 1;
326 next if $id_count == $str_count ||
327 $msg->{msgstr} eq '""' ||
328 grep { /fuzzy/ } @{$msg->{_flags}};
329 warn_normal(
330 "unconsistent %s count: ($id_count/$str_count):\n" .
331 " line: " . $msg->{loaded_line_number} . "\n" .
332 " msgid: " . $msg->{msgid} . "\n" .
333 " msgstr: " . $msg->{msgstr} . "\n", undef);
337 # set our charset in to UTF-8
338 if (!defined $charset_in) {
339 $charset_in = TmplTokenizer::charset_canon('UTF-8');
340 warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n" unless ( $quiet );
342 # set our charset out to UTF-8
343 if (!defined $charset_out) {
344 $charset_out = TmplTokenizer::charset_canon('UTF-8');
345 warn "Warning: Charset Out defaulting to $charset_out\n" unless ( $quiet );
347 my $xgettext = './xgettext.pl'; # actual text extractor script
348 my $st;
350 if ($action eq 'create') {
351 # updates the list. As the list is empty, every entry will be added
352 if (!-s $str_file) {
353 warn "Removing empty file $str_file\n" unless ( $quiet );
354 unlink $str_file || die "$str_file: $!\n";
356 die "$str_file: Output file already exists\n" if -f $str_file;
357 my($tmph1, $tmpfile1) = tmpnam();
358 my($tmph2, $tmpfile2) = tmpnam();
359 close $tmph2; # We just want a name
360 # Generate the temporary file that acts as <MODULE>/POTFILES.in
361 for my $input (@in_files) {
362 print $tmph1 "$input\n";
364 close $tmph1;
365 warn "I $charset_in O $charset_out" unless ( $quiet );
366 # Generate the specified po file ($str_file)
367 $st = system ($xgettext, '-s', '-f', $tmpfile1, '-o', $tmpfile2,
368 (defined $charset_in? ('-I', $charset_in): ()),
369 (defined $charset_out? ('-O', $charset_out): ())
371 # Run msgmerge so that the pot file looks like a real pot file
372 # We need to help msgmerge a bit by pre-creating a dummy po file that has
373 # the headers and the "" msgid & msgstr. It will fill in the rest.
374 if ($st == 0) {
375 # Merge the temporary "pot file" with the specified po file ($str_file)
376 # FIXME: msgmerge(1) is a Unix dependency
377 # FIXME: need to check the return value
378 unless (-f $str_file) {
379 open(my $infh, '<', $tmpfile2);
380 open(my $outfh, '>', $str_file);
381 while (<$infh>) {
382 print $outfh $_;
383 last if /^\n/s;
385 close $infh;
386 close $outfh;
388 $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
389 } else {
390 error_normal("Text extraction failed: $xgettext: $!\n", undef);
391 error_additional("Will not run msgmerge\n", undef);
393 unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
394 unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
396 } elsif ($action eq 'update') {
397 my($tmph1, $tmpfile1) = tmpnam();
398 my($tmph2, $tmpfile2) = tmpnam();
399 close $tmph2; # We just want a name
400 # Generate the temporary file that acts as <MODULE>/POTFILES.in
401 for my $input (@in_files) {
402 print $tmph1 "$input\n";
404 close $tmph1;
405 # Generate the temporary file that acts as <MODULE>/<LANG>.pot
406 $st = system($xgettext, '-s', '-f', $tmpfile1, '-o', $tmpfile2,
407 '--po-mode',
408 (defined $charset_in? ('-I', $charset_in): ()),
409 (defined $charset_out? ('-O', $charset_out): ()));
410 if ($st == 0) {
411 # Merge the temporary "pot file" with the specified po file ($str_file)
412 # FIXME: msgmerge(1) is a Unix dependency
413 # FIXME: need to check the return value
414 if ( @filenames ) {
415 my ($tmph3, $tmpfile3) = tmpnam();
416 $st = system("msgcat $str_file $tmpfile2 > $tmpfile3");
417 $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile3 -o - | msgattrib --no-obsolete -o $str_file")
418 unless $st;
419 } else {
420 $st = system("msgmerge ".($quiet?'-q':'')." -s $str_file $tmpfile2 -o - | msgattrib --no-obsolete -o $str_file");
422 } else {
423 error_normal("Text extraction failed: $xgettext: $!\n", undef);
424 error_additional("Will not run msgmerge\n", undef);
426 unlink $tmpfile1 || warn_normal("$tmpfile1: unlink failed: $!\n", undef);
427 unlink $tmpfile2 || warn_normal("$tmpfile2: unlink failed: $!\n", undef);
429 } elsif ($action eq 'install') {
430 if(!defined($out_dir)) {
431 usage_error("You must specify an output directory when using the install method.");
434 if ( scalar @in_dirs > 1 ) {
435 usage_error("You must specify only one input directory when using the install method.");
438 my $in_dir = shift @in_dirs;
440 if ($in_dir eq $out_dir) {
441 warn "You must specify a different input and output directory.\n";
442 exit -1;
445 # Make sure the output directory exists
446 # (It will auto-create it, but for compatibility we should not)
447 -d $out_dir || die "$out_dir: The directory does not exist\n";
449 # Try to open the file, because Locale::PO doesn't check :-/
450 open(my $fh, '<', $str_file) || die "$str_file: $!\n";
451 close $fh;
453 # creates the new tmpl file using the new translation
454 for my $input (@in_files) {
455 die "Assertion failed"
456 unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
458 my $target = $out_dir . substr($input, length($in_dir));
459 my $targetdir = ($target =~ /[^\/]+$/s) ? $` : undef;
461 if (!defined $type || $input =~ /\.(?:$type)$/) {
462 my $h = TmplTokenizer->new( $input );
463 $h->set_allow_cformat( 1 );
464 VerboseWarnings::set_input_file_name($input);
465 mkdir_recursive($targetdir) unless -d $targetdir;
466 print STDERR "Creating $target...\n" unless $quiet;
467 open( my $fh, ">:encoding(UTF-8)", "$target" ) || die "$target: $!\n";
468 text_replace( $h, $fh );
469 close $fh;
470 } else {
471 # just copying the file
472 mkdir_recursive($targetdir) unless -d $targetdir;
473 system("cp -f $input $target");
474 print STDERR "Copying $input...\n" unless $quiet;
478 } else {
479 usage_error('Unknown action specified.');
482 if ($st == 0) {
483 printf "The %s seems to be successful.\n", $action unless $quiet;
484 } else {
485 printf "%s FAILED.\n", "\u$action" unless $quiet;
487 exit 0;
489 ###############################################################################
491 =head1 SYNOPSIS
493 ./tmpl_process3.pl [ I<tmpl_process.pl options> ]
495 =head1 DESCRIPTION
497 This is an alternative version of the tmpl_process.pl script,
498 using standard gettext-style PO files. While there still might
499 be changes made to the way it extracts strings, at this moment
500 it should be stable enough for general use; it is already being
501 used for the Chinese and Polish translations.
503 Currently, the create, update, and install actions have all been
504 reimplemented and seem to work.
506 =head2 Features
508 =over
510 =item -
512 Translation files in standard Uniforum PO format.
513 All standard tools including all gettext tools,
514 plus PO file editors like kbabel(1) etc.
515 can be used.
517 =item -
519 Minor changes in whitespace in source templates
520 do not generally require strings to be re-translated.
522 =item -
524 Able to handle <TMPL_VAR> variables in the templates;
525 <TMPL_VAR> variables are usually extracted in proper context,
526 represented by a short %s placeholder.
528 =item -
530 Able to handle text input and radio button INPUT elements
531 in the templates; these INPUT elements are also usually
532 extracted in proper context,
533 represented by a short %S or %p placeholder.
535 =item -
537 Automatic comments in the generated PO files to provide
538 even more context (line numbers, and the names and types
539 of the variables).
541 =item -
543 The %I<n>$s (or %I<n>$p, etc.) notation can be used
544 for change the ordering of the variables,
545 if such a reordering is required for correct translation.
547 =item -
549 If a particular <TMPL_VAR> should not appear in the
550 translation, it can be suppressed with the %0.0s notation.
552 =item -
554 Using the PO format also means translators can add their
555 own comments in the translation files, if necessary.
557 =item -
559 Create, update, and install actions are all based on the
560 same scanner module. This ensures that update and install
561 have the same idea of what is a translatable string;
562 attribute names in tags, for example, will not be
563 accidentally translated.
565 =back
567 =head1 NOTES
569 Anchors are represented by an <AI<n>> notation.
570 The meaning of this non-standard notation might not be obvious.
572 The create action calls xgettext.pl to do the actual work;
573 the update action calls xgettext.pl, msgmerge(1) and msgattrib(1)
574 to do the actual work.
576 =head1 BUGS
578 xgettext.pl must be present in the current directory; both
579 msgmerge(1) and msgattrib(1) must also be present in the search path.
580 The script currently does not check carefully whether these
581 dependent commands are present.
583 Locale::PO(3) has a lot of bugs. It can neither parse nor
584 generate GNU PO files properly; a couple of workarounds have
585 been written in TmplTokenizer and more is likely to be needed
586 (e.g., to get rid of the "Strange line" warning for #~).
588 This script may not work in Windows.
590 There are probably some other bugs too, since this has not been
591 tested very much.
593 =head1 SEE ALSO
595 xgettext.pl,
596 TmplTokenizer.pm,
597 msgmerge(1),
598 Locale::PO(3),
599 translator_doc.txt
601 http://www.saas.nsw.edu.au/koha_wiki/index.php?page=DifficultTerms
603 =cut