chiark / gitweb /
do not mess with high-codepoint quotes
[xfonts-traditional] / 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             }
116         }
117         print $outbdf $_ or die $!;
118     }
119     die $! if $inbdf->error;
120     die $! if $outbdf->error or !$outbdf->flush;
121     die unless $state eq 'idle';
122     if ($modified) {
123         printf $logfile "%s: %d glyphs changed\n", $what, $modified
124             or die $!;
125     } else {
126         printf $logfile "%s: unchanged - no rules matched\n", $what
127             or die $!;
128     }
129     return $modified;
130 }
131
132 sub loadfoundries () {
133     $foundryinfo = '';
134     foreach my $path (@rulespath) {
135         if (!stat $path) {
136             die "$path $!" unless $!==&ENOENT;
137             next;
138         }
139         $foundryinfo .= statsummary().' '.$path."\0\n";
140
141         my $p = "$path/foundries";
142         my $f = new IO::File $p;
143         if (!$f) {
144             die "$p $!" unless $!==&ENOENT;
145             print $reportfh "foundries: none in $p\n" or die $! if $verbose;
146             next;
147         }
148         stat $f or die $!;
149         while (<$f>) {
150             s/^\s*//; s/\s+$//;
151             next if m/^\#/;
152             m/^(\w+)\s+(\w+)$/ or die;
153             my $k = lc $1;
154             next if exists $foundrymap{$k};
155             $foundrymap{$k}=$2;
156         }
157         $f->error and die $!;
158         reportloaded('foundries: loaded ',$p);
159     }
160     die "no foundry maps\n" unless %foundrymap;
161 }
162
163 sub processpcfgz ($$$$) {
164     my ($inpcfgz,$outpcfgz,$logfile,$what) = @_;
165     print $reportfh "processing $inpcfgz to $outpcfgz\n" if $verbose>=2;
166     my $current = new IO::File $inpcfgz, '<' or die "$inpcfgz $!";
167     my ($usread,$uswrite);
168     my ($reader,$writer);
169     my @children;
170     foreach my $proc (['gunzip'], ['pcf2bdf'], [],
171                       ['bdftopcf'],['',qw(gzip -1 -n)]) {
172         my $isfinal = (@$proc && $proc->[0] eq '');
173         if (!$isfinal) {
174             $reader = new IO::Handle or die $!;
175             $writer = new IO::Handle or die $!;
176             new IO::Pipe($reader,$writer) or die $!;
177         } else {
178             shift @$proc;
179             $reader = undef;
180             $writer = new IO::File $outpcfgz, '>' or die "$outpcfgz $!";
181         }
182         if (@$proc) {
183             my $exe = $proc->[0];
184             my $child = fork;  defined $child or die $!;
185             if (!$child) {
186                 open STDIN, '<&', $current or die $!;
187                 open STDOUT, '>&', $writer or die $!;
188                 if (!$isfinal) {
189                     close $reader or die $!;
190                 }
191                 close $usread or die $! if $usread;
192                 close $uswrite or die $! if $uswrite;
193                 exec $exe @$proc or die "$exe $!";
194             }
195             push @children, [ $child, $exe, defined $usread ];
196             close $current or die $!;
197             close $writer or die $!;
198             $current = $reader;
199         } else {
200             $usread = $current;
201             $uswrite = $writer;
202             $current = $reader;
203         }
204     }
205     my $r = processbdf($usread,$uswrite,$logfile,$what);
206     my $none = $r !~ m/^\d/;
207     if ($none) {
208         flush $uswrite or die $!;
209     } else {
210         close $uswrite or die $!;
211     }
212     close $usread or die $!;
213     foreach my $chinfo (@children) {
214         my ($child,$exe,$isoutput)=@$chinfo;
215         my $sigok = 0;
216         if ($none) {
217             if ($isoutput) {
218                 $sigok = 9;
219                 kill 9, $child or die "$child $!";
220             } else {
221                 $sigok = 13;
222             }
223         }
224         $!=0; waitpid($child, 0) == $child or die "$child $!";
225         !$? or ($?&~128)==$sigok or die "$exe [$child] $sigok $?";
226     }
227     return $r;
228 }
229
230 sub processfontdir ($) {
231     my ($fontdir) = @_;
232     if (!opendir FD, $fontdir) {
233         die "$fontdir $!" unless $!==&ENOENT;
234         return;
235     }
236     my $changed = 0;
237     my $olddone = do "$fontdir/$donefile";
238     if (!$olddone) {
239         die "$fontdir $! $@ " unless $!==&ENOENT;
240     } elsif ($olddone->{''} ne $foundryinfo) {
241         our $repro_reported;
242         print $reportfh "reprocessing fonts (rules updated)\n" or die $!
243             unless $repro_reported++;
244         $olddone = undef;
245     }
246     if (!$olddone) {
247         $olddone = { };
248         $changed = 1;
249     }
250     my $newdone = { '' => $foundryinfo };
251     my $log = new IO::File "$fontdir/$logfile", "w" 
252         or die "$fontdir/$logfile $!";
253     my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
254     my $updated=0;
255     my $reported=0;
256     my $anypcfs=0;
257
258     flush $reportfh or die $!;
259     while (my $dent = scalar readdir FD) {
260         if ($dent =~ m/^\Q$fontprefix\E.*\.new$/) {
261             unlink "$fontdir/$dent" or $!==&ENOENT or die "$fontdir $dent $!";
262             next;
263         }
264         next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
265         print $reportfh "processing $fontdir...\n" or die $!
266             unless $reported++;
267         if ($dent =~ m/^\Q$fontprefix/) {
268             $outfiles{$dent} |= 1;
269             next;
270         }
271         if (!stat "$fontdir/$dent") {
272             die "$fontdir $dent $!" unless $!==&ENOENT;
273             next;
274         }
275         die "$fontdir $dent" unless -f _;
276         $anypcfs++;
277
278         my $stats = statsummary();
279         my $tdone = $olddone->{$dent};
280         my $outdent = $fontprefix.$dent;
281         if (defined $tdone && $tdone eq $stats) {
282             $outfiles{$outdent} |= 2;
283             $newdone->{$dent} = $stats;
284             next;
285         }
286
287         my $r = processpcfgz("$fontdir/$dent",
288                              "$fontdir/$outdent.new",
289                              $log, $dent);
290         if ($r !~ m/^\d/) {
291             printf $log "%s: unchanged - %s\n", $dent, $r;
292             unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
293         } else {
294             rename "$fontdir/$outdent.new", "$fontdir/$outdent"
295                 or die "$fontdir $outdent $!";
296             $updated++;
297             $outfiles{$outdent} |= 3;
298         }
299         $newdone->{$dent} = $stats;
300         $changed = 1;
301     }
302     my $affected=0;
303     foreach my $olddent (keys %outfiles) {
304         my $state = $outfiles{$olddent};
305         if ($state & 2) {
306             $affected++ if $state & 1;
307             next;
308         }
309         unlink "$fontdir/$olddent" or die "$fontdir $olddent $!";
310         $changed = 1;
311         $updated++;
312     }
313     if (!stat "$fontdir/fonts.dir") {
314         $!==&ENOENT or die "$fontdir $!";
315     } else {
316         $!=0; $?=0; system 'mkfontdir',$fontdir;
317         die "$fontdir $? $!" if $? or $!;
318     }
319     if (!$anypcfs) {
320         unlink "$fontdir/$logfile" or die "$fontdir $!";
321         unlink "$fontdir/$donefile" or $!==&ENOENT or die "$fontdir $!";
322     } elsif ($changed) {
323         my $newdoneh = new IO::File "$fontdir/$donefile.new", 'w' 
324             or die "$fontdir $!";
325         print $newdoneh Dumper($newdone) or die "$fontdir $!";
326         close $newdoneh or die "$fontdir $!";
327         rename "$fontdir/$donefile.new","$fontdir/$donefile"
328             or die "$fontdir $!";
329     }
330     if ($reported || %$newdone || $affected || $updated) {
331         printf " processed %s: %d pcfs, %d affected, %d updated.\n",
332             $fontdir, (scalar keys %$newdone), $affected, $updated;
333     }
334 }
335
336 sub processfonttree ($) {
337     my ($tree) = @_;
338     find({ follow => 1,
339            dangling_symlinks => 0,
340            no_chdir => 1,
341            wanted => sub {
342                return unless -d _;
343                processfontdir($File::Find::name);
344            }},
345          $tree);
346 }
347
348 our $stdin = new IO::File '<&STDIN' or die $!;
349 our $stdout = new IO::File '>&STDOUT' or die $!;
350 our $stderr = new IO::File '>&STDERR' or die $!;
351 $reportfh = $stdout;
352
353 our (@options)=(
354     'R|rules-include=s@' => \@rulespath,
355     'share-dir=s' => \$sharedir,
356     'verbose|v+' => \$verbose,
357     );
358
359 sub define_mode ($$) {
360     my ($optname,$f) = @_;
361     push @options, $optname, sub {
362         die "only one mode may be specified\n" if defined $mode;
363         $mode=$f;
364     };
365 }
366
367 define_mode('bdf-filter', sub {
368     die "no arguments allowed with --bdf-filter\n" if @ARGV;
369     $reportfh = $stderr;
370     loadfoundries();
371     my $r = processbdf($stdin,$stdout,$reportfh,'stdin');
372     if ($r !~ m/^\d/) {
373         print STDERR "stdin not processed: $r\n";
374         exit 2;
375     }
376 });
377
378 define_mode('process-pcf', sub {
379     die "need source and destination pcf.gz\n" if @ARGV!=2;
380     loadfoundries();
381     my $r = processpcfgz($ARGV[0],$ARGV[1],$reportfh,"pcf");
382     if ($r !~ m/^\d/) {
383         print STDERR "pcf not processed: $r\n";
384         exit 2;
385     }
386 });
387
388 define_mode('process-fontdirs', sub {
389     die "need font dir(s)\n" unless @ARGV;
390     loadfoundries();
391     foreach my $d (@ARGV) {
392         processfontdir($d);
393     }
394 });
395
396 define_mode('process-fonttrees', sub {
397     die "need font tree(s)\n" unless @ARGV;
398     loadfoundries();
399     foreach my $d (@ARGV) {
400         processfonttree($d);
401     }
402 });
403
404 define_mode('update', sub {
405     die "no arguments allowed with --postinst\n" unless !@ARGV;
406     loadfoundries();
407     foreach my $d (@fonttrees) {
408         processfonttree($d);
409     }
410 });
411
412 Getopt::Long::Configure(qw(bundling));
413 GetOptions(@options) or exit 127;
414
415 push @rulespath, "$sharedir/rules";
416
417 die "need a mode\n" unless $mode;
418
419 $mode->();