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