rt/devel/tools/extract-message-catalog

   1 #!/usr/bin/env perl
   2 # BEGIN BPS TAGGED BLOCK {{{
   3 #
   4 # COPYRIGHT:
   5 #
   6 # This software is Copyright (c) 1996-2017 Best Practical Solutions, LLC
   7 #                                          <sales@bestpractical.com>
   8 #
   9 # (Except where explicitly superseded by other copyright notices)
  10 #
  11 #
  12 # LICENSE:
  13 #
  14 # This work is made available to you under the terms of Version 2 of
  15 # the GNU General Public License. A copy of that license should have
  16 # been provided with this software, but in any event can be snarfed
  17 # from www.gnu.org.
  18 #
  19 # This work is distributed in the hope that it will be useful, but
  20 # WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 # General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with this program; if not, write to the Free Software
  26 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  27 # 02110-1301 or visit their web page on the internet at
  28 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  29 #
  30 #
  31 # CONTRIBUTION SUBMISSION POLICY:
  32 #
  33 # (The following paragraph is not intended to limit the rights granted
  34 # to you to modify and distribute this software under the terms of
  35 # the GNU General Public License and is only of importance to you if
  36 # you choose to contribute your changes and enhancements to the
  37 # community by submitting them to Best Practical Solutions, LLC.)
  38 #
  39 # By intentionally submitting any modifications, corrections or
  40 # derivatives to this work, or any other work intended for use with
  41 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  42 # you are the copyright holder for those contributions and you grant
  43 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  44 # royalty-free, perpetual, license to use, copy, create derivative
  45 # works based on those contributions, and sublicense and distribute
  46 # those contributions and any derivatives thereof.
  47 #
  48 # END BPS TAGGED BLOCK }}}
  49 # Portions Copyright 2002 Autrijus Tang <autrijus@autrijus.org>
  50
  51 use strict;
  52 use warnings;
  53
  54 use open qw/ :std :encoding(UTF-8) /;
  55
  56 use File::Find;
  57 use File::Copy;
  58 use Regexp::Common;
  59 use Carp;
  60 use Locale::PO;
  61 $| = 1;
  62
  63 # po dir is for extensions
  64 @ARGV = (<share/po/*.po>, <share/po/*.pot>, <po/*.po>, <po/*.pot>) unless @ARGV;
  65
  66 our %FILECAT;
  67
  68 # extract all strings and stuff them into %FILECAT
  69 # scan html dir for extensions
  70 File::Find::find( { wanted => \&extract_strings_from_code, follow => 1 }, qw(bin sbin lib share html etc) );
  71
  72 # ensure proper escaping and [_1] => %1 transformation
  73 foreach my $str ( sort keys %FILECAT ) {
  74     my $entry = delete $FILECAT{$str};
  75     next unless @{$entry};
  76
  77     my ($filename, $line) = @{ $entry->[0] };
  78     my $location = "$filename line $line" . (@{$entry} > 1 ? " (and ".(@{$entry}-1)." other places)" : "");
  79
  80     if ($str =~ /^\s/m || $str =~ /\s$/m || $str =~ /\\n$/m) {
  81         warn "Extraneous whitespace in '$str' at $location\n";
  82     }
  83     if (grep {$_->[3]} @{$entry} and $str =~ /([\$\@]\w+)/) {
  84         warn "Interpolated variable '$1' in '$str' at $location\n";
  85     }
  86
  87     my $escape = sub { $_ = shift; s/\b_(\d+)/%$1/; $_ };
  88     $str =~ s/((?<!~)(?:~~)*)\[_(\d+)\]/$1%$2/g;
  89     $str =~ s/((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]/"$1%$2(".$escape->($3).")"/eg;
  90     $str =~ s/~([\[\]])/$1/g;
  91
  92     my $po = Locale::PO->new(-msgid => $str, -msgstr => "");
  93     $po->reference( join ( ' ', sort map $_->[0].":".$_->[1], @{ $entry } ) );
  94     my %seen;
  95     my @vars;
  96     foreach my $find ( sort { $a->[2] cmp $b->[2] } grep { $_->[2] } @{ $entry } ) {
  97         my ( $file, $line, $var ) = @{$find};
  98         $var =~ s/^\s*,\s*//;
  99         $var =~ s/\s*$//;
 100         push @vars, "($var)" unless $seen{$var}++;
 101     }
 102     $po->automatic( join( "\n", @vars) );
 103
 104     $FILECAT{$po->msgid} = $po;
 105 }
 106
 107 # update all language dictionaries
 108 foreach my $dict (@ARGV) {
 109     $dict = "share/po/$dict.pot" if ( $dict eq 'rt' );
 110     $dict = "share/po/$dict.po" unless -f $dict or $dict =~ m!/!;
 111
 112     my $lang = $dict;
 113     $lang =~ s|.*/||;
 114     $lang =~ s|\.po$||;
 115     $lang =~ s|\.pot$||;
 116
 117     update($lang, $dict);
 118 }
 119
 120 sub extract_strings_from_code {
 121     my $file = $_;
 122
 123     local $/;
 124     return if ( -d $_ || !-e _ );
 125     return
 126       if ( $File::Find::dir =~
 127         qr!lib/blib|lib/t/autogen|var|m4|local|share/fonts! );
 128     return if ( /\.(?:pot|po|bak|gif|png|psd|jpe?g|svg|css|js)$/ );
 129     return if ( /~|,D|,B$|extract-message-catalog$|tweak-template-locstring$/ );
 130     return if ( /StyleGuide.pod/ );
 131     return if ( /^[\.#]/ );
 132     return if ( -f "$_.in" );
 133
 134     print "Looking at $File::Find::name";
 135     my $filename = $File::Find::name;
 136     $filename =~ s'^\./'';
 137     $filename =~ s'\.in$'';
 138
 139     unless (open _, '<', $file) {
 140         print "\n  Cannot open $file for reading ($!), skipping.\n\n";
 141         return;
 142     }
 143
 144     my $errors = 0;
 145
 146     my $re_space_wo_nl = qr{(?!\n)\s};
 147     my $re_loc_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc $re_space_wo_nl* $}mx;
 148     my $re_loc_qw_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_qw $re_space_wo_nl* $}mx;
 149     my $re_loc_paren_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc \(\) $re_space_wo_nl* $}mx;
 150     my $re_loc_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_pair $re_space_wo_nl* $}mx;
 151     my $re_loc_left_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_left_pair $re_space_wo_nl* $}mx;
 152     my $re_delim = $RE{delimited}{-delim=>q{'"}}{-keep};
 153
 154     $_ = <_>;
 155
 156     # Mason filter: <&|/l>...</&> and <&|/l_unsafe>...</&>
 157     my $line = 1;
 158     while (m!\G(.*?<&\|/l(?:_unsafe)?(.*?)&>(.*?)</&>)!sg) {
 159         my ( $all, $vars, $str ) = ( $1, $2, $3 );
 160         $vars =~ s/[\n\r]//g;
 161         $line += ( $all =~ tr/\n/\n/ );
 162         $str =~ s/\\(['"\\])/$1/g;
 163         push @{ $FILECAT{$str} }, [ $filename, $line, $vars ];
 164     }
 165
 166     # Localization function: loc(...)
 167     $line = 1;
 168     pos($_) = 0;
 169     while (m/\G(.*?\bloc$RE{balanced}{-parens=>'()'}{-keep})/sg) {
 170         my ( $all, $match ) = ( $1, $2 );
 171         $line += ( $all =~ tr/\n/\n/ );
 172
 173         my ( $vars, $str );
 174         next unless ( $match =~ /\(\s*($re_delim)(.*?)\s*\)$/so );
 175
 176         my $interp = (substr($1,0,1) eq '"' ? 1 : 0);
 177         $str = substr( $1, 1, -1 );       # $str comes before $vars now
 178         $vars = $9;
 179
 180         $vars =~ s/[\n\r]//g;
 181         $str  =~ s/\\(['"\\])/$1/g;
 182
 183         push @{ $FILECAT{$str} }, [ $filename, $line, $vars, $interp ];
 184     }
 185
 186     my %seen;
 187     # Comment-based mark: "..." # loc
 188     $line = 1;
 189     pos($_) = 0;
 190     while (m/\G(.*?($re_delim)[ \{\}\)\],;]*$re_loc_suffix)/smgo) {
 191         my ( $all, $str ) = ( $1, $2 );
 192         $line += ( $all =~ tr/\n/\n/ );
 193         $seen{$line}++;
 194         unless ( defined $str ) {
 195             print "\n" unless $errors++;
 196             print "  Couldn't process loc at $filename:$line:\n  $str\n";
 197             next;
 198         }
 199         my $interp = (substr($str,0,1) eq '"' ? 1 : 0);
 200         $str = substr($str, 1, -1);
 201         $str =~ s/\\(['"\\])/$1/g;
 202         push @{ $FILECAT{$str} }, [ $filename, $line, '', $interp ];
 203     }
 204
 205     # Comment-based mark for list to loc():  ("...", $foo, $bar)  # loc()
 206     $line = 1;
 207     pos($_) = 0;
 208     while (m/\G(.*? $RE{balanced}{-parens=>'()'}{-keep} [ \{\}\)\],;]* $re_loc_paren_suffix)/sgx) {
 209         my ( $all, $match ) = ( $1, $2 );
 210         $line += ( $all =~ tr/\n/\n/ );
 211
 212         my ( $vars, $str );
 213         unless ( $match =~
 214                 /\(\s*($re_delim)(.*?)\s*\)$/so ) {
 215             print "\n" unless $errors++;
 216             print "  Failed to match delimited against $match, line $line";
 217             next;
 218         }
 219
 220         my $interp = (substr($1,0,1) eq '"' ? 1 : 0);
 221         $str = substr( $1, 1, -1 );       # $str comes before $vars now
 222         $vars = $9;
 223         $seen{$line}++;
 224
 225         $vars =~ s/[\n\r]//g;
 226         $str  =~ s/\\(['"\\])/$1/g;
 227
 228         push @{ $FILECAT{$str} }, [ $filename, $line, $vars, $interp ];
 229     }
 230
 231     # Comment-based qw mark: "qw(...)" # loc_qw
 232     $line = 1;
 233     pos($_) = 0;
 234     while (m/\G(.*?(?:qw\(([^)]+)\)[ \{\}\)\],;]*)?$re_loc_qw_suffix)/smgo) {
 235         my ( $all, $str ) = ( $1, $2 );
 236         $line += ( $all =~ tr/\n/\n/ );
 237         $seen{$line}++;
 238         unless ( defined $str ) {
 239             print "\n" unless $errors++;
 240             print "  Couldn't process loc_qw at $filename:$line:\n  $str\n";
 241             next;
 242         }
 243         foreach my $value (split ' ', $str) {
 244             push @{ $FILECAT{$value} }, [ $filename, $line, '' ];
 245         }
 246     }
 247
 248     # Comment-based left pair mark: "..." => ... # loc_left_pair
 249     $line = 1;
 250     pos($_) = 0;
 251     while (m/\G(.*?(?:(\w+|$re_delim)\s*=>[^#\n]+?)?$re_loc_left_pair_suffix)/smgo) {
 252         my ( $all, $key ) = ( $1, $2 );
 253         $line += ( $all =~ tr/\n/\n/ );
 254         $seen{$line}++;
 255         unless ( defined $key ) {
 256             print "\n" unless $errors++;
 257             print "  Couldn't process loc_left_pair at $filename:$line:\n  $key\n";
 258             next;
 259         }
 260         my $interp = (substr($key,0,1) eq '"' ? 1 : 0);
 261         $key =~ s/\\(['"\\])/$1/g if $key =~ s/^(['"])(.*)\1$/$2/g; # dequote potentially quoted string
 262         push @{ $FILECAT{$key} }, [ $filename, $line, '', $interp ];
 263     }
 264
 265     # Comment-based pair mark: "..." => "..." # loc_pair
 266     $line = 1;
 267     pos($_) = 0;
 268     while (m/\G(.*?(?:(\w+|$re_delim)\s*=>\s*($re_delim)[ \{\}\)\],;]*)?$re_loc_pair_suffix)/smgo) {
 269         my ( $all, $key, $val ) = ( $1, $2, $10 );
 270         $line += ( $all =~ tr/\n/\n/ );
 271         $seen{$line}++;
 272         unless ( defined $key && defined $val ) {
 273             print "\n" unless $errors++;
 274             print "  Couldn't process loc_pair at $filename:$line:\n  $key\n  $val\n";
 275             next;
 276         }
 277         my $interp_key = (substr($key,0,1) eq '"' ? 1 : 0);
 278         $key =~ s/\\(['"\\])/$1/g if $key =~ s/^(['"])(.*)\1$/$2/g; # dequote potentially quoted string
 279         push @{ $FILECAT{$key} }, [ $filename, $line, '', $interp_key ];
 280
 281         my $interp_val = (substr($val,0,1) eq '"' ? 1 : 0);
 282         $val = substr($val, 1, -1);    # dequote always quoted string
 283         $val  =~ s/\\(['"\\])/$1/g;
 284         push @{ $FILECAT{$val} }, [ $filename, $line, '', $interp_val ];
 285     }
 286
 287     # Specific key  foo => "...", #loc{foo}
 288     $line = 1;
 289     pos($_) = 0;
 290     while (m/\G(.*?(\w+|$re_delim)\s*=>\s*($re_delim)(?-s:.*?)\#$re_space_wo_nl*loc\{\2\}$re_space_wo_nl*)$/smgo) {
 291         my ( $all, $key, $val ) = ( $1, $2, $10 );
 292         $line += ( $all =~ tr/\n/\n/ );
 293         $seen{$line}++;
 294         unless ( defined $key && defined $val ) {
 295             warn "Couldn't process loc_pair at $filename:$line:\n  $key\n  $val\n";
 296             next;
 297         }
 298         $val = substr($val, 1, -1);    # dequote always quoted string
 299         $val  =~ s/\\(['"])/$1/g;
 300         push @{ $FILECAT{$val} }, [ $filename, $line, '' ];
 301     }
 302
 303     # Check for ones we missed
 304     $line = 1;
 305     pos($_) = 0;
 306     while (m/\G(.*? \# $re_space_wo_nl* (loc (_\w+|\(\)|{$re_delim})?) $re_space_wo_nl* $)/smgox) {
 307         my ($all, $loc_type) = ($1, $2);
 308         $line += ( $all =~ tr/\n/\n/ );
 309         next if $seen{$line};
 310         print "\n" unless $errors++;
 311         print "  $loc_type that did not match, line $line of $filename\n";
 312     }
 313
 314     if ($errors) {
 315         print "\n"
 316     } else {
 317         print "\r", " " x 100, "\r";
 318     }
 319
 320     close (_);
 321 }
 322
 323 sub uniq {
 324     my %seen;
 325     return grep { !$seen{$_}++ } @_;
 326 }
 327
 328 sub update {
 329     my $lang = shift;
 330     my $file = shift;
 331
 332     unless (!-e $file or -w $file) {
 333         warn "Can't write to $lang, skipping...\n";
 334         return;
 335     }
 336
 337     my $is_english = ( $lang =~ /^en(?:[^A-Za-z]|$)/ );
 338
 339     print "Updating $lang";
 340     my $lexicon = Locale::PO->load_file_ashash( $file, "utf-8" );
 341
 342     # Default to the empty string for new ones
 343     $lexicon->{$_->msgid} ||= $_
 344         for values %FILECAT;
 345
 346     my $errors = 0;
 347     for my $msgid ( keys %{$lexicon} ) {
 348         my $entry = $lexicon->{$msgid};
 349
 350         # Don't output empty translations for english
 351         if (not length $entry->dequote($entry->msgstr) and $is_english) {
 352             delete $lexicon->{$msgid};
 353             next;
 354         }
 355
 356         # The PO properties at the top are always fine to leave as-is
 357         next if not length $entry->dequote($msgid);
 358
 359         # Not found in source?  Drop it
 360         my $source = $FILECAT{$msgid};
 361         if (not $source) {
 362             delete $lexicon->{$msgid};
 363             next;
 364         }
 365
 366         # Pull in the properties from the source
 367         $entry->reference( $source->reference );
 368         $entry->automatic( $source->automatic );
 369
 370         my $fail = validate_msgstr($lang,
 371                                    map {$entry->dequote($_)}
 372                                        $entry->msgid, $entry->msgstr);
 373         next unless $fail;
 374         print "\n" unless $errors++;
 375         print $fail;
 376     }
 377
 378     my @order = map {$_->[0]}
 379                 sort {$a->[1] cmp $b->[1]}
 380                 map {[$_, $_->dequote($_->msgid)]}
 381                 values %{$lexicon};
 382
 383     Locale::PO->save_file_fromarray($file, \@order, "utf-8")
 384           or die "Couldn't update '$file': $!";
 385
 386     if ($errors) {
 387         print "\n";
 388     } else {
 389         print "\r", " "x100, "\r";
 390     }
 391     return 1;
 392 }
 393
 394 sub validate_msgstr {
 395     my $lang   = shift;
 396     my $msgid  = shift;
 397     my $msgstr = shift;
 398
 399     return if not defined $msgstr or $msgstr eq ''; # no translation for this string
 400
 401     # we uniq because a string can use a placeholder more than once
 402     # (eg %1 %quant(%1, ...) like in our czech localization
 403     my @expected_variables = uniq($msgid =~ /%\d+/g);
 404     my @got_variables = uniq($msgstr =~ /%\d+/g);
 405
 406     # this catches the case where expected uses %1,%2 and got uses %1,%3
 407     # unlike a simple @expected_variables == @got_variables
 408     my $expected = join ", ", sort @expected_variables;
 409     my $got      = join ", ", sort @got_variables;
 410     return if $expected eq $got;
 411
 412     return "  expected (" . $expected . ") in msgid: $msgid\n" .
 413            "       got (" . $got      . ") in msgstr: $msgstr\n";
 414 }