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