File: printrule

package info (click to toggle)
xfonts-traditional 1.8.0
  • links: PTS
  • area: main
  • in suites: buster, stretch
  • size: 1,100 kB
  • ctags: 24
  • sloc: perl: 577; sh: 251; makefile: 32
file content (51 lines) | stat: -rwxr-xr-x 1,414 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
#!/usr/bin/perl -w
# usage:
#  printrule bad.bdf good.bdf <height> '^ENCODING <nn>$' 0|1 <comment>
#  printrule bad.bdf good.bdf <height> '^STARTCHAR <name>$' 0|1 <comment>

# This script is an assistant for printing rules for pasting into
# *.rules files.  The idea is that you get bdfs of the font you don't
# and do like, and specify the character, and it will print a rule
# that fixes it.  
#
# Final argument, if 1, says the glyph is a letter without an
# ascender, and edits the regexp not to match the whitespace where
# accents might go.

use strict;
use IO::File;

die unless @ARGV==6;
our ($badf,$goodf,$height,$regexp,$partial,$comment) = @ARGV;

sub get ($) {
    my ($p) = @_;
    my $f = new IO::File $p or die "$p $!";
    while (<$f>) {
	last if m/$regexp/o;
    }
    die $p unless defined;
    while (<$f>) {
	last if m/^BITMAP$/;
    }
    my $glyph='';
    for (my $y=0; $y<$height; $y++) {
	<$f> =~ m/^([0-9a-f]+)$/i or die "$y $height $p $_ ?";
	$glyph.="$1;";
    }
    $glyph =~ s/\;$//;
    return $glyph;
}

my $bad = get($badf);
my $good = get($goodf);
my $s;
if ($partial) {
    $bad  =~ s/^(?:00\;)+//;  my $badrm= $&;
    $good =~ s/^(?:00\;)+//;  my $goodrm= $&;
    die "$badrm $bad   $goodrm $good " unless $badrm eq $goodrm;
    $s = sprintf 's/\\b%s$/%s/', $bad, $good;
} else {    
    $s = sprintf 's/^%s$/%s/', $bad, $good;
}
printf "    %s; # %s\n", $s, $comment or die $!;