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
  30 ###############################################################################
  31
  32 sub find_translation ($) {
  33     my($s) = @_;
  34     my $key = TmplTokenizer::quote_po($s) if $s =~ /\S/;
  35     return defined $href->{$key}
  36                 && !$href->{$key}->fuzzy
  37                 && length Locale::PO->dequote($href->{$key}->msgstr)?
  38            Locale::PO->dequote($href->{$key}->msgstr): $s;
  39 }
  40
  41 sub text_replace_tag ($$) {
  42     my($t, $attr) = @_;
  43     my $it;
  44     # value [tag=input], meta
  45     my $tag = lc($1) if $t =~ /^<(\S+)/s;
  46     my $translated_p = 0;
  47     for my $a ('alt', 'content', 'title', 'value') {
  48         if ($attr->{$a}) {
  49             next if $a eq 'content' && $tag ne 'meta';
  50             next if $a eq 'value' && ($tag ne 'input'
  51                 || (ref $attr->{'type'} && $attr->{'type'}->[1] =~ /^(?:hidden|radio)$/)); # FIXME
  52             my($key, $val, $val_orig, $order) = @{$attr->{$a}}; #FIXME
  53             my($pre, $trimmed, $post) = TmplTokenizer::trim $val;
  54             if ($val =~ /\S/s) {
  55                 my $s = $pre . find_translation($trimmed) . $post;
  56                 if ($attr->{$a}->[1] ne $s) { #FIXME
  57                     $attr->{$a}->[1] = $s; # FIXME
  58                     $attr->{$a}->[2] = ($s =~ /"/s)? "'$s'": "\"$s\""; #FIXME
  59                     $translated_p = 1;
  60                 }
  61             }
  62         }
  63     }
  64     if ($translated_p) {
  65         $it = "<$tag"
  66             . join('', map {
  67                     sprintf(' %s=%s', $_, $attr->{$_}->[2]) #FIXME
  68                 } sort {
  69                     $attr->{$a}->[3] <=> $attr->{$b}->[3] #FIXME
  70                 } keys %$attr)
  71             . '>';
  72     } else {
  73         $it = $t;
  74     }
  75     return $it;
  76 }
  77
  78 sub text_replace (**) {
  79     my($h, $output) = @_;
  80     for (;;) {
  81         my $s = TmplTokenizer::next_token $h;
  82     last unless defined $s;
  83         my($kind, $t, $attr) = ($s->type, $s->string, $s->attributes);
  84         if ($kind eq TmplTokenType::TEXT) {
  85             my($pre, $trimmed, $post) = TmplTokenizer::trim $t;
  86             print $output $pre, find_translation($trimmed), $post;
  87         } elsif ($kind eq TmplTokenType::TEXT_PARAMETRIZED) {
  88             my $fmt = find_translation($s->form);
  89             print $output TmplTokenizer::parametrize($fmt, map {
  90                 my($kind, $t, $attr) = ($_->type, $_->string, $_->attributes);
  91                 $kind == TmplTokenType::TAG && %$attr?
  92                     text_replace_tag($t, $attr): $t } $s->parameters);
  93         } elsif ($kind eq TmplTokenType::TAG && %$attr) {
  94             print $output text_replace_tag($t, $attr);
  95         } elsif (defined $t) {
  96             print $output $t;
  97         }
  98     }
  99 }
 100
 101 # FIXME: Should we use the GNOME convention of using POTFILES.in instead?
 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 my $action = shift or usage_error('You must specify an ACTION.');
 150 usage_error('You must at least specify input and string list filenames.')
 151     if !@in_files || !defined $str_file;
 152
 153 # Type match defaults to *.tmpl plus *.inc if not specified
 154 $type = "tmpl|inc" if !defined($type);
 155
 156 # Check the inputs for being files or directories
 157 for my $input (@in_files) {
 158     usage_error("$input: Input must be a file or directory.\n"
 159             . "(Symbolic links are not supported at the moment)")
 160         unless -d $input || -f $input;;
 161 }
 162
 163 # Generates the global exclude regular expression
 164 $exclude_regex =  '(?:'.join('|', @excludes).')' if @excludes;
 165
 166 # Generate the list of input files if a directory is specified
 167 if (-d $in_files[0]) {
 168     die "If you specify a directory as input, you must specify only it.\n"
 169             if @in_files > 1;
 170
 171     # input is a directory, generates list of files to process
 172     $in_dir = $in_files[0];
 173     $in_dir =~ s/\/$//; # strips the trailing / if any
 174     @in_files = listfiles($in_dir, $type);
 175 } else {
 176     for my $input (@in_files) {
 177         die "You cannot specify input files and directories at the same time.\n"
 178                 unless -f $input;
 179     }
 180 }
 181
 182 if ($action eq 'create')  {
 183     # updates the list. As the list is empty, every entry will be added
 184     die "$str_file: Output file already exists" if -f $str_file;
 185     my($tmph, $tmpfile) = tmpnam();
 186     for my $input (@in_files) {
 187         print $tmph "$input\n";
 188     }
 189     close $tmph;
 190     system {'./xgettext.pl'} ('xgettext.pl', '-s', '-f', $tmpfile, '-o', $str_file);
 191     unlink $tmpfile || warn_normal "$tmpfile: unlink failed: $!\n", undef;
 192
 193 } elsif ($action eq 'update') {
 194     my($tmph1, $tmpfile1) = tmpnam();
 195     my($tmph2, $tmpfile2) = tmpnam();
 196     close $tmph2; # We just want a name
 197     for my $input (@in_files) {
 198         print $tmph1 "$input\n";
 199     }
 200     close $tmph1;
 201     system('./xgettext.pl', '-s', '-f', $tmpfile1, '-o', $tmpfile2);
 202     system('msgmerge', '-U', '-s', $str_file, $tmpfile2);
 203     unlink $tmpfile1 || warn_normal "$tmpfile1: unlink failed: $!\n", undef;
 204     unlink $tmpfile2 || warn_normal "$tmpfile2: unlink failed: $!\n", undef;
 205
 206 } elsif ($action eq 'install') {
 207     if(!defined($out_dir)) {
 208         usage_error("You must specify an output directory when using the install method.");
 209     }
 210
 211     if ($in_dir eq $out_dir) {
 212         warn "You must specify a different input and output directory.\n";
 213         exit -1;
 214     }
 215
 216     # Make sure the output directory exists
 217     # (It will auto-create it, but for compatibility we should not)
 218     -d $out_dir || die "$out_dir: The directory does not exist\n";
 219
 220     # Try to open the file, because Locale::PO doesn't check :-/
 221     open(INPUT, "<$str_file") || die "$str_file: $!\n";
 222     close INPUT;
 223
 224     # restores the string list from file
 225     $href = Locale::PO->load_file_ashash($str_file);
 226
 227     # creates the new tmpl file using the new translation
 228     for my $input (@in_files) {
 229         die "Assertion failed"
 230                 unless substr($input, 0, length($in_dir) + 1) eq "$in_dir/";
 231
 232         my $h = TmplTokenizer->new( $input );
 233         $h->set_allow_cformat( 1 );
 234         VerboseWarnings::set_input_file_name $input;
 235
 236         my $target = $out_dir . substr($input, length($in_dir));
 237         my $targetdir = $` if $target =~ /[^\/]+$/s;
 238         if (!-d $targetdir) {
 239             print STDERR "Making directory $targetdir...";
 240             # creates with rwxrwxr-x permissions
 241             mkdir($targetdir, 0775) || warn_normal "$targetdir: $!", undef;
 242         }
 243         print STDERR "Creating $target...\n";
 244         open( OUTPUT, ">$target" ) || die "$target: $!\n";
 245         text_replace( $h, *OUTPUT );
 246         close OUTPUT;
 247     }
 248
 249 } else {
 250     usage_error('Unknown action specified.');
 251 }
 252 exit 0;
 253
 254 ###############################################################################
 255
 256 =head1 SYNOPSIS
 257
 258 ./tmpl_process3.pl [ I<tmpl_process.pl options> ]
 259
 260 =head1 DESCRIPTION
 261
 262 This is an experimental version of the tmpl_process.pl script,
 263 using standard gettext-style PO files.
 264
 265 Currently, the create, update, and install actions have all been
 266 reimplemented and seem to work.
 267
 268 The create action calls xgettext.pl to do the actual work;
 269 the update action calls xgettext.pl and msgmerge(1) to do the
 270 actual work.
 271
 272 The script can detect <TMPL_VAR> directives embedded inside what
 273 appears to be a full sentence (this actual work being done by
 274 TmplTokenizer(3)); these larger patterns appear in the translation
 275 file as c-format strings with %s.
 276
 277 =head1 BUGS
 278
 279 The --help option has not been implemented yet.
 280
 281 There are probably some real bugs too, since this has not been
 282 tested very much.
 283
 284 xgettext.pl must be present in the current directory; the
 285 msgmerge(1) command must also be present in the search path.
 286 The script currently does not check carefully whether these
 287 dependent commands are present.
 288
 289 Locale::PO(3) has a lot of bugs. It can neither parse nor
 290 generate GNU PO files properly; a couple of workarounds have
 291 been written in TmplTokenizer and more is likely to be needed
 292 (e.g., to get rid of the "Strange line" warning for #~).
 293
 294 =head1 SEE ALSO
 295
 296 xgettext.pl,
 297 msgmerge(1),
 298 Locale::PO(3),
 299 translator_doc.txt
 300
 301 =cut