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-2015 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 File::Find;
  55 use File::Copy;
  56 use Regexp::Common;
  57 use Carp;
  58
  59 # po dir is for extensions
  60 @ARGV = (<share/po/*.po>, <share/po/*.pot>, <po/*.po>, <po/*.pot>) unless @ARGV;
  61
  62 our %FILECAT;
  63
  64 # extract all strings and stuff them into %FILECAT
  65 # scan html dir for extensions
  66 File::Find::find( { wanted => \&extract_strings_from_code, follow => 1 }, qw(bin sbin lib share html etc) );
  67
  68 # ensure proper escaping and [_1] => %1 transformation
  69 foreach my $str ( sort keys %FILECAT ) {
  70     my $entry = $FILECAT{$str};
  71     my $oldstr = $str;
  72
  73     $str =~ s/\\/\\\\/g;
  74     $str =~ s/\"/\\"/g;
  75     $str =~ s/((?<!~)(?:~~)*)\[_(\d+)\]/$1%$2/g;
  76     $str =~ s/((?<!~)(?:~~)*)\[([A-Za-z#*]\w*),([^\]]+)\]/"$1%$2(".escape($3).")"/eg;
  77     $str =~ s/~([\[\]])/$1/g;
  78
  79     delete $FILECAT{$oldstr};
  80     $FILECAT{$str} = $entry;
  81 }
  82
  83 # update all language dictionaries
  84 foreach my $dict (@ARGV) {
  85     $dict = "share/po/$dict.pot" if ( $dict eq 'rt' );
  86     $dict = "share/po/$dict.po" unless -f $dict or $dict =~ m!/!;
  87
  88     my $lang = $dict;
  89     $lang =~ s|.*/||;
  90     $lang =~ s|\.po$||;
  91     $lang =~ s|\.pot$||;
  92
  93     update($lang, $dict);
  94 }
  95
  96 # warn about various red flags in loc strings
  97 foreach my $str ( sort keys %FILECAT ) {
  98     my $entry = $FILECAT{$str};
  99     my $entry_count = @$entry;
 100
 101     # doesn't exist in the current codebase, ignore for now
 102     next if $entry_count == 0;
 103
 104     my ($filename, $line) = @{ $entry->[0] };
 105
 106     my $location = "$filename line $line" . ($entry_count > 1 ? " (and ".($entry_count-1)." other places)" : "");
 107
 108     if ($str =~ /^\s/m || $str =~ /\s$/m || $str =~ /\\n$/m) {
 109         warn "Extraneous whitespace in '$str' at $location\n";
 110     }
 111
 112     if ($str =~ /([\$\@]\w+)/) {
 113         warn "Interpolated variable '$1' in '$str' at $location\n";
 114     }
 115 }
 116
 117
 118 sub extract_strings_from_code {
 119     my $file = $_;
 120
 121     local $/;
 122     return if ( -d $_ || !-e _ );
 123     return
 124       if ( $File::Find::dir =~
 125         qr!lib/blib|lib/t/autogen|var|m4|local|share/fonts! );
 126     return if ( /\.(?:pot|po|bak|gif|png|psd|jpe?g|svg|css|js)$/ );
 127     return if ( /~|,D|,B$|extract-message-catalog$|tweak-template-locstring$/ );
 128     return if ( /StyleGuide.pod/ );
 129     return if ( /^[\.#]/ );
 130     return if ( -f "$_.in" );
 131
 132     print "Looking at $File::Find::name\n";
 133     my $filename = $File::Find::name;
 134     $filename =~ s'^\./'';
 135     $filename =~ s'\.in$'';
 136
 137     unless (open _, '<', $file) {
 138         print "Cannot open $file for reading ($!), skipping.\n";
 139         return;
 140     }
 141
 142     my $re_space_wo_nl = qr{(?!\n)\s};
 143     my $re_loc_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc $re_space_wo_nl* $}mx;
 144     my $re_loc_qw_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_qw $re_space_wo_nl* $}mx;
 145     my $re_loc_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_pair $re_space_wo_nl* $}mx;
 146     my $re_loc_left_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_left_pair $re_space_wo_nl* $}mx;
 147     my $re_delim = $RE{delimited}{-delim=>q{'"}}{-keep};
 148
 149     $_ = <_>;
 150
 151     # Mason filter: <&|/l>...</&> and <&|/l_unsafe>...</&>
 152     my $line = 1;
 153     while (m!\G(.*?<&\|/l(?:_unsafe)?(.*?)&>(.*?)</&>)!sg) {
 154         my ( $all, $vars, $str ) = ( $1, $2, $3 );
 155         $vars =~ s/[\n\r]//g;
 156         $line += ( $all =~ tr/\n/\n/ );
 157         $str =~ s/\\'/\'/g;
 158         #print "STR IS $str\n";
 159         push @{ $FILECAT{$str} }, [ $filename, $line, $vars ];
 160     }
 161
 162     # Localization function: loc(...)
 163     $line = 1;
 164     pos($_) = 0;
 165     while (m/\G(.*?\bloc$RE{balanced}{-parens=>'()'}{-keep})/sg) {
 166         my ( $all, $match ) = ( $1, $2 );
 167         $line += ( $all =~ tr/\n/\n/ );
 168
 169         my ( $vars, $str );
 170         if ( $match =~
 171                 /\(\s*($re_delim)(.*?)\s*\)$/so ) {
 172
 173             $str = substr( $1, 1, -1 );       # $str comes before $vars now
 174             $vars = $9;
 175         }
 176         else {
 177             next;
 178         }
 179
 180         $vars =~ s/[\n\r]//g;
 181         $str  =~ s/\\'/\'/g;
 182
 183         push @{ $FILECAT{$str} }, [ $filename, $line, $vars ];
 184     }
 185
 186     # Comment-based mark: "..." # loc
 187     $line = 1;
 188     pos($_) = 0;
 189     while (m/\G(.*?($re_delim)[\}\)\],;]*$re_loc_suffix)/smgo) {
 190         my ( $all, $str ) = ( $1, $2 );
 191         $line += ( $all =~ tr/\n/\n/ );
 192         unless ( defined $str ) {
 193             warn "Couldn't process loc at $filename:$line";
 194             next;
 195         }
 196         $str = substr($str, 1, -1);
 197         $str =~ s/\\'/\'/g;
 198         push @{ $FILECAT{$str} }, [ $filename, $line, '' ];
 199     }
 200
 201     # Comment-based qw mark: "qw(...)" # loc_qw
 202     $line = 1;
 203     pos($_) = 0;
 204     while (m/\G(.*?(?:qw\(([^)]+)\)\s*[\{\}\)\],; ]*)?$re_loc_qw_suffix)/smgo) {
 205         my ( $all, $str ) = ( $1, $2 );
 206         $line += ( $all =~ tr/\n/\n/ );
 207         unless ( defined $str ) {
 208             warn "Couldn't process loc_qw at $filename:$line";
 209             next;
 210         }
 211         foreach my $value (split ' ', $str) {
 212             push @{ $FILECAT{$value} }, [ $filename, $line, '' ];
 213         }
 214     }
 215
 216     # Comment-based left pair mark: "..." => ... # loc_left_pair
 217     $line = 1;
 218     pos($_) = 0;
 219     while (m/\G(.*?(?:(\w+|$re_delim)\s*=>[^#\n]+?)?$re_loc_left_pair_suffix)/smgo) {
 220         my ( $all, $key ) = ( $1, $2 );
 221         $line += ( $all =~ tr/\n/\n/ );
 222         unless ( defined $key ) {
 223             warn "Couldn't process loc_left_pair at $filename:$line";
 224             next;
 225         }
 226         $key  =~ s/\\'/\'/g;
 227         push @{ $FILECAT{$key} }, [ $filename, $line, '' ];
 228     }
 229
 230     # Comment-based pair mark: "..." => "..." # loc_pair
 231     $line = 1;
 232     pos($_) = 0;
 233     while (m/\G(.*?(?:(\w+)\s*=>\s*($re_delim)[\}\)\],;]*)?$re_loc_pair_suffix)/smgo) {
 234         my ( $all, $key, $val ) = ( $1, $2, $3 );
 235         $line += ( $all =~ tr/\n/\n/ );
 236         unless ( defined $key && defined $val ) {
 237             warn "Couldn't process loc_pair at $filename:$line";
 238             next;
 239         }
 240         $val = substr($val, 1, -1);
 241         $key  =~ s/\\'/\'/g;
 242         $val  =~ s/\\'/\'/g;
 243         push @{ $FILECAT{$key} }, [ $filename, $line, '' ];
 244         push @{ $FILECAT{$val} }, [ $filename, $line, '' ];
 245     }
 246
 247     close (_);
 248 }
 249
 250 sub update {
 251     my $lang = shift;
 252     my $file = shift;
 253     my ( %Lexicon, %Header);
 254     my $out = '';
 255
 256     unless (!-e $file or -w $file) {
 257         warn "Can't write to $lang, skipping...\n";
 258         return;
 259     }
 260
 261     print "Updating $lang...\n";
 262
 263     my @lines;
 264     @lines = (<LEXICON>) if open LEXICON, '<', $file;
 265     @lines = grep { !/^(#(:|\.)\s*|$)/ } @lines;
 266     while (@lines) {
 267         my $msghdr = "";
 268         $msghdr .= shift @lines while ( $lines[0] && $lines[0] !~ /^(#~ )?msgid/ );
 269
 270         my $msgid  = "";
 271
 272 # '#~ ' is the prefix of launchpad for msg that's not found the the source
 273 # we'll remove the prefix later so we can still show them with our own mark
 274
 275         $msgid .= shift @lines while ( $lines[0] && $lines[0] =~ /^(#~ )?(msgid|")/ );
 276         my $msgstr = "";
 277         $msgstr .= shift @lines while ( $lines[0] && $lines[0] =~ /^(#~ )?(msgstr|")/ );
 278
 279         last unless $msgid;
 280
 281         chomp $msgid;
 282         chomp $msgstr;
 283
 284         $msgid  =~ s/^#~ //mg;
 285         $msgstr =~ s/^#~ //mg;
 286
 287         $msgid  =~ s/^msgid "(.*)"\s*?$/$1/m    or warn "$msgid in $file";
 288
 289         if ( $msgid eq '' ) {
 290             # null msgid, msgstr will have head info
 291             $msgstr =~ s/^msgstr "(.*)"\s*?$/$1/ms or warn "$msgstr  in $file";
 292         }
 293         else {
 294             $msgstr =~ s/^msgstr "(.*)"\s*?$/$1/m or warn "$msgstr  in $file";
 295         }
 296
 297         if ( $msgid ne ''  ) {
 298             for my $msg ( \$msgid, \$msgstr ) {
 299                 if ( $$msg =~ /\n/ ) {
 300                     my @lines = split /\n/, $$msg;
 301                     $$msg =
 302                       shift @lines;   # first line don't need to handle any more
 303                     for (@lines) {
 304                         if (/^"(.*)"\s*$/) {
 305                             $$msg .= $1;
 306                         }
 307                     }
 308                 }
 309
 310                 # convert \\n back to \n
 311                 $$msg =~ s/(?!\\)\\n/\n/g;
 312             }
 313         }
 314
 315         $Lexicon{$msgid} = $msgstr;
 316         $Header{$msgid}  = $msghdr;
 317     }
 318
 319     my $is_english = ( $lang =~ /^en(?:[^A-Za-z]|$)/ );
 320
 321     foreach my $str ( keys %FILECAT ) {
 322         $Lexicon{$str} ||= '';
 323     }
 324     foreach ( sort keys %Lexicon ) {
 325         my $f = join ( ' ', sort map $_->[0].":".$_->[1], @{ $FILECAT{$_} } );
 326         my $nospace = $_;
 327         $nospace =~ s/ +$//;
 328
 329         if ( !$Lexicon{$_} and $Lexicon{$nospace} ) {
 330             $Lexicon{$_} =
 331               $Lexicon{$nospace} . ( ' ' x ( length($_) - length($nospace) ) );
 332         }
 333
 334         next if !length( $Lexicon{$_} ) and $is_english;
 335
 336         my %seen;
 337         $out .= $Header{$_} if exists $Header{$_};
 338
 339
 340
 341         next if (!$f && $_ && !$Lexicon{$_});
 342         if ( $f && $f !~ /^\s+$/ ) {
 343
 344             $out .= "#: $f\n";
 345         }
 346         elsif ($_) {
 347             $out .= "#: NOT FOUND IN SOURCE\n";
 348         }
 349         foreach my $entry ( sort { $a->[2] cmp $b->[2] } grep { $_->[2] } @{ $FILECAT{$_} } ) {
 350             my ( $file, $line, $var ) = @{$entry};
 351             $var =~ s/^\s*,\s*//;
 352             $var =~ s/\s*$//;
 353             $out .= "#. ($var)\n" unless $seen{$var}++;
 354         }
 355         $out .= 'msgid ' . fmt($_) . "msgstr \"$Lexicon{$_}\"\n\n";
 356     }
 357
 358     open PO, '>', $file or die "Couldn't open '$file' for writing: $!";
 359     print PO $out;
 360     close PO;
 361
 362     return 1;
 363 }
 364
 365 sub escape {
 366     my $text = shift;
 367     $text =~ s/\b_(\d+)/%$1/;
 368     return $text;
 369 }
 370
 371 sub fmt {
 372     my $str = shift;
 373     return "\"$str\"\n" unless $str =~ /\n/;
 374
 375     my $multi_line = ($str =~ /\n(?!\z)/);
 376     $str =~ s/\n/\\n"\n"/g;
 377
 378     if ($str =~ /\n"$/) {
 379         chop $str;
 380     }
 381     else {
 382         $str .= "\"\n";
 383     }
 384     return $multi_line ? qq(""\n"$str) : qq("$str);
 385 }