source: git/lib/po-to-msg.pl @ 5d4e21e

debian/1.4.1-1
Last change on this file since 5d4e21e was ee18dba, checked in by Olly Betts <olly@…>, 6 years ago

lib/po-to-msg.pl: Only check C format strings in messages with the
c-format flag.

  • Property mode set to 100755
File size: 8.5 KB
Line 
1#!/usr/bin/perl -w
2require 5.008;
3use bytes;
4use strict;
5use Locale::PO;
6
7use integer;
8
9# Magic identifier (12 bytes)
10my $magic = "Svx\nMsg\r\n\xfe\xff\0";
11# Designed to be corrupted by ASCII ftp, top bit stripping (or
12# being used for parity).  Contains a zero byte so more likely
13# to be flagged as data (e.g. by perl's "-B" test).
14
15my $srcdir = $0;
16$srcdir =~ s!/[^/]+$!!;
17
18my $major = 0;
19my $minor = 8;
20
21# File format (multi-byte numbers in network order (bigendian)):
22# 12 bytes: Magic identifier
23# 1 byte:   File format major version number (0)
24# 1 byte:   File format minor version number (8)
25# 2 bytes:  Number of messages (N)
26# 4 bytes:  Offset from XXXX to end of file
27# XXXX:
28# N*:
29# <message> NUL
30
31my %msgs = ();
32${$msgs{'en'}}[0] = '©';
33
34# my %uses = ();
35
36my $file;
37
38my %n = ();
39my %loc = ();
40$file = "$srcdir/survex.pot";
41my $num_list = Locale::PO->load_file_asarray($file);
42foreach my $po_entry (@{$num_list}) {
43    my $ref = $po_entry->reference;
44    (defined $ref && $ref =~ /^n:(\d+)$/m) or next;
45    my $msgno = $1;
46    my $key = $po_entry->msgid;
47    my $msg = c_unescape($po_entry->dequote($key));
48    my $where = $file . ":" . $po_entry->loaded_line_number;
49    ${$loc{'en'}}[$msgno] = $where;
50    if (${$msgs{'en'}}[$msgno]) {
51        print STDERR "$where: warning: already had message $msgno for language 'en'\n";
52    }
53    ${$msgs{'en'}}[$msgno] = $msg;
54    ++$n{$msgno};
55}
56my $last = 0;
57for (sort { $a <=> $b } keys %n) {
58    if ($_ > $last + 1) {
59        print STDERR "$file: Unused msg numbers: ", join(" ", $last + 1 .. $_ - 1), "\n";
60    }
61    $last = $_;
62}
63print STDERR "$file: Last used msg number: $last\n";
64%n = ();
65
66my %fuzzy;
67my %c_format;
68for my $po_file (@ARGV) {
69    my $language = $po_file;
70    $language =~ s/\.po$//;
71
72    $file = "$srcdir/$po_file";
73    my $po_hash = Locale::PO->load_file_ashash($file);
74
75    if (exists $$po_hash{'""'}) {
76        if ($$po_hash{'""'}->msgstr =~ /^(?:.*\\n)?Language:\s*([^\s\\]+)/im) {
77            if ($language ne $1) {
78                my $line = 3 + scalar(@{[$& =~ /(\\n)/g]});
79                print STDERR "$file:$line: Language code '$1' doesn't match '$language' from filename\n";
80            }
81        } else {
82            my $line = 2 + scalar(@{[$$po_hash{'""'}->msgstr =~ /(\\n)/g]});
83            print STDERR "$file:$line: No suitable 'Language:' field in header\n";
84        }
85    } else {
86        print STDERR "$file:1: Expected 'msgid \"\"' with header\n";
87    }
88
89    my $fuzzy = 0;
90    foreach my $po_entry (@{$num_list}) {
91        my $ref = $po_entry->reference;
92        (defined $ref && $ref =~ /^n:(\d+)$/m) or next;
93        my $msgno = $1;
94        my $key = $po_entry->msgid;
95        my $ent = $$po_hash{$key};
96        my $where = $file . ":" . $po_entry->loaded_line_number;
97        ${$loc{$language}}[$msgno] = $where;
98        if (defined $ent) {
99            my $msg = c_unescape($po_entry->dequote($ent->msgstr));
100            next if $msg eq '';
101            if (${$msgs{$language}}[$msgno]) {
102                print STDERR "$where: warning: already had message $msgno for language $language\n";
103            }
104            ${$msgs{$language}}[$msgno] = $msg;
105            $ent->fuzzy() and ++$fuzzy;
106        }
107        $po_entry->c_format and $c_format{$language}[$msgno]++;
108    }
109    $fuzzy{$language} = $fuzzy;
110}
111
112my $lang;
113my @langs = sort grep ! /_\*$/, keys %msgs;
114
115my $num_msgs = -1;
116foreach $lang (@langs) {
117   my $aref = $msgs{$lang};
118   $num_msgs = scalar @$aref if scalar @$aref > $num_msgs;
119}
120
121foreach $lang (@langs) {
122   my $fnm = $lang;
123   $file = "$srcdir/$lang.po";
124   $fnm =~ s/(_.*)$/\U$1/;
125   open OUT, ">$fnm.msg" or die $!;
126
127   my $aref = $msgs{$lang};
128
129   my $parentaref;
130   my $mainlang = $lang;
131   $parentaref = $msgs{$mainlang} if $mainlang =~ s/_.*$//;
132
133   print OUT $magic or die $!;
134   print OUT pack("CCn", $major, $minor, $num_msgs) or die $!;
135
136   my $buff = '';
137   my $missing = 0;
138
139   for my $n (0 .. $num_msgs - 1) {
140      my $warned = 0;
141      my $msg = $$aref[$n];
142      if (!defined $msg) {
143         $msg = $$parentaref[$n] if defined $parentaref;
144         if (!defined $msg) {
145            $msg = ${$msgs{'en'}}[$n];
146            # don't report if we have a parent (as the omission will be
147            # reported there)
148            if (defined $msg && $msg ne '' && $msg ne '©' && !defined $parentaref) {
149               ++$missing;
150               $warned = 1;
151            } else {
152               $msg = '' if !defined $msg;
153            }
154         }
155      } else {
156         if ($lang ne 'en') {
157             my $c_format = $c_format{$lang}[$n] // 0;
158             sanity_check("Message $n in language $lang", $msg, ${$msgs{'en'}}[$n], ${$loc{$lang}}[$n], $c_format);
159         }
160      }
161      $buff .= $msg . "\0";
162   }
163
164   print OUT pack('N',length($buff)), $buff or die $!;
165   close OUT or die $!;
166
167   my $fuzzy = $fuzzy{$lang};
168   if ($missing || $fuzzy) {
169       print STDERR "Warning: $file: ";
170       if ($missing) {
171           print STDERR "$missing missing message(s)";
172           if ($fuzzy) {
173               print STDERR " and $fuzzy fuzzy message(s)";
174           }
175       } else {
176           print STDERR "$fuzzy fuzzy message(s)";
177       }
178       print STDERR " for $lang\n";
179   }
180}
181
182sub sanity_check {
183   my ($what, $msg, $orig, $where, $c_format) = @_;
184   if ($c_format) {
185      # check printf-like specifiers match
186      # allow valid printf specifiers, or %<any letter> to support strftime
187      # and other printf-like formats.
188      my @pcent_m = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $msg;
189      my @pcent_o = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $orig;
190      while (scalar @pcent_m || scalar @pcent_o) {
191          if (!scalar @pcent_m) {
192              print STDERR "$where: warning: $what misses out \%spec $pcent_o[0]\n";
193          } elsif (!scalar @pcent_o) {
194              print STDERR "$where: warning: $what has extra \%spec $pcent_m[0]\n";
195          } elsif ($pcent_m[0] ne $pcent_o[0]) {
196              print STDERR "$where: warning: $what has \%spec $pcent_m[0] instead of $pcent_o[0]\n";
197          }
198          pop @pcent_m;
199          pop @pcent_o;
200      }
201   }
202
203   # Check for missing (or added) ellipses (...)
204   if ($msg =~ /\.\.\./ && $orig !~ /\.\.\./) {
205       print STDERR "$where: warning: $what has ellipses but original doesn't\n";
206   } elsif ($msg !~ /\.\.\./ && $orig =~ /\.\.\./) {
207       print STDERR "$where: warning: $what is missing ellipses\n";
208   }
209
210   # Check for missing (or added) menu shortcut (&)
211   if ($msg =~ /\&[A-Za-z\xc2-\xf4]/ && $orig !~ /\&[A-Za-z]/) {
212       print STDERR "$where: warning: $what has menu shortcut but original doesn't\n";
213   } elsif ($msg !~ /\&[A-Za-z\xc2-\xf4]/ && $orig =~ /\&[A-Za-z]/) {
214       print STDERR "$where: warning: $what is missing menu shortcut\n";
215   }
216
217   # Check for missing (or added) double quotes (“ and ”)
218   if (scalar($msg =~ s/(?:“|»)/$&/g) != scalar($orig =~ s/“/$&/g)) {
219       print STDERR "$where: warning: $what has different numbers of “\n";
220       print STDERR "$orig\n$msg\n\n";
221   }
222   if (scalar($msg =~ s/(?:”|«)/$&/g) != scalar($orig =~ s/”/$&/g)) {
223       print STDERR "$where: warning: $what has different numbers of ”\n";
224       print STDERR "$orig\n$msg\n\n";
225   }
226
227   # Check for missing (or added) menu accelerator "##"
228   if ($msg =~ /\#\#/ && $orig !~ /\#\#/) {
229       print STDERR "$where: warning: $what has menu accelerator but original doesn't\n";
230   } elsif ($msg !~ /\#\#/ && $orig =~ /\#\#/) {
231       print STDERR "$where: warning: $what is missing menu accelerator\n";
232   } elsif ($orig =~ /\#\#(.*)/) {
233       my $acc_o = $1;
234       my ($acc_m) = $msg =~ /\#\#(.*)/;
235       if ($acc_o ne $acc_m) {
236           print STDERR "$where: warning: $what has menu accelerator $acc_m instead of $acc_o\n";
237       }
238   }
239
240   # Check for missing (or added) menu accelerator "\t"
241   if ($msg =~ /\t/ && $orig !~ /\t/) {
242       print STDERR "$where: warning: $what has menu accelerator but original doesn't\n";
243   } elsif ($msg !~ /\t/ && $orig =~ /\t/) {
244       print STDERR "$where: warning: $what is missing menu accelerator\n";
245   } elsif ($orig =~ /\t(.*)/) {
246       my $acc_o = $1;
247       my ($acc_m) = $msg =~ /\t(.*)/;
248       if ($acc_o ne $acc_m) {
249           print STDERR "$where: warning: $what has menu accelerator $acc_m instead of $acc_o\n";
250       }
251   }
252}
253
254sub c_unescape {
255   my $str = shift @_;
256   $str =~ s/\\(x..|0|[0-7][0-7][0-7]|.)/&c_unescape_char($1)/ge;
257   return $str;
258}
259
260sub c_unescape_char {
261    my $ch = shift @_;
262    if ($ch eq '0' || $ch eq 'x00' || $ch eq '000') {
263        print STDERR "Nul byte in translation! (\\$ch)\n";
264        exit(1);
265    }
266    return $ch if $ch eq '"' || $ch eq '\\';
267    return "\n" if $ch eq "n";
268    return "\t" if $ch eq "t";
269    return "\r" if $ch eq "r";
270    return "\f" if $ch eq "f";
271    return chr(hex(substr($ch,1))) if $ch =~ /^x../;
272    return chr(oct($ch)) if $ch =~ /^[0-7][0-7][0-7]/;
273    print STDERR "Unknown C-escape in translation! (\\$ch)\n";
274    exit(1);
275}
Note: See TracBrowser for help on using the repository browser.