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
   8 our $prefix="/usr/local";
   9 our $package='xfonts-traditional';
  10 our $sharedir="$prefix/share/$package";
  11 our @fontsdirs=qw(/usr/share/fonts/X11 /usr/local/share/fonts/X11);
  12 our $donefile="$package.done";
  13 our $fontprefix="trad--";
  14 our @rulespath;
  15 our $mode;
  16 our %foundrymap;
  17 our $verbose=0;
  18 our $reportfh;
  19
  20 sub reportloaded {
  21     return unless $verbose;
  22     print $reportfh @_,"\n" or die $!;
  23 }
  24
  25 sub loadrules ($) {
  26     my ($key) = @_;
  27     our %cache;
  28     my $fc=$cache{$key};
  29     return $fc if $fc;
  30     foreach my $path (@rulespath) {
  31         my $script="$path/$key.rules";
  32         $!=0; $@=''; my $f = do $script;
  33         if (defined $f) {
  34             reportloaded("rules: loaded ",$script);
  35             $cache{$key}=$f;
  36             return $f;
  37         }
  38         die "$! $? $script" unless $! == &ENOENT;
  39     }
  40     return $cache{$key}=undef;
  41 }
  42
  43 sub processbdf ($$$) {
  44     my ($inbdf,$outbdf,$what) = @_;
  45     my $state='idle';
  46     my ($foundry,$font);
  47     my ($w,$h,$xo,$yo,$y,$bitmap,$glyph);
  48     my $modified=0;
  49     while (<$inbdf>) {
  50         if ($state eq 'bitmap' && $y==$h) {
  51             $glyph = uc $glyph;
  52             $glyph =~ s/\;$//;
  53             local ($_) = $glyph;
  54             my $key= sprintf "%s,%d,%d,%d,%d", $foundry,$w,$h,$xo,$yo;
  55             my $rules= loadrules($key);
  56             return (0,'no rules') if !$rules;
  57             $rules->();
  58             $modified += ($_ ne $glyph);
  59             print $outbdf $_,"\n" or die $!
  60                 foreach split /\;/, $_; # /;
  61             $state='idle';
  62         }
  63         if ($state eq 'bitmap') {
  64             m/^([0-9a-fA-F]+)\s+$/ or die $y;
  65             length($1) == (($w+7 >> 3) << 1) or die "$1 $w";
  66             $glyph .= "$1;";
  67             $y++;
  68             next;
  69         }
  70         if ($state eq 'idle' && m/^FOUNDRY\s+/) {
  71             die if defined $foundry;
  72             return (0,'foundry syntax') unless m/^FOUNDRY\s+\"(\w+)\"\s+/;
  73             $foundry = $foundrymap{lc $1};
  74             return (0,'no foundry') unless defined $foundry;
  75             $_ = "FOUNDRY \"$foundry\"\n";
  76         }
  77         if ($state eq 'idle' && m/^FONT\s+/) {
  78             die if defined $font;
  79             return 0 unless m/^(FONT\s+)\-(\w+)\-/;
  80             $font = $foundrymap{lc $2};
  81             return (0,'no foundry') unless defined $font;
  82             $_ = "FONT -$font-$'";
  83         }
  84         if ($state eq 'idle' && m/^STARTCHAR\s/) {
  85             die unless defined $foundry;
  86             die unless defined $font;
  87             return (0,'foundry != font') unless $foundry eq $font;
  88             $state='startchar';
  89             $w=undef;
  90         }
  91         if ($state eq 'startchar') {
  92             if (m/^BBX\s+(\+?\d+)\s+(\+?\d+)\s+([-+]?\d+)\s+([-+]?\d+)\s+$/) {
  93                 ($w,$h,$xo,$yo) = ($1,$2,$3,$4);
  94             }
  95             if (m/^BITMAP\s+$/) {
  96                 die unless defined $w;
  97                 $y=0;
  98                 $glyph='';
  99                 $state='bitmap';
 100             }
 101         }
 102         print $outbdf $_ or die $!;
 103     }
 104     die $! if $inbdf->error;
 105     die $! if $outbdf->error or !$outbdf->flush;
 106     die unless $state eq 'idle';
 107     if ($modified) {
 108         printf $reportfh "%s: %d glyphs changed\n", $what, $modified
 109             or die $!;
 110     } else {
 111         printf $reportfh "%s: unchanged - no rules matched\n", $what
 112             or die $!;
 113     }
 114     return $modified;
 115 }
 116
 117 our (@options)=(
 118     'R|rules-include=s@' => \@rulespath,
 119     'share-dir=s' => \$sharedir,
 120     'verbose|v+' => \$verbose,
 121     );
 122
 123 sub define_mode ($$) {
 124     my ($optname,$f) = @_;
 125     push @options, $optname, sub {
 126         die "only one mode may be specified\n" if defined $mode;
 127         $mode=$f;
 128     };
 129 }
 130
 131 sub loadfoundries () {
 132     foreach my $path (@rulespath) {
 133         my $p = "$path/foundries";
 134         my $f = new IO::File $p;
 135         if (!$f) {
 136             die "$p $!" unless $!==&ENOENT;
 137             print $reportfh "foundries: none in $p\n" or die $! if $verbose;
 138             next;
 139         }
 140         while (<$f>) {
 141             s/^\s*//; s/\s+$//;
 142             next if m/^\#/;
 143             m/^(\w+)\s+(\w+)$/ or die;
 144             my $k = lc $1;
 145             next if exists $foundrymap{$k};
 146             $foundrymap{$k}=$2;
 147         }
 148         $f->error and die $!;
 149         reportloaded('foundries: loaded ',$p);
 150     }
 151     die "no foundry maps\n" unless %foundrymap;
 152 }
 153
 154 sub processfontdir ($) {
 155     my ($fontdir) = @_;
 156     if (!opendir FD, $fontdir) {
 157         die "$fontdir $!" unless $!==&ENOENT;
 158         return;
 159     }
 160     my $done = do "$fontdir/$donefile";
 161     if (!$done) {
 162         die "$fontdir $! $@ " unless $!==&ENOENT;
 163         $done = { };
 164     }
 165     my %found;
 166     while (my $dent = readdir FD) {
 167         next unless $dent =~ m/^[^.\/].*\.pcf\.gz$/;
 168         if ($dent =~ m/^\Q$fontprefix/) {
 169             $found{$dent} = 1;
 170             next;
 171         }
 172         if (!stat $dent) {
 173             die "$fontdir $dent $!" unless $!==&ENOENT;
 174             next;
 175         }
 176         die "$fontdir $dent" unless -f _;
 177         my $stats = join ' ', ((stat _)[1,7,9,10]);
 178         $tdone = $done{$dent};
 179         if (defined $tdone && $tdone eq $stats) {
 180             $found{$dent} = 2;
 181             next;
 182         }
 183
 184
 185 our $stdin = new IO::File '<&STDIN' or die $!;
 186 our $stdout = new IO::File '>&STDOUT' or die $!;
 187 our $stderr = new IO::File '>&STDERR' or die $!;
 188 $reportfh = $stdout;
 189
 190 define_mode('bdf-filter', sub {
 191     die "no arguments allowed with --bdf-filter\n" if @ARGV;
 192     $reportfh = $stderr;
 193     loadfoundries();
 194     my $r = processbdf($stdin,$stdout,'stdin');
 195     if ($r !~ m/^\d/) {
 196         print STDERR "stdin not processed: $r\n";
 197         exit 2;
 198     }
 199 });
 200
 201 Getopt::Long::Configure(qw(bundling));
 202 GetOptions(@options) or exit 127;
 203
 204 push @rulespath, "$sharedir/rules";
 205
 206 die "need a mode\n" unless $mode;
 207
 208 $mode->();
 209
 210 #   70  zcat /usr/share/fonts/X11/misc/6x13.pcf.gz |pcf2bdf >in.bdf
 211 #   71  ./utility <in.bdf >out.bdf
 212 #   83  bdftopcf out.bdf >out.pcf
 213 #   84  gzip out.pcf
 214 #   85  cp out.pcf.gz /usr/share/fonts/X11/misc/
 215 # really mkfontdir /usr/share/fonts/X11/misc/
 216 # xset fp rehash
 217 # xfontsel