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 "$y $height $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 $!;