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