| 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 $!; |