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     }
 235     if ($olddone && $olddone->{''} ne $foundryinfo) {
 236         our $repro_reported;
 237         print $reportfh "reprocessing fonts (rules updated)\n" or die $!
 238             unless $repro_reported++;
 239         $olddone = undef;
 240     }
 241     if (!$olddone) {
 242         $olddone = { };
 243         $changed = 1;
 244     }
 245     my $newdone = { '' => $foundryinfo };
 246     my $log = new IO::File "$fontdir/$logfile", "w"
 247         or die "$fontdir/$logfile $!";
 248     my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
 249     my $updated=0;
 250     my $reported=0;
 251     my $anypcfs=0;
 252
 253     flush $reportfh or die $!;
 254     while (my $dent = scalar readdir FD) {
 255         if ($dent =~ m/^\Q$fontprefix\E.*\.new$/) {
 256             unlink "$fontdir/$dent" or $!==&ENOENT or die "$fontdir $dent $!";
 257             next;
 258         }
 259         next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
 260         print $reportfh "processing $fontdir...\n" or die $!
 261             unless $reported++;
 262         if ($dent =~ m/^\Q$fontprefix/) {
 263             $outfiles{$dent} |= 1;
 264             next;
 265         }
 266         if (!stat "$fontdir/$dent") {
 267             die "$fontdir $dent $!" unless $!==&ENOENT;
 268             next;
 269         }
 270         die "$fontdir $dent" unless -f _;
 271         $anypcfs++;
 272
 273         my $stats = statsummary();
 274         my $tdone = $olddone->{$dent};
 275         my $outdent = $fontprefix.$dent;
 276         if (defined $tdone && $tdone eq $stats) {
 277             $outfiles{$outdent} |= 2;
 278             $newdone->{$dent} = $stats;
 279             next;
 280         }
 281
 282         my $r = processpcfgz("$fontdir/$dent",
 283                              "$fontdir/$outdent.new",
 284                              $log, $dent);
 285         if ($r !~ m/^\d/) {
 286             printf $log "%s: unchanged - %s\n", $dent, $r;
 287             unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
 288         } else {
 289             rename "$fontdir/$outdent.new", "$fontdir/$outdent"
 290                 or die "$fontdir $outdent $!";
 291             $updated++;
 292             $outfiles{$outdent} |= 3;
 293         }
 294         $newdone->{$dent} = $stats;
 295         $changed = 1;
 296     }
 297     my $affected=0;
 298     foreach my $olddent (keys %outfiles) {
 299         my $state = $outfiles{$olddent};
 300         if ($state & 2) {
 301             $affected++ if $state & 1;
 302             next;
 303         }
 304         unlink "$fontdir/$olddent" or die "$fontdir $olddent $!";
 305         $changed = 1;
 306         $updated++;
 307     }
 308     if (!stat "$fontdir/fonts.dir") {
 309         $!==&ENOENT or die "$fontdir $!";
 310     } else {
 311         $!=0; $?=0; system 'mkfontdir',$fontdir;
 312         die "$fontdir $? $!" if $? or $!;
 313     }
 314     if (!$anypcfs) {
 315         unlink "$fontdir/$logfile" or die "$fontdir $!";
 316         unlink "$fontdir/$donefile" or $!==&ENOENT or die "$fontdir $!";
 317     } elsif ($changed) {
 318         my $newdoneh = new IO::File "$fontdir/$donefile.new", 'w'
 319             or die "$fontdir $!";
 320         print $newdoneh Dumper($newdone) or die "$fontdir $!";
 321         close $newdoneh or die "$fontdir $!";
 322         rename "$fontdir/$donefile.new","$fontdir/$donefile"
 323             or die "$fontdir $!";
 324     }
 325     if ($reported || %$newdone || $affected || $updated) {
 326         printf " processed %s: %d pcfs, %d affected, %d updated.\n",
 327             $fontdir, (scalar keys %$newdone), $affected, $updated;
 328     }
 329 }
 330
 331 sub processfonttree ($) {
 332     my ($tree) = @_;
 333     find({ follow => 1,
 334            dangling_symlinks => 0,
 335            no_chdir => 1,
 336            wanted => sub {
 337                return unless -d _;
 338                processfontdir($File::Find::name);
 339            }},
 340          $tree);
 341 }
 342
 343 our $stdin = new IO::File '<&STDIN' or die $!;
 344 our $stdout = new IO::File '>&STDOUT' or die $!;
 345 our $stderr = new IO::File '>&STDERR' or die $!;
 346 $reportfh = $stdout;
 347
 348 our (@options)=(
 349     'R|rules-include=s@' => \@rulespath,
 350     'share-dir=s' => \$sharedir,
 351     'verbose|v+' => \$verbose,
 352     );
 353
 354 sub define_mode ($$) {
 355     my ($optname,$f) = @_;
 356     push @options, $optname, sub {
 357         die "only one mode may be specified\n" if defined $mode;
 358         $mode=$f;
 359     };
 360 }
 361
 362 define_mode('bdf-filter', sub {
 363     die "no arguments allowed with --bdf-filter\n" if @ARGV;
 364     $reportfh = $stderr;
 365     loadfoundries();
 366     my $r = processbdf($stdin,$stdout,$reportfh,'stdin');
 367     if ($r !~ m/^\d/) {
 368         print STDERR "stdin not processed: $r\n";
 369         exit 2;
 370     }
 371 });
 372
 373 define_mode('process-pcf', sub {
 374     die "need source and destination pcf.gz\n" if @ARGV!=2;
 375     loadfoundries();
 376     my $r = processpcfgz($ARGV[0],$ARGV[1],$reportfh,"pcf");
 377     if ($r !~ m/^\d/) {
 378         print STDERR "pcf not processed: $r\n";
 379         exit 2;
 380     }
 381 });
 382
 383 define_mode('process-fontdirs', sub {
 384     die "need font dir(s)\n" unless @ARGV;
 385     loadfoundries();
 386     foreach my $d (@ARGV) {
 387         processfontdir($d);
 388     }
 389 });
 390
 391 define_mode('process-fonttrees', sub {
 392     die "need font tree(s)\n" unless @ARGV;
 393     loadfoundries();
 394     foreach my $d (@ARGV) {
 395         processfonttree($d);
 396     }
 397 });
 398
 399 define_mode('update', sub {
 400     die "no arguments allowed with --postinst\n" unless !@ARGV;
 401     loadfoundries();
 402     foreach my $d (@fonttrees) {
 403         processfonttree($d);
 404     }
 405 });
 406
 407 Getopt::Long::Configure(qw(bundling));
 408 GetOptions(@options) or exit 127;
 409
 410 push @rulespath, "$sharedir/rules";
 411
 412 die "need a mode\n" unless $mode;
 413
 414 $mode->();