src/librarian/font-optimizer/ext/Font-TTF/lib/Font/TTF/Kern/Subtable.pm

   1 package Font::TTF::Kern::Subtable;
   2
   3 =head1 NAME
   4
   5 Font::TTF::Kern::Subtable - Kern Subtable superclass for AAT
   6
   7 =head1 METHODS
   8
   9 =cut
  10
  11 use strict;
  12 use Font::TTF::Utils;
  13 use Font::TTF::AATutils;
  14 use IO::File;
  15
  16 require Font::TTF::Kern::OrderedList;
  17 require Font::TTF::Kern::StateTable;
  18 require Font::TTF::Kern::ClassArray;
  19 require Font::TTF::Kern::CompactClassArray;
  20
  21 sub new
  22 {
  23     my ($class) = @_;
  24     my ($self) = {};
  25
  26     $class = ref($class) || $class;
  27
  28     bless $self, $class;
  29 }
  30
  31 sub create
  32 {
  33     my ($class, $type, $coverage, $length) = @_;
  34
  35     $class = ref($class) || $class;
  36
  37     my $subclass;
  38     if ($type == 0) {
  39         $subclass = 'Font::TTF::Kern::OrderedList';
  40     }
  41     elsif ($type == 1) {
  42         $subclass = 'Font::TTF::Kern::StateTable';
  43     }
  44     elsif ($type == 2) {
  45         $subclass = 'Font::TTF::Kern::ClassArray';
  46     }
  47     elsif ($type == 3) {
  48         $subclass = 'Font::TTF::Kern::CompactClassArray';
  49     }
  50
  51     my @options;
  52     push @options,'vertical'    if ($coverage & 0x8000) != 0;
  53     push @options,'crossStream' if ($coverage & 0x4000) != 0;
  54     push @options,'variation'   if ($coverage & 0x2000) != 0;
  55
  56     my ($subTable) = $subclass->new(@options);
  57
  58     map { $subTable->{$_} = 1 } @options;
  59
  60     $subTable->{'type'} = $type;
  61     $subTable->{'length'} = $length;
  62
  63     $subTable;
  64 }
  65
  66 =head2 $t->out($fh)
  67
  68 Writes the table to a file
  69
  70 =cut
  71
  72 sub out
  73 {
  74     my ($self, $fh) = @_;
  75
  76     my $subtableStart = $fh->tell();
  77     my $type = $self->{'type'};
  78     my $coverage = $type;
  79     $coverage += 0x8000 if $self->{'vertical'};
  80     $coverage += 0x4000 if $self->{'crossStream'};
  81     $coverage += 0x2000 if $self->{'variation'};
  82
  83     $fh->print(TTF_Pack("LSS", 0, $coverage, $self->{'tupleIndex'}));    # placeholder for length
  84
  85     $self->out_sub($fh);
  86
  87     my $length = $fh->tell() - $subtableStart;
  88     my $padBytes = (4 - ($length & 3)) & 3;
  89     $fh->print(pack("C*", (0) x $padBytes));
  90     $length += $padBytes;
  91     $fh->seek($subtableStart, IO::File::SEEK_SET);
  92     $fh->print(pack("N", $length));
  93     $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
  94 }
  95
  96 =head2 $t->print($fh)
  97
  98 Prints a human-readable representation of the table
  99
 100 =cut
 101
 102 sub post
 103 {
 104     my ($self) = @_;
 105
 106     my $post = $self->{' PARENT'}{' PARENT'}{'post'};
 107     if (defined $post) {
 108         $post->read;
 109     }
 110     else {
 111         $post = {};
 112     }
 113
 114     return $post;
 115 }
 116
 117 sub print
 118 {
 119     my ($self, $fh) = @_;
 120
 121     my $post = $self->post();
 122     $fh = 'STDOUT' unless defined $fh;
 123 }
 124
 125 =head2 $t->print_classes($fh)
 126
 127 Prints a human-readable representation of the table
 128
 129 =cut
 130
 131 sub print_classes
 132 {
 133     my ($self, $fh) = @_;
 134
 135     my $post = $self->post();
 136
 137     my $classes = $self->{'classes'};
 138     foreach (0 .. $#$classes) {
 139         my $class = $classes->[$_];
 140         if (defined $class) {
 141             $fh->printf("\t\tClass %d:\t%s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$class));
 142         }
 143     }
 144 }
 145
 146 sub dumpClasses
 147 {
 148     my ($self, $classes, $fh) = @_;
 149     my $post = $self->post();
 150
 151     foreach (0 .. $#$classes) {
 152         my $c = $classes->[$_];
 153         if ($#$c > -1) {
 154             $fh->printf("<class n=\"%s\">\n", $_);
 155             foreach (@$c) {
 156                 $fh->printf("<g index=\"%s\" name=\"%s\"/>\n", $_, $post->{'VAL'}[$_]);
 157             }
 158             $fh->printf("</class>\n");
 159         }
 160     }
 161 }
 162
 163 1;
 164
 165 =head1 BUGS
 166
 167 None known
 168
 169 =head1 AUTHOR
 170
 171 Jonathan Kew L<Jonathan_Kew@sil.org>. See L<Font::TTF::Font> for copyright and
 172 licensing.
 173
 174 =cut
 175