source: git/lib/po-to-msg.pl @ 6186bca

RELEASE/1.2debug-cidebug-ci-sanitisersstereowalls-data
Last change on this file since 6186bca was 6186bca, checked in by Olly Betts <olly@…>, 11 years ago

lib/po-to-msg.pl: Report unused message numbers.

  • Property mode set to 100755
File size: 7.9 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 %n = ();
37my $num_list = Locale::PO->load_file_asarray("$srcdir/po_codes");
38foreach my $po_entry (@{$num_list}) {
39    my $msgno = $po_entry->dequote($po_entry->msgstr);
40    next if $msgno !~ /^\d+$/;
41    my $key = $po_entry->msgid;
42    my $msg = c_unescape($po_entry->dequote($key));
43    if (${$msgs{'en'}}[$msgno]) {
44        print STDERR "Warning: already had message $msgno for language 'en'\n";
45    }
46    ${$msgs{'en'}}[$msgno] = $msg;
47    ++$n{$msgno};
48}
49my $last = 0;
50for (sort { $a <=> $b } keys %n) {
51    if ($_ > $last + 1) {
52        print STDERR "Unused msg numbers: ", join(" ", $last + 1 .. $_ - 1), "\n";
53    }
54    $last = $_;
55}
56print STDERR "Last used msg number: $last\n";
57%n = ();
58
59for my $po_file (@ARGV) {
60    my $language = $po_file;
61    $language =~ s/\.po$//;
62
63    my $po_hash = Locale::PO->load_file_ashash("$srcdir/$po_file");
64
65    foreach my $po_entry (@{$num_list}) {
66        my $msgno = $po_entry->dequote($po_entry->msgstr);
67        next if $msgno !~ /^\d+$/;
68        my $key = $po_entry->msgid;
69        my $ent = $$po_hash{$key};
70        if (defined $ent) {
71            my $msg = c_unescape($po_entry->dequote($ent->msgstr));
72            next if $msg eq '';
73            if (${$msgs{$language}}[$msgno]) {
74                print STDERR "Warning: already had message $msgno for language $language\n";
75            }
76            ${$msgs{$language}}[$msgno] = $msg;
77        }
78    }
79
80#       local $_;
81#       open FINDUSES, "grep -no '*/$msgno\\>' \Q$srcdir\E/../src/*.cc \Q$srcdir\E../src/*.c \Q$srcdir\E/../src/*.h|" or die $!;
82#       while (<FINDUSES>) {
83#          push @{$uses{$msgno}}, $1 if /^([^:]*:\d+):/;
84#       }
85#       close FINDUSES;
86
87}
88
89my $lang;
90my @langs = sort grep ! /_\*$/, keys %msgs;
91
92my $num_msgs = -1;
93foreach $lang (@langs) {
94   my $aref = $msgs{$lang};
95   $num_msgs = scalar @$aref if scalar @$aref > $num_msgs;
96}
97
98foreach $lang (@langs) {
99   my $fnm = $lang;
100   $fnm =~ s/(_.*)$/\U$1/;
101   open OUT, ">$fnm.msg" or die $!;
102
103   my $aref = $msgs{$lang};
104
105   my $parentaref;
106   my $mainlang = $lang;
107   $parentaref = $msgs{$mainlang} if $mainlang =~ s/_.*$//;
108
109   print OUT $magic or die $!;
110   print OUT pack("CCn", $major, $minor, $num_msgs) or die $!;
111
112   my $buff = '';
113   my $missing = 0;
114   my $retranslate = 0;
115
116   for my $n (0 .. $num_msgs - 1) {
117      my $warned = 0;
118      my $msg = $$aref[$n];
119      if (!defined $msg) {
120         $msg = $$parentaref[$n] if defined $parentaref;
121         if (!defined $msg) {
122            $msg = ${$msgs{'en'}}[$n];
123            # don't report if we have a parent (as the omission will be
124            # reported there)
125            if (defined $msg && $msg ne '' && !defined $parentaref) {
126               ++$missing;
127               $warned = 1;
128            } else {
129               $msg = '' if !defined $msg;
130            }
131         }
132      } else {
133         if ($lang ne 'en') {
134             sanity_check("Message $n in language $lang", $msg, ${$msgs{'en'}}[$n]);
135         }
136      }
137      $buff .= $msg . "\0";
138   }
139
140   print OUT pack('N',length($buff)), $buff or die $!;
141   close OUT or die $!;
142
143   if ($missing || $retranslate) {
144       print STDERR "Warning: ";
145       if ($missing) {
146           print STDERR "$lang: $missing missing message(s)";
147           if ($retranslate) {
148               print STDERR " and $retranslate requiring retranslation";
149           }
150       } else {
151           print STDERR "$lang: $retranslate message(s) requiring retranslation";
152       }
153       print STDERR "\n";
154   }
155}
156
157sub sanity_check {
158   my ($where, $msg, $orig) = @_;
159   # FIXME: Only do this if the message has the "c-format" flag.
160   # check printf-like specifiers match
161   # allow valid printf specifiers, or %<any letter> to support strftime
162   # and other printf-like formats.
163   my @pcent_m = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $msg;
164   my @pcent_o = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $orig;
165   while (scalar @pcent_m || scalar @pcent_o) {
166       if (!scalar @pcent_m) {
167           print STDERR "Warning: $where misses out \%spec $pcent_o[0]\n";
168       } elsif (!scalar @pcent_o) {
169           print STDERR "Warning: $where has extra \%spec $pcent_m[0]\n";
170       } elsif ($pcent_m[0] ne $pcent_o[0]) {
171           print STDERR "Warning: $where has \%spec $pcent_m[0] instead of $pcent_o[0]\n";
172       }
173       pop @pcent_m;
174       pop @pcent_o;
175   }
176
177   # Check for missing (or added) ellipses (...)
178   if ($msg =~ /\.\.\./ && $orig !~ /\.\.\./) {
179       print STDERR "Warning: $where has ellipses but original doesn't\n";
180   } elsif ($msg !~ /\.\.\./ && $orig =~ /\.\.\./) {
181       print STDERR "Warning: $where is missing ellipses\n";
182   }
183
184   # Check for missing (or added) menu shortcut (@)
185   if ($msg =~ /\@[A-Za-z]/ && $orig !~ /\@[A-Za-z]/) {
186       print STDERR "Warning: $where has menu shortcut but original doesn't\n";
187   } elsif ($msg !~ /\@[A-Za-z]/ && $orig =~ /\@[A-Za-z]/) {
188       print STDERR "Warning: $where is missing menu shortcut\n";
189   }
190
191   # Check for missing (or added) menu shortcut (&)
192   if ($msg =~ /\&[A-Za-z]/ && $orig !~ /\&[A-Za-z]/) {
193       print STDERR "Warning: $where has menu shortcut but original doesn't\n";
194   } elsif ($msg !~ /\&[A-Za-z]/ && $orig =~ /\&[A-Za-z]/) {
195       print STDERR "Warning: $where is missing menu shortcut\n";
196   }
197
198   # Check for missing (or added) double quotes (“ and ”)
199   if (scalar($msg =~ s/“/$&/g) != scalar($orig =~ s/(?:“|»)/$&/g)) {
200       print STDERR "Warning: $where has different numbers of “\n";
201       print STDERR "$orig\n$msg\n\n";
202   }
203   if (scalar($msg =~ s/”/$&/g) != scalar($orig =~ s/(?:”|«)/$&/g)) {
204       print STDERR "Warning: $where has different numbers of ”\n";
205       print STDERR "$orig\n$msg\n\n";
206   }
207
208   # Check for missing (or added) menu accelerator "##"
209   if ($msg =~ /\#\#/ && $orig !~ /\#\#/) {
210       print STDERR "Warning: $where has menu accelerator but original doesn't\n";
211   } elsif ($msg !~ /\#\#/ && $orig =~ /\#\#/) {
212       print STDERR "Warning: $where is missing menu accelerator\n";
213   } elsif ($orig =~ /\#\#(.*)/) {
214       my $acc_o = $1;
215       my ($acc_m) = $msg =~ /\#\#(.*)/;
216       if ($acc_o ne $acc_m) {
217           print STDERR "Warning: $where has menu accelerator $acc_m instead of $acc_o\n";
218       }
219   }
220
221   # Check for missing (or added) menu accelerator "\t"
222   if ($msg =~ /\t/ && $orig !~ /\t/) {
223       print STDERR "Warning: $where has menu accelerator but original doesn't\n";
224   } elsif ($msg !~ /\t/ && $orig =~ /\t/) {
225       print STDERR "Warning: $where is missing menu accelerator\n";
226   } elsif ($orig =~ /\t(.*)/) {
227       my $acc_o = $1;
228       my ($acc_m) = $msg =~ /\t(.*)/;
229       if ($acc_o ne $acc_m) {
230           print STDERR "Warning: $where has menu accelerator $acc_m instead of $acc_o\n";
231       }
232   }
233}
234
235sub c_unescape {
236   my $str = shift @_;
237   $str =~ s/\\(x..|0|[0-7][0-7][0-7]|.)/&c_unescape_char($1)/ge;
238   return $str;
239}
240
241sub c_unescape_char {
242    my $ch = shift @_;
243    if ($ch eq '0' || $ch eq 'x00' || $ch eq '000') {
244        print STDERR "Nul byte in translation! (\\$ch)\n";
245        exit(1);
246    }
247    return $ch if $ch eq '"' || $ch eq '\\';
248    return "\n" if $ch eq "n";
249    return "\t" if $ch eq "t";
250    return "\r" if $ch eq "r";
251    return "\f" if $ch eq "f";
252    return chr(hex(substr($ch,1))) if $ch =~ /^x../;
253    return chr(oct($ch)) if $ch =~ /^[0-7][0-7][0-7]/;
254    print STDERR "Unknown C-escape in translation! (\\$ch)\n";
255    exit(1);
256}
Note: See TracBrowser for help on using the repository browser.