chiark / gitweb /
exactly as found in #660965 message 34
[xfonts-traditional.git] / printrule
1 #!/usr/bin/perl -w
2 # usage:
3 #  printrule bad.bdf good.bdf <height> '^ENCODING <nn>$' 0|1 <comment>
4 #  printrule bad.bdf good.bdf <height> '^STARTCHAR <name>$' 0|1 <comment>
5
6 # This script is an assistant for printing rules for pasting into
7 # *.rules files.  The idea is that you get bdfs of the font you don't
8 # and do like, and specify the character, and it will print a rule
9 # that fixes it.  
10 #
11 # Final argument, if 1, says the glyph is a letter without an
12 # ascender, and edits the regexp not to match the whitespace where
13 # accents might go.
14
15 use strict;
16 use IO::File;
17
18 die unless @ARGV==6;
19 our ($badf,$goodf,$height,$regexp,$partial,$comment) = @ARGV;
20
21 sub get ($) {
22     my ($p) = @_;
23     my $f = new IO::File $p or die "$p $!";
24     while (<$f>) {
25         last if m/$regexp/o;
26     }
27     die $p unless defined;
28     while (<$f>) {
29         last if m/^BITMAP$/;
30     }
31     my $glyph='';
32     for (my $y=0; $y<$height; $y++) {
33         <$f> =~ m/^([0-9a-f]+)$/i or die "$p $_ ?";
34         $glyph.="$1;";
35     }
36     $glyph =~ s/\;$//;
37     return $glyph;
38 }
39
40 my $bad = get($badf);
41 my $good = get($goodf);
42 my $s;
43 if ($partial) {
44     $bad  =~ s/^(?:00\;)+//;  my $badrm= $&;
45     $good =~ s/^(?:00\;)+//;  my $goodrm= $&;
46     die "$badrm $bad   $goodrm $good " unless $badrm eq $goodrm;
47     $s = sprintf 's/\\b%s$/%s/', $bad, $good;
48 } else {    
49     $s = sprintf 's/^%s$/%s/', $bad, $good;
50 }
51 printf "    %s; # %s\n", $s, $comment or die $!;