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 - Experimental version of tmpl_process.pl
  10 using gettext-compatible translation files
  11
  12 =cut
  13
  14 use strict;
  15 use Getopt::Long;
  16 use Locale::PO;
  17 use File::Temp qw( :POSIX );
  18 use TmplTokenizer;
  19 use VerboseWarnings qw( error_normal warn_normal );
  20
  21 ###############################################################################
  22
  23 use vars qw( @in_files $in_dir $str_file $out_dir );
  24 use vars qw( @excludes $exclude_regex );
  25 use vars qw( $recursive_p );
  26 use vars qw( $pedantic_p );
  27 use vars qw( $href );
  28 use vars qw( $type );   # file extension (DOS form without the dot) to match
  29 use vars qw( $charset_in $charset_out );
  30
  31 ###############################################################################
  32
  33 sub find_translation ($) {
  34     my($s) = @_;
  35     my $key = $s;
  36     if ($s =~ /\S/s) {
  37         $key = TmplTokenizer::string_canon($key);
  38         $key = TmplTokenizer::charset_convert($key, $charset_in, $charset_out);
  39         $key = TmplTokenizer::quote_po($key);
  40     }
  41     return defined $href->{$key}
  42                 && !$href->{$key}->fuzzy
  43                 && length Locale::PO->dequote($href->{$key}->msgstr)?
  44            Locale::PO->dequote($href->{$key}->msgstr): $s;
  45 }
  46
  47 sub text_replace_tag ($$) {
  48     my($t, $attr) = @_;
  49     my $it;
  50     # value [tag=input], meta
  51     my $tag = lc($1) if $t =~ /^<(\S+)/s;
  52     my $translated_p = 0;
  53     for my $a ('alt', 'content', 'title', 'value') {
  54         if ($attr->{$a}) {
  55             next if $a eq 'content' && $tag ne 'meta';
  56             next if $a eq 'value' && ($tag ne 'input'
  57                 || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME
  58             my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
  59             my($pre, $trimmed, $post) = TmplTokenizer::trim $val;
  60             if ($val =~ /\S/s) {
  61                 my $s = $pre . find_translation($trimmed) . $post;
  62                 if ($attr->{$a}->[1] ne $s) { #FIXME
  63                     $attr->{$a}->[1] = $s; # FIXME
  64                     $attr->{$a}->[2] = ($s =~ /"/s)? "'$s'": "\"$s\""; #FIXME
  65                     $translated_p = 1;
  66                 }
  67             }
  68         }
  69     }
  70     if ($translated_p) {
  71         $it = "<$tag"
  72             . join('', map {
  73                     sprintf(' %s=%s', $_, $attr->{$_}->[2]) #FIXME
  74                 } sort {
  75                     $attr->{$a}->[3] <=> $attr->{$b}->[3] #FIXME
  76                 } keys %$attr)
  77             . '>';
  78     } else {
  79         $it = $t;
  80     }
  81     return $it;
  82 }
  83
  84 sub text_replace (**) {
  85     my($h, $output) = @_;
  86     for (;;) {
  87         my $s = TmplTokenizer::next_token $h;
  88     last unless defined $s;
  89         my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
  90         if ($kind eq TmplTokenType::TEXT) {
  91             my($pre, $trimmed, $post) = TmplTokenizer::trim $t;
  92             print $output $pre, find_translation($trimmed), $post;
  93         } elsif ($kind eq TmplTokenType::TEXT_PARAMETRIZED) {
  94             my $fmt = find_translation($s->form);
  95             print $output TmplTokenizer::parametrize($fmt, [ map {
  96                 my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
  97                 $kind == TmplTokenType::TAG && %$attr?
  98                     text_replace_tag($t, $attr): $t } $s->parameters ], [ $s->anchors ]);
  99         } elsif ($kind eq TmplTokenType::TAG && %$attr) {
 100             print $output text_replace_tag($t, $attr);
 101         } elsif (defined $t) {
 102             print $output $t;
 103         }
 104     }
 105 }
 106
 107 sub listfiles ($$) {
 108     my($dir, $type) = @_;
 109     my @it = ();
 110     if (opendir(DIR, $dir)) {
 111         my @dirent = readdir DIR;       # because DIR is shared when recursing
 112         closedir DIR;
 113         for my $dirent (@dirent) {
 114             my $path = "$dir/$dirent";
 115             if ($dirent =~ /^\./ || $dirent eq 'CVS' || $dirent eq 'RCS'
 116             || (defined $exclude_regex && $dirent =~ /^(?:$exclude_regex)$/)) {
 117                 ;
 118             } elsif (-f $path) {
 119                 push @it, $path if !defined $type || $dirent =~ /\.(?:$type)$/;
 120             } elsif (-d $path && $recursive_p) {
 121                 push @it, listfiles($path, $type);
 122             }
 123         }
 124     } else {
 125         warn_normal "$dir: $!", undef;
 126     }
 127     return @it;
 128 }
 129
 130 ###############################################################################
 131
 132 sub usage_error (;$) {
 133     for my $msg (split(/\n/, $_[0])) {
 134         print STDERR "$msg\n";
 135     }
 136     print STDERR "Try `$0 --help' for more information.\n";
 137     exit(-1);
 138 }
 139
 140 ###############################################################################
 141
 142 GetOptions(
 143     'input|i=s'                         => \@in_files,
 144     'outputdir|o=s'                     => \$out_dir,
 145     'recursive|r'                       => \$recursive_p,
 146     'str-file|s=s'                      => \$str_file,
 147     'exclude|x=s'                       => \@excludes,
 148     'pedantic-warnings|pedantic'        => sub { $pedantic_p = 1 },
 149 ) || usage_error;
 150
 151 VerboseWarnings::set_application_name $0;
 152 VerboseWarnings::set_pedantic_mode $pedantic_p;
 153
 154 # try to make sure .po files are backed up (see BUGS)
 155 $ENV{VERSION_CONTROL} = 't';
 156
 157 # keep the buggy Locale::PO quiet if it says stupid things
 158 $SIG{__WARN__} = sub {
 159         my($s) = @_;
 160         print STDERR $s unless $s =~ /^Strange line in [^:]+: #~/s
 161     };
 162
 163 my $action = shift or usage_error('You must specify an ACTION.');
 164 usage_error('You must at least specify input and string list filenames.')
 165     if !@in_files || !defined $str_file;
 166
 167 # Type match defaults to *.tmpl plus *.inc if not specified
 168 $type = "tmpl|inc" if !defined($type);
 169
 170 # Check the inputs for being files or directories
 171 for my $input (@in_files) {
 172     usage_error("$input: Input must be a file or directory.\n"
 173             . "(Symbolic links are not supported at the moment)")
 174         unless -d $input || -f $input;;
 175 }
 176
 177 # Generates the global exclude regular expression
 178 $exclude_regex =  '(?:'.join('|', @excludes).')' if @excludes;
 179
 180 # Generate the list of input files if a directory is specified
 181 if (-d $in_files[0]) {
 182     die "If you specify a directory as input, you must specify only it.\n"
 183             if @in_files > 1;
 184
 185     # input is a directory, generates list of files to process
 186     $in_dir = $in_files[0];
 187     $in_dir =~ s/\/$//; # strips the trailing / if any
 188     @in_files = listfiles($in_dir, $type);
 189 } else {
 190     for my $input (@in_files) {
 191         die "You cannot specify input files and directories at the same time.\n"
 192                 unless -f $input;
 193     }
 194 }
 195
 196 # restores the string list from file
 197 $href = Locale::PO->load_file_ashash($str_file);
 198
 199 # guess the charsets. HTML::Templates defaults to iso-8859-1
 200 if (defined $href) {
 201     $charset_out = TmplTokenizer::charset_canon $2
 202             if $href->{'""'}->msgstr =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/;
 203     for my $msgid (keys %$href) {
 204         if ($msgid =~ /\bcharset=(["']?)([^;\s"'\\]+)\1/) {
 205             my $candidate = TmplTokenizer::charset_canon $2;
 206             die "Conflicting charsets in msgid: $charset_in vs $candidate\n"
 207                     if defined $charset_in && $charset_in ne $candidate;
 208             $charset_in = $candidate;
 209         }
 210     }
 211 }
 212 if (!defined $charset_in) {
 213     $charset_in = TmplTokenizer::charset_canon 'iso8859-1';
 214     warn "Warning: Can't determine original templates' charset, defaulting to $charset_in\n";
 215 }
 216
 217 if ($action eq 'create')  {
 218     # updates the list. As the list is empty, every entry will be added
 219     die "$str_file: Output file already exists" if -f $str_file;
 220     my($tmph, $tmpfile) = tmpnam();
 221     # Generate the temporary file that acts as <MODULE>/POTFILES.in
 222     for my $input (@in_files) {
 223         print $tmph "$input\n";
 224     }
 225     close $tmph;
 226     # Generate the specified po file ($str_file)
 227     system ('xgettext.pl', '-s', '-f', $tmpfile, '-o', $str_file);
 228     unlink $tmpfile || warn_normal "$tmpfile: unlink failed: $!\n", undef;
 229
 230 } elsif ($action eq 'update') {
 231     my($tmph1, $tmpfile1) = tmpnam();
 232     my($tmph2, $tmpfile2) = tmpnam();
 233     close $tmph2; # We just want a name
 234     # Generate the temporary file that acts as <MODULE>/POTFILES.in
 235     for my $input (@in_files) {
 236         print $tmph1 "$input\n";
 237     }
 238     close $tmph1;
 239     # Generate the temporary file that acts as <MODULE>/<LANG>.pot
 240     system('./xgettext.pl', '-s', '-f', $tmpfile1, '-o', $tmpfile2,
 241             (defined $charset_in? ('-I', $charset_in): ()),
 242             (defined $charset_out? ('-O', $charset_out): ()));
 243     # Merge the temporary "pot file" with the specified po file ($str_file)
 244     # FIXME: msgmerge(1) is a Unix dependency
 245     # FIXME: need to check the return value
 246     system('msgmerge', '-U', '-s', $str_file, $tmpfile2);
 247     unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
 248     unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
 249
 250 } elsif ($action eq 'install') {
 251     if(!defined($out_dir)) {
 252         usage_error("You must specify an output directory when using the install method.");
 253     }
 254
 255     if ($in_dir eq $out_dir) {
 256         warn "You must specify a different input and output directory.\n";
 257         exit -1;
 258     }
 259
 260     # Make sure the output directory exists
 261     # (It will auto-create it, but for compatibility we should not)
 262     -d $out_dir || die "$out_dir: The directory does not exist\n";
 263
 264     # Try to open the file, because Locale::PO doesn't check :-/
 265     open(INPUT, "<$str_file") || die "$str_file: $!\n";
 266     close INPUT;
 267
 268     # creates the new tmpl file using the new translation
 269     for my $input (@in_files) {
 270         die "Assertion failed"
 271                 unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
 272
 273         my $h = TmplTokenizer->new( $input );
 274         $h->set_allow_cformat( 1 );
 275         VerboseWarnings::set_input_file_name $input;
 276
 277         my $target = $out_dir . substr($input, length($in_dir));
 278         my $targetdir = $` if $target =~ /[^\/]+$/s;
 279         if (!-d $targetdir) {
 280             print STDERR "Making directory $targetdir...";
 281             # creates with rwxrwxr-x permissions
 282             mkdir($targetdir, 0775) || warn_normal "$targetdir: $!", undef;
 283         }
 284         print STDERR "Creating $target...\n";
 285         open( OUTPUT, ">$target" ) || die "$target: $!\n";
 286         text_replace( $h, *OUTPUT );
 287         close OUTPUT;
 288     }
 289
 290 } else {
 291     usage_error('Unknown action specified.');
 292 }
 293 exit 0;
 294
 295 ###############################################################################
 296
 297 =head1 SYNOPSIS
 298
 299 ./tmpl_process3.pl [ I<tmpl_process.pl options> ]
 300
 301 =head1 DESCRIPTION
 302
 303 This is an experimental version of the tmpl_process.pl script,
 304 using standard gettext-style PO files.  Note that the behaviour
 305 of this script should still be considered unstable.
 306
 307 Currently, the create, update, and install actions have all been
 308 reimplemented and seem to work.
 309
 310 The create action calls xgettext.pl to do the actual work;
 311 the update action calls xgettext.pl and msgmerge(1) to do the
 312 actual work.
 313
 314 The script can detect <TMPL_VAR> directives embedded inside what
 315 appears to be a full sentence (this actual work being done by
 316 TmplTokenizer(3)); these larger patterns appear in the translation
 317 file as c-format strings with %s.
 318
 319 Whitespace in extracted strings are folded to single blanks, in
 320 order to prevent new strings from appearing when minor changes in
 321 the original templates occur, and to prevent overly difficult to
 322 read strings in the PO file.
 323
 324 =head1 BUGS
 325
 326 The --help option has not been implemented yet.
 327
 328 xgettext.pl must be present in the current directory; the
 329 msgmerge(1) command must also be present in the search path.
 330 The script currently does not check carefully whether these
 331 dependent commands are present.
 332
 333 If xgettext.pl is interrupted by the user, a corrupted po file
 334 will result. This is very seriously wrong.
 335
 336 Locale::PO(3) has a lot of bugs. It can neither parse nor
 337 generate GNU PO files properly; a couple of workarounds have
 338 been written in TmplTokenizer and more is likely to be needed
 339 (e.g., to get rid of the "Strange line" warning for #~).
 340
 341 There are probably some other bugs too, since this has not been
 342 tested very much.
 343
 344 =head1 SEE ALSO
 345
 346 xgettext.pl,
 347 msgmerge(1),
 348 Locale::PO(3),
 349 translator_doc.txt
 350
 351 =cut