chiark / gitweb /
Process `9x15' too.
[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 use Sys::CPU;
11
12 our $prefix="/usr/local";
13 our $package='xfonts-traditional';
14 our $sharedir="$prefix/share/$package";
15 our @fonttrees=qw(/usr/share/fonts/X11 /usr/local/share/fonts/X11);
16 our $donefile="$package.done";
17 our $logfile="$package.log";
18 our $fontprefix="trad--";
19 our $bdfnorm="bdfnorm";
20 our @rulespath;
21 our $mode;
22 our %foundrymap;
23 our $verbose=0;
24 our $reportfh;
25 our $foundryinfo;
26 our %props;
27 our $tolerate_bad_fonts=1;
28 our $always_reprocess;
29 our $wanted_parallel;
30
31 sub reportloaded {
32     return unless $verbose;
33     print $reportfh @_,"\n" or die $!;
34 }
35
36 sub statsummary () {
37     return join ' ', ((stat _)[1,7,9,10]);
38 }
39
40 sub loadrules ($) {
41     my ($key) = @_;
42     our %cache;
43     my $fc=$cache{$key};  
44     return $fc if $fc;
45     foreach my $path (@rulespath) {
46         my $script="$path/$key.rules";
47         $!=0; $@=''; my $f = do $script;
48         if (defined $f) {
49             reportloaded("rules: loaded ",$script);
50             $cache{$key}=$f;
51             return $f;
52         }
53         die "$! $? $script" unless $! == &ENOENT;
54     }
55     return $cache{$key}=undef;
56 }
57
58 sub processbdf ($$$$) {
59     my ($inbdf,$outbdf,$logfh,$what) = @_;
60     my $state='idle';
61     my ($foundry,$font);
62     my ($w,$h,$xo,$yo,$y,$bitmap,$glyph);
63     my $modified=0;
64     %props = ();
65     my $anyinput=0;
66     while (<$inbdf>) {
67         $anyinput=1;
68         if ($state eq 'bitmap' && $y==$h) {
69             $glyph = uc $glyph;
70             $glyph =~ s/\;$//;
71             local ($_) = $glyph;
72             my $key= sprintf "%s,%d,%d,%d,%d", $foundry,$w,$h,$xo,$yo;
73             my $rules= loadrules($key);
74             return 'no rules' if !$rules;
75             $rules->();
76             $modified += ($_ ne $glyph);
77             print $outbdf $_,"\n" or die $!
78                 foreach split /\;/, $_; # /;
79             $state='idle';
80         }
81         if ($state eq 'bitmap') {
82             m/^([0-9a-fA-F]+)\s+$/ or die $y;
83             length($1) == (($w+7 >> 3) << 1) or die "$1 $w";
84             $glyph .= "$1;";
85             $y++;
86             next;
87         }
88         if ($state eq 'idle' && m/^FOUNDRY\s+/) {
89             die if defined $foundry;
90             return 'foundry syntax' unless m/^FOUNDRY\s+\"(\w+)\"\s+/;
91             $foundry = $foundrymap{lc $1};
92             return 'no foundry' unless defined $foundry;
93             $_ = "FOUNDRY \"$foundry\"\n";
94         }
95         if ($state eq 'idle' && m/^FONT\s+/) {
96             die if defined $font;
97             return 'simple font name' unless m/^(FONT\s+)\-(\w+)\-/;
98             $font = $foundrymap{lc $2};
99             return 'no foundry' unless defined $font;
100             $_ = "FONT -$font-$'";
101         }
102         if ($state eq 'idle' && m/^STARTCHAR\s/) {
103             die unless defined $foundry;
104             die unless defined $font;
105             return 'foundry != font' unless $foundry eq $font;
106             $state='startchar';
107             $w=undef;
108         }
109         if (($state eq 'idle' || $state eq 'startchar') &&
110             m/^([A-Z_]+)\s+(.*\S)\s+$/) {
111             $props{$1}=$2;
112         }
113         if ($state eq 'startchar') {
114             if (m/^BBX\s+(\+?\d+)\s+(\+?\d+)\s+([-+]?\d+)\s+([-+]?\d+)\s+$/) {
115                 ($w,$h,$xo,$yo) = ($1,$2,$3,$4);
116             }
117             if (m/^BITMAP\s+$/) {
118                 die unless defined $w;
119                 $y=0;
120                 $glyph='';
121                 $state='bitmap';
122                 $props{' 7bit'}=
123                     ($props{'CHARSET_REGISTRY'} =~ m/iso8859|utf|iso10646/i &&
124                      $props{'ENCODING'} <= 127);
125             }
126         }
127         print $outbdf $_ or die $!;
128     }
129     die $! if $inbdf->error;
130     die $! if $outbdf->error or !$outbdf->flush;
131     die unless $state eq 'idle';
132     return 'no bdf data' # also special cased in processpcfgz
133         if !$anyinput;
134     if ($modified) {
135         printf $logfh "%s: %d glyphs changed\n", $what, $modified
136             or die $!;
137     } else {
138         printf $logfh "%s: unchanged - no rules matched\n", $what
139             or die $!;
140     }
141     return $modified;
142 }
143
144 sub loadfoundries () {
145     $foundryinfo = '';
146     foreach my $path (@rulespath) {
147         if (!stat $path) {
148             die "$path $!" unless $!==&ENOENT;
149             next;
150         }
151         $foundryinfo .= statsummary().' '.$path."\0\n";
152
153         my $p = "$path/foundries";
154         my $f = new IO::File $p;
155         if (!$f) {
156             die "$p $!" unless $!==&ENOENT;
157             print $reportfh "foundries: none in $p\n" or die $! if $verbose;
158             next;
159         }
160         stat $f or die $!;
161         while (<$f>) {
162             s/^\s*//; s/\s+$//;
163             next if m/^\#/;
164             m/^([.0-9A-Za-z]+)\s+([.0-9A-Za-z]+)$/ or die;
165             my $k = lc $1;
166             next if exists $foundrymap{$k};
167             $foundrymap{$k}=$2;
168         }
169         $f->error and die $!;
170         reportloaded('foundries: loaded ',$p);
171     }
172     die "no foundry maps\n" unless %foundrymap;
173 }
174
175 our %ch;
176
177 sub filter_st_isok ($) {
178     my ($ch) = @_;
179     my $st = $ch->{St};
180     return !$st || $ch->{SigOK}{($st & ~128)};
181 }
182
183 sub process_filter ($$$$$$$$) {
184     my ($rr, $input, $output,$what,$logfh,
185         $procs, $sigpipeok, $after_hook) = @_;
186     my ($reader,$writer);
187     my @children;
188     my ($usread,$uswrite);
189
190     my $current = $input;
191
192     foreach my $proc (@$procs) {
193         my $isfinal = (@$proc && $proc->[0] eq '');
194         if (!$isfinal) {
195             $reader = new IO::Handle or die $!;
196             $writer = new IO::Handle or die $!;
197             new IO::Pipe($reader,$writer) or die $!;
198         } else {
199             shift @$proc;
200             $reader = undef;
201             $writer = $output;
202         }
203         if (@$proc) {
204             my $exe = $proc->[0];
205             my $child = fork;  defined $child or die $!;
206             if (!$child) {
207                 open STDIN, '<&', $current or die $!;
208                 open STDOUT, '>&', $writer or die $!;
209                 if (!$isfinal) {
210                     close $reader or die $!;
211                 }
212                 close $usread or die $! if $usread;
213                 close $uswrite or die $! if $uswrite;
214                 exec $exe @$proc or die "$exe $!";
215             }
216             my $ch = {
217                 Pid => $child,
218                 Exe => $exe,
219                 Stage => (!$exe ? 'self' : defined $usread ? 'out' : 'in'),
220                 SigOK => { },
221             };
222             push @children, $ch;
223             $ch{$exe} = $ch;
224             close $current or die $!;
225             close $writer or die $!;
226             $current = $reader;
227         } else {
228             $usread = $current;
229             $uswrite = $writer;
230             $current = $reader;
231         }
232     }
233     $$rr = processbdf($usread,$uswrite,$logfh,$what);
234     my $none = $$rr !~ m/^\d/;
235
236     $ch{$_}{SigOK}{13} = 1 foreach @$sigpipeok;
237
238     if ($none || !$$rr) {
239         # We're not going to install or use this so we can kill our
240         # input and output filters.  We kill the input filters so that
241         # we don't risk waiting for them.  (If the input filter died
242         # for some other reason then sending it a KILL now won't
243         # affect its exit status.)  We kill the output filters (before
244         # we close the output pipe) so we don't produce messages from
245         # our output filters about corrupted data.  And we tolerate
246         # SIGPIPE in all the input filters.
247         flush $uswrite or die $!;
248
249         my $filterkind = 'input';
250         foreach my $ch (@children) {
251             if ($ch->{Stage} ne 'self') {
252                 kill 9, $ch->{Pid} or die "$ch->{Pid} $ch->{Exe} $!";
253                 $ch->{SigOK}{9} = 1;
254             } else {
255                 $filterkind = 'output';
256                 next;
257             }
258             if ($filterkind eq 'input') {
259                 $ch->{SigOK}{13} = 1;
260             }
261         }
262         # ... we might not have read all the output from pcf2bdf, which is OK
263     }
264
265     close $uswrite or die $!;
266     close $usread or die $!;
267
268     foreach my $ch (@children) {
269         $!=0; waitpid($ch->{Pid}, 0) == $ch->{Pid} or
270             die "$ch->{Pid} $ch->{Exe} $!";
271         $ch->{St} = $?;
272     }
273
274     $after_hook->();
275
276     foreach my $ch (@children) {
277         if (!filter_st_isok($ch)) {
278             die "update-xfonts-traditional:".
279                 " $ch->{Exe} [$ch->{Pid}] for $what".
280                 " failed $ch->{St}".
281                 " (".(join ' ', keys %{ $ch->{SigOK} })." ok)\n";
282         }
283     }
284 }
285
286 sub processpcfgz ($$$$) {
287     my ($inpcfgz,$outpcfgz,$logfh,$what) = @_;
288     print $reportfh "processing $inpcfgz to $outpcfgz\n" if $verbose>=2;
289     my $input = new IO::File $inpcfgz, '<' or die "$inpcfgz $!";
290     my $output = new IO::File $outpcfgz, '>' or die "$outpcfgz $!";
291
292     my $r;
293     process_filter(\$r, $input, $output, $inpcfgz, $logfh,
294         [
295             ['gunzip'], ['pcf2bdf'], [$bdfnorm],
296             [],
297             ['bdftopcf'],['',qw(gzip -1 -n)]
298         ],
299         [qw(gunzip)],
300         # ... we never care if pcf2bdf didn't want all the data
301         sub {
302             if ($tolerate_bad_fonts &&
303                 $r eq 'no bdf data' &&
304                 filter_st_isok($ch{'gunzip'}) &&
305                 ($ch{'pcf2bdf'}{St} & ~128) == 6)
306             {
307                 $r = "pcf2bdf failed ($ch{'pcf2bdf'}{St})";
308                 print STDERR "warning: $r: skipping $inpcfgz\n";
309                 $ch{'pcf2bdf'}{SigOK}{6} = 1;
310             }
311     });
312     return $r;
313 }
314
315 sub processfontdir ($) {
316     my ($fontdir) = @_;
317     if (!opendir FD, $fontdir) {
318         die "$fontdir $!" unless $!==&ENOENT;
319         return;
320     }
321     my $changed = 0;
322     my $olddone;
323     if (!$always_reprocess) {
324         $olddone = do "$fontdir/$donefile";
325         if (!$olddone) {
326             die "$fontdir $! $@ " unless $!==&ENOENT;
327         } elsif ($olddone->{''} ne $foundryinfo) {
328             our $repro_reported;
329             print $reportfh "reprocessing fonts (rules updated)\n" or die $!
330                 unless $repro_reported++;
331             $olddone = undef;
332         }
333     }
334     if (!$olddone) {
335         $olddone = { };
336         $changed = 1;
337     }
338     my $newdone = { '' => $foundryinfo };
339     my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
340     my $updated=0;
341     my $reported=0;
342     my $anypcfs=0;
343
344     my $logpath = "$fontdir/$logfile";
345     unlink "$logpath" or $!==&ENOENT or die "$logpath $!";
346     my $logfh = new IO::File $logpath, ">>" or die "$logpath $!";
347
348     if (!$wanted_parallel) {
349         $wanted_parallel = Sys::CPU::cpu_count();
350         printf $reportfh "parallelism: %d\n", $wanted_parallel if $verbose>=2;
351     }
352     $wanted_parallel = 1 if $wanted_parallel < 1;
353
354     our %inprogress;
355
356     my $await = sub {
357         my $child = wait;
358         die $! unless defined $child;
359         my $job = $inprogress{$child};
360         die $child unless $job;
361
362         my $dent = $job->{Dent};
363         my $outdent = $job->{Outdent};
364         my $stats = $job->{Stats};
365         if ($?==0) {
366             $updated++;
367             $outfiles{$outdent} |= 3;
368         } elsif ($?==2*256) {
369         } else {
370             die "update-xfonts-traditional: processing of".
371                 " $fontdir/$dent [$child] failed ($?)\n";
372         }
373         $newdone->{$dent} = $stats;
374         $changed = 1;
375         delete $inprogress{$child};
376     };
377
378     flush $reportfh or die $!;
379     while (my $dent = scalar readdir FD) {
380         if ($dent =~ m/^\Q$fontprefix\E.*\.new$/) {
381             unlink "$fontdir/$dent" or $!==&ENOENT or die "$fontdir $dent $!";
382             next;
383         }
384         next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
385         print $reportfh "processing $fontdir...\n" or die $!
386             unless $reported++;
387         if ($dent =~ m/^\Q$fontprefix/) {
388             $outfiles{$dent} |= 1;
389             next;
390         }
391         if (!stat "$fontdir/$dent") {
392             die "$fontdir $dent $!" unless $!==&ENOENT;
393             next;
394         }
395         die "$fontdir $dent" unless -f _;
396         $anypcfs++;
397
398         my $stats = statsummary();
399         my $tdone = $olddone->{$dent};
400         my $outdent = $fontprefix.$dent;
401         if (defined $tdone && $tdone eq $stats) {
402             $outfiles{$outdent} |= 2;
403             $newdone->{$dent} = $stats;
404             next;
405         }
406
407         $await->() while scalar keys %inprogress >= $wanted_parallel;
408
409         my $child = fork;  die unless defined $child;
410         if (!$child) {
411             my $r = processpcfgz("$fontdir/$dent",
412                                  "$fontdir/$outdent.new",
413                                  $logfh, $dent);
414             my $rc;
415             if ($r !~ m/^\d/) {
416                 printf $logfh "%s: unchanged - %s\n", $dent, $r;
417                 unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
418                 $rc = 2;
419             } else {
420                 rename "$fontdir/$outdent.new", "$fontdir/$outdent"
421                     or die "$fontdir $outdent $!";
422                 $rc = 0;
423             }
424             $logfh->flush or die "$logpath $!";
425             exit $rc;
426         }
427         $inprogress{$child} = {
428             Dent => $dent,
429             Outdent => $outdent,
430             Stats => $stats,
431         };
432     }
433     $await->() while scalar keys %inprogress;
434
435     my $affected=0;
436     foreach my $olddent (keys %outfiles) {
437         my $state = $outfiles{$olddent};
438         if ($state & 2) {
439             $affected++ if $state & 1;
440             next;
441         }
442         unlink "$fontdir/$olddent" or die "$fontdir $olddent $!";
443         $changed = 1;
444         $updated++;
445     }
446     if (!stat "$fontdir/fonts.dir") {
447         $!==&ENOENT or die "$fontdir $!";
448     } else {
449         $!=0; $?=0; system 'mkfontdir',$fontdir;
450         die "$fontdir $? $!" if $? or $!;
451     }
452     if (!$anypcfs) {
453         unlink "$logpath" or die "$fontdir $!";
454         unlink "$fontdir/$donefile" or $!==&ENOENT or die "$fontdir $!";
455     } elsif ($changed) {
456         my $newdoneh = new IO::File "$fontdir/$donefile.new", 'w' 
457             or die "$fontdir $!";
458         print $newdoneh Dumper($newdone) or die "$fontdir $!";
459         close $newdoneh or die "$fontdir $!";
460         rename "$fontdir/$donefile.new","$fontdir/$donefile"
461             or die "$fontdir $!";
462     }
463     if ($reported || %$newdone || $affected || $updated) {
464         printf " processed %s: %d pcfs, %d affected, %d updated.\n",
465             $fontdir, (scalar keys %$newdone), $affected, $updated;
466     }
467 }
468
469 sub processfonttree ($) {
470     my ($tree) = @_;
471     find({ follow => 1,
472            dangling_symlinks => 0,
473            no_chdir => 1,
474            wanted => sub {
475                return unless -d _;
476                processfontdir($File::Find::name);
477            }},
478          $tree);
479 }
480
481 our $stdin = new IO::File '<&STDIN' or die $!;
482 our $stdout = new IO::File '>&STDOUT' or die $!;
483 our $stderr = new IO::File '>&STDERR' or die $!;
484 $reportfh = $stdout;
485
486 our (@options)=(
487     'R|rules-include=s@' => \@rulespath,
488     'share-dir=s' => \$sharedir,
489     'verbose|v+' => \$verbose,
490     'j|parallel=i' => \$wanted_parallel,
491     'always-reprocess!' => \$always_reprocess,
492     'tolerate-bad-fonts!' => \$tolerate_bad_fonts,
493     );
494
495 sub define_mode ($$) {
496     my ($optname,$f) = @_;
497     push @options, $optname, sub {
498         die "only one mode may be specified\n" if defined $mode;
499         $mode=$f;
500     };
501 }
502
503 define_mode('bdf-filter', sub {
504     die "no arguments allowed with --bdf-filter\n" if @ARGV;
505     $reportfh = $stderr;
506     loadfoundries();
507     my $r = processbdf($stdin,$stdout,$reportfh,'stdin');
508     if ($r !~ m/^\d/) {
509         print STDERR "stdin not processed: $r\n";
510         exit 2;
511     }
512 });
513
514 define_mode('process-pcf', sub {
515     die "need source and destination pcf.gz\n" if @ARGV!=2;
516     loadfoundries();
517     my $r = processpcfgz($ARGV[0],$ARGV[1],$reportfh,"pcf");
518     if ($r !~ m/^\d/) {
519         print STDERR "pcf not processed: $r\n";
520         exit 2;
521     }
522 });
523
524 define_mode('process-fontdirs', sub {
525     die "need font dir(s)\n" unless @ARGV;
526     loadfoundries();
527     foreach my $d (@ARGV) {
528         processfontdir($d);
529     }
530 });
531
532 define_mode('process-fonttrees', sub {
533     die "need font tree(s)\n" unless @ARGV;
534     loadfoundries();
535     foreach my $d (@ARGV) {
536         processfonttree($d);
537     }
538 });
539
540 define_mode('update', sub {
541     die "no arguments allowed with --postinst\n" unless !@ARGV;
542     loadfoundries();
543     foreach my $d (@fonttrees) {
544         processfonttree($d);
545     }
546 });
547
548 Getopt::Long::Configure(qw(bundling));
549 GetOptions(@options) or exit 127;
550
551 push @rulespath, "$sharedir/rules";
552 $bdfnorm = "$sharedir/$bdfnorm";
553
554 die "need a mode\n" unless $mode;
555
556 $mode->();