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