source: git/lib/makemsgs.pl @ 0804fbe

RELEASE/1.2debug-cidebug-ci-sanitisersstereowalls-data
Last change on this file since 0804fbe was 05ef66c, checked in by Olly Betts <olly@…>, 18 years ago

Copy back new makemsgs.pl from 1.1 and fix the 2 minor problems it finds
in this branch

git-svn-id: file:///home/survex-svn/survex/trunk@3154 4b37db11-9a0c-4f06-9ece-9ab7cdaee568

  • Property mode set to 100755
File size: 9.0 KB
Line 
1#!/usr/bin/perl -w
2require 5.008;
3use bytes;
4use strict;
5
6use integer;
7
8# messages >= this value are written to a header file
9my $dontextract_threshold = 1000;
10
11# Magic identifier (12 bytes)
12my $magic = "Svx\nMsg\r\n\xfe\xff\0";
13# Designed to be corrupted by ASCII ftp, top bit stripping (or
14# being used for parity).  Contains a zero byte so more likely
15# to be flagged as data (e.g. by perl's "-B" test).
16
17my $major = 0;
18my $minor = 8;
19
20# File format (multi-byte numbers in network order (bigendian)):
21# 12 bytes: Magic identifier
22# 1 byte:   File format major version number (0)
23# 1 byte:   File format minor version number (8)
24# 2 bytes:  Number of messages (N)
25# 4 bytes:  Offset from XXXX to end of file
26# XXXX:
27# N*:
28# <message> NUL
29
30my %ent = ();
31
32open ENT, ($ENV{srcdir}?"$ENV{srcdir}/":"")."named-entities.txt" or die $!;
33while (<ENT>) {
34   my ($e, $v) = /^(\w+),(\d+)/;
35   $ent{$e} = $v;
36}
37close ENT;
38
39my %msgs = ();
40my %dontextract = ();
41
42my %raw = ();
43my $raw = '';
44my $raw_comments = '';
45my $curmsg = -1;
46
47while (<>) {
48   if (/^\s*#/) {
49       $raw_comments .= $_;
50       next; # skip comments
51   }
52
53   # en:  0 0.81 the message
54   # en-us: 0 0.81 " the message "
55   my ($langs, $msgno, $dummy, $msg) = /^([-\w,]+):\s*(\d+)\s+("?)(.*)\3/;
56
57   if ($msgno != $curmsg) {
58       if ($msgno < $curmsg) {
59           print STDERR "Warning: message number jumps back from $curmsg to $msgno\n";
60       }
61       $raw{$curmsg} = $raw;
62       $raw = '';
63       $curmsg = $msgno;
64   }   
65
66   $raw .= $raw_comments . $_;
67   $raw_comments = '';
68
69   unless (defined $langs) {
70      chomp;
71      print STDERR "Warning: Bad line: \"$_\"\n";
72      next;
73   }
74
75   $langs =~ tr/-/_/;
76
77   if ($msg =~ /[\0-\x1f\x7f-\xff]/) {
78      print STDERR "Warning: literal character in message $msgno\n";
79   }
80
81   my $utf8 = string_to_utf8($msg);
82   for (split /,/, $langs) {
83      if ($msgno >= $dontextract_threshold) {
84         if (${$dontextract{$_}}[$msgno - $dontextract_threshold]) {
85             print STDERR "Warning: already had message $msgno for language $_\n";
86         }
87         ${$dontextract{$_}}[$msgno - $dontextract_threshold] = $utf8;
88      } else {
89         if (${$msgs{$_}}[$msgno]) {
90             print STDERR "Warning: already had message $msgno for language $_\n";
91         }
92         ${$msgs{$_}}[$msgno] = $utf8;
93      }
94   }
95}
96$raw{$curmsg} = $raw;
97
98my $lang;
99my @langs = sort grep ! /_\*$/, keys %msgs;
100
101my $num_msgs = -1;
102foreach $lang (@langs) {
103   my $aref = $msgs{$lang};
104   $num_msgs = scalar @$aref if scalar @$aref > $num_msgs;
105   unlink "$lang.todo";
106}
107
108foreach $lang (@langs) {
109   my $fnm = $lang;
110   $fnm =~ s/(_.*)$/\U$1/;
111   open OUT, ">$fnm.msg" or die $!;
112   
113   my $aref = $msgs{$lang};
114 
115   my $parentaref;
116   my $mainlang = $lang;
117   $parentaref = $msgs{$mainlang} if $mainlang =~ s/_.*$//;
118
119   print OUT $magic or die $!;
120   print OUT pack("CCn", $major, $minor, $num_msgs) or die $!;
121
122   my $buff = '';
123   my $missing = 0;
124   my $retranslate = 0;
125
126   for my $n (0 .. $num_msgs - 1) {
127      my $warned = 0;
128      my $msg = $$aref[$n];
129      if (!defined $msg) {
130         $msg = $$parentaref[$n] if defined $parentaref;
131         if (!defined $msg) {
132            $msg = ${$msgs{'en'}}[$n];
133            # don't report if we have a parent (as the omission will be
134            # reported there)
135            if (defined $msg && $msg ne '' && !defined $parentaref) {
136               $missing++;
137               open TODO, ">>$lang.todo" or die $!;
138               print TODO $raw{$n}, "\n";
139               close TODO;
140               $warned = 1;
141            } else {
142               $msg = '' if !defined $msg;
143            }
144         }
145      } else {
146         if ($lang ne 'en') {
147             sanity_check("Message $n in language $lang", $msg, ${$msgs{'en'}}[$n]);
148         }
149      }
150      if (defined($raw{$n})
151          && $raw{$n} =~ /^\s*#\s*TRANSLATE\b[- \ta-z]*\b$lang\b([^-]|$)/m) {
152         if ($warned) {
153            print STDERR "Warning: message $n missing and also marked for retranslation for language $lang\n";
154         } else {
155            ++$retranslate;
156            open TODO, ">>$lang.todo" or die $!;
157            print TODO $raw{$n}, "\n";
158            close TODO;
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   if ($missing || $retranslate) {
168       print STDERR "Warning: see $lang.todo for ";
169       if ($missing) {
170           print STDERR "$missing missing message(s)";
171           if ($retranslate) {
172               print STDERR " and $retranslate requiring retranslation";
173           }
174       } else {
175           print STDERR "$retranslate message(s) requiring retranslation";
176       }
177       print STDERR "\n";
178   }
179}
180
181my $num_dontextract = -1;
182foreach $lang (@langs) {
183   my $aref = $dontextract{$lang};
184   if (defined(@$aref)) {
185       $num_dontextract = scalar @$aref if scalar @$aref > $num_dontextract;
186   }
187}
188
189foreach $lang (@langs) {
190   my $fnm = $lang;
191   $fnm =~ s/(_.*)$/\U$1/;
192   open OUT, ">$fnm.h" or die $!;
193   print OUT "#define N_DONTEXTRACTMSGS ", $num_dontextract, "\n";
194   print OUT "static unsigned char dontextractmsgs[] =";
195
196   my $missing = 0;
197   for my $n (0 .. $num_dontextract - 1) {
198      print OUT "\n";
199
200      my $aref = $dontextract{$lang};
201 
202      my $parentaref;
203      my $mainlang = $lang;
204      $parentaref = $dontextract{$mainlang} if $mainlang =~ s/_.*$//;
205
206      my $msg = $$aref[$n];
207      if (!defined $msg) {
208         $msg = $$parentaref[$n] if defined $parentaref;
209         if (!defined $msg) {
210            $msg = ${$dontextract{'en'}}[$n];
211            # don't report if we have a parent (as the omission will be reported there)
212            if (defined $msg && $msg ne '' && !defined $parentaref) {
213               ++$missing;
214               open TODO, ">>$lang.todo" or die $!;
215               print TODO $raw{$dontextract_threshold + $n}, "\n";
216               close TODO;
217            } else {
218               $msg = '';
219            }
220         }
221      } else {
222         if ($lang ne 'en') {
223             sanity_check("Message $n in language $lang", $msg, $$aref[$n]);
224         }
225      }
226      $msg =~ s/\\/\\\\/g;
227      $msg =~ s/"/\\"/g;
228      $msg =~ s/\t/\\t/g;
229      $msg =~ s/\n/\\n/g;
230      $msg =~ s/\r/\\r/g;
231      if ($msg =~ /^ / || $msg =~ / $/) {
232         $msg =~ s/\\"/\\\\\\"/g;
233         $msg = '\\"'.$msg.'\\"';
234      }
235      print OUT "   /*", $dontextract_threshold + $n, "*/ \"$msg\\0\"";
236   }
237   print OUT ";\n";
238   close OUT or die $!;
239
240   if ($missing) {
241       print STDERR "Warning: see $lang.todo for $missing missing \"don't extract\" message(s)\n";
242   }
243}
244
245#for (sort {$a<=>$b} keys %raw) {print "$_ = [$raw{$_}]\n";}
246
247sub string_to_utf8 {
248   my $s = shift;
249   $s =~ s/([\x80-\xff])/char_to_utf8(ord($1))/eg;
250   $s =~ s/\&(#\d+|#x[a-f0-9]+|[a-z0-9]+);?/decode_entity($1)/eig;
251   return $s;
252}
253
254sub decode_entity {
255   my $ent = shift;
256   return char_to_utf8($1) if $ent =~ /^#(\d+)$/;
257   return char_to_utf8(hex($1)) if $ent =~ /^#x([a-f0-9]+)$/;
258   return char_to_utf8($ent{$ent}) if exists $ent{$ent};
259   $ent = "\&$ent;";
260   print STDERR "Warning: entity \"$ent\" unknown\n";
261   return $ent;
262}
263
264sub char_to_utf8 {
265   my $unicode = shift;
266   # ASCII is easy, and the most common case
267   return chr($unicode) if $unicode < 0x80;
268
269   my $result = '';
270   my $n = 0x20;
271   while (1) {
272      $result = chr(0x80 | ($unicode & 0x3f)) . $result;
273      $unicode >>= 6;
274      last if $unicode < $n;
275      $n >>= 1;
276   }
277   $result = chr((0x100 - $n*2) | $unicode) . $result;
278   return $result;
279}
280
281sub sanity_check {
282   my ($where, $msg, $orig) = @_;
283   # check printf-like specifiers match
284   # allow valid printf specifiers, or %<any letter> to support strftime
285   # and other printf-like formats.
286   my @pcent_m = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $msg;
287   my @pcent_o = grep /\%/, split /(%(?:[-#0 +'I]*(?:[0-9]*|\*|\*m\$)(?:\.[0-9]*)?(?:hh|ll|[hlLqjzt])?[diouxXeEfFgGaAcsCSpn]|[a-zA-Z]))/, $orig;
288   while (scalar @pcent_m || scalar @pcent_o) {
289       if (!scalar @pcent_m) {
290           print STDERR "Warning: $where misses out \%spec $pcent_o[0]\n";
291       } elsif (!scalar @pcent_o) {
292           print STDERR "Warning: $where has extra \%spec $pcent_m[0]\n";
293       } elsif ($pcent_m[0] ne $pcent_o[0]) {
294           print STDERR "Warning: $where has \%spec $pcent_m[0] instead of $pcent_o[0]\n";
295       }
296       pop @pcent_m;
297       pop @pcent_o;
298   }
299
300   # Check for missing (or added) elipses (...)
301   if ($msg =~ /\.\.\./ && $orig !~ /\.\.\./) {
302       print STDERR "Warning: $where has elipses but original doesn't\n";
303   } elsif ($msg !~ /\.\.\./ && $orig =~ /\.\.\./) {
304       print STDERR "Warning: $where is missing elipses\n";
305   }
306
307   # Check for missing (or added) menu shortcut (@)
308   if ($msg =~ /\@[A-Za-z]/ && $orig !~ /\@[A-Za-z]/) {
309       print STDERR "Warning: $where has menu shortcut but original doesn't\n";
310   } elsif ($msg !~ /\@[A-Za-z]/ && $orig =~ /\@[A-Za-z]/) {
311       print STDERR "Warning: $where is missing menu shortcut\n";
312   }
313
314   # Check for missing (or added) menu accelerator "##"
315   if ($msg =~ /\#\#/ && $orig !~ /\#\#/) {
316       print STDERR "Warning: $where has menu accelerator but original doesn't\n";
317   } elsif ($msg !~ /\#\#/ && $orig =~ /\#\#/) {
318       print STDERR "Warning: $where is missing menu accelerator\n";
319   } elsif ($orig =~ /\#\#(.*)/) {
320       my $acc_o = $1;
321       my ($acc_m) = $msg =~ /\#\#(.*)/;
322       if ($acc_o ne $acc_m) {
323           print STDERR "Warning: $where has menu accelerator $acc_m instead of $acc_o\n";
324       }
325   }
326}
Note: See TracBrowser for help on using the repository browser.