better about when to update fonts.dir

[xfonts-traditional] / update-xfonts-traditional

#!/usr/bin/perl -w
use strict;
use POSIX;
use IO::File;
use Getopt::Long;
use File::Glob qw(:glob);
use Data::Dumper;
use IO::Pipe;
use File::Find;

our $prefix="/usr/local";
our $package='xfonts-traditional';
our $sharedir="$prefix/share/$package";
our @fonttrees=qw(/usr/share/fonts/X11 /usr/local/share/fonts/X11);
our $donefile="$package.done";
our $logfile="$package.log";
our $fontprefix="trad--";
our @rulespath;
our $mode;
our %foundrymap;
our $verbose=0;
our $reportfh;

sub reportloaded {
    return unless $verbose;
    print $reportfh @_,"\n" or die $!;
}

sub loadrules ($) {
    my ($key) = @_;
    our %cache;
    my $fc=$cache{$key};  
    return $fc if $fc;
    foreach my $path (@rulespath) {
	my $script="$path/$key.rules";
	$!=0; $@=''; my $f = do $script;
	if (defined $f) {
	    reportloaded("rules: loaded ",$script);
	    $cache{$key}=$f;
	    return $f;
	}
	die "$! $? $script" unless $! == &ENOENT;
    }
    return $cache{$key}=undef;
}

sub processbdf ($$$$) {
    my ($inbdf,$outbdf,$logfile,$what) = @_;
    my $state='idle';
    my ($foundry,$font);
    my ($w,$h,$xo,$yo,$y,$bitmap,$glyph);
    my $modified=0;
    while (<$inbdf>) {
	if ($state eq 'bitmap' && $y==$h) {
	    $glyph = uc $glyph;
	    $glyph =~ s/\;$//;
	    local ($_) = $glyph;
	    my $key= sprintf "%s,%d,%d,%d,%d", $foundry,$w,$h,$xo,$yo;
	    my $rules= loadrules($key);
	    return (0,'no rules') if !$rules;
	    $rules->();
	    $modified += ($_ ne $glyph);
	    print $outbdf $_,"\n" or die $!
		foreach split /\;/, $_; # /;
	    $state='idle';
	}
	if ($state eq 'bitmap') {
	    m/^([0-9a-fA-F]+)\s+$/ or die $y;
	    length($1) == (($w+7 >> 3) << 1) or die "$1 $w";
	    $glyph .= "$1;";
	    $y++;
	    next;
	}
	if ($state eq 'idle' && m/^FOUNDRY\s+/) {
	    die if defined $foundry;
	    return (0,'foundry syntax') unless m/^FOUNDRY\s+\"(\w+)\"\s+/;
	    $foundry = $foundrymap{lc $1};
	    return (0,'no foundry') unless defined $foundry;
	    $_ = "FOUNDRY \"$foundry\"\n";
	}
	if ($state eq 'idle' && m/^FONT\s+/) {
	    die if defined $font;
	    return (0,'simple font name') unless m/^(FONT\s+)\-(\w+)\-/;
	    $font = $foundrymap{lc $2};
	    return (0,'no foundry') unless defined $font;
	    $_ = "FONT -$font-$'";
	}
	if ($state eq 'idle' && m/^STARTCHAR\s/) {
	    die unless defined $foundry;
	    die unless defined $font;
	    return (0,'foundry != font') unless $foundry eq $font;
	    $state='startchar';
	    $w=undef;
	}
	if ($state eq 'startchar') {
	    if (m/^BBX\s+(\+?\d+)\s+(\+?\d+)\s+([-+]?\d+)\s+([-+]?\d+)\s+$/) {
		($w,$h,$xo,$yo) = ($1,$2,$3,$4);
	    }
	    if (m/^BITMAP\s+$/) {
		die unless defined $w;
		$y=0;
		$glyph='';
		$state='bitmap';
	    }
	}
	print $outbdf $_ or die $!;
    }
    die $! if $inbdf->error;
    die $! if $outbdf->error or !$outbdf->flush;
    die unless $state eq 'idle';
    if ($modified) {
	printf $logfile "%s: %d glyphs changed\n", $what, $modified
	    or die $!;
    } else {
	printf $logfile "%s: unchanged - no rules matched\n", $what
	    or die $!;
    }
    return $modified;
}

sub loadfoundries () {
    foreach my $path (@rulespath) {
	my $p = "$path/foundries";
	my $f = new IO::File $p;
	if (!$f) {
	    die "$p $!" unless $!==&ENOENT;
	    print $reportfh "foundries: none in $p\n" or die $! if $verbose;
	    next;
	}
	while (<$f>) {
	    s/^\s*//; s/\s+$//;
	    next if m/^\#/;
	    m/^(\w+)\s+(\w+)$/ or die;
	    my $k = lc $1;
	    next if exists $foundrymap{$k};
	    $foundrymap{$k}=$2;
	}
	$f->error and die $!;
	reportloaded('foundries: loaded ',$p);
    }
    die "no foundry maps\n" unless %foundrymap;
}

sub processpcfgz ($$$$) {
    my ($inpcfgz,$outpcfgz,$logfile,$what) = @_;

    my $current = new IO::File $inpcfgz, '<' or die "$inpcfgz $!";
    my ($usread,$uswrite);
    my ($reader,$writer);
    my @children;
    foreach my $proc (['zcat'], ['pcf2bdf'], [],
		      ['bdftopcf'],['',qw(gzip -1)]) {
	my $isfinal = (@$proc && $proc->[0] eq '');
	if (!$isfinal) {
	    $reader = new IO::Handle or die $!;
	    $writer = new IO::Handle or die $!;
	    new IO::Pipe($reader,$writer) or die $!;
	} else {
	    shift @$proc;
	    $reader = undef;
	    $writer = new IO::File $outpcfgz, '>' or die "$outpcfgz $!";
	}
	if (@$proc) {
	    my $exe = $proc->[0];
	    my $child = fork;  defined $child or die $!;
	    if (!$child) {
		open STDIN, '<&', $current or die $!;
		open STDOUT, '>&', $writer or die $!;
		if (!$isfinal) {
		    close $reader or die $!;
		}
		close $usread or die $! if $usread;
		close $uswrite or die $! if $uswrite;
		exec $exe @$proc or die "$exe $!";
	    }
	    push @children, [ $child, $exe, defined $usread ];
	    close $current or die $!;
	    close $writer or die $!;
	    $current = $reader;
	} else {
	    $usread = $current;
	    $uswrite = $writer;
	    $current = $reader;
	}
    }
    my $r = processbdf($usread,$uswrite,$logfile,$what);
    my $none = $r !~ m/^\d/;
    if ($none) {
	flush $uswrite or die $!;
    } else {
	close $uswrite or die $!;
    }
    close $usread or die $!;
    foreach my $chinfo (@children) {
	my ($child,$exe,$isoutput)=@$chinfo;
	my $sigok = 0;
	if ($none) {
	    if ($isoutput) {
		$sigok = 9;
		kill 9, $child or die "$child $!";
	    } else {
		$sigok = 13;
	    }
	}
	$!=0; waitpid($child, 0) == $child or die "$child $!";
	!$? or ($?&~128)==$sigok or die "$exe [$child] $sigok $?";
    }
    return $r;
}

sub processfontdir ($) {
    my ($fontdir) = @_;
    if (!opendir FD, $fontdir) {
	die "$fontdir $!" unless $!==&ENOENT;
	return;
    }
    my $changed = 0;
    my $olddone = do "$fontdir/$donefile";
    if (!$olddone) {
	die "$fontdir $! $@ " unless $!==&ENOENT;
	$olddone = { };
	$changed = 1;
    }
    my $newdone = { };
    my $log = new IO::File "$fontdir/$logfile", "w" 
	or die "$fontdir/$logfile $!";
    my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
    my $updated=0;
    my $reported=0;
    my $anypcfs=0;

    flush $reportfh or die $!;
    while (my $dent = scalar readdir FD) {
	if ($dent =~ m/^\Q$fontprefix\E.*\.new$/) {
	    unlink "$fontdir/$dent" or $!==&ENOENT or die "$fontdir $dent $!";
	    next;
	}
	next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
	print $reportfh "processing $fontdir...\n" or die $!
	    unless $reported++;
	if ($dent =~ m/^\Q$fontprefix/) {
	    $outfiles{$dent} |= 1;
	    next;
	}
	if (!stat "$fontdir/$dent") {
	    die "$fontdir $dent $!" unless $!==&ENOENT;
	    next;
	}
	die "$fontdir $dent" unless -f _;
	$anypcfs++;

	my $stats = join ' ', ((stat _)[1,7,9,10]);
	my $tdone = $olddone->{$dent};
	my $outdent = $fontprefix.$dent;
	if (defined $tdone && $tdone eq $stats) {
	    $outfiles{$outdent} |= 2;
	    $newdone->{$dent} = $stats;
	    next;
	}

	my $r = processpcfgz("$fontdir/$dent",
			     "$fontdir/$outdent.new",
			     $log, $dent);
	if ($r !~ m/^\d/) {
	    printf $log "%s: unchanged - %s\n", $dent, $r;
	    unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
	} else {
	    rename "$fontdir/$outdent.new", "$fontdir/$outdent"
		or die "$fontdir $outdent $!";
	    $updated++;
	    $outfiles{$outdent} |= 3;
	}
	$newdone->{$dent} = $stats;
	$changed = 1;
    }
    my $affected=0;
    foreach my $olddent (keys %outfiles) {
	my $state = $outfiles{$olddent};
	if ($state & 2) {
	    $affected++ if $state & 1;
	    next;
	}
	unlink "$fontdir/$olddent" or die "$fontdir $olddent $!";
	$changed = 1;
	$updated++;
    }
    if (!stat "$fontdir/fonts.dir") {
	$!==&ENOENT or die "$fontdir $!";
    } else {
	$!=0; $?=0; system 'mkfontdir',$fontdir;
	die "$fontdir $? $!" if $? or $!;
    }
    if (!$anypcfs) {
	unlink "$fontdir/$logfile" or die "$fontdir $!";
	unlink "$fontdir/$donefile" or $!==&ENOENT or die "$fontdir $!";
    } elsif ($changed) {
	my $newdoneh = new IO::File "$fontdir/$donefile.new", 'w' 
	    or die "$fontdir $!";
	print $newdoneh Dumper($newdone) or die "$fontdir $!";
	close $newdoneh or die "$fontdir $!";
	rename "$fontdir/$donefile.new","$fontdir/$donefile"
	    or die "$fontdir $!";
    }
    if ($reported || %$newdone || $affected || $updated) {
	printf " processed %s: %d pcfs, %d affected, %d updated.\n",
            $fontdir, (scalar keys %$newdone), $affected, $updated;
    }
}

sub processfonttree ($) {
    my ($tree) = @_;
    find({ follow => 1,
	   dangling_symlinks => 0,
	   no_chdir => 1,
	   wanted => sub {
	       return unless -d _;
	       processfontdir($File::Find::name);
	   }},
	 $tree);
}

our $stdin = new IO::File '<&STDIN' or die $!;
our $stdout = new IO::File '>&STDOUT' or die $!;
our $stderr = new IO::File '>&STDERR' or die $!;
$reportfh = $stdout;

our (@options)=(
    'R|rules-include=s@' => \@rulespath,
    'share-dir=s' => \$sharedir,
    'verbose|v+' => \$verbose,
    );

sub define_mode ($$) {
    my ($optname,$f) = @_;
    push @options, $optname, sub {
	die "only one mode may be specified\n" if defined $mode;
	$mode=$f;
    };
}

define_mode('bdf-filter', sub {
    die "no arguments allowed with --bdf-filter\n" if @ARGV;
    $reportfh = $stderr;
    loadfoundries();
    my $r = processbdf($stdin,$stdout,$reportfh,'stdin');
    if ($r !~ m/^\d/) {
	print STDERR "stdin not processed: $r\n";
	exit 2;
    }
});

define_mode('process-pcf', sub {
    die "need source and destination pcf.gz\n" if @ARGV!=2;
    loadfoundries();
    my $r = processpcfgz($ARGV[0],$ARGV[1],$reportfh,"pcf");
    if ($r !~ m/^\d/) {
	print STDERR "pcf not processed: $r\n";
	exit 2;
    }
});

define_mode('process-fontdirs', sub {
    die "need font dir(s)\n" unless @ARGV;
    loadfoundries();
    foreach my $d (@ARGV) {
	processfontdir($d);
    }
});

define_mode('process-fonttrees', sub {
    die "need font tree(s)\n" unless @ARGV;
    loadfoundries();
    foreach my $d (@ARGV) {
	processfonttree($d);
    }
});

define_mode('update', sub {
    die "no arguments allowed with --postinst\n" unless !@ARGV;
    loadfoundries();
    foreach my $d (@fonttrees) {
	processfonttree($d);
    }
});

Getopt::Long::Configure(qw(bundling));
GetOptions(@options) or exit 127;

push @rulespath, "$sharedir/rules";

die "need a mode\n" unless $mode;

$mode->();