2 # BEGIN BPS TAGGED BLOCK {{{
6 # This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC
7 # <sales@bestpractical.com>
9 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
31 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
48 # END BPS TAGGED BLOCK }}}
49 # Portions Copyright 2002 Autrijus Tang <autrijus@autrijus.org>
54 use open qw/ :std :encoding(UTF-8) /;
63 # po dir is for extensions
64 @ARGV = (<share/po/*.po>, <share/po/*.pot>, <po/*.po>, <po/*.pot>) unless @ARGV;
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) );
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};
77 my ($filename, $line) = @{ $entry->[0] };
78 my $location = "$filename line $line" . (@{$entry} > 1 ? " (and ".(@{$entry}-1)." other places)" : "");
80 if ($str =~ /^\s/m || $str =~ /\s$/m || $str =~ /\\n$/m) {
81 warn "Extraneous whitespace in '$str' at $location\n";
83 if (grep {$_->[3]} @{$entry} and $str =~ /([\$\@]\w+)/) {
84 warn "Interpolated variable '$1' in '$str' at $location\n";
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;
92 my $po = Locale::PO->new(-msgid => $str, -msgstr => "");
93 $po->reference( join ( ' ', sort map $_->[0].":".$_->[1], @{ $entry } ) );
96 foreach my $find ( sort { $a->[2] cmp $b->[2] } grep { $_->[2] } @{ $entry } ) {
97 my ( $file, $line, $var ) = @{$find};
100 push @vars, "($var)" unless $seen{$var}++;
102 $po->automatic( join( "\n", @vars) );
104 $FILECAT{$po->msgid} = $po;
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!/!;
117 update($lang, $dict);
120 sub extract_strings_from_code {
124 return if ( -d $_ || !-e _ );
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" );
134 print "Looking at $File::Find::name";
135 my $filename = $File::Find::name;
136 $filename =~ s'^\./'';
137 $filename =~ s'\.in$'';
139 unless (open _, '<', $file) {
140 print "\n Cannot open $file for reading ($!), skipping.\n\n";
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};
156 # Mason filter: <&|/l>...</&> and <&|/l_unsafe>...</&>
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 ];
166 # Localization function: loc(...)
169 while (m/\G(.*?\bloc$RE{balanced}{-parens=>'()'}{-keep})/sg) {
170 my ( $all, $match ) = ( $1, $2 );
171 $line += ( $all =~ tr/\n/\n/ );
174 next unless ( $match =~ /\(\s*($re_delim)(.*?)\s*\)$/so );
176 my $interp = (substr($1,0,1) eq '"' ? 1 : 0);
177 $str = substr( $1, 1, -1 ); # $str comes before $vars now
180 $vars =~ s/[\n\r]//g;
181 $str =~ s/\\(['"\\])/$1/g;
183 push @{ $FILECAT{$str} }, [ $filename, $line, $vars, $interp ];
187 # Comment-based mark: "..." # loc
190 while (m/\G(.*?($re_delim)[ \{\}\)\],;]*$re_loc_suffix)/smgo) {
191 my ( $all, $str ) = ( $1, $2 );
192 $line += ( $all =~ tr/\n/\n/ );
194 unless ( defined $str ) {
195 print "\n" unless $errors++;
196 print " Couldn't process loc at $filename:$line:\n $str\n";
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 ];
205 # Comment-based mark for list to loc(): ("...", $foo, $bar) # loc()
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/ );
214 /\(\s*($re_delim)(.*?)\s*\)$/so ) {
215 print "\n" unless $errors++;
216 print " Failed to match delimited against $match, line $line";
220 my $interp = (substr($1,0,1) eq '"' ? 1 : 0);
221 $str = substr( $1, 1, -1 ); # $str comes before $vars now
225 $vars =~ s/[\n\r]//g;
226 $str =~ s/\\(['"\\])/$1/g;
228 push @{ $FILECAT{$str} }, [ $filename, $line, $vars, $interp ];
231 # Comment-based qw mark: "qw(...)" # loc_qw
234 while (m/\G(.*?(?:qw\(([^)]+)\)[ \{\}\)\],;]*)?$re_loc_qw_suffix)/smgo) {
235 my ( $all, $str ) = ( $1, $2 );
236 $line += ( $all =~ tr/\n/\n/ );
238 unless ( defined $str ) {
239 print "\n" unless $errors++;
240 print " Couldn't process loc_qw at $filename:$line:\n $str\n";
243 foreach my $value (split ' ', $str) {
244 push @{ $FILECAT{$value} }, [ $filename, $line, '' ];
248 # Comment-based left pair mark: "..." => ... # loc_left_pair
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/ );
255 unless ( defined $key ) {
256 print "\n" unless $errors++;
257 print " Couldn't process loc_left_pair at $filename:$line:\n $key\n";
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 ];
265 # Comment-based pair mark: "..." => "..." # loc_pair
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/ );
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";
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 ];
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 ];
287 # Specific key foo => "...", #loc{foo}
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/ );
294 unless ( defined $key && defined $val ) {
295 warn "Couldn't process loc_pair at $filename:$line:\n $key\n $val\n";
298 $val = substr($val, 1, -1); # dequote always quoted string
299 $val =~ s/\\(['"])/$1/g;
300 push @{ $FILECAT{$val} }, [ $filename, $line, '' ];
303 # Check for ones we missed
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";
317 print "\r", " " x 100, "\r";
325 return grep { !$seen{$_}++ } @_;
332 unless (!-e $file or -w $file) {
333 warn "Can't write to $lang, skipping...\n";
337 my $is_english = ( $lang =~ /^en(?:[^A-Za-z]|$)/ );
339 print "Updating $lang";
340 my $lexicon = Locale::PO->load_file_ashash( $file, "utf-8" );
342 # Default to the empty string for new ones
343 $lexicon->{$_->msgid} ||= $_
347 for my $msgid ( keys %{$lexicon} ) {
348 my $entry = $lexicon->{$msgid};
350 # Don't output empty translations for english
351 if (not length $entry->dequote($entry->msgstr) and $is_english) {
352 delete $lexicon->{$msgid};
356 # The PO properties at the top are always fine to leave as-is
357 next if not length $entry->dequote($msgid);
359 # Not found in source? Drop it
360 my $source = $FILECAT{$msgid};
362 delete $lexicon->{$msgid};
366 # Pull in the properties from the source
367 $entry->reference( $source->reference );
368 $entry->automatic( $source->automatic );
370 my $fail = validate_msgstr($lang,
371 map {$entry->dequote($_)}
372 $entry->msgid, $entry->msgstr);
374 print "\n" unless $errors++;
378 my @order = map {$_->[0]}
379 sort {$a->[1] cmp $b->[1]}
380 map {[$_, $_->dequote($_->msgid)]}
383 Locale::PO->save_file_fromarray($file, \@order, "utf-8")
384 or die "Couldn't update '$file': $!";
389 print "\r", " "x100, "\r";
394 sub validate_msgstr {
399 return if not defined $msgstr or $msgstr eq ''; # no translation for this string
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);
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;
412 return " expected (" . $expected . ") in msgid: $msgid\n" .
413 " got (" . $got . ") in msgstr: $msgstr\n";