misc/translator/tmpl_process3.pl

   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
   6
   7 =head1 NAME
   8
   9 tmpl_process3.pl - Alternative version of tmpl_process.pl
  10 using gettext-compatible translation files
  11
  12 =cut
  13
  14 use strict;
  15 #use warnings; FIXME - Bug 2505
  16 use Getopt::Long;
  17 use Locale::PO;
  18 use File::Temp qw( :POSIX );
  19 use TmplTokenizer;
  20 use VerboseWarnings qw( :warn :die );
  21
  22 ###############################################################################
  23
  24 use vars qw( @in_files $in_dir $str_file $out_dir $quiet );
  25 use vars qw( @excludes $exclude_regex );
  26 use vars qw( $recursive_p );
  27 use vars qw( $pedantic_p );
  28 use vars qw( $href );
  29 use vars qw( $type );   # file extension (DOS form without the dot) to match
  30 use vars qw( $charset_in $charset_out );
  31
  32 ###############################################################################
  33
  34 sub find_translation ($) {
  35     my($s) = @_;
  36     my $key = $s;
  37     if ($s =~ /\S/s) {
  38     $key = TmplTokenizer::string_canon($key);
  39     $key = TmplTokenizer::charset_convert($key, $charset_in, $charset_out);
  40     $key = TmplTokenizer::quote_po($key);
  41     }
  42     return defined $href->{$key}
  43         && !$href->{$key}->fuzzy
  44         && length Locale::PO->dequote($href->{$key}->msgstr)?
  45        Locale::PO->dequote($href->{$key}->msgstr): $s;
  46 }
  47
  48 sub text_replace_tag ($$) {
  49     my($t, $attr) = @_;
  50     my $it;
  51
  52     # value [tag=input], meta
  53     my $tag = lc($1) if $t =~ /^<(\S+)/s;
  54     my $translated_p = 0;
  55     for my $a ('alt', 'content', 'title', 'value','label') {
  56     if ($attr->{$a}) {
  57         next if $a eq 'label' && $tag ne 'optgroup';
  58         next if $a eq 'content' && $tag ne 'meta';
  59         next if $a eq 'value' && ($tag ne 'input' || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:checkbox|hidden|radio|text)$/)); # FIXME
  60
  61         my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
  62         if ($val =~ /\S/s) {
  63         my $s = find_translation($val);
  64         if ($attr->{$a}->[1] ne $s) { #FIXME
  65             $attr->{$a}->[1] = $s; # FIXME
  66             $attr->{$a}->[2] = ($s =~ /"/s)? "'$s'": "\"$s\""; #FIXME
  67             $translated_p = 1;
  68         }
  69         }
  70     }
  71     }
  72     if ($translated_p) {
  73      $it = "<$tag"
  74           . join('', map { if ($_ ne '/'){
  75                              sprintf(' %s="%s"', $_, $attr->{$_}->[1]);
  76           }
  77               else {
  78                   sprintf(' %s',$_);
  79                   }
  80
  81               } sort {
  82                   $attr->{$a}->[3] <=> $attr->{$b}->[3] #FIXME
  83               } keys %$attr);
  84         if ($tag eq 'img'){
  85             $it .= ' />';
  86         }
  87         else {
  88            $it .= '>';
  89         }
  90     }
  91     else {
  92         $it = $t;
  93     }
  94     return $it;
  95 }
  96
  97 sub text_replace (**) {
  98     my($h, $output) = @_;
  99     for (;;) {
 100     my $s = TmplTokenizer::next_token $h;
 101     last unless defined $s;
 102     my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
 103     if ($kind eq TmplTokenType::TEXT) {
 104         print $output find_translation($t);
 105     } elsif ($kind eq TmplTokenType::TEXT_PARAMETRIZED) {
 106         my $fmt = find_translation($s->form);
 107         print $output TmplTokenizer::parametrize($fmt, 1, $s, sub {
 108         $_ = $_[0];
 109         my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
 110         $kind == TmplTokenType::TAG && %$attr?
 111             text_replace_tag($t, $attr): $t });
 112     } elsif ($kind eq TmplTokenType::TAG && %$attr) {
 113         print $output text_replace_tag($t, $attr);
 114     } elsif ($s->has_js_data) {
 115         for my $t (@{$s->js_data}) {
 116         # FIXME for this whole block
 117         if ($t->[0]) {
 118             printf $output "%s%s%s", $t->[2], find_translation $t->[3],
 119                 $t->[2];
 120         } else {
 121             print $output $t->[1];
 122         }
 123         }
 124     } elsif (defined $t) {
 125         # Quick fix to bug 4472
 126         $t = "<!DOCTYPE stylesheet ["  if $t =~ /DOCTYPE stylesheet/ ;
 127         print $output $t;
 128     }
 129     }
 130 }
 131
 132 sub listfiles ($$$) {
 133     my($dir, $type, $action) = @_;
 134     my @it = ();
 135     if (opendir(DIR, $dir)) {
 136     my @dirent = readdir DIR;   # because DIR is shared when recursing
 137     closedir DIR;
 138     for my $dirent (@dirent) {
 139         my $path = "$dir/$dirent";
 140         if ($dirent =~ /^\./ || $dirent eq 'CVS' || $dirent eq 'RCS'
 141         || (defined $exclude_regex && $dirent =~ /^(?:$exclude_regex)$/)) {
 142         ;
 143         } elsif (-f $path) {
 144         push @it, $path if (!defined $type || $dirent =~ /\.(?:$type)$/) || $action eq 'install';
 145         } elsif (-d $path && $recursive_p) {
 146         push @it, listfiles($path, $type, $action);
 147         }
 148     }
 149     } else {
 150     warn_normal "$dir: $!", undef;
 151     }
 152     return @it;
 153 }
 154
 155 ###############################################################################
 156
 157 sub mkdir_recursive ($) {
 158     my($dir) = @_;
 159     local($`, $&, $', $1);
 160     $dir = $` if $dir ne /^\/+$/ && $dir =~ /\/+$/;
 161     my ($prefix, $basename) = ($dir =~ /\/([^\/]+)$/s)? ($`, $1): ('.', $dir);
 162     mkdir_recursive($prefix) if $prefix ne '.' && !-d $prefix;
 163     if (!-d $dir) {
 164     print STDERR "Making directory $dir..." unless $quiet;
 165     # creates with rwxrwxr-x permissions
 166     mkdir($dir, 0775) || warn_normal "$dir: $!", undef;
 167     }
 168 }
 169
 170 ###############################################################################
 171
 172 sub usage ($) {
 173     my($exitcode) = @_;
 174     my $h = $exitcode? *STDERR: *STDOUT;
 175     print $h <<EOF;
 176 Usage: $0 create [OPTION]
 177   or:  $0 update [OPTION]
 178   or:  $0 install [OPTION]
 179   or:  $0 --help
 180 Create or update PO files from templates, or install translated templates.
 181
 182   -i, --input=SOURCE          Get or update strings from SOURCE file.
 183                               SOURCE is a directory if -r is also specified.
 184   -o, --outputdir=DIRECTORY   Install translation(s) to specified DIRECTORY
 185       --pedantic-warnings     Issue warnings even for detected problems
 186                               which are likely to be harmless
 187   -r, --recursive             SOURCE in the -i option is a directory
 188   -s, --str-file=FILE         Specify FILE as the translation (po) file
 189                               for input (install) or output (create, update)
 190   -x, --exclude=REGEXP        Exclude files matching the given REGEXP
 191       --help                  Display this help and exit
 192   -q, --quiet                 no output to screen (except for errors)
 193
 194 The -o option is ignored for the "create" and "update" actions.
 195 Try `perldoc $0 for perhaps more information.
 196 EOF
 197     exit($exitcode);
 198 }#`
 199
 200 ###############################################################################
 201
 202 sub usage_error (;$) {
 203     for my $msg (split(/\n/, $_[0])) {
 204     print STDERR "$msg\n";
 205     }
 206     print STDERR "Try `$0 --help for more information.\n";
 207     exit(-1);
 208 }
 209
 210 ###############################################################################
 211
 212 GetOptions(
 213     'input|i=s'             => \@in_files,
 214     'outputdir|o=s'         => \$out_dir,
 215     'recursive|r'           => \$recursive_p,
 216     'str-file|s=s'          => \$str_file,
 217     'exclude|x=s'           => \@excludes,
 218     'quiet|q'               => \$quiet,
 219     'pedantic-warnings|pedantic'    => sub { $pedantic_p = 1 },
 220     'help'              => \&usage,
 221 ) || usage_error;
 222
 223 VerboseWarnings::set_application_name $0;
 224 VerboseWarnings::set_pedantic_mode $pedantic_p;
 225
 226 # keep the buggy Locale::PO quiet if it says stupid things
 227 $SIG{__WARN__} = sub {
 228     my($s) = @_;
 229     print STDERR $s unless $s =~ /^Strange line in [^:]+: #~/s
 230     };
 231
 232 my $action = shift or usage_error('You must specify an ACTION.');
 233 usage_error('You must at least specify input and string list filenames.')
 234     if !@in_files || !defined $str_file;
 235
 236 # Type match defaults to *.tt plus *.inc if not specified
 237 $type = "tt|inc|xsl" if !defined($type);
 238
 239 # Check the inputs for being files or directories
 240 for my $input (@in_files) {
 241     usage_error("$input: Input must be a file or directory.\n"
 242         . "(Symbolic links are not supported at the moment)")
 243     unless -d $input || -f $input;;
 244 }
 245
 246 # Generates the global exclude regular expression
 247 $exclude_regex =  '(?:'.join('|', @excludes).')' if @excludes;
 248
 249 # Generate the list of input files if a directory is specified
 250 if (-d $in_files[0]) {
 251     die "If you specify a directory as input, you must specify only it.\n"
 252         if @in_files > 1;
 253
 254     # input is a directory, generates list of files to process
 255     $in_dir = $in_files[0];
 256     $in_dir =~ s/\/$//; # strips the trailing / if any
 257     @in_files = listfiles($in_dir, $type, $action);
 258 } else {
 259     for my $input (@in_files) {
 260     die "You cannot specify input files and directories at the same time.\n"
 261         unless -f $input;
 262     }
 263 }
 264
 265 # restores the string list from file
 266 $href = Locale::PO->load_file_ashash($str_file);
 267
 268 # guess the charsets. HTML::Templates defaults to iso-8859-1
 269 if (defined $href) {
 270     die "$str_file: PO file is corrupted, or not a PO file\n" unless defined $href->{'""'};
 271     $charset_out = TmplTokenizer::charset_canon $2 if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
 272     $charset_in = $charset_out;
 273     warn "Charset in/out: ".$charset_out;
 274 #     for my $msgid (keys %$href) {
 275 #   if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
 276 #       my $candidate = TmplTokenizer::charset_canon $2;
 277 #       die "Conflicting charsets in msgid: $charset_in vs $candidate => $msgid\n"
 278 #           if defined $charset_in && $charset_in ne $candidate;
 279 #       $charset_in = $candidate;
 280 #   }
 281 #     }
 282 }
 283
 284 # set our charset in to UTF-8
 285 if (!defined $charset_in) {
 286     $charset_in = TmplTokenizer::charset_canon 'UTF-8';
 287     warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
 288 }
 289 # set our charset out to UTF-8
 290 if (!defined $charset_out) {
 291     $charset_out = TmplTokenizer::charset_canon 'UTF-8';
 292     warn "Warning: Charset Out defaulting to $charset_out\n";
 293 }
 294 my $xgettext = './xgettext.pl'; # actual text extractor script
 295 my $st;
 296
 297 if ($action eq 'create')  {
 298     # updates the list. As the list is empty, every entry will be added
 299     if (!-s $str_file) {
 300     warn "Removing empty file $str_file\n";
 301     unlink $str_file || die "$str_file: $!\n";
 302     }
 303     die "$str_file: Output file already exists\n" if -f $str_file;
 304     my($tmph1, $tmpfile1) = tmpnam();
 305     my($tmph2, $tmpfile2) = tmpnam();
 306     close $tmph2; # We just want a name
 307     # Generate the temporary file that acts as <MODULE>/POTFILES.in
 308     for my $input (@in_files) {
 309     print $tmph1 "$input\n";
 310     }
 311     close $tmph1;
 312     warn "I $charset_in O $charset_out";
 313     # Generate the specified po file ($str_file)
 314     $st = system ($xgettext, '-s', '-f', $tmpfile1, '-o', $tmpfile2,
 315             (defined $charset_in? ('-I', $charset_in): ()),
 316             (defined $charset_out? ('-O', $charset_out): ())
 317     );
 318     # Run msgmerge so that the pot file looks like a real pot file
 319     # We need to help msgmerge a bit by pre-creating a dummy po file that has
 320     # the headers and the "" msgid & msgstr. It will fill in the rest.
 321     if ($st == 0) {
 322     # Merge the temporary "pot file" with the specified po file ($str_file)
 323     # FIXME: msgmerge(1) is a Unix dependency
 324     # FIXME: need to check the return value
 325     unless (-f $str_file) {
 326         local(*INPUT, *OUTPUT);
 327         open(INPUT, "<$tmpfile2");
 328         open(OUTPUT, ">$str_file");
 329         while (<INPUT>) {
 330         print OUTPUT;
 331         last if /^\n/s;
 332         }
 333         close INPUT;
 334         close OUTPUT;
 335     }
 336     $st = system('msgmerge', '-U', '-s', $str_file, $tmpfile2);
 337     } else {
 338     error_normal "Text extraction failed: $xgettext: $!\n", undef;
 339     error_additional "Will not run msgmerge\n", undef;
 340     }
 341 #   unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
 342 #   unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
 343
 344 } elsif ($action eq 'update') {
 345     my($tmph1, $tmpfile1) = tmpnam();
 346     my($tmph2, $tmpfile2) = tmpnam();
 347     close $tmph2; # We just want a name
 348     # Generate the temporary file that acts as <MODULE>/POTFILES.in
 349     for my $input (@in_files) {
 350     print $tmph1 "$input\n";
 351     }
 352     close $tmph1;
 353     # Generate the temporary file that acts as <MODULE>/<LANG>.pot
 354     $st = system($xgettext, '-s', '-f', $tmpfile1, '-o', $tmpfile2,
 355         '--po-mode',
 356         (defined $charset_in? ('-I', $charset_in): ()),
 357         (defined $charset_out? ('-O', $charset_out): ()));
 358     if ($st == 0) {
 359     # Merge the temporary "pot file" with the specified po file ($str_file)
 360     # FIXME: msgmerge(1) is a Unix dependency
 361     # FIXME: need to check the return value
 362     $st = system('msgmerge', '-U', '-s', $str_file, $tmpfile2);
 363     } else {
 364     error_normal "Text extraction failed: $xgettext: $!\n", undef;
 365     error_additional "Will not run msgmerge\n", undef;
 366     }
 367 #   unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
 368 #   unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
 369
 370 } elsif ($action eq 'install') {
 371     if(!defined($out_dir)) {
 372     usage_error("You must specify an output directory when using the install method.");
 373     }
 374
 375     if ($in_dir eq $out_dir) {
 376     warn "You must specify a different input and output directory.\n";
 377     exit -1;
 378     }
 379
 380     # Make sure the output directory exists
 381     # (It will auto-create it, but for compatibility we should not)
 382     -d $out_dir || die "$out_dir: The directory does not exist\n";
 383
 384     # Try to open the file, because Locale::PO doesn't check :-/
 385     open(INPUT, "<$str_file") || die "$str_file: $!\n";
 386     close INPUT;
 387
 388     # creates the new tmpl file using the new translation
 389     for my $input (@in_files) {
 390         die "Assertion failed"
 391             unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
 392 #       print "$input / $type\n";
 393         if (!defined $type || $input =~ /\.(?:$type)$/) {
 394             my $h = TmplTokenizer->new( $input );
 395             $h->set_allow_cformat( 1 );
 396             VerboseWarnings::set_input_file_name $input;
 397
 398             my $target = $out_dir . substr($input, length($in_dir));
 399             my $targetdir = $` if $target =~ /[^\/]+$/s;
 400             mkdir_recursive($targetdir) unless -d $targetdir;
 401             print STDERR "Creating $target...\n" unless $quiet;
 402             open( OUTPUT, ">$target" ) || die "$target: $!\n";
 403             text_replace( $h, *OUTPUT );
 404             close OUTPUT;
 405         } else {
 406         # just copying the file
 407             my $target = $out_dir . substr($input, length($in_dir));
 408             my $targetdir = $` if $target =~ /[^\/]+$/s;
 409             mkdir_recursive($targetdir) unless -d $targetdir;
 410             system("cp -f $input $target");
 411             print STDERR "Copying $input...\n" unless $quiet;
 412         }
 413     }
 414
 415 } else {
 416     usage_error('Unknown action specified.');
 417 }
 418
 419 if ($st == 0) {
 420     printf "The %s seems to be successful.\n", $action unless $quiet;
 421 } else {
 422     printf "%s FAILED.\n", "\u$action" unless $quiet;
 423 }
 424 exit 0;
 425
 426 ###############################################################################
 427
 428 =head1 SYNOPSIS
 429
 430 ./tmpl_process3.pl [ I<tmpl_process.pl options> ]
 431
 432 =head1 DESCRIPTION
 433
 434 This is an alternative version of the tmpl_process.pl script,
 435 using standard gettext-style PO files.  While there still might
 436 be changes made to the way it extracts strings, at this moment
 437 it should be stable enough for general use; it is already being
 438 used for the Chinese and Polish translations.
 439
 440 Currently, the create, update, and install actions have all been
 441 reimplemented and seem to work.
 442
 443 =head2 Features
 444
 445 =over
 446
 447 =item -
 448
 449 Translation files in standard Uniforum PO format.
 450 All standard tools including all gettext tools,
 451 plus PO file editors like kbabel(1) etc.
 452 can be used.
 453
 454 =item -
 455
 456 Minor changes in whitespace in source templates
 457 do not generally require strings to be re-translated.
 458
 459 =item -
 460
 461 Able to handle <TMPL_VAR> variables in the templates;
 462 <TMPL_VAR> variables are usually extracted in proper context,
 463 represented by a short %s placeholder.
 464
 465 =item -
 466
 467 Able to handle text input and radio button INPUT elements
 468 in the templates; these INPUT elements are also usually
 469 extracted in proper context,
 470 represented by a short %S or %p placeholder.
 471
 472 =item -
 473
 474 Automatic comments in the generated PO files to provide
 475 even more context (line numbers, and the names and types
 476 of the variables).
 477
 478 =item -
 479
 480 The %I<n>$s (or %I<n>$p, etc.) notation can be used
 481 for change the ordering of the variables,
 482 if such a reordering is required for correct translation.
 483
 484 =item -
 485
 486 If a particular <TMPL_VAR> should not appear in the
 487 translation, it can be suppressed with the %0.0s notation.
 488
 489 =item -
 490
 491 Using the PO format also means translators can add their
 492 own comments in the translation files, if necessary.
 493
 494 =item -
 495
 496 Create, update, and install actions are all based on the
 497 same scanner module. This ensures that update and install
 498 have the same idea of what is a translatable string;
 499 attribute names in tags, for example, will not be
 500 accidentally translated.
 501
 502 =back
 503
 504 =head1 NOTES
 505
 506 Anchors are represented by an <AI<n>> notation.
 507 The meaning of this non-standard notation might not be obvious.
 508
 509 The create action calls xgettext.pl to do the actual work;
 510 the update action calls xgettext.pl and msgmerge(1) to do the
 511 actual work.
 512
 513 =head1 BUGS
 514
 515 xgettext.pl must be present in the current directory; the
 516 msgmerge(1) command must also be present in the search path.
 517 The script currently does not check carefully whether these
 518 dependent commands are present.
 519
 520 Locale::PO(3) has a lot of bugs. It can neither parse nor
 521 generate GNU PO files properly; a couple of workarounds have
 522 been written in TmplTokenizer and more is likely to be needed
 523 (e.g., to get rid of the "Strange line" warning for #~).
 524
 525 This script may not work in Windows.
 526
 527 There are probably some other bugs too, since this has not been
 528 tested very much.
 529
 530 =head1 SEE ALSO
 531
 532 xgettext.pl,
 533 TmplTokenizer.pm,
 534 msgmerge(1),
 535 Locale::PO(3),
 536 translator_doc.txt
 537
 538 http://www.saas.nsw.edu.au/koha_wiki/index.php?page=DifficultTerms
 539
 540 =cut