xfonts-traditional 1.6 / usr / bin / 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;
use Sys::CPU;

our $prefix="/usr";
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;
our $foundryinfo;
our %props;
our $tolerate_bad_fonts=1;
our $always_reprocess;
our $wanted_parallel;

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

sub statsummary () {
    return join ' ', ((stat _)[1,7,9,10]);
}

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;
    %props = ();
    my $anyinput=0;
    while (<$inbdf>) {
	$anyinput=1;
	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 '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 'foundry syntax' unless m/^FOUNDRY\s+\"(\w+)\"\s+/;
	    $foundry = $foundrymap{lc $1};
	    return 'no foundry' unless defined $foundry;
	    $_ = "FOUNDRY \"$foundry\"\n";
	}
	if ($state eq 'idle' && m/^FONT\s+/) {
	    die if defined $font;
	    return 'simple font name' unless m/^(FONT\s+)\-(\w+)\-/;
	    $font = $foundrymap{lc $2};
	    return 'no foundry' unless defined $font;
	    $_ = "FONT -$font-$'";
	}
	if ($state eq 'idle' && m/^STARTCHAR\s/) {
	    die unless defined $foundry;
	    die unless defined $font;
	    return 'foundry != font' unless $foundry eq $font;
	    $state='startchar';
	    $w=undef;
	}
	if (($state eq 'idle' || $state eq 'startchar') &&
	    m/^([A-Z_]+)\s+(.*\S)\s+$/) {
	    $props{$1}=$2;
	}
	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';
		$props{' 7bit'}=
		    ($props{'CHARSET_REGISTRY'} =~ m/iso8859|utf|iso10646/i &&
		     $props{'ENCODING'} <= 127);
	    }
	}
	print $outbdf $_ or die $!;
    }
    die $! if $inbdf->error;
    die $! if $outbdf->error or !$outbdf->flush;
    die unless $state eq 'idle';
    return 'no bdf data' # also special cased in processpcfgz
	if !$anyinput;
    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 () {
    $foundryinfo = '';
    foreach my $path (@rulespath) {
	if (!stat $path) {
	    die "$path $!" unless $!==&ENOENT;
	    next;
	}
	$foundryinfo .= statsummary().' '.$path."\0\n";

	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;
	}
	stat $f or die $!;
	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) = @_;
    print $reportfh "processing $inpcfgz to $outpcfgz\n" if $verbose>=2;
    my $current = new IO::File $inpcfgz, '<' or die "$inpcfgz $!";
    my ($usread,$uswrite);
    my ($reader,$writer);
    my @children;
    my %ch;
    foreach my $proc (['gunzip'], ['pcf2bdf'], [],
		      ['bdftopcf'],['',qw(gzip -1 -n)]) {
	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 $!";
	    }
	    my $ch = {
		Pid => $child,
		Exe => $exe,
		Stage => (!$exe ? 'self' : defined $usread ? 'out' : 'in'),
		SigOK => { },
	    };
	    push @children, $ch;
	    $ch{$exe} = $ch;
	    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/;

    $ch{'gunzip'}{SigOK}{13} = 1;
    # ... we never care if pcf2bdf didn't want all the output from gunzip

    if ($none || !$r) {
	# We're not going to install or use this so we can kill our
	# input and output filters.  We kill the input filters so that
	# we don't risk waiting for them.  (If the input filter died
	# for some other reason then sending it a KILL now won't
	# affect its exit status.)  We kill the output filters (before
	# we close the output pipe) so we don't produce messages from
	# our output filters about corrupted data.
	flush $uswrite or die $!;

	foreach my $ch (@children) {
	    if ($ch->{Stage} ne 'self') {
		kill 9, $ch->{Pid} or die "$ch->{Pid} $ch->{Exe} $!";
		$ch->{SigOK}{9} = 1;
	    }
	}
	$ch{'pcf2bdf'}{SigOK}{13} = 1;
	# ... we might not have read all the output from pcf2bdf, which is OK
    }
    close $uswrite or die $!;
    close $usread or die $!;

    foreach my $ch (@children) {
	$!=0; waitpid($ch->{Pid}, 0) == $ch->{Pid} or
	    die "$ch->{Pid} $ch->{Exe} $!";
	$ch->{St} = $?;
    }

    my $st_isok = sub {
	my ($ch) = @_;
	my $st = $ch->{St};
	return !$st || $ch->{SigOK}{($st & ~128)};
    };

    if ($tolerate_bad_fonts &&
	$r eq 'no bdf data' &&
	$st_isok->($ch{'gunzip'}) &&
	($ch{'pcf2bdf'}{St} & ~128) == 6)
    {
	$r = "pcf2bdf failed ($ch{'pcf2bdf'}{St})";
	print STDERR "warning: $r: skipping $inpcfgz\n";
	$ch{'pcf2bdf'}{SigOK}{6} = 1;
    }
    foreach my $ch (@children) {
	if (!$st_isok->($ch)) {
	    die "update-xfonts-traditional:".
		" $ch->{Exe} [$ch->{Pid}] for $inpcfgz".
		" failed $ch->{St}".
		" (".(join ' ', keys %{ $ch->{SigOK} })." ok)\n";
	}
    }
    return $r;
}

sub processfontdir ($) {
    my ($fontdir) = @_;
    if (!opendir FD, $fontdir) {
	die "$fontdir $!" unless $!==&ENOENT;
	return;
    }
    my $changed = 0;
    my $olddone;
    if (!$always_reprocess) {
	$olddone = do "$fontdir/$donefile";
	if (!$olddone) {
	    die "$fontdir $! $@ " unless $!==&ENOENT;
	} elsif ($olddone->{''} ne $foundryinfo) {
	    our $repro_reported;
	    print $reportfh "reprocessing fonts (rules updated)\n" or die $!
		unless $repro_reported++;
	    $olddone = undef;
	}
    }
    if (!$olddone) {
	$olddone = { };
	$changed = 1;
    }
    my $newdone = { '' => $foundryinfo };
    my %outfiles; # bitmask: 1 /*exists*/ | 2 /*wanted*/
    my $updated=0;
    my $reported=0;
    my $anypcfs=0;

    my $logpath = "$fontdir/$logfile";
    unlink "$logpath" or $!==&ENOENT or die "$logpath $!";
    my $log = new IO::File $logpath, ">>" or die "$logpath $!";

    if (!$wanted_parallel) {
	$wanted_parallel = Sys::CPU::cpu_count();
	printf $reportfh "parallelism: %d\n", $wanted_parallel if $verbose>=2;
    }
    $wanted_parallel = 1 if $wanted_parallel < 1;

    our %inprogress;

    my $await = sub {
	my $child = wait;
	die $! unless defined $child;
	my $job = $inprogress{$child};
	die $child unless $job;

	my $dent = $job->{Dent};
	my $outdent = $job->{Outdent};
	my $stats = $job->{Stats};
	if ($?==0) {
	    $updated++;
	    $outfiles{$outdent} |= 3;
	} elsif ($?==2*256) {
	} else {
	    die "update-xfonts-traditional: processing of".
		" $fontdir/$dent [$child] failed ($?)\n";
	}
	$newdone->{$dent} = $stats;
	$changed = 1;
	delete $inprogress{$child};
    };

    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 = statsummary();
	my $tdone = $olddone->{$dent};
	my $outdent = $fontprefix.$dent;
	if (defined $tdone && $tdone eq $stats) {
	    $outfiles{$outdent} |= 2;
	    $newdone->{$dent} = $stats;
	    next;
	}

	$await->() while scalar keys %inprogress >= $wanted_parallel;

	my $child = fork;  die unless defined $child;
	if (!$child) {
	    my $r = processpcfgz("$fontdir/$dent",
				 "$fontdir/$outdent.new",
				 $log, $dent);
	    my $rc;
	    if ($r !~ m/^\d/) {
		printf $log "%s: unchanged - %s\n", $dent, $r;
		unlink "$fontdir/$outdent.new" or die "$fontdir $outdent $!";
		$rc = 2;
	    } else {
		rename "$fontdir/$outdent.new", "$fontdir/$outdent"
		    or die "$fontdir $outdent $!";
		$rc = 0;
	    }
	    $log->flush or die "$logpath $!";
	    exit $rc;
	}
	$inprogress{$child} = {
	    Dent => $dent,
	    Outdent => $outdent,
	    Stats => $stats,
	};
    }
    $await->() while scalar keys %inprogress;

    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 "$logpath" 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,
    'j|parallel=i' => \$wanted_parallel,
    'always-reprocess!' => \$always_reprocess,
    'tolerate-bad-fonts!' => \$tolerate_bad_fonts,
    );

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->();