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