chiark / gitweb /
fix wide characters; tested iso10646
[xfonts-traditional.git] / update-xfonts-traditional
1 #!/usr/bin/perl -w
2 use strict;
3 use POSIX;
4 use IO::File;
5 use Getopt::Long;
6 use File::Glob qw(:glob);
7 use Data::Dumper;
8 use IO::Pipe;
9 use File::Find;
10
11 our $prefix="/usr/local";
12 our $package='xfonts-traditional';
13 our $sharedir="$prefix/share/$package";
14 our @fonttrees=qw(/usr/share/fonts/X11 /usr/local/share/fonts/X11);
15 our $donefile="$package.done";
16 our $logfile="$package.log";
17 our $fontprefix="trad--";
18 our @rulespath;
19 our $mode;
20 our %foundrymap;
21 our $verbose=0;
22 our $reportfh;
23 our $foundryinfo;
24 our %props;
25
26 sub reportloaded {
27     return unless $verbose;
28     print $reportfh @_,"\n" or die $!;
29 }
30
31 sub statsummary () {
32     return join ' ', ((stat _)[1,7,9,10]);
33 }
34
35 sub loadrules ($) {
36     my ($key) = @_;
37     our %cache;
38     my $fc=$cache{$key};  
39     return $fc if $fc;
40     foreach my $path (@rulespath) {
41         my $script="$path/$key.rules";
42         $!=0; $@=''; my $f = do $script;
43         if (defined $f) {
44             reportloaded("rules: loaded ",$script);
45             $cache{$key}=$f;
46             return $f;
47         }
48         die "$! $? $script" unless $! == &ENOENT;
49     }
50     return $cache{$key}=undef;
51 }
52
53 sub processbdf ($$$$) {
54     my ($inbdf,$outbdf,$logfile,$what) = @_;
55     my $state='idle';
56     my ($foundry,$font);
57     my ($w,$h,$xo,$yo,$y,$bitmap,$glyph);
58     my $modified=0;
59     %props = ();
60     while (<$inbdf>) {
61         if ($state eq 'bitmap' && $y==$h) {
62             $glyph = uc $glyph;
63             $glyph =~ s/\;$//;
64             local ($_) = $glyph;
65             my $key= sprintf "%s,%d,%d,%d,%d", $foundry,$w,$h,$xo,$yo;
66             my $rules= loadrules($key);
67             return (0,'no rules') if !$rules;
68             $rules->();
69             $modified += ($_ ne $glyph);
70             print $outbdf $_,"\n" or die $!
71                 foreach split /\;/, $_; # /;
72             $state='idle';
73         }
74         if ($state eq 'bitmap') {
75             m/^([0-9a-fA-F]+)\s+$/ or die $y;
76             length($1) == (($w+7 >> 3) << 1) or die "$1 $w";
77             $glyph .= "$1;";
78             $y++;
79             next;
80         }
81         if ($state eq 'idle' && m/^FOUNDRY\s+/) {
82             die if defined $foundry;
83             return (0,'foundry syntax') unless m/^FOUNDRY\s+\"(\w+)\"\s+/;
84             $foundry = $foundrymap{lc $1};
85             return (0,'no foundry') unless defined $foundry;
86             $_ = "FOUNDRY \"$foundry\"\n";
87         }
88         if ($state eq 'idle' && m/^FONT\s+/) {
89             die if defined $font;
90             return (0,'simple font name') unless m/^(FONT\s+)\-(\w+)\-/;
91             $font = $foundrymap{lc $2};
92             return (0,'no foundry') unless defined $font;
93             $_ = "FONT -$font-$'";
94         }
95         if ($state eq 'idle' && m/^STARTCHAR\s/) {
96             die unless defined $foundry;
97             die unless defined $font;
98             return (0,'foundry != font') unless $foundry eq $font;
99             $state='startchar';
100             $w=undef;
101         }
102         if (($state eq 'idle' || $state eq 'startchar') &&
103             m/^([A-Z_]+)\s+(.*\S)\s+$/) {
104             $props{$1}=$2;
105         }
106         if ($state eq 'startchar') {
107             if (m/^BBX\s+(\+?\d+)\s+(\+?\d+)\s+([-+]?\d+)\s+([-+]?\d+)\s+$/) {
108                 ($w,$h,$xo,$yo) = ($1,$2,$3,$4);
109             }
110             if (m/^BITMAP\s+$/) {
111                 die unless defined $w;
112                 $y=0;
113                 $glyph='';
114                 $state='bitmap';
115                 $props{' 7bit'}=
116                     ($props{'CHARSET_REGISTRY'} =~ m/iso8859|utf|iso10646/i &&
117                      $props{'ENCODING'} <= 127);
118             }
119         }
120         print $outbdf $_ or die $!;
121     }
122     die $! if $inbdf->error;
123     die $! if $outbdf->error or !$outbdf->flush;
124     die unless $state eq 'idle';
125     if ($modified) {
126         printf $logfile "%s: %d glyphs changed\n", $what, $modified
127             or die $!;
128     } else {
129         printf $logfile "%s: unchanged - no rules matched\n", $what
130             or die $!;
131     }
132     return $modified;
133 }
134
135 sub loadfoundries () {
136     $foundryinfo = '';
137     foreach my $path (@rulespath) {
138         if (!stat $path) {
139             die "$path $!" unless $!==&ENOENT;
140             next;
141         }
142         $foundryinfo .= statsummary().' '.$path."\0\n";
143
144         my $p = "$path/foundries";
145         my $f = new IO::File $p;
146         if (!$f) {
147             die "$p $!" unless $!==&ENOENT;
148             print $reportfh "foundries: none in $p\n" or die $! if $verbose;
149             next;
150         }
151         stat $f or die $!;
152         while (<$f>) {
153             s/^\s*//; s/\s+$//;
154             next if m/^\#/;
155             m/^(\w+)\s+(\w+)$/ or die;
156             my $k = lc $1;
157             next if exists $foundrymap{$k};
158             $foundrymap{$k}=$2;
159         }
160         $f->error and die $!;
161         reportloaded('foundries: loaded ',$p);
162     }
163     die "no foundry maps\n" unless %foundrymap;
164 }
165
166 sub processpcfgz ($$$$) {
167     my ($inpcfgz,$outpcfgz,$logfile,$what) = @_;
168     print $reportfh "processing $inpcfgz to $outpcfgz\n" if $verbose>=2;
169     my $current = new IO::File $inpcfgz, '<' or die "$inpcfgz $!";
170     my ($usread,$uswrite);
171     my ($reader,$writer);
172     my @children;
173     foreach my $proc (['gunzip'], ['pcf2bdf'], [],
174                       ['bdftopcf'],['',qw(gzip -1 -n)]) {
175         my $isfinal = (@$proc && $proc->[0] eq '');
176         if (!$isfinal) {
177             $reader = new IO::Handle or die $!;
178             $writer = new IO::Handle or die $!;
179             new IO::Pipe($reader,$writer) or die $!;
180         } else {
181             shift @$proc;
182             $reader = undef;
183             $writer = new IO::File $outpcfgz, '>' or die "$outpcfgz $!";
184         }
185         if (@$proc) {
186             my $exe = $proc->[0];
187             my $child = fork;  defined $child or die $!;
188             if (!$child) {
189                 open STDIN, '<&', $current or die $!;
190                 open STDOUT, '>&', $writer or die $!;
191                 if (!$isfinal) {
192                     close $reader or die $!;
193                 }
194                 close $usread or die $! if $usread;
195                 close $uswrite or die $! if $uswrite;
196                 exec $exe @$proc or die "$exe $!";
197             }
198             push @children, [ $child, $exe, defined $usread ];
199             close $current or die $!;
200             close $writer or die $!;
201             $current = $reader;
202         } else {
203             $usread = $current;
204             $uswrite = $writer;
205             $current = $reader;
206         }
207     }
208     my $r = processbdf($usread,$uswrite,$logfile,$what);
209     my $none = $r !~ m/^\d/;
210     if ($none) {
211         flush $uswrite or die $!;
212     } else {
213         close $uswrite or die $!;
214     }
215     close $usread or die $!;
216     foreach my $chinfo (@children) {
217         my ($child,$exe,$isoutput)=@$chinfo;
218         my $sigok = 0;
219         if ($none) {
220             if ($isoutput) {
221                 $sigok = 9;
222                 kill 9, $child or die "$child $!";
223             } else {
224                 $sigok = 13;
225             }
226         }
227         $!=0; waitpid($child, 0) == $child or die "$child $!";
228         !$? or ($?&~128)==$sigok or die "$exe [$child] $sigok $?";
229     }
230     return $r;
231 }
232
233 sub processfontdir ($) {
234     my ($fontdir) = @_;
235     if (!opendir FD, $fontdir) {
236         die "$fontdir $!" unless $!==&ENOENT;
237         return;
238     }
239     my $changed = 0;
240     my $olddone = do "$fontdir/$donefile";
241     if (!$olddone) {
242         die "$fontdir $! $@ " unless $!==&ENOENT;
243     } elsif ($olddone->{''} ne $foundryinfo) {
244         our $repro_reported;
245         print $reportfh "reprocessing fonts (rules updated)\n" or die $!
246             unless $repro_reported++;
247         $olddone = undef;
248     }
249     if (!$olddone) {
250         $olddone = { };
251         $changed = 1;
252     }
253     my $newdone = { '' => $foundryinfo };
254     my $log = new IO::File "$fontdir/$logfile", "w" 
255         or die "$fontdir/$logfile $!";
256     my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
257     my $updated=0;
258     my $reported=0;
259     my $anypcfs=0;
260
261     flush $reportfh or die $!;
262     while (my $dent = scalar readdir FD) {
263         if ($dent =~ m/^\Q$fontprefix\E.*\.new$/) {
264             unlink "$fontdir/$dent" or $!==&ENOENT or die "$fontdir $dent $!";
265             next;
266         }
267         next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
268         print $reportfh "processing $fontdir...\n" or die $!
269             unless $reported++;
270         if ($dent =~ m/^\Q$fontprefix/) {
271             $outfiles{$dent} |= 1;
272             next;
273         }
274         if (!stat "$fontdir/$dent") {
275             die "$fontdir $dent $!" unless $!==&ENOENT;
276             next;
277         }
278         die "$fontdir $dent" unless -f _;
279         $anypcfs++;
280
281         my $stats = statsummary();
282         my $tdone = $olddone->{$dent};
283         my $outdent = $fontprefix.$dent;
284         if (defined $tdone && $tdone eq $stats) {
285             $outfiles{$outdent} |= 2;
286             $newdone->{$dent} = $stats;
287             next;
288         }
289
290         my $r = processpcfgz("$fontdir/$dent",
291                              "$fontdir/$outdent.new",
292                              $log, $dent);
293         if ($r !~ m/^\d/) {
294             printf $log "%s: unchanged - %s\n", $dent, $r;
295             unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
296         } else {
297             rename "$fontdir/$outdent.new", "$fontdir/$outdent"
298                 or die "$fontdir $outdent $!";
299             $updated++;
300             $outfiles{$outdent} |= 3;
301         }
302         $newdone->{$dent} = $stats;
303         $changed = 1;
304     }
305     my $affected=0;
306     foreach my $olddent (keys %outfiles) {
307         my $state = $outfiles{$olddent};
308         if ($state & 2) {
309             $affected++ if $state & 1;
310             next;
311         }
312         unlink "$fontdir/$olddent" or die "$fontdir $olddent $!";
313         $changed = 1;
314         $updated++;
315     }
316     if (!stat "$fontdir/fonts.dir") {
317         $!==&ENOENT or die "$fontdir $!";
318     } else {
319         $!=0; $?=0; system 'mkfontdir',$fontdir;
320         die "$fontdir $? $!" if $? or $!;
321     }
322     if (!$anypcfs) {
323         unlink "$fontdir/$logfile" or die "$fontdir $!";
324         unlink "$fontdir/$donefile" or $!==&ENOENT or die "$fontdir $!";
325     } elsif ($changed) {
326         my $newdoneh = new IO::File "$fontdir/$donefile.new", 'w' 
327             or die "$fontdir $!";
328         print $newdoneh Dumper($newdone) or die "$fontdir $!";
329         close $newdoneh or die "$fontdir $!";
330         rename "$fontdir/$donefile.new","$fontdir/$donefile"
331             or die "$fontdir $!";
332     }
333     if ($reported || %$newdone || $affected || $updated) {
334         printf " processed %s: %d pcfs, %d affected, %d updated.\n",
335             $fontdir, (scalar keys %$newdone), $affected, $updated;
336     }
337 }
338
339 sub processfonttree ($) {
340     my ($tree) = @_;
341     find({ follow => 1,
342            dangling_symlinks => 0,
343            no_chdir => 1,
344            wanted => sub {
345                return unless -d _;
346                processfontdir($File::Find::name);
347            }},
348          $tree);
349 }
350
351 our $stdin = new IO::File '<&STDIN' or die $!;
352 our $stdout = new IO::File '>&STDOUT' or die $!;
353 our $stderr = new IO::File '>&STDERR' or die $!;
354 $reportfh = $stdout;
355
356 our (@options)=(
357     'R|rules-include=s@' => \@rulespath,
358     'share-dir=s' => \$sharedir,
359     'verbose|v+' => \$verbose,
360     );
361
362 sub define_mode ($$) {
363     my ($optname,$f) = @_;
364     push @options, $optname, sub {
365         die "only one mode may be specified\n" if defined $mode;
366         $mode=$f;
367     };
368 }
369
370 define_mode('bdf-filter', sub {
371     die "no arguments allowed with --bdf-filter\n" if @ARGV;
372     $reportfh = $stderr;
373     loadfoundries();
374     my $r = processbdf($stdin,$stdout,$reportfh,'stdin');
375     if ($r !~ m/^\d/) {
376         print STDERR "stdin not processed: $r\n";
377         exit 2;
378     }
379 });
380
381 define_mode('process-pcf', sub {
382     die "need source and destination pcf.gz\n" if @ARGV!=2;
383     loadfoundries();
384     my $r = processpcfgz($ARGV[0],$ARGV[1],$reportfh,"pcf");
385     if ($r !~ m/^\d/) {
386         print STDERR "pcf not processed: $r\n";
387         exit 2;
388     }
389 });
390
391 define_mode('process-fontdirs', sub {
392     die "need font dir(s)\n" unless @ARGV;
393     loadfoundries();
394     foreach my $d (@ARGV) {
395         processfontdir($d);
396     }
397 });
398
399 define_mode('process-fonttrees', sub {
400     die "need font tree(s)\n" unless @ARGV;
401     loadfoundries();
402     foreach my $d (@ARGV) {
403         processfonttree($d);
404     }
405 });
406
407 define_mode('update', sub {
408     die "no arguments allowed with --postinst\n" unless !@ARGV;
409     loadfoundries();
410     foreach my $d (@fonttrees) {
411         processfonttree($d);
412     }
413 });
414
415 Getopt::Long::Configure(qw(bundling));
416 GetOptions(@options) or exit 127;
417
418 push @rulespath, "$sharedir/rules";
419
420 die "need a mode\n" unless $mode;
421
422 $mode->();