r1043 - in packages: . libfont-ttf-perl libfont-ttf-perl/branches
libfont-ttf-perl/branches/upstream
libfont-ttf-perl/branches/upstream/current
libfont-ttf-perl/branches/upstream/current/Examples
libfont-ttf-perl/branches/upstream/current/lib
libfont-ttf-perl/branches/upstream/current/lib/Font
libfont-ttf-perl/branches/upstream/current/lib/Font/TTF
libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern
libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort
libfont-ttf-perl/branches/upstream/current/scripts
Gunnar Wolf
gwolf at costa.debian.org
Sun Jul 17 08:09:13 UTC 2005
Author: gwolf
Date: 2005-05-25 15:08:14 +0000 (Wed, 25 May 2005)
New Revision: 1043
Added:
packages/libfont-ttf-perl/
packages/libfont-ttf-perl/branches/
packages/libfont-ttf-perl/branches/upstream/
packages/libfont-ttf-perl/branches/upstream/current/
packages/libfont-ttf-perl/branches/upstream/current/Examples/
packages/libfont-ttf-perl/branches/upstream/current/Examples/StripCmap.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/addpclt.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/makemono.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/symbol.rmp
packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfaddname.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfdeltable.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfenc.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfwidth.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/ttunadopter.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/xmldump.plx
packages/libfont-ttf-perl/branches/upstream/current/Examples/zerohyph.plx
packages/libfont-ttf-perl/branches/upstream/current/MANIFEST
packages/libfont-ttf-perl/branches/upstream/current/MANIFEST.SKIP
packages/libfont-ttf-perl/branches/upstream/current/Make.PM
packages/libfont-ttf-perl/branches/upstream/current/Makefile
packages/libfont-ttf-perl/branches/upstream/current/Makefile.PL
packages/libfont-ttf-perl/branches/upstream/current/README.TXT
packages/libfont-ttf-perl/branches/upstream/current/Setup.bat
packages/libfont-ttf-perl/branches/upstream/current/lib/
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATKern.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATutils.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Anchor.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Bsln.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Changes
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cmap.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Coverage.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cvt_.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Delta.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fdsc.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Feat.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fmtx.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Font.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fpgm.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GDEF.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GPOS.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GSUB.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyf.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyph.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hdmx.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Head.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hhea.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hmtx.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/ClassArray.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/CompactClassArray.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/OrderedList.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/StateTable.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/Subtable.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/LTSH.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Loca.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Manual.pod
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Maxp.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Chain.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Contextual.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Insertion.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Ligature.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Noncontextual.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Rearrangement.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Subtable.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Name.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OS_2.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldCmap.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldMort.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PCLT.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PSNames.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Post.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prep.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prop.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Segarr.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Table.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttc.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttopen.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Useall.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Utils.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vhea.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vmtx.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Win32.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/XMLparse.pm
packages/libfont-ttf-perl/branches/upstream/current/lib/ttfmod.pl
packages/libfont-ttf-perl/branches/upstream/current/pmake.bat
packages/libfont-ttf-perl/branches/upstream/current/scripts/
packages/libfont-ttf-perl/branches/upstream/current/scripts/check_attach.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/eurofix.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/hackos2.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/psfix.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfbuilder.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfname.plx
packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfremap.plx
packages/libfont-ttf-perl/tags/
Log:
[svn-inject] Installing original source of libfont-ttf-perl
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/StripCmap.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/StripCmap.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/StripCmap.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,35 @@
+use Font::TTF::Font;
+require 'getopts.pl';
+
+Getopts("umws");
+
+unless (defined $ARGV[1])
+{
+ die <<'EOT';
+
+ StripCmap [-m] [-u] [-w] [-s] <infile> <outfile>
+
+Strips the Macintosh (-m), Mac Unicode (-u), and/or Windows (-w) cmap from
+a ttf without without touching anything else. Emit no messages if -s.
+
+EOT
+}
+
+$f = Font::TTF::Font->open($ARGV[0]) || die "Cannot open TrueType font '$ARGV[0]' for reading.\n";
+$o = $f->{'cmap'}->read || die "Font '$ARGV[0]' has no cmap table.\n";
+
+for ($i =$o->{'Num'}-1; $i >= 0; $i--)
+{
+
+ $pID = $o->{'Tables'}[$i]{'Platform'};
+ if (($pID == 0 && $opt_u) or ($pID == 1 && $opt_m) or ($pID == 3 && $opt_w))
+ {
+ printf "Deleting cmap for platformID $pID\n" if !$opt_s;
+ splice @{$o->{'Tables'}}, $i, 1;
+ $o->{'Num'}--;
+ }
+}
+
+printf "Number of cmap tables remaining = %d\n", $o->{'Num'} if !$opt_s;
+$f->out($ARGV[1]);
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/addpclt.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/addpclt.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/addpclt.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,213 @@
+
+# Title: ADDPCLT.BAT
+# Author: M. Hosken
+# Description:
+# 1.0.0 MJPH 18-MAR-1998 Original
+
+require 'ttfmod.pl';
+require 'getopts.pl';
+do Getopts("d:z");
+
+$[ = 0;
+if ((defined $opt_d && !defined $ARGV[0]) || (!defined $opt_d && !defined $ARGV[1]))
+ {
+ die 'ADDPCLT [-d directory] [-z] <infile> <outfile>
+
+v1.0.0, 18-Mar-1998 (c) Martin_Hosken at sil.org
+
+Adds a PCLT table to a font which does not have one. Much of the information is
+guesswork or made up from investigation made in the font.
+ -d specifies output directory for processing multiple files. In which
+ case <outfile> is not used and <infile> may be a list including
+ wildcards.
+ -z debug
+';
+}
+
+$old = select(STDERR); $| = 1; select($old);
+
+$fns{"PCLT"} = "make_pclt";
+
+if (defined $opt_d)
+ {
+ foreach $f (@ARGV)
+ {
+ print STDERR "$f -> $opt_d/$f\n" unless (defined $opt_q);
+ &ttfmod($f, "$opt_d/$f", *fns);
+ }
+ }
+else
+ {
+ &ttfmod($ARGV[0], $ARGV[1], *fns, "PCLT");
+ }
+
+sub make_pclt
+{
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ return (&ttfmod'copytab(*INFILE, *OUTFILE, $len)) if ($len != 0);
+
+ $len = 54;
+ $inf[0] = 1 << 16; # version 1
+ $inf[1] = 1 << 31; # fontnumber (derived)
+ $inf[4] = 0; # black normal uncondensed
+ $inf[5] = 6 << 12; # derived font
+ $inf[7] = 629; # symbol set Win3.1
+ $inf[8] = " " x 16;
+ $inf[9] = -1;
+ $inf[10] = 0x37FFFFFE; # character complement Windows ANSI
+ $inf[12] = 0; # normal stroke weight
+ $inf[13] = 0; # normal widthType
+ $inf[14] = 0; # normal serif style
+ $inf[15] = 0; # reserved
+
+# Now for the tricky stuff!
+# Get some glyph ids
+ $off = (split(':', $ttfmod'dir{'post'}))[2];
+ seek(INFILE, $off, 0); # go to post table
+ printf "%s @ %x\n", "post", $off if defined $opt_z;
+ read(INFILE, $tdat, 4); # get format
+ ($tmaj, $tmin) = unpack("n2", $tdat);
+ read(INFILE, $tdat, 28); # chuck the rest of the header
+ print STDERR "$tmaj.$tmin " if defined $opt_z;
+ if ($tmaj == 1)
+ { ($sid, $hid, $xid) = (3, 43, 91); }
+ elsif ($tmaj == 3 || $tmaj == 4)
+ {
+ warn "No effective post table";
+ ($sid, $hid, $xid) = (0, 0, 0);
+ }
+ elsif ($tmaj == 2)
+ {
+ read(INFILE, $tdat, 2);
+ $numglyphs = unpack("n", $tdat);
+ for ($i = 0; $i < $numglyphs; $i++)
+ {
+ if ($tmin == 5)
+ {
+ read(INFILE, $tdat, 1);
+ $id = unpack("c", $tdat) + $i;
+ }
+ else
+ {
+ read(INFILE, $tdat, 2);
+ $id = unpack("n", $tdat);
+ }
+ $sid = $i if ($id == 3);
+ $hid = $i if ($id == 43);
+ $xid = $i if ($id == 91);
+ }
+ }
+
+ print STDERR ".0." if defined $opt_z;
+ if ($sid == 0)
+ { $inf[2] = 0; }
+ else
+ {
+ $off = (split(':', $ttfmod'dir{'hhea'}))[2];
+ seek(INFILE, $off, 0);
+ read(INFILE, $tdat, 36);
+ $numhmet = unpack("x34n", $tdat);
+
+ $off = (split(':', $ttfmod'dir{'hmtx'}))[2];
+ seek(INFILE, $off, 0);
+ $sid = $numhmet if ($sid > $numhmet);
+ read(INFILE, $tdat, $sid * 4 - 4);
+ read(INFILE, $tdat, 4);
+ $inf[2] = unpack("n", $tdat);
+ }
+
+ $off = (split(':', $ttfmod'dir{'head'}))[2];
+ seek(INFILE, $off+50, 0);
+ read(INFILE, $tdat, 4);
+ ($locfmt, $glyfmt) = (unpack("n2", $tdat));
+
+ print STDERR "[$locfmt, $glyfmt]\n" if defined $opt_z;
+ $off = (split(':', $ttfmod'dir{'loca'}))[2];
+ $locfmt += 1; # 0 -> 1; 1 -> 2
+ if ($xid != 0)
+ {
+ seek(INFILE, $off + $xid * $locfmt * 2, 0);
+ read(INFILE, $tdat, $locfmt * 2);
+ if ($locfmt == 1)
+ { ($xloc) = unpack("n", $tdat) * 2; }
+ else
+ { ($xloc) = unpack("N", $tdat); }
+ }
+ if ($hid != 0)
+ {
+ seek(INFILE, $off + $hid * $locfmt * 2, 0);
+ read(INFILE, $tdat, $locfmt * 2);
+ if ($locfmt == 1)
+ { $hloc = unpack("n", $tdat) * 2; }
+ else
+ { $hloc = unpack("N", $tdat); }
+ }
+
+ print STDERR ".3." if defined $opt_z;
+ $off = (split(':', $ttfmod'dir{'glyf'}))[2];
+ if ($xid != 0)
+ {
+ seek(INFILE, $off + $xloc, 0);
+ read(INFILE, $tdat, 10);
+ ($inf[3]) = unpack("x8n", $tdat);
+ } else
+ { $inf[3] = 0; }
+ if ($hid != 0)
+ {
+ seek(INFILE, $off + $hloc, 0);
+ read(INFILE, $tdat, 10);
+ $inf[6] = unpack("x8n", $tdat);
+ } else
+ { $inf[6] = 0; }
+ print STDERR "s = ($sid, $sloc); h = ($hid, $hloc); x = ($xid, $xloc)\n"
+ if defined $opt_z;
+
+# Now for some names
+ $off = (split(':', $ttfmod'dir{'name'}))[2];
+ printf STDERR "%s @ %08x\n", "name", $off if defined $opt_z;
+ seek(INFILE, $off, 0);
+ read(INFILE, $tdat, 6);
+ ($name_num) = unpack("x2n", $tdat);
+ for ($i = 0; $i < $name_num; $i++)
+ {
+ read(INFILE, $tdat, 12) || die "Unable to read name entry: $off";
+ ($id_p, $id_e, $id_l, $name_id, $str_len, $str_off)
+ = unpack("n6", $tdat);
+ ($sl, $sf) = ($str_len, $str_off)
+ if ($name_id == 2 && $id_p == 3 && $id_e == 1 && $id_l == 1033);
+ ($fl, $ff) = ($str_len, $str_off)
+ if ($name_id == 1 && $id_p == 3 && $id_e == 1 && $id_l == 1033);
+ }
+ $base = tell(INFILE);
+ seek(INFILE, $base + $sf, 0);
+ read(INFILE, $subfam, $sl);
+ $subfam =~ s/.(.)/$1/oig;
+ seek(INFILE, $base + $ff, 0);
+ read(INFILE, $fam, $fl);
+ $fam =~ s/.(.)/$1/oig;
+ substr($inf[8], 0, 11) = substr($fam, 0, 11);
+ $inf[11] = substr($fam, 0, 3) . "R00";
+ $off = 0;
+ if ($subfam =~ m/bold/oi)
+ {
+ substr($inf[8], 12 + $off, 2) = "Bd";
+ substr($inf[11], 3, 1) = "B";
+ $off += 2;
+ }
+ if ($subfam =~ m/italic/oi)
+ {
+ substr($inf[8], 12 + $off, 2) = "It";
+ substr($inf[11], 3, 1) = $off > 0 ? "J" : "I";
+ }
+ $inf[11] =~ tr/[a-z]/[A-Z]/;
+
+ $dat = pack("N2n6A16N2A6C4", @inf);
+ $csum = unpack("%32N", $dat);
+ print OUTFILE $dat;
+ print STDERR "$len, $csum, $ttfmod'dir{'PCLT'}";
+ ($len, $csum);
+}
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/makemono.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/makemono.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/makemono.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,103 @@
+
+# Title: MAKEMONO.BAT
+# Author: M. Hosken
+# Description:
+# MJPH 1.0.0 25-MAR-1998 Original
+
+require 'ttfmod.pl';
+require 'getopts.pl';
+&Getopts("d:z");
+
+if ((defined $opt_d && !defined $ARGV[0]) || (!defined $opt_d && !defined $ARGV[1]))
+{
+ die 'MAKEMONO [-d dir] [-z] <infile> <outfile>
+
+v1.0.0, 25-Mar-1998 (c) Martin_Hosken at sil.org
+
+Converts a font to be a monospaced font based on the maximum advance width.
+ -d specifies output directory for processing multiple files. In which
+ case <outfile> is not used and <infile> may be a list including
+ wildcards.
+ -z debug
+';
+}
+
+$fns{"post"} = "post";
+$fns{"hmtx"} = "hmtx";
+$fns{"OS/2"} = "os2";
+
+if (defined $opt_d)
+ {
+ foreach $f (@ARGV)
+ {
+ print STDERR "$f -> $opt_d/$f\n" unless (defined $opt_q);
+ &ttfmod($f, "$opt_d/$f", *fns);
+ }
+ }
+else
+ {
+ &ttfmod($ARGV[0], $ARGV[1], *fns);
+ }
+
+sub post
+{
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ read(INFILE, $dat, 32); # read header
+ substr($dat, 12, 4) = pack("N", 1); # mark as monospaced
+ $csum = unpack("%32N*", $dat);
+ print OUTFILE $dat;
+ ($len, $csum) = &ttfmod'copytab(*INFILE, *OUTFILE, $len-32, $csum);
+ ($len + 32, $csum);
+}
+
+sub hmtx
+{
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ $mylen = $len;
+ ($numhmet, $maxadv) = &getinfo(*INFILE);
+ print STDERR "$numhmet, $maxadv\n" if defined $opt_z;
+ for ($i = 0; $i < $numhmet; $i++)
+ {
+ read(INFILE, $dat, 4);
+ substr($dat, 0, 2) = pack("n", $maxadv);
+ print OUTFILE $dat;
+ $csum += unpack("%32N*", $dat);
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
+ $mylen -= 4;
+ }
+ ($mylen, $csum) = &ttfmod'copytab(*INFILE, *OUTFILE, $mylen, $csum);
+ ($len, $csum);
+}
+
+sub os2
+{
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ ($numhmet, $maxadv) = &getinfo(*INFILE);
+ read(INFILE, $dat, $len);
+ substr($dat, 2, 2) = pack("n", $maxadv);
+ substr($dat, 35, 1) = pack("c", 9); # magic does the trick in Windows
+ $csum = unpack("%32N*", $dat);
+ print OUTFILE $dat;
+ ($len, $csum);
+}
+
+sub getinfo
+{
+ local(*INFILE) = @_;
+
+ $loc = tell(INFILE);
+ $off = (split(':', $ttfmod'dir{'hhea'}))[2];
+ seek(INFILE, $off, 0);
+ read(INFILE, $dat, 36);
+ ($maxadv, $numhmet) = unpack("x10nx22n", $dat);
+ seek(INFILE, $loc, 0);
+ ($numhmet, $maxadv);
+}
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/symbol.rmp
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/symbol.rmp 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/symbol.rmp 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,30 @@
+0020, 007F, F020
+20AC, 20AC, F080
+0081, 0081, F081
+201A, 201A, F082
+0192, 0192, F083
+201E, 201E, F084
+2026, 2026, F085
+2020, 2021, F086
+02C6, 02C6, F088
+2030, 2030, F089
+0160, 0160, F08A
+2039, 2039, F08B
+0152, 0152, F08C
+008D, 008D, F08D
+017D, 017D, F08E
+008F, 0090, F08F
+2018, 2019, F091
+201C, 201D, F093
+2022, 2022, F095
+2013, 2014, F096
+02DC, 02DC, F098
+2122, 2122, F099
+0161, 0161, F09A
+203A, 203A, F09B
+0153, 0153, F09C
+009D, 009D, F09D
+017E, 017E, F09E
+0178, 0178, F09F
+00A0, 00FF, F0A0
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfaddname.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfaddname.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfaddname.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,32 @@
+use Font::TTF::Font;
+use IO::File;
+use Getopt::Std;
+
+getopts('e:i:l:n:p:');
+
+unless (defined $ARGV[1] && defined $opt_p && defined $opt_n && defined $opt_l)
+{
+ die <<'EOT';
+ TTFADDNAME -n num -l lang -p platform -e enc infile outfile < text
+Adds a name of given number, language and platform to the font. Text is
+assumed to be in UTF8.
+EOT
+}
+
+$in = IO::File->new("<$opt_i");
+
+$f = Font::TTF::Font->open($ARGV[0]) || die "Can't open $ARGV[0]";
+$f->{'name'}->read;
+
+while(<$in>)
+{
+ print ":$_:";
+ use UTF8;
+ s/^\x{FEFF}//o if ($. == 1);
+ $t .= $_;
+}
+
+$f->{'name'}{'strings'}[$opt_n][$opt_p][$opt_e]{$opt_l} = $t;
+
+$f->out($ARGV[1]);
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfdeltable.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfdeltable.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfdeltable.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,9 @@
+use Font::TTF::Font;
+use Getopt::Std;
+
+getopts('t:');
+
+$f = Font::TTF::Font->open($ARGV[0]);
+delete $f->{$opt_t};
+$f->out($ARGV[1]);
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfenc.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfenc.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfenc.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,152 @@
+use Font::TTF::Font;
+require 'getopt.pl';
+
+if ($ARGV[0] =~ /^\-@/oi)
+{
+ $cfgname = $';
+ shift (ARGV);
+ open(CFGFILE, "$cfgname") || die "Unable to open config file $cfgname";
+ while (<CFGFILE>)
+ { chomp; unshift (ARGV, $_); }
+}
+Getopt("e:m:p:t:x");
+
+$VERSION = 1.0; # MJPH 26-DEB-1999 Original
+
+unless (defined $ARGV[0] && defined $opt_e)
+{
+ die <<'EOT';
+ ttfenc [-e enc_file] [-m mapping_file] [-p map_file] [-t tfm_file]
+ [-x] font.ttf
+ ttfenc - at config_file font.ttf
+
+Creates a Postscript mapping file for the given font according to the 8-bit
+to Unicode mapping given in mapping_file. If the font is a Windows symbol font
+then no mapping_file is required. If no tfm file is requested, then no map_file
+entry is made, either. Requires ttf2afm and afm2tfm to run.
+
+ -e enc_file Filename of encoding file (including where to store it)
+ -m mapping_file Unicode mapping description file (e.g. cp1252.txt)
+ -p map_file The PDFTeX .map file in which to add an entry for this
+ font [OPTIONAL - absent, no entry added]
+ -t tfm_file The name and where to store the .tfm file
+ -x Disable TeX postscript name correction
+ - at config_file Specifies a file to read command line parameters from
+
+E.g.
+ ttfenc -e ipa93.enc -m cp1252.txt ipa93sr.ttf
+
+Just creates ipa93.enc from the POST table of ipa93sr.ttf
+
+ ttfenc -e %texmf%\pdftex\base\ipa93.enc -m cp1252.txt -p %texmf%\pdftex\bas
+e\ttfmap.map -t %texmf%\fonts\tfm\ttf\ipa93sr.tfm ipa93sr.ttf
+
+Create .tfm, .afm, .enc and install the files in the appropriate places. (The
+.afm is left with ipa93sr.log in the current directory)
+
+EOT
+}
+
+%texCorrect = (
+ 'mu1' => 'mu',
+ 'summation' => 'Sigma',
+ 'product' => 'Pi',
+ 'increment' => 'Delta',
+ 'middot' => 'periodcentered',
+ 'overscore' => 'macron',
+ 'dslash' => 'dmacron'
+ );
+
+$base = $ARGV[0];
+$base =~ s/(.*[\\\/])?(.*)\.ttf/$2/oi;
+
+$font = Font::TTF::Font->open("$ARGV[0]");
+$lchar = $font->{'OS/2'}->read->{'usFirstCharIndex'};
+if ($lchar < 0xF000 || $lchar > 0xF100) # a Windows symbol font?
+{
+ die "No mapping file" unless defined $opt_m;
+ $map = read_UniMap($opt_m); # no? then use mapping file
+} else
+{
+ $map = [];
+ for ($i = 0; $i < 256; $i++)
+ { $map->[$i] = $i + 0xf000; }
+}
+$font->{'post'}->read;
+$font->{'cmap'}->read;
+
+open(OUTFILE, ">$opt_e") || die "Unable to open $opt_e";
+binmode OUTFILE; # need Unix file format!
+select OUTFILE;
+
+print "/TeXBase1Encoding [\n";
+
+for ($i = 0; $i < 256; $i++)
+{
+ my ($name);
+
+ printf "%% 0x%02X\n", $i unless ($i & 15);
+ $name = $font->{'post'}{'VAL'}[$font->{'cmap'}->ms_lookup($map->[$i])];
+ $name = $texCorrect{$name} if (!$opt_x && defined $texCorrect{$name});
+ print " /$name";
+ print "\n" if ($i & 3) == 3;
+}
+
+print "] def\n";
+
+close (OUTFILE);
+
+exit unless defined $opt_t;
+
+$tfmname = $opt_t;
+$tfmname =~ s/(.*[\\\/])?(.*)\.tfm/$2/oi;
+$encname = $opt_e;
+$encname =~ s/(.*[\\\/])?(.*)\.enc/$2/oi;
+
+system("ttf2afm -e $opt_e -o $tfmname.afm $ARGV[0] > $base.log");
+open(INFILE, "afm2tfm $tfmname.afm |") || die "Can't run afm2tfm";
+$mapline = <INFILE>;
+close(INFILE);
+(undef, $psname) = split(' ', $mapline);
+
+if (defined $opt_p)
+{
+ open(OUTFILE, ">>$opt_p") || die "Can't open $opt_p for appending";
+ print OUTFILE "$tfmname $psname <$base.ttf $encname.enc\n";
+ close(OUTFILE);
+}
+
+if ($opt_t !~ /^$tfmname\.tfm/i)
+{
+ open (INFILE, "$tfmname.tfm") || die "Can't open $tfmname.tfm";
+ binmode INFILE;
+ unlink ("$opt_t") || goto getout;
+ open (OUTFILE, ">$opt_t") || goto doneit;
+ binmode OUTFILE;
+ while (read(INFILE, $dat, 4096))
+ { print OUTFILE $dat; }
+ close (OUTFILE);
+doneit:
+ close (INFILE);
+}
+
+getout:
+print STDERR "\n";
+
+sub read_UniMap
+{
+ my ($fname) = @_;
+ my ($res) = [];
+
+ open(INFILE, "$fname") || return undef;
+ while (<INFILE>)
+ {
+ s/\#.*$//oi;
+ $res->[hex($1)] = hex($2) if (m/^\s*((?:0x)?[0-9a-f]+)\s*((?:0x)?[0-9a-f]+)/oi);
+ }
+ close(INFILE);
+
+ $res;
+}
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfwidth.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfwidth.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/ttfwidth.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,376 @@
+
+# Title: TTFWIDTH.PL
+# Author: M. Hosken
+# Description: Write out character width, etc. information from a TTF file
+# in either SF or CSV format.
+# 1.2.0 25-MAR-1998 Tidy up to package with the rest
+
+require 'getopts.pl';
+do Getopts("qsuzp:");
+
+if (!defined $ARGV[0])
+ {
+ die 'TTFWIDTH [-q] [-s] [-u] [-z] [-p plat.spec] <infile> [<outfile>]
+
+v1.2.0, 25-Mar-1998 (c) Martin_Hosken at sil.org
+
+Generates character size information for each character to either Standard
+Format or Comma Separated Variables format. Essential for sorting out those
+typographical variants.
+ -u unicode as key rather than calculated 8-bit code
+ -q suppress advisory output
+ -s output in standard format
+ -p plat.spec set platform and specific ids of character map
+ -z debug
+';
+ }
+
+# print "TTFWIDTH v1.1: Freeware, (c) M. Hosken\n" if (!defined $opt_q);
+
+open(INFILE, "$ARGV[0]") || die("Unable to open \"$ARGV[0]\" for reading");
+binmode INFILE;
+if (defined $ARGV[1])
+ {
+ open(OUTFILE, ">$ARGV[1]") || die "Unable to open \"$ARGV[1]\" for writing";
+ }
+else
+ {
+ open(OUTFILE, ">&STDOUT") || die "Can't dup STDOUT";
+ }
+
+# for the most part, we don't need all the information in the font, so it
+# isn't parsed. Secondly, no checks are made that all the essential tables
+# are necessary. Trivial, but then the tables are essential and the font
+# would not work without them, so they will be there (famous last words).
+
+# first read the header and directory
+read(INFILE, $head, 12) == 12 || die "reading header";
+($ver, $numtab) = unpack("Nn", $head);
+# print "ver = $ver\nnumtab = $numtab\n";
+for ($i = 0; $i < $numtab; $i++)
+ {
+ read(INFILE, $tab, 16) == 16 || die "reading table directory";
+ ($name, $offset) = unpack("a4x4N", $tab);
+# printf "name = \"$name\", offset = %X\n", $offset;
+ $dir{$name} = $offset;
+ }
+
+# trawl the world to get all those essential numbers from the various strange
+# tables that they are spread around.
+
+# process the "head" table
+seek(INFILE, $dir{"head"}, 0);
+read(INFILE, $h_data, 54) == 54 || die "reading head table";
+($h_em, $h_longloc) = unpack("x18nx30n", $h_data);
+
+# process the "maxp" table
+seek(INFILE, $dir{"maxp"}, 0);
+read(INFILE, $m_data, 6);
+($m_num) = unpack("x4n", $m_data);
+print "The em box is $h_em units square.\nThere are $m_num glyphs\n"
+ if (!defined $opt_q);
+
+# process the "hhea" table
+seek(INFILE, $dir{"hhea"}, 0);
+read(INFILE, $h_data, 36) == 36 || die "reading hhea table";
+($h_numh) = unpack("x34n", $h_data);
+undef $h_data;
+
+# process the "cmap" table
+# contains the mappings of unicode to glyph number
+seek(INFILE, $dir{"cmap"}, 0);
+read(INFILE, $head, 4) == 4 || die "reading cmap header";
+($c_ver, $c_n) = unpack("nn", $head);
+if (defined $opt_p && $opt_p =~ m/^([0-9]+)[.]([0-9]+)/o)
+ {
+ $c_tid = $1;
+ $c_tenc = $2;
+ }
+else
+ {
+ $c_tid = 3;
+ $c_tenc = 1;
+ }
+for ($i = 0; $i < $c_n; $i++)
+ {
+ read(INFILE, $c_info, 8) == 8 || die "reading cmap dir entry";
+ ($c_id, $c_enc, $c_offset) = unpack("nnN", $c_info);
+ last if ($c_id == $c_tid); # found the encoding we want
+ }
+if ($i >= $c_n)
+ {
+ print STDERR "Can't find required encoding, using Unicode instead.\n";
+ $opt_u = 1;
+ }
+if (!defined $opt_q)
+ {
+ print "font mapping Microsoft id = $c_id, encoding = $c_enc\n";
+ print " (encoding => " . ($c_enc == 1 ? "UGL coding"
+ : "unknown or symbol") . ")\n";
+ }
+
+if ($c_enc == 1)
+ {
+# Microsoft UGL coding (8-bit to unicode mapping table)
+ (@c_enc) = (32 .. 126, 0, 0, 0, 0x201a, 0x192, 0x201e, 0x2026, 0x2020,
+ 0x2021, 0x02c6, 0x2030, 0x0160, 0x2039, 0x0152, 0, 0, 0, 0,
+ 0x2018, 0x2019, 0x201c, 0x201d, 0x2022, 0x2013, 0x2014, 0x02dc,
+ 0x2122, 0x0161, 0x203a, 0x0153, 0, 0, 0x0178,
+ 160 .. 255);
+ }
+# print it all out as comma seperated variables or standard format
+if (!defined $opt_s)
+ {
+# print OUTFILE "\"Em box\",\"$h_em\"\n";
+ if (!defined $opt_u)
+ {
+ print OUTFILE "Code, Char, ";
+ }
+
+ printf OUTFILE "%s, " x 8 . "%s\n",
+ "Unicode", "Glyph", "AdvWidth", "LSdBearing",
+ "Xmin", "Xmax", "Ymin", "Ymax", "XCentre";
+ }
+
+$big = 512;
+if (defined $opt_u && $m_num > $big)
+ {
+ $low = 0; $c_count = $big;
+ while ($c_count >= $big)
+ {
+ &getdata;
+ &printdata;
+ undef @c_uni;
+ undef @l_offsets;
+ undef @h_adw;
+ undef @h_lsb;
+ undef @g_xmin;
+ undef @g_xmax;
+ undef @g_ymin;
+ undef @g_ymax;
+ undef @map;
+ }
+ }
+else
+ {
+ $low = -1;
+ &getdata;
+ &printdata;
+ }
+close(OUTFILE);
+close(INFILE);
+
+
+sub printdata
+{
+for ($i = (defined $opt_u ? $[ : 32); $i <= (defined $opt_u ? $#c_uni : 255);
+ $i++)
+ {
+ if (defined $opt_u)
+ {
+ next if ($c_uni[$i] == 0);
+ $j = $map[$i];
+ }
+ else
+ {
+ $j = ($c_enc == 1) ? $c_map[$c_enc[$i - 32]] : $c_map[$i];
+ next if ($j == 0);
+ }
+ $o_cnt = $h_lsb[$j] + ($g_xmax[$j] - $g_xmin[$j]) / 2;
+ $o_centre = $h_adw[$j] - $o_cnt;
+ $o_centre = -$o_centre if ($o_cnt < 0);
+ if (defined $opt_s)
+ {
+ if (!defined $opt_u)
+ {
+ printf OUTFILE "\\code %d\n\\char %c\n\\uni 0x%04x\n\\glyph %d\n"
+ . "\\adw %d\n\\lsb %d\n",
+ $i, $i, ($c_enc == 1) ? $c_enc[$i] : $i + 0xf000, $i,
+ $h_adw[$j], $h_lsb[$j];
+ }
+ else
+ {
+ printf OUTFILE "\\code 0x%04x\n\\glyph %d\n\\adw %d\n\\lsb %d \n",
+ $c_uni[$i], $i, $h_adw[$j], $h_lsb[$j];
+ }
+ printf OUTFILE "\\xmin %d\n\\xmax %d\n\\ymin %d\n\\ymax %d\n\\xcent %d\n\n",
+ $g_xmin[$j], $g_xmax[$j], $g_ymin[$j], $g_ymax[$j], $o_centre;
+ }
+ else
+ {
+ if (!defined $opt_u)
+ {
+ if ($i == 34)
+ { $o_s = "\"" x 4; }
+ elsif ($i == 44)
+ { $o_s = "\",\""; }
+ else
+ { $o_s = sprintf("%c", $i); }
+ printf OUTFILE "%d,%s,0x%04X,%d,",
+ $i, $o_s, ($c_enc == 1) ? $c_enc[$i - 32] : $i + 0xf000, $j;
+ }
+ else
+ {
+ printf OUTFILE "0x%04X,%d,", $c_uni[$i], $i;
+ }
+ printf OUTFILE "%d,%d,%d,%d,%d,%d,%d\n",
+ $h_adw[$j], $h_lsb[$j], $g_xmin[$j],
+ $g_xmax[$j], $g_ymin[$j], $g_ymax[$j], $o_centre;
+ }
+ }
+}
+
+sub getdata
+{
+seek(INFILE, $dir{"cmap"} + $c_offset, 0);
+read(INFILE, $c_head, 6) == 6 || die "reading cmap table header";
+($c_fmt, $c_len, $c_ver) = unpack("nnn", $c_head);
+die "Incorrect encoding format $c_fmt, should be 4" if ($c_fmt != 4);
+read(INFILE, $c_head, 8) == 8 || die "reading cmap table header part 2";
+($c_segs) = unpack("n", $c_head);
+$c_segs = $c_segs / 2;
+# now read the real meat of the table
+read(INFILE, $c_data, 2 * $c_segs) == 2 * $c_segs || die "reading cmap_end data";
+(@c_ends) = unpack("n" x $c_segs, $c_data);
+read(INFILE, $c_data, 2 * $c_segs + 2) == 2 * $c_segs + 2
+ || die "reading cmap_start data";
+(@c_starts) = unpack("xx" . "n" x $c_segs, $c_data);
+read(INFILE, $c_data, 2 * $c_segs) == 2 * $c_segs || die "reading cmap_deltas";
+(@c_deltas) = unpack("n" x $c_segs, $c_data);
+read(INFILE, $c_data, 2 * $c_segs) == 2 * $c_segs || die "reading cmap_ranges";
+(@c_ranges) = unpack("n" x $c_segs, $c_data);
+undef $c_data;
+$num = read(INFILE, $c_idarray, $c_len - $c_segs * 8 - 16);
+(@c_idarray) = unpack("n" x ($num / 2), $c_idarray);
+undef $c_idarray;
+# convert range type information into per-code information. Creates mapping
+# table (@c_enc) to convert unicode to glyph
+$c_count = 0;
+cmap:
+for ($i = 0; $i < $c_segs - 1; $i++)
+ {
+ for ($j = $c_starts[$i]; $j <= $c_ends[$i]; $j++)
+ {
+ if ($low == -1 || $j > $low)
+ {
+ # calculate glyph number
+ if ($c_ranges[$i] != 0)
+ {
+ $index = $c_idarray[($c_ranges[$i]/2 + $j -
+ $c_starts[$i] - $c_segs + $i)];
+ }
+ else
+ {
+ $index = $j + $c_deltas[$i] - ($c_deltas[$i] > 32767 ? 65536:0);
+ # can't handle 0xf000 directly as an array index, it thinks
+ # it's negative :-(
+ }
+ if (!defined $opt_u)
+ {
+ $c_map[$j - ($c_enc == 1 ? 0 : 0xf000)] = $index;
+ $map[$index] = $index;
+ }
+ else
+ {
+ next if ($index == 0);
+ $c_count++;
+ $map[$index] = $c_count;
+ }
+ $c_uni[$index] = $j;
+ if ($low > -1 && $c_count >= $big)
+ {
+ $low = $j;
+ last cmap;
+ }
+ }
+ }
+ }
+print STDERR "$c_count " if (defined $opt_z);
+undef @c_deltas;
+undef @c_ranges;
+undef @c_starts;
+undef @c_ends;
+print STDERR "1" if (defined $opt_z);
+# generate the locations of each glyph
+
+# process the "loca" table
+seek(INFILE, $dir{"loca"}, 0);
+read(INFILE, $l_data, ($h_longloc == 1 ? 4 : 2) * ($m_num + 1));
+(@l_offs) = unpack(($h_longloc == 1 ? "N" : "n") x ($m_num + 1), $l_data);
+undef $l_data;
+$lold = -1;
+for ($i = 0; $i <= $m_num; $i++)
+ {
+ if ($c_uni[$i])
+ {
+ $l_offsets[$map[$i]] = $l_offs[$i];
+ $l_offsets[$map[$i]] = -1
+ if ($i != $m_num && $l_offs[$i] == $l_offs[$i+1]);
+ $l_offsets[$map[$i]] *= 2
+ if ($h_longloc == 0 && $l_offs[$i] != -1);
+ }
+ }
+undef @l_offs;
+print STDERR "2" if (defined $opt_z);
+# get the horizontal metrics (advance width and left side bearing)
+
+# process the "hmtx" table
+seek(INFILE, $dir{"hmtx"}, 0);
+read(INFILE, $h_data, 4 * $h_numh) == 4 * $h_numh || die "reading hmtx table";
+(@h_temp) = unpack("n" x (2 * $h_numh), $h_data);
+undef $h_data;
+for ($i = 0; $i < $h_numh; $i++)
+ {
+ $h_ladw = $h_temp[$i * 2];
+ if ($c_uni[$i])
+ {
+ $h_adw[$map[$i]] = $h_ladw;
+ $h_lsb[$map[$i]] = $h_temp[$i * 2 + 1];
+ }
+ }
+if ($h_numh != $m_num) # for monospaced fonts
+ {
+ read(INFILE, $h_data, 2 * ($m_num - $h_numh));
+ @h_temp = unpack("n" x ($m_num - $h_numh), $h_data);
+ for ($i = $h_numh; $i < $m_num; $i++)
+ {
+ if ($c_uni[$i])
+ {
+ $h_adw[$map[$i]] = $h_ladw;
+ $h_lsb[$map[$i]] = $h_temp[$i - $h_numh];
+ }
+ }
+ }
+for ($i = 0; $i <= $m_num; $i++) # convert unsigned to signed (any easier
+ # way?)
+ {
+ if ($c_uni[$i])
+ {
+ $j = $map[$i];
+ $h_adw[$j] = $h_adw[$j] - ($h_adw[$j] > 32768 ? 65536 : 0);
+ $h_lsb[$j] = $h_lsb[$j] - ($h_lsb[$j] > 32768 ? 65536 : 0);
+ }
+ }
+undef @h_temp;
+print STDERR "3" if (defined $opt_z);
+
+# process the "glyf" table to get the character bounding box dimensions
+for ($i = 0; $i <= $m_num; $i++)
+ {
+ $j = $map[$i];
+ if ($l_offsets[$j] != -1 && $c_uni[$i])
+ {
+ seek(INFILE, $dir{"glyf"} + $l_offsets[$j], 0);
+ read(INFILE, $g_data, 10) == 10 || die "reading glyph $i";
+ ($g_xmin[$j], $g_ymin[$j], $g_xmax[$j], $g_ymax[$j])
+ = unpack("x2nnnn", $g_data);
+ $g_xmin[$j] = $g_xmin[$j] - ($g_xmin[$j] > 32768 ? 65536 : 0);
+ $g_ymin[$j] = $g_ymin[$j] - ($g_ymin[$j] > 32768 ? 65536 : 0);
+ $g_xmax[$j] = $g_xmax[$j] - ($g_xmax[$j] > 32768 ? 65536 : 0);
+ $g_ymax[$j] = $g_ymax[$j] - ($g_ymax[$j] > 32768 ? 65536 : 0);
+ }
+ }
+print STDERR "4\n" if (defined $opt_z);
+}
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/ttunadopter.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/ttunadopter.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/ttunadopter.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,43 @@
+use Mac::Resources;
+use Mac::Memory;
+
+$type = MacPerl::GetFileInfo($ARGV[0]);
+
+if ($ARGV[0] =~ m/^(.*)\.(.*)$/oi) {
+ $head = $1; $tail = $2;
+} else {
+ $head = $ARGV[0]; $tail = "";
+}
+
+$head .= " 000";
+if ($type eq "tfil" || $type eq "FFIL")
+{
+ $rid = OpenResFile($ARGV[0]);
+ $num = Count1Resources("sfnt");
+ while ($num-- > 0)
+ {
+ $fh = Get1IndResource("sfnt", $num + 1);
+ LoadResource($fh) or next;
+ $fdat = $fh->get;
+ open (OUTFILE, ">$head.$tail") || die "Can't open $head.$tail";
+ binmode(OUTFILE);
+ print OUTFILE $fdat;
+ close(OUTFILE);
+ ReleaseResource($fh);
+ $head++;
+ }
+CloseResFile $rid;
+}
+
+__END__
+
+=head1 NAME
+
+ttunadopter - unpack Mac suitcase fonts into TTF fonts
+
+=head1 DESCRIPTION
+
+Dropping a suitcase file onto ttundaptor will result in a file being created for
+each font in the suitcase.
+
+=cut
\ No newline at end of file
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/xmldump.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/xmldump.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/xmldump.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,8 @@
+use Font::TTF::Font;
+
+$f = Font::TTF::Font->open($ARGV[0]);
+$f->{'loca'}->read;
+$Font::TTF::Name::utf8 = 1;
+$Font::TTF::GDEF::new_gdef = 1;
+$f->out_xml($ARGV[1]);
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Examples/zerohyph.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Examples/zerohyph.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Examples/zerohyph.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,49 @@
+require 'getopts.pl';
+use Font::TTF::Font;
+
+Getopts('u:s:');
+
+unless (defined $ARGV[1])
+{
+ die <<'EOT';
+ ZEROHYPH [-u unicode] [-s width] infile outfile
+Converts the hyphen glyph (or whichever Unicode valued glyph) to a zero width
+space.
+
+Handles the following tables: hmtx, loca, glyf, hdmx, LTSH, kern (MS
+compatability only).
+
+ -s width Set hyphen to be width per mille of the width of a space
+ -u unicode unicode value in hex [002D]
+EOT
+}
+
+$opt_u = "2D" unless defined $opt_u;
+$opt_u = hex($opt_u);
+
+my ($hyphnum); # local scope for anonymous subs
+
+$f = Font::TTF::Font->open($ARGV[0]);
+$hyphnum = $f->{'cmap'}->read->ms_lookup($opt_u);
+if ($opt_s)
+{
+ $spacenum = $f->{'cmap'}->ms_lookup(32);
+ $opt_s = $f->{'hmtx'}->read->{'advance'}[$spacenum] * $opt_s / 1000;
+}
+$f->{'hmtx'}->read->{'advance'}[$hyphnum] = $opt_s;
+$f->{'hmtx'}{'lsb'}[$hyphnum] = 0;
+$f->{'loca'}->read->{'glyphs'}[$hyphnum] = "";
+$f->{'hdmx'}->read->tables_do(sub { $_[0][$hyphnum] = 0; }) if defined $f->{'hdmx'};
+$f->{'LTSH'}->read->{'glyphs'}[$hyphnum] = 1 if defined $f->{'LTSH'};
+
+# deal with MS kerning only.
+if (defined $f->{'kern'} && $f->{'kern'}->read->{'tables'}[0]{'type'} == 0)
+{
+ delete $f->{'kern'}{'tables'}[0]{'kerns'}{$hyphnum};
+ while (($l, $r) = each(%{$f->{'kern'}{'tables'}[0]}))
+ { delete $r->{$g} if defined $r->{$g}; }
+}
+
+$f->out($ARGV[1]);
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/MANIFEST 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/MANIFEST 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,87 @@
+Examples/StripCmap.plx
+Examples/addpclt.plx
+Examples/makemono.plx
+Examples/symbol.rmp
+Examples/ttfaddname.plx
+Examples/ttfdeltable.plx
+Examples/ttfenc.plx
+Examples/ttfwidth.plx
+Examples/ttunadopter.plx
+Examples/xmldump.plx
+Examples/zerohyph.plx
+MANIFEST
+MANIFEST.SKIP
+Make.PM
+Makefile
+Makefile.PL
+README.TXT
+Setup.bat
+lib/Font/TTF/AATKern.pm
+lib/Font/TTF/AATutils.pm
+lib/Font/TTF/Anchor.pm
+lib/Font/TTF/Bsln.pm
+lib/Font/TTF/Changes
+lib/Font/TTF/Cmap.pm
+lib/Font/TTF/Coverage.pm
+lib/Font/TTF/Cvt_.pm
+lib/Font/TTF/Delta.pm
+lib/Font/TTF/Fdsc.pm
+lib/Font/TTF/Feat.pm
+lib/Font/TTF/Fmtx.pm
+lib/Font/TTF/Font.pm
+lib/Font/TTF/Fpgm.pm
+lib/Font/TTF/GDEF.pm
+lib/Font/TTF/GPOS.pm
+lib/Font/TTF/GSUB.pm
+lib/Font/TTF/Glyf.pm
+lib/Font/TTF/Glyph.pm
+lib/Font/TTF/Hdmx.pm
+lib/Font/TTF/Head.pm
+lib/Font/TTF/Hhea.pm
+lib/Font/TTF/Hmtx.pm
+lib/Font/TTF/Kern.pm
+lib/Font/TTF/Kern/ClassArray.pm
+lib/Font/TTF/Kern/CompactClassArray.pm
+lib/Font/TTF/Kern/OrderedList.pm
+lib/Font/TTF/Kern/StateTable.pm
+lib/Font/TTF/Kern/Subtable.pm
+lib/Font/TTF/LTSH.pm
+lib/Font/TTF/Loca.pm
+lib/Font/TTF/Manual.pod
+lib/Font/TTF/Maxp.pm
+lib/Font/TTF/Mort.pm
+lib/Font/TTF/Mort/Chain.pm
+lib/Font/TTF/Mort/Contextual.pm
+lib/Font/TTF/Mort/Insertion.pm
+lib/Font/TTF/Mort/Ligature.pm
+lib/Font/TTF/Mort/Noncontextual.pm
+lib/Font/TTF/Mort/Rearrangement.pm
+lib/Font/TTF/Mort/Subtable.pm
+lib/Font/TTF/Name.pm
+lib/Font/TTF/OS_2.pm
+lib/Font/TTF/OldCmap.pm
+lib/Font/TTF/OldMort.pm
+lib/Font/TTF/PCLT.pm
+lib/Font/TTF/PSNames.pm
+lib/Font/TTF/Post.pm
+lib/Font/TTF/Prep.pm
+lib/Font/TTF/Prop.pm
+lib/Font/TTF/Segarr.pm
+lib/Font/TTF/Table.pm
+lib/Font/TTF/Ttc.pm
+lib/Font/TTF/Ttopen.pm
+lib/Font/TTF/Useall.pm
+lib/Font/TTF/Utils.pm
+lib/Font/TTF/Vhea.pm
+lib/Font/TTF/Vmtx.pm
+lib/Font/TTF/Win32.pm
+lib/Font/TTF/XMLparse.pm
+lib/ttfmod.pl
+pmake.bat
+scripts/check_attach.plx
+scripts/eurofix.plx
+scripts/hackos2.plx
+scripts/psfix.plx
+scripts/ttfbuilder.plx
+scripts/ttfname.plx
+scripts/ttfremap.plx
Added: packages/libfont-ttf-perl/branches/upstream/current/MANIFEST.SKIP
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/MANIFEST.SKIP 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/MANIFEST.SKIP 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,11 @@
+blib/
+\.\$\$\$
+\.tmp
+\.bak
+CVS/
+\.tar
+misc/
+Build/
+exes/
+\.cvsignore
+^#
Added: packages/libfont-ttf-perl/branches/upstream/current/Make.PM
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Make.PM 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Make.PM 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,1321 @@
+package Make::Rule::Vars;
+use Carp;
+use strict;
+my $generation = 0; # lexical cross-package scope used!
+
+# Package to handle 'magic' variables pertaining to rules e.g. $@ $* $^ $?
+# by using tie to this package 'subsvars' can work with array of
+# hash references to possible sources of variable definitions.
+
+sub TIEHASH
+{
+ my ($class,$rule) = @_;
+ return bless \$rule,$class;
+}
+
+sub FETCH
+{
+ my $self = shift;
+ local $_ = shift;
+ my $rule = $$self;
+ return undef unless (/^[\@^<?*]$/);
+ # print STDERR "FETCH $_ for ",$rule->Name,"\n";
+ return $rule->Name if ($_ eq '@');
+ return $rule->Base if ($_ eq '*');
+ return join(' ',$rule->exp_depend) if ($_ eq '^');
+ return join(' ',$rule->out_of_date) if ($_ eq '?');
+ # Next one is dubious - I think $< is really more subtle ...
+ return ($rule->exp_depend)[0] if ($_ eq '<');
+ return undef;
+}
+
+package Make::Rule;
+use Carp;
+use strict;
+
+# Bottom level 'rule' package
+# An instance exists for each ':' or '::' rule in the makefile.
+# The commands and dependancies are kept here.
+
+sub target
+{
+ return shift->{TARGET};
+}
+
+sub Name
+{
+ return shift->target->Name;
+}
+
+sub Base
+{
+ my $name = shift->target->Name;
+ $name =~ s/\.[^.]+$//;
+ return $name;
+}
+
+sub Info
+{
+ return shift->target->Info;
+}
+
+sub depend
+{
+ my $self = shift;
+ if (@_)
+ {
+ my $name = $self->Name;
+ my $dep = shift;
+ confess "dependants $dep are not an array reference" unless ('ARRAY' eq ref $dep);
+ my $file;
+ foreach $file (@$dep)
+ {
+ unless (exists $self->{DEPHASH}{$file})
+ {
+ $self->{DEPHASH}{$file} = 1;
+ push(@{$self->{DEPEND}},$file);
+ }
+ }
+ }
+ return (wantarray) ? @{$self->{DEPEND}} : $self->{DEPEND};
+}
+
+sub command
+{
+ my $self = shift;
+ if (@_)
+ {
+ my $cmd = shift;
+ confess "commands $cmd are not an array reference" unless ('ARRAY' eq ref $cmd);
+ if (@$cmd)
+ {
+ if (@{$self->{COMMAND}})
+ {
+ warn "Command for ".$self->Name," redefined";
+ print STDERR "Was:",join("\n",@{$self->{COMMAND}}),"\n";
+ print STDERR "Now:",join("\n",@$cmd),"\n";
+ }
+ $self->{COMMAND} = $cmd;
+ }
+ else
+ {
+ if (@{$self->{COMMAND}})
+ {
+ # warn "Command for ".$self->Name," retained";
+ # print STDERR "Was:",join("\n",@{$self->{COMMAND}}),"\n";
+ }
+ }
+ }
+ return (wantarray) ? @{$self->{COMMAND}} : $self->{COMMAND};
+}
+
+#
+# The key make test - is target out-of-date as far as this rule is concerned
+# In scalar context - boolean value of 'do we need to apply the rule'
+# In list context the things we are out-of-date with e.g. magic $? variable
+#
+sub out_of_date
+{
+ my $array = wantarray;
+ my $self = shift;
+ my $info = $self->Info;
+ my @dep = ();
+ my $tdate = $self->target->date;
+ my $dep;
+ my $count = 0;
+ foreach $dep ($self->exp_depend)
+ {
+ my $date = $info->date($dep);
+ $count++;
+ if (!defined($date) || !defined($tdate) || $date < $tdate)
+ {
+ # warn $self->Name." ood wrt ".$dep."\n";
+ return 1 unless $array;
+ push(@dep,$dep);
+ }
+ }
+ return @dep if $array;
+ # Note special case of no dependencies means it is always out-of-date!
+ return !$count;
+}
+
+#
+# Return list of things rule depends on with variables expanded
+# - May need pathname and vpath processing as well
+#
+sub exp_depend
+{
+ my $self = shift;
+ my $info = $self->Info;
+ my @dep = map(split(/\s+/,$info->subsvars($_)),$self->depend);
+ return (wantarray) ? @dep : \@dep;
+}
+
+#
+# Return commands to apply rule with variables expanded
+# - No pathname processing needed, commands should always chdir()
+# to logical place (at least till we get very clever at bourne shell parsing).
+# - May need vpath processing
+#
+sub exp_command
+{
+ my $self = shift;
+ my $info = $self->Info;
+ my $base = $self->Name;
+ my %var;
+ tie %var,'Make::Rule::Vars',$self;
+ my @cmd = map($info->subsvars($_,\%var),$self->command);
+ return (wantarray) ? @cmd : \@cmd;
+}
+
+#
+# clone creates a new rule derived from an existing rule, but
+# with a different target. Used when left hand side was a variable.
+# perhaps should be used for dot/pattern rule processing too.
+#
+sub clone
+{
+ my ($self,$target) = @_;
+ my %hash = %$self;
+ $hash{TARGET} = $target;
+ $hash{DEPEND} = [@{$self->{DEPEND}}];
+ $hash{DEPHASH} = {%{$self->{DEPHASH}}};
+ my $obj = bless \%hash,ref $self;
+ return $obj;
+}
+
+sub new
+{
+ my $class = shift;
+ my $target = shift;
+ my $kind = shift;
+ my $self = bless { TARGET => $target, # parent target (left hand side)
+ KIND => $kind, # : or ::
+ DEPEND => [], DEPHASH => {}, # right hand args
+ COMMAND => [] # command(s)
+ },$class;
+ $self->depend(shift) if (@_);
+ $self->command(shift) if (@_);
+ return $self;
+}
+
+#
+# This code has to go somewhere but no good home obvious yet.
+# - only applies to ':' rules, but needs top level database
+# - perhaps in ->commands of derived ':' class?
+#
+sub find_commands
+{
+ my ($self) = @_;
+ if (!@{$self->{COMMAND}} && @{$self->{DEPEND}})
+ {
+ my $info = $self->Info;
+ my $name = $self->Name;
+ my @dep = $self->depend;
+ my @rule = $info->patrule($self->Name);
+ if (@rule)
+ {
+ $self->depend($rule[0]);
+ $self->command($rule[1]);
+ }
+ }
+}
+
+#
+# Spew a shell script to perfom the 'make' e.g. make -n
+#
+sub Script
+{
+ my $self = shift;
+ return unless $self->out_of_date;
+ my @cmd = $self->exp_command;
+ if (@cmd)
+ {
+ my $file;
+ my $com = ($^O eq 'MSWin32') ? 'rem ': '# ';
+ print $com,$self->Name,"\n";
+ foreach $file ($self->exp_command)
+ {
+ $file =~ s/^[\@\s-]*//;
+ print "$file\n";
+ }
+ }
+}
+
+#
+# Normal 'make' method
+#
+sub Make
+{
+ my $self = shift;
+ my $file;
+ return unless ($self->out_of_date);
+ my @cmd = $self->exp_command;
+ my $info = $self->Info;
+ if (@cmd)
+ {
+ foreach my $file ($self->exp_command)
+ {
+ $file =~ s/^([\@\s-]*)//;
+ my $prefix = $1;
+ print "$file\n" unless ($prefix =~ /\@/);
+ my $code = $info->exec($file);
+ if ($code && $prefix !~ /-/)
+ {
+ die "Code $code from $file";
+ }
+ }
+ }
+}
+
+#
+# Print rule out in makefile syntax
+# - currently has variables expanded as debugging aid.
+# - will eventually become make -p
+# - may be useful for writing makefiles from MakeMaker too...
+#
+sub Print
+{
+ my $self = shift;
+ my $file;
+ print $self->Name,' ',$self->{KIND},' ';
+ foreach $file ($self->depend)
+ {
+ print " \\\n $file";
+ }
+ print "\n";
+ my @cmd = $self->exp_command;
+ if (@cmd)
+ {
+ foreach $file ($self->exp_command)
+ {
+ print "\t",$file,"\n";
+ }
+ }
+ else
+ {
+ print STDERR "No commands for ",$self->Name,"\n" unless ($self->target->phony);
+ }
+ print "\n";
+}
+
+package Make::Target;
+use Carp;
+use strict;
+use Cwd;
+
+#
+# Intermediate 'target' package
+# There is an instance of this for each 'target' that apears on
+# the left hand side of a rule i.e. for each thing that can be made.
+#
+sub new
+{
+ my ($class,$info,$target) = @_;
+ return bless { NAME => $target, # name of thing
+ MAKEFILE => $info, # Makefile context
+ Pass => 0 # Used to determine if 'done' this sweep
+ },$class;
+}
+
+sub date
+{
+ my $self = shift;
+ my $info = $self->Info;
+ return $info->date($self->Name);
+}
+
+sub phony
+{
+ my $self = shift;
+ return $self->Info->phony($self->Name);
+}
+
+
+sub colon
+{
+ my $self = shift;
+ if (@_)
+ {
+ if (exists $self->{COLON})
+ {
+ my $dep = $self->{COLON};
+ if (@_ == 1)
+ {
+ # merging an existing rule
+ my $other = shift;
+ $dep->depend(scalar $other->depend);
+ $dep->command(scalar $other->command);
+ }
+ else
+ {
+ $dep->depend(shift);
+ $dep->command(shift);
+ }
+ }
+ else
+ {
+ $self->{COLON} = (@_ == 1) ? shift->clone($self) : Make::Rule->new($self,':', at _);
+ }
+ }
+ if (exists $self->{COLON})
+ {
+ return (wantarray) ? ($self->{COLON}) : $self->{COLON};
+ }
+ else
+ {
+ return (wantarray) ? () : undef;
+ }
+}
+
+sub dcolon
+{
+ my $self = shift;
+ if (@_)
+ {
+ my $rule = (@_ == 1) ? shift->clone($self) : Make::Rule->new($self,'::', at _);
+ $self->{DCOLON} = [] unless (exists $self->{DCOLON});
+ push(@{$self->{DCOLON}},$rule);
+ }
+ return (exists $self->{DCOLON}) ? @{$self->{DCOLON}} : ();
+}
+
+sub Name
+{
+ return shift->{NAME};
+}
+
+sub Info
+{
+ return shift->{MAKEFILE};
+}
+
+sub ProcessColon
+{
+ my ($self) = @_;
+ my $c = $self->colon;
+ $c->find_commands if $c;
+}
+
+sub ExpandTarget
+{
+ my ($self) = @_;
+ my $target = $self->Name;
+ my $info = $self->Info;
+ my $colon = delete $self->{COLON};
+ my $dcolon = delete $self->{DCOLON};
+ foreach my $expand (split(/\s+/,$info->subsvars($target)))
+ {
+ next unless defined($expand);
+ my $t = $info->Target($expand);
+ if (defined $colon)
+ {
+ $t->colon($colon);
+ }
+ foreach my $d (@{$dcolon})
+ {
+ $t->dcolon($d);
+ }
+ }
+}
+
+sub done
+{
+ my $self = shift;
+ my $info = $self->Info;
+ my $pass = $info->pass;
+ return 1 if ($self->{Pass} == $pass);
+ $self->{Pass} = $pass;
+ return 0;
+}
+
+sub recurse
+{
+ my ($self,$method, at args) = @_;
+ my $info = $self->Info;
+ my $rule;
+ my $i = 0;
+ foreach $rule ($self->colon,$self->dcolon)
+ {
+ my $dep;
+ my $j = 0;
+ foreach $dep ($rule->exp_depend)
+ {
+ my $t = $info->{Depend}{$dep};
+ if (defined $t)
+ {
+ $t->$method(@args)
+ }
+ else
+ {
+ unless ($info->exists($dep))
+ {
+ my $dir = cwd();
+ die "Cannot recurse $method - no target $dep in $dir"
+ }
+ }
+ }
+ }
+}
+
+sub Script
+{
+ my $self = shift;
+ my $info = $self->Info;
+ my $rule = $self->colon;
+ return if ($self->done);
+ $self->recurse('Script');
+ foreach $rule ($self->colon,$self->dcolon)
+ {
+ $rule->Script;
+ }
+}
+
+sub Make
+{
+ my $self = shift;
+ my $info = $self->Info;
+ my $rule = $self->colon;
+ return if ($self->done);
+ $self->recurse('Make');
+ foreach $rule ($self->colon,$self->dcolon)
+ {
+ $rule->Make;
+ }
+}
+
+sub Print
+{
+ my $self = shift;
+ my $info = $self->Info;
+ return if ($self->done);
+ my $rule = $self->colon;
+ foreach $rule ($self->colon,$self->dcolon)
+ {
+ $rule->Print;
+ }
+ $self->recurse('Print');
+}
+
+package Make;
+use 5.005; # Need look-behind assertions
+use Carp;
+use strict;
+use Config;
+use Cwd;
+use File::Spec;
+use vars qw($VERSION);
+$VERSION = '1.00';
+
+my %date;
+
+sub phony
+{
+ my ($self,$name) = @_;
+ return exists $self->{PHONY}{$name};
+}
+
+sub suffixes
+{
+ my ($self) = @_;
+ return keys %{$self->{'SUFFIXES'}};
+}
+
+#
+# Construct a new 'target' (or find old one)
+# - used by parser to add to data structures
+#
+sub Target
+{
+ my ($self,$target) = @_;
+ unless (exists $self->{Depend}{$target})
+ {
+ my $t = Make::Target->new($self,$target);
+ $self->{Depend}{$target} = $t;
+ if ($target =~ /%/)
+ {
+ $self->{Pattern}{$target} = $t;
+ }
+ elsif ($target =~ /^\./)
+ {
+ $self->{Dot}{$target} = $t;
+ }
+ else
+ {
+ push(@{$self->{Targets}},$t);
+ }
+ }
+ return $self->{Depend}{$target};
+}
+
+#
+# Utility routine for patching %.o type 'patterns'
+#
+sub patmatch
+{
+ my $key = shift;
+ local $_ = shift;
+ my $pat = $key;
+ $pat =~ s/\./\\./;
+ $pat =~ s/%/(\[^\/\]*)/;
+ if (/$pat$/)
+ {
+ return $1;
+ }
+ return undef;
+}
+
+#
+# old vpath lookup routine
+#
+sub locate
+{
+ my $self = shift;
+ local $_ = shift;
+ return $_ if (-r $_);
+ my $key;
+ foreach $key (keys %{$self->{vpath}})
+ {
+ my $Pat;
+ if (defined($Pat = patmatch($key,$_)))
+ {
+ my $dir;
+ foreach $dir (split(/:/,$self->{vpath}{$key}))
+ {
+ return "$dir/$_" if (-r "$dir/$_");
+ }
+ }
+ }
+ return undef;
+}
+
+#
+# Convert traditional .c.o rules into GNU-like into %o : %c
+#
+sub dotrules
+{
+ my ($self) = @_;
+ my $t;
+ foreach $t (keys %{$self->{Dot}})
+ {
+ my $e = $self->subsvars($t);
+ $self->{Dot}{$e} = delete $self->{Dot}{$t} unless ($t eq $e);
+ }
+ my (@suffix) = $self->suffixes;
+ foreach $t (@suffix)
+ {
+ my $d;
+ my $r = delete $self->{Dot}{$t};
+ if (defined $r)
+ {
+ my @rule = ($r->colon) ? ($r->colon->depend) : ();
+ if (@rule)
+ {
+ delete $self->{Dot}{$t->Name};
+ print STDERR $t->Name," has dependants\n";
+ push(@{$self->{Targets}},$r);
+ }
+ else
+ {
+ # print STDERR "Build \% : \%$t\n";
+ $self->Target('%')->dcolon(['%'.$t],scalar $r->colon->command);
+ }
+ }
+ foreach $d (@suffix)
+ {
+ $r = delete $self->{Dot}{$t.$d};
+ if (defined $r)
+ {
+ # print STDERR "Build \%$d : \%$t\n";
+ $self->Target('%'.$d)->dcolon(['%'.$t],scalar $r->colon->command);
+ }
+ }
+ }
+ foreach $t (keys %{$self->{Dot}})
+ {
+ push(@{$self->{Targets}},delete $self->{Dot}{$t});
+ }
+}
+
+#
+# Return 'full' pathname of name given directory info.
+# - may be the place to do vpath stuff ?
+#
+
+my %pathname;
+
+sub pathname
+{
+ my ($self,$name) = @_;
+ my $hash = $self->{'Pathname'};
+ unless (exists $hash->{$name})
+ {
+ if (File::Spec->file_name_is_absolute($name))
+ {
+ $hash->{$name} = $name;
+ }
+ else
+ {
+ $name =~ s,^\./,,;
+ $hash->{$name} = File::Spec->catfile($self->{Dir},$name);
+ }
+ }
+ return $hash->{$name};
+
+}
+
+#
+# Return modified date of name if it exists
+#
+sub date
+{
+ my ($self,$name) = @_;
+ my $path = $self->pathname($name);
+ unless (exists $date{$path})
+ {
+ $date{$path} = -M $path;
+ }
+ return $date{$path};
+}
+
+#
+# Check to see if name is a target we can make or an existing
+# file - used to see if pattern rules are valid
+# - Needs extending to do vpath lookups
+#
+sub exists
+{
+ my ($self,$name) = @_;
+ return 1 if (exists $self->{Depend}{$name});
+ return 1 if defined $self->date($name);
+ # print STDERR "$name '$path' does not exist\n";
+ return 0;
+}
+
+#
+# See if we can find a %.o : %.c rule for target
+# .c.o rules are already converted to this form
+#
+sub patrule
+{
+ my ($self,$target) = @_;
+ my $key;
+ # print STDERR "Trying pattern for $target\n";
+ foreach $key (keys %{$self->{Pattern}})
+ {
+ my $Pat;
+ if (defined($Pat = patmatch($key,$target)))
+ {
+ my $t = $self->{Pattern}{$key};
+ my $rule;
+ foreach $rule ($t->dcolon)
+ {
+ my @dep = $rule->exp_depend;
+ if (@dep)
+ {
+ my $dep = $dep[0];
+ $dep =~ s/%/$Pat/g;
+ # print STDERR "Try $target : $dep\n";
+ if ($self->exists($dep))
+ {
+ foreach (@dep)
+ {
+ s/%/$Pat/g;
+ }
+ return (\@dep,scalar $rule->command);
+ }
+ }
+ }
+ }
+ }
+ return ();
+}
+
+#
+# Old code to handle vpath stuff - not used yet
+#
+sub needs
+{my ($self,$target) = @_;
+ unless ($self->{Done}{$target})
+ {
+ if (exists $self->{Depend}{$target})
+ {
+ my @depend = split(/\s+/,$self->subsvars($self->{Depend}{$target}));
+ foreach (@depend)
+ {
+ $self->needs($_);
+ }
+ }
+ else
+ {
+ my $vtarget = $self->locate($target);
+ if (defined $vtarget)
+ {
+ $self->{Need}{$vtarget} = $target;
+ }
+ else
+ {
+ $self->{Need}{$target} = $target;
+ }
+ }
+ }
+}
+
+#
+# Substitute $(xxxx) and $x style variable references
+# - should handle ${xxx} as well
+# - recurses till they all go rather than doing one level,
+# which may need fixing
+#
+sub subsvars
+{
+ my $self = shift;
+ local $_ = shift;
+ my @var = @_;
+ push(@var,$self->{Override},$self->{Vars},\%ENV);
+ croak("Trying to subsitute undef value") unless (defined $_);
+ while (/(?<!\$)\$\(([^()]+)\)/ || /(?<!\$)\$([<\@^?*])/)
+ {
+ my ($key,$head,$tail) = ($1,$`,$');
+ my $value;
+ if ($key =~ /^([\w._]+|\S)(?::(.*))?$/)
+ {
+ my ($var,$op) = ($1,$2);
+ foreach my $hash (@var)
+ {
+ $value = $hash->{$var};
+ if (defined $value)
+ {
+ last;
+ }
+ }
+ unless (defined $value)
+ {
+ die "$var not defined in '$_'" unless (length($var) > 1);
+ $value = '';
+ }
+ if (defined $op)
+ {
+ if ($op =~ /^s(.).*\1.*\1/)
+ {
+ local $_ = $self->subsvars($value);
+ $op =~ s/\\/\\\\/g;
+ eval $op.'g';
+ $value = $_;
+ }
+ else
+ {
+ die "$var:$op = '$value'\n";
+ }
+ }
+ }
+ elsif ($key =~ /wildcard\s*(.*)$/)
+ {
+ $value = join(' ',glob($self->pathname($1)));
+ }
+ elsif ($key =~ /shell\s*(.*)$/)
+ {
+ $value = join(' ',split('\n',`$1`));
+ }
+ elsif ($key =~ /addprefix\s*([^,]*),(.*)$/)
+ {
+ $value = join(' ',map($1 . $_,split('\s+',$2)));
+ }
+ elsif ($key =~ /notdir\s*(.*)$/)
+ {
+ my @files = split(/\s+/,$1);
+ foreach (@files)
+ {
+ s#^.*/([^/]*)$#$1#;
+ }
+ $value = join(' ', at files);
+ }
+ elsif ($key =~ /dir\s*(.*)$/)
+ {
+ my @files = split(/\s+/,$1);
+ foreach (@files)
+ {
+ s#^(.*)/[^/]*$#$1#;
+ }
+ $value = join(' ', at files);
+ }
+ elsif ($key =~ /^subst\s+([^,]*),([^,]*),(.*)$/)
+ {
+ my ($a,$b) = ($1,$2);
+ $value = $3;
+ $a =~ s/\./\\./;
+ $value =~ s/$a/$b/;
+ }
+ elsif ($key =~ /^mktmp,(\S+)\s*(.*)$/)
+ {
+ my ($file,$content) = ($1,$2);
+ open(TMP,">$file") || die "Cannot open $file:$!";
+ $content =~ s/\\n//g;
+ print TMP $content;
+ close(TMP);
+ $value = $file;
+ }
+ else
+ {
+ warn "Cannot evaluate '$key' in '$_'\n";
+ }
+ $_ = "$head$value$tail";
+ }
+ s/\$\$/\$/g;
+ return $_;
+}
+
+#
+# Split a string into tokens - like split(/\s+/,...) but handling
+# $(keyword ...) with embedded \s
+# Perhaps should also understand "..." and '...' ?
+#
+sub tokenize
+{
+ local $_ = $_[0];
+ my @result = ();
+ s/\s+$//;
+ while (length($_))
+ {
+ s/^\s+//;
+ last unless (/^\S/);
+ my $token = "";
+ while (/^\S/)
+ {
+ if (s/^\$([\(\{])//)
+ {
+ $token .= $&;
+ my $paren = $1 eq '(';
+ my $brace = $1 eq '{';
+ my $count = 1;
+ while (length($_) && ($paren || $brace))
+ {
+ s/^.//;
+ $token .= $&;
+ $paren += ($& eq '(');
+ $paren -= ($& eq ')');
+ $brace += ($& eq '{');
+ $brace -= ($& eq '}');
+ }
+ die "Mismatched {} in $_[0]" if ($brace);
+ die "Mismatched () in $_[0]" if ($paren);
+ }
+ elsif (s/^(\$\S?|[^\s\$]+)//)
+ {
+ $token .= $&;
+ }
+ }
+ push(@result,$token);
+ }
+ return (wantarray) ? @result : \@result;
+}
+
+
+#
+# read makefile (or fragment of one) either as a result
+# of a command line, or an 'include' in another makefile.
+#
+sub makefile
+{
+ my ($self,$makefile,$name) = @_;
+ local $_;
+ print STDERR "Reading $name\n";
+Makefile:
+ while (<$makefile>)
+ {
+ last unless (defined $_);
+ chomp($_);
+ if (/\\$/)
+ {
+ chop($_);
+ s/\s*$//;
+ my $more = <$makefile>;
+ $more =~ s/^\s*/ /;
+ $_ .= $more;
+ redo;
+ }
+ next if (/^\s*#/);
+ next if (/^\s*$/);
+ s/#.*$//;
+ s/^\s+//;
+ if (/^(-?)include\s+(.*)$/)
+ {
+ my $opt = $1;
+ my $file;
+ foreach $file (tokenize($self->subsvars($2)))
+ {
+ local *Makefile;
+ my $path = $self->pathname($file);
+ if (open(Makefile,"<$path"))
+ {
+ $self->makefile(\*Makefile,$path);
+ close(Makefile);
+ }
+ else
+ {
+ warn "Cannot open $path:$!" unless ($opt eq '-') ;
+ }
+ }
+ }
+ elsif (/^\s*([\w._]+)\s*:?=\s*(.*)$/)
+ {
+ $self->{Vars}{$1} = (defined $2) ? $2 : "";
+# print STDERR "$1 = ",$self->{Vars}{$1},"\n";
+ }
+ elsif (/^vpath\s+(\S+)\s+(.*)$/)
+ {my ($pat,$path) = ($1,$2);
+ $self->{Vpath}{$pat} = $path;
+ }
+ elsif (/^\s*([^:]*)(::?)\s*(.*)$/)
+ {
+ my ($target,$kind,$depend) = ($1,$2,$3);
+ my @cmnds;
+ if ($depend =~ /^([^;]*);(.*)$/)
+ {
+ ($depend,$cmnds[0]) = ($1,$2);
+ }
+ while (<$makefile>)
+ {
+ next if (/^\s*#/);
+ next if (/^\s*$/);
+ last unless (/^\t/);
+ chop($_);
+ if (/\\$/)
+ {
+ chop($_);
+ $_ .= ' ';
+ $_ .= <$makefile>;
+ redo;
+ }
+ next if (/^\s*$/);
+ s/^\s+//;
+ push(@cmnds,$_);
+ }
+ $depend =~ s/\s\s+/ /;
+ $target =~ s/\s\s+/ /;
+ my @depend = tokenize($depend);
+ foreach (tokenize($target))
+ {
+ my $t = $self->Target($_);
+ my $index = 0;
+ if ($kind eq '::' || /%/)
+ {
+ $t->dcolon(\@depend,\@cmnds);
+ }
+ else
+ {
+ $t->colon(\@depend,\@cmnds);
+ }
+ }
+ redo Makefile;
+ }
+ else
+ {
+ warn "Ignore '$_'\n";
+ }
+ }
+}
+
+sub pseudos
+{
+ my $self = shift;
+ my $key;
+ foreach $key (qw(SUFFIXES PHONY PRECIOUS PARALLEL))
+ {
+ my $t = delete $self->{Dot}{'.'.$key};
+ if (defined $t)
+ {
+ my $dep;
+ $self->{$key} = {};
+ foreach $dep ($t->colon->exp_depend)
+ {
+ $self->{$key}{$dep} = 1;
+ }
+ }
+ }
+}
+
+
+sub ExpandTarget
+{
+ my $self = shift;
+ foreach my $t (@{$self->{'Targets'}})
+ {
+ $t->ExpandTarget;
+ }
+ foreach my $t (@{$self->{'Targets'}})
+ {
+ $t->ProcessColon;
+ }
+}
+
+sub parse
+{
+ my ($self,$file) = @_;
+ if (defined $file)
+ {
+ $file = $self->pathname($file);
+ }
+ else
+ {
+ my @files = qw(makefile Makefile);
+ unshift(@files,'GNUmakefile') if ($self->{GNU});
+ my $name;
+ foreach $name (@files)
+ {
+ $file = $self->pathname($name);
+ if (-r $file)
+ {
+ $self->{Makefile} = $name;
+ last;
+ }
+ }
+ }
+ local (*Makefile);
+ open(Makefile,"<$file") || croak("Cannot open $file:$!");
+ $self->makefile(\*Makefile,$file);
+ close(Makefile);
+
+ # Next bits should really be done 'lazy' on need.
+
+ $self->pseudos; # Pull out .SUFFIXES etc.
+ $self->dotrules; # Convert .c.o into %.o : %.c
+}
+
+sub PrintVars
+{
+ my $self = shift;
+ local $_;
+ foreach (keys %{$self->{Vars}})
+ {
+ print "$_ = ",$self->{Vars}{$_},"\n";
+ }
+ print "\n";
+}
+
+sub exec
+{
+ my $self = shift;
+ undef %date;
+ $generation++;
+ if ($^O eq 'MSWin32')
+ {
+ my $cwd = cwd();
+ my $ret;
+ chdir $self->{Dir};
+ $ret = system(@_);
+ chdir $cwd;
+ return $ret;
+ }
+ else
+ {
+ my $pid = fork;
+ if ($pid)
+ {
+ waitpid $pid,0;
+ return $?;
+ }
+ else
+ {
+ my $dir = $self->{Dir};
+ chdir($dir) || die "Cannot cd to $dir";
+ # handle leading VAR=value here ?
+ # To handle trivial cases like ': libpTk.a' force using /bin/sh
+ exec("/bin/sh","-c", at _) || confess "Cannot exec ".join(' ', at _);
+ }
+ }
+}
+
+sub NextPass { shift->{Pass}++ }
+sub pass { shift->{Pass} }
+
+sub apply
+{
+ my $self = shift;
+ my $method = shift;
+ $self->NextPass;
+ my @targets = ();
+ # print STDERR join(' ',Apply => $method, at _),"\n";
+ foreach (@_)
+ {
+ if (/^(\w+)=(.*)$/)
+ {
+ # print STDERR "OVERRIDE: $1 = $2\n";
+ $self->{Override}{$1} = $2;
+ }
+ else
+ {
+ push(@targets,$_);
+ }
+ }
+ #
+ # This expansion is dubious as it alters the database
+ # as a function of current values of Override.
+ #
+ $self->ExpandTarget; # Process $(VAR) :
+ @targets = ($self->{'Targets'}[0])->Name unless (@targets);
+ # print STDERR join(' ',Targets => $method,map($_->Name, at targets)),"\n";
+ foreach (@targets)
+ {
+ my $t = $self->{Depend}{$_};
+ unless (defined $t)
+ {
+ print STDERR join(' ',$method, at _),"\n";
+ die "Cannot `$method' - no target $_"
+ }
+ $t->$method();
+ }
+}
+
+sub Script
+{
+ shift->apply(Script => @_);
+}
+
+sub Print
+{
+ shift->apply(Print => @_);
+}
+
+sub Make
+{
+ shift->apply(Make => @_);
+}
+
+sub new
+{
+ my ($class,%args) = @_;
+ unless (defined $args{Dir})
+ {
+ chomp($args{Dir} = getcwd());
+ }
+ my $self = bless { %args,
+ Pattern => {}, # GNU style %.o : %.c
+ Dot => {}, # Trad style .c.o
+ Vpath => {}, # vpath %.c info
+ Vars => {}, # Variables defined in makefile
+ Depend => {}, # hash of targets
+ Targets => [], # ordered version so we can find 1st one
+ Pass => 0, # incremented each sweep
+ Pathname => {}, # cache of expanded names
+ Need => {},
+ Done => {},
+ },$class;
+ $self->{Vars}{CC} = $Config{cc};
+ $self->{Vars}{AR} = $Config{ar};
+ $self->{Vars}{CFLAGS} = $Config{optimize};
+ $self->makefile(\*DATA,__FILE__);
+ $self->parse($self->{Makefile});
+ return $self;
+}
+
+=head1 NAME
+
+Make - module for processing makefiles
+
+=head1 SYNOPSIS
+
+ require Make;
+ my $make = Make->new(...);
+ $make->parse($file);
+ $make->Script(@ARGV)
+ $make->Make(@ARGV)
+ $make->Print(@ARGV)
+
+ my $targ = $make->Target($name);
+ $targ->colon([dependancy...],[command...]);
+ $targ->dolon([dependancy...],[command...]);
+ my @depends = $targ->colon->depend;
+ my @commands = $targ->colon->command;
+
+=head1 DESCRIPTION
+
+Make->new creates an object if C<new(Makefile =E<gt> $file)> is specified
+then it is parsed. If not the usual makefile Makefile sequence is
+used. (If GNU => 1 is passed to new then GNUmakefile is looked for first.)
+
+C<$make-E<gt>Make(target...)> 'makes' the target(s) specified
+(or the first 'real' target in the makefile).
+
+C<$make-E<gt>Print> can be used to 'print' to current C<select>'ed stream
+a form of the makefile with all variables expanded.
+
+C<$make-E<gt>Script(target...)> can be used to 'print' to
+current C<select>'ed stream the equivalent bourne shell script
+that a make would perform i.e. the output of C<make -n>.
+
+There are other methods (used by parse) which can be used to add and
+manipulate targets and their dependants. There is a hierarchy of classes
+which is still evolving. These classes and their methods will be documented when
+they are a little more stable.
+
+The syntax of makefile accepted is reasonably generic, but I have not re-read
+any documentation yet, rather I have implemented my own mental model of how
+make works (then fixed it...).
+
+In addition to traditional
+
+ .c.o :
+ $(CC) -c ...
+
+GNU make's 'pattern' rules e.g.
+
+ %.o : %.c
+ $(CC) -c ...
+
+Likewise a subset of GNU makes $(function arg...) syntax is supported.
+
+Via pmake Make has built perl/Tk from the C<MakeMaker> generated Makefiles...
+
+=head1 BUGS
+
+At present C<new> must always find a makefile, and
+C<$make-E<gt>parse($file)> can only be used to augment that file.
+
+More attention needs to be given to using the package to I<write> makefiles.
+
+The rules for matching 'dot rules' e.g. .c.o and/or pattern rules e.g. %.o : %.c
+are suspect. For example give a choice of .xs.o vs .xs.c + .c.o behaviour
+seems a little odd.
+
+Variables are probably substituted in different 'phases' of the process
+than in make(1) (or even GNU make), so 'clever' uses will probably not
+work.
+
+UNIXisms abound.
+
+=head1 SEE ALSO
+
+L<pmake>
+
+=head1 AUTHOR
+
+Nick Ing-Simmons
+
+=cut
+
+1;
+#
+# Remainder of file is in makefile syntax and constitutes
+# the built in rules
+#
+__DATA__
+
+.SUFFIXES: .o .c .y .h .sh .cps
+
+.c.o :
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ $<
+
+.c :
+ $(CC) $(CFLAGS) $(CPPFLAGS) -o $@ $< $(LDFLAGS) $(LDLIBS)
+
+.y.o:
+ $(YACC) $<
+ $(CC) $(CFLAGS) $(CPPFLAGS) -c -o $@ y.tab.c
+ $(RM) y.tab.c
+
+.y.c:
+ $(YACC) $<
+ mv y.tab.c $@
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Makefile
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Makefile 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Makefile 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,921 @@
+# This Makefile is for the Font::TTF extension to perl.
+#
+# It was generated automatically by MakeMaker version
+# 5.45 (Revision: 1.222) from the contents of
+# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
+#
+# ANY CHANGES MADE HERE WILL BE LOST!
+#
+# MakeMaker ARGV: ()
+#
+# MakeMaker Parameters:
+
+# ABSTRACT => q[TTF font support for Perl]
+# AUTHOR => q[martin_hosken at sil.org]
+# EXE_FILES => [q[scripts/check_attach.plx], q[scripts/eurofix.plx], q[scripts/hackos2.plx], q[scripts/psfix.plx], q[scripts/ttfbuilder.plx], q[scripts/ttfname.plx], q[scripts/ttfremap.plx]]
+# NAME => q[Font::TTF]
+# VERSION_FROM => q[lib/Font/TTF/Font.pm]
+# dist => { TO_UNIX=>q[perl -Mtounix -e "tounix(\"$(DISTVNAME)\")"] }
+
+# --- MakeMaker post_initialize section:
+
+
+# --- MakeMaker const_config section:
+
+# These definitions are from config.sh (via D:/Progs/Perl/lib/Config.pm)
+
+# They may have been overridden via Makefile.PL or on the command line
+AR = lib
+CC = cl
+CCCDLFLAGS =
+CCDLFLAGS =
+DLEXT = dll
+DLSRC = dl_win32.xs
+LD = link
+LDDLFLAGS = -dll -nologo -nodefaultlib -release -libpath:"D:\Progs\Perl\lib\CORE" -machine:x86
+LDFLAGS = -nologo -nodefaultlib -release -libpath:"D:\Progs\Perl\lib\CORE" -machine:x86
+LIBC = msvcrt.lib
+LIB_EXT = .lib
+OBJ_EXT = .obj
+OSNAME = MSWin32
+OSVERS = 4.0
+RANLIB = rem
+SO = dll
+EXE_EXT = .exe
+FULL_AR =
+
+
+# --- MakeMaker constants section:
+AR_STATIC_ARGS = cr
+NAME = Font::TTF
+DISTNAME = Font-TTF
+NAME_SYM = Font_TTF
+VERSION = 0.34
+VERSION_SYM = 0_34
+XS_VERSION = 0.34
+INST_BIN = blib\bin
+INST_EXE = blib\script
+INST_LIB = blib\lib
+INST_ARCHLIB = blib\arch
+INST_SCRIPT = blib\script
+PREFIX = D:\Progs\Perl
+INSTALLDIRS = site
+INSTALLPRIVLIB = $(PREFIX)\lib
+INSTALLARCHLIB = $(PREFIX)\lib
+INSTALLSITELIB = D:\Progs\Perl\site\lib
+INSTALLSITEARCH = D:\Progs\Perl\site\lib
+INSTALLBIN = $(PREFIX)\bin
+INSTALLSCRIPT = $(PREFIX)\bin
+PERL_LIB = D:\Progs\Perl\lib
+PERL_ARCHLIB = D:\Progs\Perl\lib
+SITELIBEXP = D:\Progs\Perl\site\lib
+SITEARCHEXP = D:\Progs\Perl\site\lib
+LIBPERL_A = libperl.lib
+FIRST_MAKEFILE = Makefile
+MAKE_APERL_FILE = Makefile.aperl
+PERLMAINCC = $(CC)
+PERL_INC = D:\Progs\Perl\lib\CORE
+PERL = D:\Progs\Perl\bin\Perl.exe
+FULLPERL = D:\Progs\Perl\bin\Perl.exe
+
+VERSION_MACRO = VERSION
+DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\"
+XS_VERSION_MACRO = XS_VERSION
+XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"
+
+MAKEMAKER =
+MM_VERSION = 5.45
+
+# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
+# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!!
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+FULLEXT = Font\TTF
+BASEEXT = TTF
+PARENT_NAME = Font
+DLBASE = $(BASEEXT)
+VERSION_FROM = lib/Font/TTF/Font.pm
+OBJECT =
+LDFROM = $(OBJECT)
+LINKTYPE = dynamic
+
+# Handy lists of source code files:
+XS_FILES=
+C_FILES =
+O_FILES =
+H_FILES =
+HTMLLIBPODS =
+HTMLSCRIPTPODS =
+MAN1PODS =
+MAN3PODS =
+HTMLEXT = html
+INST_MAN1DIR =
+INSTALLMAN1DIR =
+MAN1EXT = 1
+INST_MAN3DIR =
+INSTALLMAN3DIR =
+MAN3EXT = 3
+
+# work around a famous dec-osf make(1) feature(?):
+makemakerdflt: all
+
+.SUFFIXES: .xs .c .C .cpp .cxx .cc $(OBJ_EXT)
+
+# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
+# some make implementations will delete the Makefile when we rebuild it. Because
+# we call false(1) when we rebuild it. So make(1) is not completely wrong when it
+# does so. Our milage may vary.
+# .PRECIOUS: Makefile # seems to be not necessary anymore
+
+.PHONY: all config static dynamic test linkext manifest
+
+# Where is the Config information that we are using/depend on
+CONFIGDEP = $(PERL_ARCHLIB)\Config.pm $(PERL_INC)\config.h
+
+# Where to put things:
+INST_LIBDIR = $(INST_LIB)\Font
+INST_ARCHLIBDIR = $(INST_ARCHLIB)\Font
+
+INST_AUTODIR = $(INST_LIB)\auto\$(FULLEXT)
+INST_ARCHAUTODIR = $(INST_ARCHLIB)\auto\$(FULLEXT)
+
+INST_STATIC =
+INST_DYNAMIC =
+INST_BOOT =
+
+EXPORT_LIST = TTF.def
+
+PERL_ARCHIVE = $(PERL_INC)\perl56.lib
+
+TO_INST_PM = lib/Font/TTF/AATKern.pm \
+ lib/Font/TTF/AATutils.pm \
+ lib/Font/TTF/Anchor.pm \
+ lib/Font/TTF/Bsln.pm \
+ lib/Font/TTF/Changes \
+ lib/Font/TTF/Cmap.pm \
+ lib/Font/TTF/Coverage.pm \
+ lib/Font/TTF/Cvt_.pm \
+ lib/Font/TTF/Delta.pm \
+ lib/Font/TTF/Fdsc.pm \
+ lib/Font/TTF/Feat.pm \
+ lib/Font/TTF/Fmtx.pm \
+ lib/Font/TTF/Font.pm \
+ lib/Font/TTF/Fpgm.pm \
+ lib/Font/TTF/GDEF.pm \
+ lib/Font/TTF/GPOS.pm \
+ lib/Font/TTF/GSUB.pm \
+ lib/Font/TTF/Glyf.pm \
+ lib/Font/TTF/Glyph.pm \
+ lib/Font/TTF/Hdmx.pm \
+ lib/Font/TTF/Head.pm \
+ lib/Font/TTF/Hhea.pm \
+ lib/Font/TTF/Hmtx.pm \
+ lib/Font/TTF/Kern.pm \
+ lib/Font/TTF/Kern/ClassArray.pm \
+ lib/Font/TTF/Kern/CompactClassArray.pm \
+ lib/Font/TTF/Kern/OrderedList.pm \
+ lib/Font/TTF/Kern/StateTable.pm \
+ lib/Font/TTF/Kern/Subtable.pm \
+ lib/Font/TTF/LTSH.pm \
+ lib/Font/TTF/Loca.pm \
+ lib/Font/TTF/Manual.pod \
+ lib/Font/TTF/Maxp.pm \
+ lib/Font/TTF/Mort.pm \
+ lib/Font/TTF/Mort/Chain.pm \
+ lib/Font/TTF/Mort/Contextual.pm \
+ lib/Font/TTF/Mort/Insertion.pm \
+ lib/Font/TTF/Mort/Ligature.pm \
+ lib/Font/TTF/Mort/Noncontextual.pm \
+ lib/Font/TTF/Mort/Rearrangement.pm \
+ lib/Font/TTF/Mort/Subtable.pm \
+ lib/Font/TTF/Name.pm \
+ lib/Font/TTF/OS_2.pm \
+ lib/Font/TTF/OldCmap.pm \
+ lib/Font/TTF/OldMort.pm \
+ lib/Font/TTF/PCLT.pm \
+ lib/Font/TTF/PSNames.pm \
+ lib/Font/TTF/Post.pm \
+ lib/Font/TTF/Prep.pm \
+ lib/Font/TTF/Prop.pm \
+ lib/Font/TTF/Segarr.pm \
+ lib/Font/TTF/Table.pm \
+ lib/Font/TTF/Ttc.pm \
+ lib/Font/TTF/Ttopen.pm \
+ lib/Font/TTF/Useall.pm \
+ lib/Font/TTF/Utils.pm \
+ lib/Font/TTF/Vhea.pm \
+ lib/Font/TTF/Vmtx.pm \
+ lib/Font/TTF/Win32.pm \
+ lib/Font/TTF/XMLparse.pm \
+ lib/ttfmod.pl
+
+PM_TO_BLIB = lib/Font/TTF/Kern/ClassArray.pm \
+ $(INST_LIB)\Font\TTF\Kern\ClassArray.pm \
+ lib/Font/TTF/Anchor.pm \
+ $(INST_LIB)\Font\TTF\Anchor.pm \
+ lib/Font/TTF/Head.pm \
+ $(INST_LIB)\Font\TTF\Head.pm \
+ lib/Font/TTF/PCLT.pm \
+ $(INST_LIB)\Font\TTF\PCLT.pm \
+ lib/Font/TTF/Mort/Rearrangement.pm \
+ $(INST_LIB)\Font\TTF\Mort\Rearrangement.pm \
+ lib/Font/TTF/Vmtx.pm \
+ $(INST_LIB)\Font\TTF\Vmtx.pm \
+ lib/Font/TTF/Mort/Noncontextual.pm \
+ $(INST_LIB)\Font\TTF\Mort\Noncontextual.pm \
+ lib/Font/TTF/Mort/Chain.pm \
+ $(INST_LIB)\Font\TTF\Mort\Chain.pm \
+ lib/Font/TTF/Bsln.pm \
+ $(INST_LIB)\Font\TTF\Bsln.pm \
+ lib/Font/TTF/Post.pm \
+ $(INST_LIB)\Font\TTF\Post.pm \
+ lib/Font/TTF/Cvt_.pm \
+ $(INST_LIB)\Font\TTF\Cvt_.pm \
+ lib/Font/TTF/Maxp.pm \
+ $(INST_LIB)\Font\TTF\Maxp.pm \
+ lib/Font/TTF/OS_2.pm \
+ $(INST_LIB)\Font\TTF\OS_2.pm \
+ lib/Font/TTF/Ttc.pm \
+ $(INST_LIB)\Font\TTF\Ttc.pm \
+ lib/Font/TTF/Win32.pm \
+ $(INST_LIB)\Font\TTF\Win32.pm \
+ lib/Font/TTF/Fmtx.pm \
+ $(INST_LIB)\Font\TTF\Fmtx.pm \
+ lib/Font/TTF/Name.pm \
+ $(INST_LIB)\Font\TTF\Name.pm \
+ lib/Font/TTF/Delta.pm \
+ $(INST_LIB)\Font\TTF\Delta.pm \
+ lib/Font/TTF/Kern/CompactClassArray.pm \
+ $(INST_LIB)\Font\TTF\Kern\CompactClassArray.pm \
+ lib/Font/TTF/Mort.pm \
+ $(INST_LIB)\Font\TTF\Mort.pm \
+ lib/Font/TTF/Utils.pm \
+ $(INST_LIB)\Font\TTF\Utils.pm \
+ lib/Font/TTF/Loca.pm \
+ $(INST_LIB)\Font\TTF\Loca.pm \
+ lib/Font/TTF/Fpgm.pm \
+ $(INST_LIB)\Font\TTF\Fpgm.pm \
+ lib/Font/TTF/Kern/Subtable.pm \
+ $(INST_LIB)\Font\TTF\Kern\Subtable.pm \
+ lib/Font/TTF/GPOS.pm \
+ $(INST_LIB)\Font\TTF\GPOS.pm \
+ lib/Font/TTF/OldMort.pm \
+ $(INST_LIB)\Font\TTF\OldMort.pm \
+ lib/Font/TTF/Vhea.pm \
+ $(INST_LIB)\Font\TTF\Vhea.pm \
+ lib/Font/TTF/Manual.pod \
+ $(INST_LIB)\Font\TTF\Manual.pod \
+ lib/Font/TTF/Ttopen.pm \
+ $(INST_LIB)\Font\TTF\Ttopen.pm \
+ lib/Font/TTF/Cmap.pm \
+ $(INST_LIB)\Font\TTF\Cmap.pm \
+ lib/Font/TTF/Prop.pm \
+ $(INST_LIB)\Font\TTF\Prop.pm \
+ lib/Font/TTF/LTSH.pm \
+ $(INST_LIB)\Font\TTF\LTSH.pm \
+ lib/Font/TTF/Mort/Subtable.pm \
+ $(INST_LIB)\Font\TTF\Mort\Subtable.pm \
+ lib/Font/TTF/Hmtx.pm \
+ $(INST_LIB)\Font\TTF\Hmtx.pm \
+ lib/Font/TTF/AATutils.pm \
+ $(INST_LIB)\Font\TTF\AATutils.pm \
+ lib/Font/TTF/Kern/OrderedList.pm \
+ $(INST_LIB)\Font\TTF\Kern\OrderedList.pm \
+ lib/Font/TTF/Kern/StateTable.pm \
+ $(INST_LIB)\Font\TTF\Kern\StateTable.pm \
+ lib/Font/TTF/Fdsc.pm \
+ $(INST_LIB)\Font\TTF\Fdsc.pm \
+ lib/Font/TTF/XMLparse.pm \
+ $(INST_LIB)\Font\TTF\XMLparse.pm \
+ lib/Font/TTF/OldCmap.pm \
+ $(INST_LIB)\Font\TTF\OldCmap.pm \
+ lib/Font/TTF/Table.pm \
+ $(INST_LIB)\Font\TTF\Table.pm \
+ lib/Font/TTF/Glyf.pm \
+ $(INST_LIB)\Font\TTF\Glyf.pm \
+ lib/Font/TTF/Mort/Ligature.pm \
+ $(INST_LIB)\Font\TTF\Mort\Ligature.pm \
+ lib/Font/TTF/GSUB.pm \
+ $(INST_LIB)\Font\TTF\GSUB.pm \
+ lib/Font/TTF/Hdmx.pm \
+ $(INST_LIB)\Font\TTF\Hdmx.pm \
+ lib/Font/TTF/AATKern.pm \
+ $(INST_LIB)\Font\TTF\AATKern.pm \
+ lib/Font/TTF/Coverage.pm \
+ $(INST_LIB)\Font\TTF\Coverage.pm \
+ lib/Font/TTF/Prep.pm \
+ $(INST_LIB)\Font\TTF\Prep.pm \
+ lib/Font/TTF/Mort/Insertion.pm \
+ $(INST_LIB)\Font\TTF\Mort\Insertion.pm \
+ lib/Font/TTF/Mort/Contextual.pm \
+ $(INST_LIB)\Font\TTF\Mort\Contextual.pm \
+ lib/Font/TTF/GDEF.pm \
+ $(INST_LIB)\Font\TTF\GDEF.pm \
+ lib/Font/TTF/PSNames.pm \
+ $(INST_LIB)\Font\TTF\PSNames.pm \
+ lib/Font/TTF/Font.pm \
+ $(INST_LIB)\Font\TTF\Font.pm \
+ lib/Font/TTF/Feat.pm \
+ $(INST_LIB)\Font\TTF\Feat.pm \
+ lib/ttfmod.pl \
+ $(INST_LIB)\ttfmod.pl \
+ lib/Font/TTF/Kern.pm \
+ $(INST_LIB)\Font\TTF\Kern.pm \
+ lib/Font/TTF/Glyph.pm \
+ $(INST_LIB)\Font\TTF\Glyph.pm \
+ lib/Font/TTF/Changes \
+ $(INST_LIB)\Font\TTF\Changes \
+ lib/Font/TTF/Useall.pm \
+ $(INST_LIB)\Font\TTF\Useall.pm \
+ lib/Font/TTF/Hhea.pm \
+ $(INST_LIB)\Font\TTF\Hhea.pm \
+ lib/Font/TTF/Segarr.pm \
+ $(INST_LIB)\Font\TTF\Segarr.pm
+
+
+# --- MakeMaker tool_autosplit section:
+
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MAutoSplit -e "autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);"
+
+
+# --- MakeMaker tool_xsubpp section:
+
+
+# --- MakeMaker tools_other section:
+
+SHELL = cmd /x /c
+CHMOD = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e chmod
+CP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp
+LD = link
+MV = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv
+NOOP = rem
+RM_F = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f
+RM_RF = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf
+TEST_F = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f
+TOUCH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e touch
+UMASK_NULL = umask 0
+DEV_NULL = > NUL
+
+# The following is a portable way to say mkdir -p
+# To see which directories are created, change the if 0 to if 1
+MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath
+
+# This helps us to minimize the effect of the .exists files A yet
+# better solution would be to have a stable file in the perl
+# distribution with a timestamp of zero. But this solution doesn't
+# need any changes to the core distribution and works with older perls
+EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
+
+# Here we warn users that an old packlist file was found somewhere,
+# and that they should call some uninstall routine
+WARN_IF_OLD_PACKLIST = $(PERL) -lwe "exit unless -f $$ARGV[0];" \
+-e "print 'WARNING: I have found an old package in';" \
+-e "print ' ', $$ARGV[0], '.';" \
+-e "print 'Please make sure the two installations are not conflicting';"
+
+UNINST=0
+VERBINST=1
+
+MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
+-e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');"
+
+DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \
+-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', $$arg=shift, '|', $$arg, '>';" \
+-e "print '=over 4';" \
+-e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \
+-e "print '=back';"
+
+UNINSTALL = $(PERL) -MExtUtils::Install \
+-e "uninstall($$ARGV[0],1,1); print \"\nUninstall is deprecated. Please check the";" \
+-e "print \" packlist above carefully.\n There may be errors. Remove the\";" \
+-e "print \" appropriate files manually.\n Sorry for the inconveniences.\n\""
+
+
+# --- MakeMaker dist section:
+
+DISTVNAME = $(DISTNAME)-$(VERSION)
+TAR = tar
+TARFLAGS = cvf
+ZIP = zip
+ZIPFLAGS = -r
+COMPRESS = gzip --best
+SUFFIX = .gz
+SHAR = shar
+PREOP = @$(NOOP)
+POSTOP = @$(NOOP)
+TO_UNIX = perl -Mtounix -e "tounix(\"$(DISTVNAME)\")"
+CI = ci -u
+RCS_LABEL = rcs -Nv$(VERSION_SYM): -q
+DIST_CP = best
+DIST_DEFAULT = tardist
+
+
+# --- MakeMaker macro section:
+
+
+# --- MakeMaker depend section:
+
+
+# --- MakeMaker cflags section:
+
+
+# --- MakeMaker const_loadlibs section:
+
+
+# --- MakeMaker const_cccmd section:
+
+
+# --- MakeMaker post_constants section:
+
+
+# --- MakeMaker pasthru section:
+PASTHRU = -nologo
+
+# --- MakeMaker c_o section:
+
+
+# --- MakeMaker xs_c section:
+
+
+# --- MakeMaker xs_o section:
+
+
+# --- MakeMaker top_targets section:
+
+#all :: config $(INST_PM) subdirs linkext manifypods
+
+all :: pure_all htmlifypods manifypods
+ @$(NOOP)
+
+pure_all :: config pm_to_blib subdirs linkext
+ @$(NOOP)
+
+subdirs :: $(MYEXTLIB)
+ @$(NOOP)
+
+config :: Makefile $(INST_LIBDIR)\.exists
+ @$(NOOP)
+
+config :: $(INST_ARCHAUTODIR)\.exists
+ @$(NOOP)
+
+config :: $(INST_AUTODIR)\.exists
+ @$(NOOP)
+
+$(INST_AUTODIR)\.exists :: D:\Progs\Perl\lib\CORE\perl.h
+ @$(MKPATH) $(INST_AUTODIR)
+ @$(EQUALIZE_TIMESTAMP) D:\Progs\Perl\lib\CORE\perl.h $(INST_AUTODIR)\.exists
+
+ -@$(CHMOD) $(PERM_RWX) $(INST_AUTODIR)
+
+$(INST_LIBDIR)\.exists :: D:\Progs\Perl\lib\CORE\perl.h
+ @$(MKPATH) $(INST_LIBDIR)
+ @$(EQUALIZE_TIMESTAMP) D:\Progs\Perl\lib\CORE\perl.h $(INST_LIBDIR)\.exists
+
+ -@$(CHMOD) $(PERM_RWX) $(INST_LIBDIR)
+
+$(INST_ARCHAUTODIR)\.exists :: D:\Progs\Perl\lib\CORE\perl.h
+ @$(MKPATH) $(INST_ARCHAUTODIR)
+ @$(EQUALIZE_TIMESTAMP) D:\Progs\Perl\lib\CORE\perl.h $(INST_ARCHAUTODIR)\.exists
+
+ -@$(CHMOD) $(PERM_RWX) $(INST_ARCHAUTODIR)
+
+help:
+ perldoc ExtUtils::MakeMaker
+
+Version_check:
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -MExtUtils::MakeMaker=Version_check \
+ -e "Version_check('$(MM_VERSION)')"
+
+
+# --- MakeMaker linkext section:
+
+linkext :: $(LINKTYPE)
+ @$(NOOP)
+
+
+# --- MakeMaker dlsyms section:
+
+TTF.def: Makefile.PL
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \
+ -e "Mksymlists('NAME' => 'Font::TTF', 'DLBASE' => '$(BASEEXT)', 'DL_FUNCS' => { }, 'FUNCLIST' => [], 'IMPORTS' => { }, 'DL_VARS' => []);"
+
+
+# --- MakeMaker dynamic section:
+
+## $(INST_PM) has been moved to the all: target.
+## It remains here for awhile to allow for old usage: "make dynamic"
+#dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT) $(INST_PM)
+dynamic :: Makefile $(INST_DYNAMIC) $(INST_BOOT)
+ @$(NOOP)
+
+
+# --- MakeMaker dynamic_bs section:
+
+BOOTSTRAP =
+
+
+# --- MakeMaker dynamic_lib section:
+
+
+# --- MakeMaker static section:
+
+## $(INST_PM) has been moved to the all: target.
+## It remains here for awhile to allow for old usage: "make static"
+#static :: Makefile $(INST_STATIC) $(INST_PM)
+static :: Makefile $(INST_STATIC)
+ @$(NOOP)
+
+
+# --- MakeMaker static_lib section:
+
+
+# --- MakeMaker htmlifypods section:
+
+htmlifypods : pure_all
+ @$(NOOP)
+
+
+# --- MakeMaker manifypods section:
+
+manifypods :
+ @$(NOOP)
+
+
+# --- MakeMaker processPL section:
+
+
+# --- MakeMaker installbin section:
+
+$(INST_SCRIPT)\.exists :: D:\Progs\Perl\lib\CORE\perl.h
+ @$(MKPATH) $(INST_SCRIPT)
+ @$(EQUALIZE_TIMESTAMP) D:\Progs\Perl\lib\CORE\perl.h $(INST_SCRIPT)\.exists
+
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)
+
+EXE_FILES = scripts/check_attach.plx scripts/eurofix.plx scripts/hackos2.plx scripts/psfix.plx scripts/ttfbuilder.plx scripts/ttfname.plx scripts/ttfremap.plx
+
+FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -e "system qq[pl2bat.bat ].shift"
+
+pure_all :: $(INST_SCRIPT)\check_attach.plx $(INST_SCRIPT)\ttfname.plx $(INST_SCRIPT)\ttfbuilder.plx $(INST_SCRIPT)\hackos2.plx $(INST_SCRIPT)\eurofix.plx $(INST_SCRIPT)\psfix.plx $(INST_SCRIPT)\ttfremap.plx
+ @$(NOOP)
+
+realclean ::
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\check_attach.plx $(INST_SCRIPT)\ttfname.plx $(INST_SCRIPT)\ttfbuilder.plx $(INST_SCRIPT)\hackos2.plx $(INST_SCRIPT)\eurofix.plx $(INST_SCRIPT)\psfix.plx $(INST_SCRIPT)\ttfremap.plx
+
+$(INST_SCRIPT)\check_attach.plx: scripts/check_attach.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\check_attach.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/check_attach.plx $(INST_SCRIPT)\check_attach.plx
+ $(FIXIN) $(INST_SCRIPT)\check_attach.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\check_attach.plx
+
+$(INST_SCRIPT)\ttfname.plx: scripts/ttfname.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\ttfname.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/ttfname.plx $(INST_SCRIPT)\ttfname.plx
+ $(FIXIN) $(INST_SCRIPT)\ttfname.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\ttfname.plx
+
+$(INST_SCRIPT)\ttfbuilder.plx: scripts/ttfbuilder.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\ttfbuilder.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/ttfbuilder.plx $(INST_SCRIPT)\ttfbuilder.plx
+ $(FIXIN) $(INST_SCRIPT)\ttfbuilder.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\ttfbuilder.plx
+
+$(INST_SCRIPT)\hackos2.plx: scripts/hackos2.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\hackos2.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/hackos2.plx $(INST_SCRIPT)\hackos2.plx
+ $(FIXIN) $(INST_SCRIPT)\hackos2.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\hackos2.plx
+
+$(INST_SCRIPT)\eurofix.plx: scripts/eurofix.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\eurofix.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/eurofix.plx $(INST_SCRIPT)\eurofix.plx
+ $(FIXIN) $(INST_SCRIPT)\eurofix.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\eurofix.plx
+
+$(INST_SCRIPT)\psfix.plx: scripts/psfix.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\psfix.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/psfix.plx $(INST_SCRIPT)\psfix.plx
+ $(FIXIN) $(INST_SCRIPT)\psfix.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\psfix.plx
+
+$(INST_SCRIPT)\ttfremap.plx: scripts/ttfremap.plx Makefile $(INST_SCRIPT)\.exists
+ @$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_SCRIPT)\ttfremap.plx
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp scripts/ttfremap.plx $(INST_SCRIPT)\ttfremap.plx
+ $(FIXIN) $(INST_SCRIPT)\ttfremap.plx
+ -@$(CHMOD) $(PERM_RWX) $(INST_SCRIPT)\ttfremap.plx
+
+
+# --- MakeMaker subdirs section:
+
+# none
+
+# --- MakeMaker clean section:
+
+# Delete temporary files but do not touch installed files. We don't delete
+# the Makefile here so a later make realclean still has a makefile to use.
+
+clean ::
+ -$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf ./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp
+ -$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv Makefile Makefile.old $(DEV_NULL)
+
+
+# --- MakeMaker realclean section:
+
+# Delete temporary files (via clean) and also delete installed files
+realclean purge :: clean
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf $(INST_AUTODIR) $(INST_ARCHAUTODIR)
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Kern\ClassArray.pm $(INST_LIB)\Font\TTF\Anchor.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Head.pm $(INST_LIB)\Font\TTF\PCLT.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Mort\Rearrangement.pm $(INST_LIB)\Font\TTF\Vmtx.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Mort\Noncontextual.pm $(INST_LIB)\Font\TTF\Mort\Chain.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Bsln.pm $(INST_LIB)\Font\TTF\Post.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Cvt_.pm $(INST_LIB)\Font\TTF\Maxp.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\OS_2.pm $(INST_LIB)\Font\TTF\Ttc.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Win32.pm $(INST_LIB)\Font\TTF\Fmtx.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Name.pm $(INST_LIB)\Font\TTF\Delta.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Kern\CompactClassArray.pm $(INST_LIB)\Font\TTF\Mort.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Utils.pm $(INST_LIB)\Font\TTF\Loca.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Fpgm.pm $(INST_LIB)\Font\TTF\Kern\Subtable.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\GPOS.pm $(INST_LIB)\Font\TTF\OldMort.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Vhea.pm $(INST_LIB)\Font\TTF\Manual.pod
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Ttopen.pm $(INST_LIB)\Font\TTF\Cmap.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Prop.pm $(INST_LIB)\Font\TTF\LTSH.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Mort\Subtable.pm $(INST_LIB)\Font\TTF\Hmtx.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\AATutils.pm $(INST_LIB)\Font\TTF\Kern\OrderedList.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Kern\StateTable.pm $(INST_LIB)\Font\TTF\Fdsc.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\XMLparse.pm $(INST_LIB)\Font\TTF\OldCmap.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Table.pm $(INST_LIB)\Font\TTF\Glyf.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Mort\Ligature.pm $(INST_LIB)\Font\TTF\GSUB.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Hdmx.pm $(INST_LIB)\Font\TTF\AATKern.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Coverage.pm $(INST_LIB)\Font\TTF\Prep.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Mort\Insertion.pm $(INST_LIB)\Font\TTF\Mort\Contextual.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\GDEF.pm $(INST_LIB)\Font\TTF\PSNames.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Font.pm $(INST_LIB)\Font\TTF\Feat.pm $(INST_LIB)\ttfmod.pl
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Kern.pm $(INST_LIB)\Font\TTF\Glyph.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Changes $(INST_LIB)\Font\TTF\Useall.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f $(INST_LIB)\Font\TTF\Hhea.pm $(INST_LIB)\Font\TTF\Segarr.pm
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf Makefile Makefile.old
+
+
+# --- MakeMaker dist_basics section:
+
+distclean :: realclean distcheck
+
+distcheck :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \
+ -e fullcheck
+
+skipcheck :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \
+ -e skipcheck
+
+manifest :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \
+ -e mkmanifest
+
+veryclean : realclean
+ $(RM_F) *~ *.orig */*~ */*.orig
+
+
+# --- MakeMaker dist_core section:
+
+dist : $(DIST_DEFAULT)
+ @$(PERL) -le "print \"Warning: Makefile possibly out of date with $$vf\" if " \
+ -e "-e ($$vf=\"$(VERSION_FROM)\") and -M $$vf < -M \"Makefile\";"
+
+tardist : $(DISTVNAME).tar$(SUFFIX)
+
+zipdist : $(DISTVNAME).zip
+
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+uutardist : $(DISTVNAME).tar$(SUFFIX)
+ uuencode $(DISTVNAME).tar$(SUFFIX) \
+ $(DISTVNAME).tar$(SUFFIX) > \
+ $(DISTVNAME).tar$(SUFFIX)_uu
+
+shdist : distdir
+ $(PREOP)
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+
+# --- MakeMaker dist_dir section:
+
+distdir :
+ $(RM_RF) $(DISTVNAME)
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \
+ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
+
+
+# --- MakeMaker dist_test section:
+
+disttest : distdir
+ cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL
+ cd $(DISTVNAME) && $(MAKE)
+ cd $(DISTVNAME) && $(MAKE) test
+
+
+# --- MakeMaker dist_ci section:
+
+ci :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \
+ -e "@all = keys %{ maniread() };" \
+ -e "print(\"Executing $(CI) @all\n\"); system(\"$(CI) @all\");" \
+ -e "print(\"Executing $(RCS_LABEL) ...\n\"); system(\"$(RCS_LABEL) @all\");"
+
+
+# --- MakeMaker install section:
+
+install :: all pure_install doc_install
+
+install_perl :: all pure_perl_install doc_perl_install
+
+install_site :: all pure_site_install doc_site_install
+
+install_ :: install_site
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+pure_install :: pure_$(INSTALLDIRS)_install
+
+doc_install :: doc_$(INSTALLDIRS)_install
+ @echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
+
+pure__install : pure_site_install
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+doc__install : doc_site_install
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+pure_perl_install ::
+ @$(MOD_INSTALL) \
+ read $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist \
+ write $(INSTALLARCHLIB)\auto\$(FULLEXT)\.packlist \
+ $(INST_LIB) $(INSTALLPRIVLIB) \
+ $(INST_ARCHLIB) $(INSTALLARCHLIB) \
+ $(INST_BIN) $(INSTALLBIN) \
+ $(INST_SCRIPT) $(INSTALLSCRIPT) \
+ $(INST_HTMLLIBDIR) $(INSTALLHTMLPRIVLIBDIR) \
+ $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
+ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \
+ $(INST_MAN3DIR) $(INSTALLMAN3DIR)
+ @$(WARN_IF_OLD_PACKLIST) \
+ $(SITEARCHEXP)\auto\$(FULLEXT)
+
+
+pure_site_install ::
+ @$(MOD_INSTALL) \
+ read $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist \
+ write $(INSTALLSITEARCH)\auto\$(FULLEXT)\.packlist \
+ $(INST_LIB) $(INSTALLSITELIB) \
+ $(INST_ARCHLIB) $(INSTALLSITEARCH) \
+ $(INST_BIN) $(INSTALLBIN) \
+ $(INST_SCRIPT) $(INSTALLSCRIPT) \
+ $(INST_HTMLLIBDIR) $(INSTALLHTMLSITELIBDIR) \
+ $(INST_HTMLSCRIPTDIR) $(INSTALLHTMLSCRIPTDIR) \
+ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \
+ $(INST_MAN3DIR) $(INSTALLMAN3DIR)
+ @$(WARN_IF_OLD_PACKLIST) \
+ $(PERL_ARCHLIB)\auto\$(FULLEXT)
+
+doc_perl_install ::
+ -@$(MKPATH) $(INSTALLARCHLIB)
+ -@$(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLPRIVLIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> $(INSTALLARCHLIB)\perllocal.pod
+
+doc_site_install ::
+ -@$(MKPATH) $(INSTALLARCHLIB)
+ -@$(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLSITELIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> $(INSTALLARCHLIB)\perllocal.pod
+
+
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs
+
+uninstall_from_perldirs ::
+ @$(UNINSTALL) $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist
+
+uninstall_from_sitedirs ::
+ @$(UNINSTALL) $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist
+
+
+# --- MakeMaker force section:
+# Phony target to force checking subdirectories.
+FORCE:
+ @$(NOOP)
+
+
+# --- MakeMaker perldepend section:
+
+
+# --- MakeMaker makefile section:
+
+# We take a very conservative approach here, but it\'s worth it.
+# We move Makefile to Makefile.old here to avoid gnu make looping.
+Makefile : Makefile.PL $(CONFIGDEP)
+ @echo "Makefile out-of-date with respect to $?"
+ @echo "Cleaning current config before rebuilding Makefile..."
+ -@$(RM_F) Makefile.old
+ -@$(MV) Makefile Makefile.old
+ -$(MAKE) -f Makefile.old clean $(DEV_NULL) || $(NOOP)
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL
+ @echo "==> Your Makefile has been rebuilt. <=="
+ @echo "==> Please rerun the make command. <=="
+ false
+
+# To change behavior to :: would be nice, but would break Tk b9.02
+# so you find such a warning below the dist target.
+#Makefile :: $(VERSION_FROM)
+# @echo "Warning: Makefile possibly out of date with $(VERSION_FROM)"
+
+
+# --- MakeMaker staticmake section:
+
+# --- MakeMaker makeaperl section ---
+MAP_TARGET = perl
+FULLPERL = D:\Progs\Perl\bin\Perl.exe
+
+$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
+ $(MAKE) -f $(MAKE_APERL_FILE) $@
+
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
+ @echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
+ @$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ Makefile.PL DIR= \
+ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
+ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=
+
+
+# --- MakeMaker test section:
+
+TEST_VERBOSE=0
+TEST_TYPE=test_$(LINKTYPE)
+TEST_FILE = test.pl
+TEST_FILES =
+TESTDB_SW = -d
+
+testdb :: testdb_$(LINKTYPE)
+
+test :: $(TEST_TYPE)
+ @echo 'No tests defined for $(NAME) extension.'
+
+test_dynamic :: pure_all
+
+testdb_dynamic :: pure_all
+ $(FULLPERL) $(TESTDB_SW) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(TEST_FILE)
+
+test_ : test_dynamic
+
+test_static :: test_dynamic
+testdb_static :: testdb_dynamic
+
+
+# --- MakeMaker ppd section:
+# Creates a PPD (Perl Package Description) for a binary distribution.
+ppd:
+ @$(PERL) -e "print qq{<SOFTPKG NAME=\"Font-TTF\" VERSION=\"0,34,0,0\">\n}. qq{\t<TITLE>Font-TTF</TITLE>\n}. qq{\t<ABSTRACT>TTF font support for Perl</ABSTRACT>\n}. qq{\t<AUTHOR>martin_hosken\@sil.org</AUTHOR>\n}. qq{\t<IMPLEMENTATION>\n}. qq{\t\t<OS NAME=\"$(OSNAME)\" />\n}. qq{\t\t<ARCHITECTURE NAME=\"MSWin32-x86-multi-thread\" />\n}. qq{\t\t<CODEBASE HREF=\"\" />\n}. qq{\t</IMPLEMENTATION>\n}. qq{</SOFTPKG>\n}" > Font-TTF.ppd
+
+# --- MakeMaker pm_to_blib section:
+
+pm_to_blib: $(TO_INST_PM)
+ @$(PERL) "-I$(INST_ARCHLINE)" "-I$(INST_LIB)" \
+ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
+ -e "pm_to_blib({ qw[$(PM_TO_BLIB)] }, '$(INST_LIB)\auto')
+ @$(TOUCH) $@
+
+
+
+# --- MakeMaker selfdocument section:
+
+
+# --- MakeMaker postamble section:
+
+
+# End.
Added: packages/libfont-ttf-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Makefile.PL 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Makefile.PL 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,41 @@
+use ExtUtils::MakeMaker;
+
+ at scripts = grep {-f } glob("scripts/*.*");
+ at theselibs = grep {-f } glob("lib/Font/TTF/*");
+
+# incantation to enable MY::pm_to_blib later on
+push(@ExtUtils::MakeMaker::Overridable, qw(pm_to_blib)) if ($^O eq 'MSWin32');
+
+WriteMakefile (
+ NAME => "Font::TTF",
+ VERSION_FROM => "lib/Font/TTF/Font.pm",
+ EXE_FILES => \@scripts,
+# HTMLLIBPODS => {map {my $t = $_; $t=~s/\..*?$/.html/o; $t='blib/Html/'.$t; $_ => $t;} @theselibs},
+# HTMLSCRIPTPODS => {map {my $t=$_; $t=~s/\..*?$/.html/o; $t='blib/Html/'.$t; $_ => $t;} @scripts},
+ AUTHOR => "martin_hosken\@sil.org",
+ ABSTRACT => "TTF font support for Perl",
+ dist => { 'TO_UNIX' => 'perl -Mtounix -e "tounix(\"$(DISTVNAME)\")"' }
+ );
+
+if ($^O eq 'MSWin32') {
+# incantation to solve the problem of everyone's $Config{make} being 'nmake'
+# when we want 'pmake'. And $Config{} is read only.
+# actually, this is just a copy of the code from ExtUtiles::MM_Win32 tidied
+# up (to expose tabs) and the dependency on Config removed
+sub MY::pm_to_blib
+{
+ my $self = shift;
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ return <<"EOT";
+
+pm_to_blib: \$(TO_INST_PM)
+\t$self->{NOECHO}\$(PERL) \"-I\$(INST_ARCHLINE)\" \"-I\$(INST_LIB)\" \\
+\t\"-I\$(PERL_ARCHLIB)\" \"-I\$(PERL_LIB)\" -MExtUtils::Install \\
+\t-e \"pm_to_blib({ qw[\$(PM_TO_BLIB)] }, '$autodir')
+\t$self->{NOECHO}\$(TOUCH) \$@
+
+EOT
+}
+
+}
+
Added: packages/libfont-ttf-perl/branches/upstream/current/README.TXT
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/README.TXT 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/README.TXT 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,163 @@
+ Perl Module: Font::TTF
+
+Announcing:
+
+The addition of many new tables including support for the OpenType
+tables: GSUB, GDEF and GPOS and also a bunch of AAT tables. The module
+now also supports XML output and a buggy XML input. All of these new
+features should be considered as Alpha code and particularly the XML
+language is liable to change for some of the more complex table types.
+
+After a long wait, Name tables now try to return UTF8 strings where
+possible. The deprecation period has now passed and by default the
+Name.pm returns strings as utf8 where possible. See Name.pm for details.
+To get old behaviour, set C<$Font::TTF::Name::utf8> to 0.
+
+Solution to the installation problem for users on Win32, without make.
+Use pmake instead. Wherever you see the command: make, in this document,
+type: pmake instead.
+
+=head1 Introduction
+
+Perl module for TrueType font hacking. Supports reading, processing and
+writing of the following tables: GDEF, GPOS, GSUB, LTSH, OS/2, PCLT,
+bsln, cmap, cvt, fdsc, feat, fpgm, glyf, hdmx, head, hhea, hmtx, kern,
+loca, maxp, mort, name, post, prep, prop, vhea, vmtx and the reading and
+writing of all other table types.
+
+In short, you can do almost anything with a standard TrueType font with
+this module. Be Brave!
+
+The module also includes various useful utilities:
+
+check_attach Checks an attachment point database against a font. See
+ ttfbuilder for details
+eurofix Fixes fonts created for Win95 so that they work in Win98 and NT4
+ sp4, Win2K and so on.
+hackos2 This old favourite lets you do unspeakable things to your OS/2
+ table, including sorting Unicode range bits and codepage bits
+ (Perl 4)
+psfix Tidy up the postscript names in a font to be Postscript
+ conformant
+ttfbuilder Build fonts from other fonts, including ligature building, etc.
+ Has excellent explanatory POD
+ttfname Renames a font and allows access to name strings. This needs
+ a rewrite (Perl 4)
+ttfremap Simpler font subsetter than ttfbuilder
+
+
+Also included are the following example scripts. To use these you will need to
+install them manually from the examples directory included in the distribution.
+
+StripCmap Strips a specified cmap from the given font
+addpclt Makes up values and adds a PCLT table to a font
+makemono Makes a font mono spaced (Perl 4)
+symbol.rmp Example remap file for ttfremap
+ttfdeltable Deletes a specified table from a font
+ttfenc Create .enc, .afm, .tfm and .map entry for a ttf file based on
+ Unicode rather than postscript. Requires afm2tfm and ttf2afm.
+ttfwidth Create a table of interesting information regarding widths of
+ characters. FRET is a much better tool for this now (Perl 4)
+xmldump Dumps a font as XML. The XML needs some work for some of the
+ more complex tables
+zerohyph Create a zero width hyphen in place of the normal hyphen
+
+Any suggestions, improvements, additions, subclasses, etc. would be gratefully
+received and probably included in a future release. Please send them to me.
+
+This module has been tested on Win32, Unix and Mac.
+
+=head1 SYNOPSIS
+
+Here is the regression test (you provide your own font). Run it once and then
+again on the output of the first run. There should be no differences between
+the outputs of the two runs.
+
+ use Font::TTF::Font;
+
+ $f = Font::TTF::Font->open($ARGV[0]);
+
+ # force a read of all the tables
+ $f->tables_do(sub { $_[0]->read; });
+
+ # force read of all glyphs (use read_dat to use lots of memory!)
+ # $f->{'loca'}->glyphs_do(sub { $_[0]->read; });
+ $f->{'loca'}->glyphs_do(sub { $_[0]->read_dat; });
+ # NB. no need to $g->update since $_[0]->{'glyf'}->out will do it for us
+
+ $f->out($ARGV[1]);
+ $f->DESTROY; # forces close of $in and maybe memory reclaim!
+
+=head1 PERL4 Utilities
+
+As an aside, the following Perl4 system and utilities have been slung in:
+
+perlmod.pl This is the Perl4 library for these programs
+
+addpclt Create a PCLT table for a font with lots of junk in it
+Hackos2 Do all sorts of unspeakable things to the OS/2 table
+MakeMono Force a font to be mono-spaced
+Ttfname Rename a font (and set any other name strings)
+TTFWIDTH Find the centre of every glyph in a font and print report
+
+=head1 Installation
+
+If you have received this package as part of an Activestate PPM style .zip file
+then type
+
+ ppm install Font-TTF.ppd
+
+Otherwise.
+
+To configure this module, cd to the directory that contains this README file
+and type the following.
+
+ perl Makefile.PL
+
+Alternatively, if you plan to install Font::TTF somewhere other than
+your system's perl library directory. You can type something like this:
+
+ perl Makefile.PL PREFIX=/home/me/perl INSTALLDIRS=perl
+
+Then to build you run make.
+
+ make
+
+If you have write access to the perl library directories, you may then
+install by typing:
+
+ make install
+
+To tidy up, type:
+
+ make realclean
+
+Win32 users should use pmake instead of make. Alternatively installation can be
+done on Win32 by typing:
+
+ Setup
+
+Or using the install feature in tools like WinZip.
+
+=head1 CHANGES
+
+=head2 Future Changes
+
+I do not anticipate any more restructuring changes (but reserve the right to do so).
+One area I am waiting to change is that of the Name table where I would like to
+pass strings using UTF-8. When the UTF-8 version of Perl is ported to Win32 then I
+can start the changes and cross-mappings (for the Mac).
+
+=head1 AUTHOR
+
+Martin Hosken L<Martin_Hosken at sil.org>
+
+Copyright Martin Hosken 1998 and following.
+
+No warranty or expression of effectiveness for anything, least of all anyone's
+safety, is implied in this software or documentation.
+
+=head2 Licensing
+
+The Perl TTF module is licensed under the Perl Artistic License.
+
Added: packages/libfont-ttf-perl/branches/upstream/current/Setup.bat
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/Setup.bat 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/Setup.bat 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,4 @@
+perl Makefile.PL
+call pmake install
+call pmake realclean
+
Property changes on: packages/libfont-ttf-perl/branches/upstream/current/Setup.bat
___________________________________________________________________
Name: svn:executable
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATKern.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATKern.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATKern.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,140 @@
+package Font::TTF::AATKern;
+
+=head1 NAME
+
+Font::TTF::AATKern
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Kern::Subtable;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+
+ $self->SUPER::read or return $self;
+
+ my ($dat, $fh, $numSubtables);
+ $fh = $self->{' INFILE'};
+
+ $fh->read($dat, 8);
+ ($self->{'version'}, $numSubtables) = TTF_Unpack("fL", $dat);
+
+ my $subtables = [];
+ foreach (1 .. $numSubtables) {
+ my $subtableStart = $fh->tell();
+
+ $fh->read($dat, 8);
+ my ($length, $coverage, $tupleIndex) = TTF_Unpack("LSS", $dat);
+ my $type = $coverage & 0x00ff;
+
+ my $subtable = Font::TTF::Kern::Subtable->create($type, $coverage, $length);
+ $subtable->read($fh);
+
+ $subtable->{'tupleIndex'} = $tupleIndex if $subtable->{'variation'};
+ $subtable->{' PARENT'} = $self;
+ push @$subtables, $subtable;
+ }
+
+ $self->{'subtables'} = $subtables;
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ my $subtables = $self->{'subtables'};
+ $fh->print(TTF_Pack("fL", $self->{'version'}, scalar @$subtables));
+
+ foreach (@$subtables) {
+ $_->out($fh);
+ }
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ $self->read unless $self->{' read'};
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $fh->printf("version %f\n", $self->{'version'});
+
+ my $subtables = $self->{'subtables'};
+ foreach (@$subtables) {
+ $_->print($fh);
+ }
+}
+
+sub dumpXML
+{
+ my ($self, $fh) = @_;
+ $self->read unless $self->{' read'};
+
+ my $post = $self->{' PARENT'}->{'post'};
+ $post->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+ $fh->printf("<kern version=\"%f\">\n", $self->{'version'});
+
+ my $subtables = $self->{'subtables'};
+ foreach (@$subtables) {
+ $fh->printf("<%s", $_->type);
+ $fh->printf(" vertical=\"1\"") if $_->{'vertical'};
+ $fh->printf(" crossStream=\"1\"") if $_->{'crossStream'};
+ $fh->printf(" variation=\"1\"") if $_->{'variation'};
+ $fh->printf(" tupleIndex=\"%s\"", $_->{'tupleIndex'}) if exists $_->{'tupleIndex'};
+ $fh->printf(">\n");
+
+ $_->dumpXML($fh);
+
+ $fh->printf("</%s>\n", $_->type);
+ }
+
+ $fh->printf("</kern>\n");
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATutils.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATutils.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/AATutils.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,688 @@
+package Font::TTF::AATutils;
+
+use strict;
+use vars qw(@ISA @EXPORT);
+require Exporter;
+
+use Font::TTF::Utils;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ AAT_read_lookup
+ AAT_pack_lookup
+ AAT_write_lookup
+ AAT_pack_classes
+ AAT_write_classes
+ AAT_pack_states
+ AAT_write_states
+ AAT_read_state_table
+ AAT_read_subtable
+ xmldump
+);
+
+sub xmldump
+{
+ my ($var, $links, $depth, $processedVars, $type) = @_;
+
+ $processedVars = {} unless (defined $processedVars);
+ print("<?xml version='1.0' encoding='UTF-8'?>\n") if $depth == 0; # not necessarily true encoding for all text!
+
+ my $indent = "\t" x $depth;
+
+ my ($objType, $addr) = ($var =~ m/^.+=(.+)\((.+)\)$/);
+ unless (defined $type) {
+ if (defined $addr) {
+ if (defined $processedVars->{$addr}) {
+ if ($links) {
+ printf("%s%s\n", $indent, "<a href=\"#$addr\">$objType</a>");
+ }
+ else {
+ printf("%s%s\n", $indent, "<a>$objType</a>");
+ }
+ return;
+ }
+ $processedVars->{$addr} = 1;
+ }
+ }
+
+ $type = ref $var unless defined $type;
+
+ if ($type eq 'REF') {
+ printf("%s<ref val=\"%s\"/>\n", $indent, $$var);
+ }
+ elsif ($type eq 'SCALAR') {
+ printf("%s<scalar>%s</scalar>\n", $indent, $var);
+ }
+ elsif ($type eq 'ARRAY') {
+ # printf("%s<array>\n", $indent);
+ foreach (0 .. $#$var) {
+ if (ref($var->[$_])) {
+ printf("%s<arrayItem index=\"%d\">\n", $indent, $_);
+ xmldump($var->[$_], $links, $depth + 1, $processedVars);
+ printf("%s</arrayItem>\n", $indent);
+ }
+ else {
+ printf("%s<arrayItem index=\"%d\">%s</arrayItem>\n", $indent, $_, $var->[$_]);
+ }
+ }
+ # printf("%s</array>\n", $indent);
+ }
+ elsif ($type eq 'HASH') {
+ # printf("%s<hash>\n", $indent);
+ foreach (sort keys %$var) {
+ if (ref($var->{$_})) {
+ printf("%s<hashElem key=\"%s\">\n", $indent, $_);
+ xmldump($var->{$_}, $links, $depth + 1, $processedVars);
+ printf("%s</hashElem>\n", $indent);
+ }
+ else {
+ printf("%s<hashElem key=\"%s\">%s</hashElem>\n", $indent, $_, $var->{$_});
+ }
+ }
+ # printf("%s</hash>\n", $indent);
+ }
+ elsif ($type eq 'CODE') {
+ printf("%s<CODE/>\n", $indent, $var);
+ }
+ elsif ($type eq 'GLOB') {
+ printf("%s<GLOB/>\n", $indent, $var);
+ }
+ elsif ($type eq '') {
+ printf("%s<val>%s</val>\n", $indent, $var);
+ }
+ else {
+ if ($links) {
+ printf("%s<obj class=\"%s\" id=\"#%s\">\n", $indent, $type, $addr);
+ }
+ else {
+ printf("%s<obj class=\"%s\">\n", $indent, $type);
+ }
+ xmldump($var, $links, $depth + 1, $processedVars, $objType);
+ printf("%s</obj>\n", $indent);
+ }
+}
+
+=head2 ($classes, $states) = AAT_read_subtable($fh, $baseOffset, $subtableStart, $limits)
+
+=cut
+
+sub AAT_read_subtable
+{
+ my ($fh, $baseOffset, $subtableStart, $limits) = @_;
+
+ my $limit = 0xffffffff;
+ foreach (@$limits) {
+ $limit = $_ if ($_ > $subtableStart and $_ < $limit);
+ }
+ die if $limit == 0xffffffff;
+
+ my $dat;
+ $fh->seek($baseOffset + $subtableStart, IO::File::SEEK_SET);
+ $fh->read($dat, $limit - $subtableStart);
+
+ $dat;
+}
+
+=head2 $length = AAT_write_state_table($fh, $classes, $states, $numExtraTables, $packEntry)
+
+$packEntry is a subroutine for packing an entry into binary form, called as
+
+$dat = $packEntry($entry, $entryTable, $numEntries)
+
+where the entry is a comma-separated list of nextStateOffset, flags, actions
+
+=cut
+
+sub AAT_pack_state_table
+{
+ my ($classes, $states, $numExtraTables, $packEntry) = @_;
+
+ my ($dat) = pack("n*", (0) x (4 + $numExtraTables)); # placeholders for stateSize, classTable, stateArray, entryTable
+
+ my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
+ my (@classTable, $i);
+ foreach $i (0 .. $#$classes) {
+ my $class = $classes->[$i];
+ foreach (@$class) {
+ $firstGlyph = $_ if $_ < $firstGlyph;
+ $lastGlyph = $_ if $_ > $lastGlyph;
+ $classTable[$_] = $i;
+ }
+ }
+
+ my $classTable = length($dat);
+ $dat .= pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
+ map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
+ $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) & 1) == 0; # pad if odd number of glyphs
+
+ my $stateArray = length($dat);
+ my (@entries, %entries);
+ my $state = $states->[0];
+ my $stateSize = @$state;
+ die "stateSize below minimum allowed (4)" if $stateSize < 4;
+ die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
+ warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
+
+ foreach (@$states) {
+ die "inconsistent state size" if @$_ != $stateSize;
+ foreach (@$_) {
+ my $actions = $_->{'actions'};
+ my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, $_->{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
+ if (not defined $entries{$entry}) {
+ push @entries, $entry;
+ $entries{$entry} = $#entries;
+ die "too many different state array entries" if $#entries == 256;
+ }
+ $dat .= pack("C", $entries{$entry});
+ }
+ }
+ $dat .= pack("C", 0) if (@$states & 1) != 0 and ($stateSize & 1) != 0; # pad if state array size is odd
+
+ my $entryTable = length($dat);
+ $dat .= map { &$packEntry($_, $entryTable, $#entries + 1) } @entries;
+
+ my ($dat1) = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
+ substr($dat, 0, length($dat1)) = $dat1;
+
+ return $dat;
+}
+
+sub AAT_write_state_table
+{
+ my ($fh, $classes, $states, $numExtraTables, $packEntry) = @_;
+
+ my $stateTableStart = $fh->tell();
+
+ $fh->print(pack("n*", (0) x (4 + $numExtraTables))); # placeholders for stateSize, classTable, stateArray, entryTable
+
+ my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
+ my (@classTable, $i);
+ foreach $i (0 .. $#$classes) {
+ my $class = $classes->[$i];
+ foreach (@$class) {
+ $firstGlyph = $_ if $_ < $firstGlyph;
+ $lastGlyph = $_ if $_ > $lastGlyph;
+ $classTable[$_] = $i;
+ }
+ }
+
+ my $classTable = $fh->tell() - $stateTableStart;
+ $fh->print(pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
+ map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph)));
+ $fh->print(pack("C", 0)) if (($lastGlyph - $firstGlyph) & 1) == 0; # pad if odd number of glyphs
+
+ my $stateArray = $fh->tell() - $stateTableStart;
+ my (@entries, %entries);
+ my $state = $states->[0];
+ my $stateSize = @$state;
+ die "stateSize below minimum allowed (4)" if $stateSize < 4;
+ die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
+ warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
+
+ foreach (@$states) {
+ die "inconsistent state size" if @$_ != $stateSize;
+ foreach (@$_) {
+ my $actions = $_->{'actions'};
+ my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, $_->{'flags'}, ref($actions) eq 'ARRAY' ? @$actions : $actions);
+ if (not defined $entries{$entry}) {
+ push @entries, $entry;
+ $entries{$entry} = $#entries;
+ die "too many different state array entries" if $#entries == 256;
+ }
+ $fh->print(pack("C", $entries{$entry}));
+ }
+ }
+ $fh->print(pack("C", 0)) if (@$states & 1) != 0 and ($stateSize & 1) != 0; # pad if state array size is odd
+
+ my $entryTable = $fh->tell() - $stateTableStart;
+ $fh->print(map { &$packEntry($_, $entryTable, $#entries + 1) } @entries);
+
+ my $length = $fh->tell() - $stateTableStart;
+ $fh->seek($stateTableStart, IO::File::SEEK_SET);
+ $fh->print(pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable));
+
+ $fh->seek($stateTableStart + $length, IO::File::SEEK_SET);
+ $length;
+}
+
+sub AAT_pack_classes
+{
+ my ($classes) = @_;
+
+ my ($firstGlyph, $lastGlyph) = (0xffff, 0, 0);
+ my (@classTable, $i);
+ foreach $i (0 .. $#$classes) {
+ my $class = $classes->[$i];
+ foreach (@$class) {
+ $firstGlyph = $_ if $_ < $firstGlyph;
+ $lastGlyph = $_ if $_ > $lastGlyph;
+ $classTable[$_] = $i;
+ }
+ }
+
+ my ($dat) = pack("nnC*", $firstGlyph, $lastGlyph - $firstGlyph + 1,
+ map { defined $classTable[$_] ? $classTable[$_] : 1 } ($firstGlyph .. $lastGlyph));
+ $dat .= pack("C", 0) if (($lastGlyph - $firstGlyph) & 1) == 0; # pad if odd number of glyphs
+
+ return $dat;
+}
+
+sub AAT_write_classes
+{
+ my ($fh, $classes) = @_;
+
+ $fh->print(AAT_pack_classes($fh, $classes));
+}
+
+sub AAT_pack_states
+{
+ my ($classes, $stateArray, $states, $buildEntryProc) = @_;
+
+ my ($entries, %entryHash);
+ my $state = $states->[0];
+ my $stateSize = @$state;
+
+ die "stateSize below minimum allowed (4)" if $stateSize < 4;
+ die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
+ warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
+
+ my ($dat);
+ foreach (@$states) {
+ die "inconsistent state size" if @$_ != $stateSize;
+ foreach (@$_) {
+ my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, &$buildEntryProc($_));
+ if (not defined $entryHash{$entry}) {
+ push @$entries, $entry;
+ $entryHash{$entry} = $#$entries;
+ die "too many different state array entries" if $#$entries == 256;
+ }
+ $dat .= pack("C", $entryHash{$entry});
+ }
+ }
+ $dat .= pack("C", 0) if (@$states & 1) != 0 and ($stateSize & 1) != 0; # pad if state array size is odd
+
+ ($dat, $stateSize, $entries);
+}
+
+sub AAT_write_states
+{
+ my ($fh, $classes, $stateArray, $states, $buildEntryProc) = @_;
+
+ my ($entries, %entryHash);
+ my $state = $states->[0];
+ my $stateSize = @$state;
+
+ die "stateSize below minimum allowed (4)" if $stateSize < 4;
+ die "stateSize (" . $stateSize . ") too small for max class number (" . $#$classes . ")" if $stateSize < $#$classes + 1;
+ warn "state array has unreachable columns" if $stateSize > $#$classes + 1;
+
+ foreach (@$states) {
+ die "inconsistent state size" if @$_ != $stateSize;
+ foreach (@$_) {
+ my $entry = join(",", $stateArray + $_->{'nextState'} * $stateSize, &$buildEntryProc($_));
+ if (not defined $entryHash{$entry}) {
+ push @$entries, $entry;
+ $entryHash{$entry} = $#$entries;
+ die "too many different state array entries" if $#$entries == 256;
+ }
+ $fh->print(pack("C", $entryHash{$entry}));
+ }
+ }
+ $fh->print(pack("C", 0)) if (@$states & 1) != 0 and ($stateSize & 1) != 0; # pad if state array size is odd
+
+ ($stateSize, $entries);
+}
+
+=head2 ($classes, $states, $entries) = AAT_read_state_table($fh, $numActionWords)
+
+=cut
+
+sub AAT_read_state_table
+{
+ my ($fh, $numActionWords) = @_;
+
+ my $stateTableStart = $fh->tell();
+ my $dat;
+ $fh->read($dat, 8);
+ my ($stateSize, $classTable, $stateArray, $entryTable) = unpack("nnnn", $dat);
+
+ my $classes; # array of lists of glyphs
+
+ $fh->seek($stateTableStart + $classTable, IO::File::SEEK_SET);
+ $fh->read($dat, 4);
+ my ($firstGlyph, $nGlyphs) = unpack("nn", $dat);
+ $fh->read($dat, $nGlyphs);
+ foreach (unpack("C*", $dat)) {
+ if ($_ != 1) {
+ my $class = $classes->[$_];
+ push(@$class, $firstGlyph);
+ $classes->[$_] = $class unless defined $classes->[$_];
+ }
+ $firstGlyph++;
+ }
+
+ $fh->seek($stateTableStart + $stateArray, IO::File::SEEK_SET);
+ my $states; # array of arrays of hashes{nextState, flags, actions}
+
+ my $entrySize = 4 + ($numActionWords * 2);
+ my $lastState = 1;
+ my $entries;
+ while ($#$states < $lastState) {
+ $fh->read($dat, $stateSize);
+ my @stateEntries = unpack("C*", $dat);
+ my $state;
+ foreach (@stateEntries) {
+ if (not defined $entries->[$_]) {
+ my $loc = $fh->tell();
+ $fh->seek($stateTableStart + $entryTable + ($_ * $entrySize), IO::File::SEEK_SET);
+ $fh->read($dat, $entrySize);
+ my ($nextState, $flags, $actions);
+ ($nextState, $flags, @$actions) = unpack("n*", $dat);
+ $nextState -= $stateArray;
+ $nextState /= $stateSize;
+ $entries->[$_] = { 'nextState' => $nextState, 'flags' => $flags };
+ $entries->[$_]->{'actions'} = $actions if $numActionWords > 0;
+ $lastState = $nextState if ($nextState > $lastState);
+ $fh->seek($loc, IO::File::SEEK_SET);
+ }
+ push(@$state, $entries->[$_]);
+ }
+ push(@$states, $state);
+ }
+
+ ($classes, $states, $entries);
+}
+
+=head2 ($format, $lookup) = AAT_read_lookup($fh, $valueSize, $length, $default)
+
+=cut
+
+sub AAT_read_lookup
+{
+ my ($fh, $valueSize, $length, $default) = @_;
+
+ my $lookupStart = $fh->tell();
+ my ($dat, $unpackChar);
+ if ($valueSize == 1) {
+ $unpackChar = "C";
+ }
+ elsif ($valueSize == 2) {
+ $unpackChar = "n";
+ }
+ elsif ($valueSize == 4) {
+ $unpackChar = "N";
+ }
+ else {
+ die "unsupported value size";
+ }
+
+ $fh->read($dat, 2);
+ my $format = unpack("n", $dat);
+ my $lookup;
+
+ if ($format == 0) {
+ $fh->read($dat, $length - 2);
+ my $i = -1;
+ $lookup = { map { $i++; ($_ != $default) ? ($i, $_) : () } unpack($unpackChar . "*", $dat) };
+ }
+
+ elsif ($format == 2) {
+ $fh->read($dat, 10);
+ my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
+ die if $unitSize != 4 + $valueSize;
+ foreach (1 .. $nUnits) {
+ $fh->read($dat, $unitSize);
+ my ($lastGlyph, $firstGlyph, $value) = unpack("nn" . $unpackChar, $dat);
+ if ($firstGlyph != 0xffff and $value != $default) {
+ foreach ($firstGlyph .. $lastGlyph) {
+ $lookup->{$_} = $value;
+ }
+ }
+ }
+ }
+
+ elsif ($format == 4) {
+ $fh->read($dat, 10);
+ my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
+ die if $unitSize != 6;
+ foreach (1 .. $nUnits) {
+ $fh->read($dat, $unitSize);
+ my ($lastGlyph, $firstGlyph, $offset) = unpack("nnn", $dat);
+ if ($firstGlyph != 0xffff) {
+ my $loc = $fh->tell();
+ $fh->seek($lookupStart + $offset, IO::File::SEEK_SET);
+ $fh->read($dat, ($lastGlyph - $firstGlyph + 1) * $valueSize);
+ my @values = unpack($unpackChar . "*", $dat);
+ foreach (0 .. $lastGlyph - $firstGlyph) {
+ $lookup->{$firstGlyph + $_} = $values[$_] if $values[$_] != $default;
+ }
+ $fh->seek($loc, IO::File::SEEK_SET);
+ }
+ }
+ }
+
+ elsif ($format == 6) {
+ $fh->read($dat, 10);
+ my ($unitSize, $nUnits, $searchRange, $entrySelector, $rangeShift) = unpack("nnnnn", $dat);
+ die if $unitSize != 2 + $valueSize;
+ foreach (1 .. $nUnits) {
+ $fh->read($dat, $unitSize);
+ my ($glyph, $value) = unpack("n" . $unpackChar, $dat);
+ $lookup->{$glyph} = $value if $glyph != 0xffff and $value != $default;
+ }
+ }
+
+ elsif ($format == 8) {
+ $fh->read($dat, 4);
+ my ($firstGlyph, $glyphCount) = unpack("nn", $dat);
+ $fh->read($dat, $glyphCount * $valueSize);
+ $firstGlyph--;
+ $lookup = { map { $firstGlyph++; $_ != $default ? ($firstGlyph, $_) : () } unpack($unpackChar . "*", $dat) };
+ }
+
+ else {
+ die "unknown lookup format";
+ }
+
+ $fh->seek($lookupStart + $length, IO::File::SEEK_SET);
+
+ ($format, $lookup);
+}
+
+=head2 AAT_write_lookup($fh, $format, $lookup, $valueSize, $default)
+
+=cut
+
+sub AAT_pack_lookup
+{
+ my ($format, $lookup, $valueSize, $default) = @_;
+
+ my $packChar;
+ if ($valueSize == 1) {
+ $packChar = "C";
+ }
+ elsif ($valueSize == 2) {
+ $packChar = "n";
+ }
+ elsif ($valueSize == 4) {
+ $packChar = "N";
+ }
+ else {
+ die "unsupported value size";
+ }
+
+ my ($dat) = pack("n", $format);
+
+ my ($firstGlyph, $lastGlyph) = (0xffff, 0);
+ foreach (keys %$lookup) {
+ $firstGlyph = $_ if $_ < $firstGlyph;
+ $lastGlyph = $_ if $_ > $lastGlyph;
+ }
+ my $glyphCount = $lastGlyph - $firstGlyph + 1;
+
+ if ($format == 0) {
+ $dat .= pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph));
+ }
+
+ elsif ($format == 2) {
+ my $prev = $default;
+ my $segStart = $firstGlyph;
+ my $dat1;
+ foreach ($firstGlyph .. $lastGlyph + 1) {
+ my $val = $lookup->{$_};
+ $val = $default unless defined $val;
+ if ($val != $prev) {
+ $dat1 .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
+ $prev = $val;
+ $segStart = $_;
+ }
+ }
+ $dat1 .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
+ my $unitSize = 4 + $valueSize;
+ $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
+ $dat .= $dat1;
+ }
+
+ elsif ($format == 4) {
+ my $segArray = new Font::TTF::Segarr($valueSize);
+ $segArray->add_segment($firstGlyph, 1, map { $lookup->{$_} } ($firstGlyph .. $lastGlyph));
+ my ($start, $end, $offset);
+ $offset = 12 + @$segArray * 6 + 6; # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
+ my $dat1;
+ foreach (@$segArray) {
+ $start = $_->{'START'};
+ $end = $start + $_->{'LEN'} - 1;
+ $dat1 .= pack("nnn", $end, $start, $offset);
+ $offset += $_->{'LEN'} * 2;
+ }
+ $dat1 .= pack("nnn", 0xffff, 0xffff, 0);
+ $dat .= pack("nnnnn", 6, TTF_bininfo(length($dat1) / 6, 6));
+ $dat .= $dat1;
+ foreach (@$segArray) {
+ $dat1 = $_->{'VAL'};
+ $dat .= pack($packChar . "*", @$dat1);
+ }
+ }
+
+ elsif ($format == 6) {
+ die "unsupported" if $valueSize != 2;
+ my $dat1 = pack("n*", map { $_, $lookup->{$_} } sort { $a <=> $b } grep { $lookup->{$_} ne $default } keys %$lookup);
+ my $unitSize = 2 + $valueSize;
+ $dat .= pack("nnnnn", $unitSize, TTF_bininfo(length($dat1) / $unitSize, $unitSize));
+ $dat .= $dat1;
+ }
+
+ elsif ($format == 8) {
+ $dat .= pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1);
+ $dat .= pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph));
+ }
+
+ else {
+ die "unknown lookup format";
+ }
+
+ my $padBytes = (4 - (length($dat) & 3)) & 3;
+ $dat .= pack("C*", (0) x $padBytes);
+
+ return $dat;
+}
+
+sub AAT_write_lookup
+{
+ my ($fh, $format, $lookup, $valueSize, $default) = @_;
+
+ my $lookupStart = $fh->tell();
+ my $packChar;
+ if ($valueSize == 1) {
+ $packChar = "C";
+ }
+ elsif ($valueSize == 2) {
+ $packChar = "n";
+ }
+ elsif ($valueSize == 4) {
+ $packChar = "N";
+ }
+ else {
+ die "unsupported value size";
+ }
+
+ $fh->print(pack("n", $format));
+
+ my ($firstGlyph, $lastGlyph) = (0xffff, 0);
+ foreach (keys %$lookup) {
+ $firstGlyph = $_ if $_ < $firstGlyph;
+ $lastGlyph = $_ if $_ > $lastGlyph;
+ }
+ my $glyphCount = $lastGlyph - $firstGlyph + 1;
+
+ if ($format == 0) {
+ $fh->print(pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } (0 .. $lastGlyph)));
+ }
+
+ elsif ($format == 2) {
+ my $prev = $default;
+ my $segStart = $firstGlyph;
+ my $dat;
+ foreach ($firstGlyph .. $lastGlyph + 1) {
+ my $val = $lookup->{$_};
+ $val = $default unless defined $val;
+ if ($val != $prev) {
+ $dat .= pack("nn" . $packChar, $_ - 1, $segStart, $prev) if $prev != $default;
+ $prev = $val;
+ $segStart = $_;
+ }
+ }
+ $dat .= pack("nn" . $packChar, 0xffff, 0xffff, 0);
+ my $unitSize = 4 + $valueSize;
+ $fh->print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
+ $fh->print($dat);
+ }
+
+ elsif ($format == 4) {
+ my $segArray = new Font::TTF::Segarr($valueSize);
+ $segArray->add_segment($firstGlyph, 1, map { $lookup->{$_} } ($firstGlyph .. $lastGlyph));
+ my ($start, $end, $offset);
+ $offset = 12 + @$segArray * 6 + 6; # 12 is size of format word + binSearchHeader; 6 bytes per segment; 6 for terminating segment
+ my $dat;
+ foreach (@$segArray) {
+ $start = $_->{'START'};
+ $end = $start + $_->{'LEN'} - 1;
+ $dat .= pack("nnn", $end, $start, $offset);
+ $offset += $_->{'LEN'} * 2;
+ }
+ $dat .= pack("nnn", 0xffff, 0xffff, 0);
+ $fh->print(pack("nnnnn", 6, TTF_bininfo(length($dat) / 6, 6)));
+ $fh->print($dat);
+ foreach (@$segArray) {
+ $dat = $_->{'VAL'};
+ $fh->print(pack($packChar . "*", @$dat));
+ }
+ }
+
+ elsif ($format == 6) {
+ die "unsupported" if $valueSize != 2;
+ my $dat = pack("n*", map { $_, $lookup->{$_} } sort { $a <=> $b } grep { $lookup->{$_} ne $default } keys %$lookup);
+ my $unitSize = 2 + $valueSize;
+ $fh->print(pack("nnnnn", $unitSize, TTF_bininfo(length($dat) / $unitSize, $unitSize)));
+ $fh->print($dat);
+ }
+
+ elsif ($format == 8) {
+ $fh->print(pack("nn", $firstGlyph, $lastGlyph - $firstGlyph + 1));
+ $fh->print(pack($packChar . "*", map { defined $lookup->{$_} ? $lookup->{$_} : defined $default ? $default : $_ } ($firstGlyph .. $lastGlyph)));
+ }
+
+ else {
+ die "unknown lookup format";
+ }
+
+ my $length = $fh->tell() - $lookupStart;
+ my $padBytes = (4 - ($length & 3)) & 3;
+ $fh->print(pack("C*", (0) x $padBytes));
+ $length += $padBytes;
+
+ $length;
+}
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Anchor.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Anchor.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Anchor.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,208 @@
+package Font::TTF::Anchor;
+
+=head1 TITLE
+
+Font::TTF::Anchor - Anchor points for GPOS tables
+
+=head1 DESCRIPTION
+
+The Anchor defines an anchor point on a glyph providing various information
+depending on how much is available, including such information as the co-ordinates,
+a curve point and even device specific modifiers.
+
+=head1 INSTANCE VARIABLES
+
+=over 4
+
+=item x
+
+XCoordinate of the anchor point
+
+=item y
+
+YCoordinate of the anchor point
+
+=item p
+
+Curve point on the glyph to use as the anchor point
+
+=item xdev
+
+Device table (delta) for the xcoordinate
+
+=item ydev
+
+Device table (delta) for the ycoordinate
+
+=item xid
+
+XIdAnchor for multiple master horizontal metric id
+
+=item yid
+
+YIdAnchor for multiple master vertical metric id
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+
+
+=head2 new
+
+Creates a new Anchor
+
+=cut
+
+sub new
+{
+ my ($class) = shift;
+ my ($self) = {@_};
+
+ bless $self, $class;
+}
+
+
+=head2 read($fh)
+
+Reads the anchor from the given file handle at that point. The file handle is left
+at an arbitrary read point, usually the end of something!
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat, $loc, $fmt, $x, $y, $p, $xoff, $yoff);
+
+ $fh->read($dat, 6);
+ ($fmt, $x, $y) = unpack('n*', $dat);
+ if ($fmt == 4)
+ { ($self->{'xid'}, $self->{'yid'}) = ($x, $y); }
+ else
+ { ($self->{'x'}, $self->{'y'}) = ($x, $y); }
+
+ if ($fmt == 2)
+ {
+ $fh->read($dat, 2);
+ $self->{'p'} = unpack('n', $dat);
+ } elsif ($fmt == 3)
+ {
+ $fh->read($dat, 4);
+ ($xoff, $yoff) = unpack('n2', $dat);
+ $loc = $fh->tell() - 10;
+ if ($xoff)
+ {
+ $fh->seek($loc + $xoff, 0);
+ $self->{'xdev'} = Font::TTF::Delta->new->read($fh);
+ }
+ if ($yoff)
+ {
+ $fh->seek($loc + $yoff, 0);
+ $self->{'ydev'} = Font::TTF::Delta->new->read($fh);
+ }
+ }
+ $self;
+}
+
+
+=head2 out($fh, $style)
+
+Outputs the Anchor to the given file handle at this point also addressing issues
+of deltas. If $style is set, then no output is set to the file handle. The return
+value is the output string.
+
+=cut
+
+sub out
+{
+ my ($self, $fh, $style) = @_;
+ my ($xoff, $yoff, $fmt, $out);
+
+ if (defined $self->{'xid'} || defined $self->{'yid'})
+ { $out = pack('n*', 4, $self->{'xid'}, $self->{'yid'}); }
+ elsif (defined $self->{'p'})
+ { $out = pack('n*', 2, @{$self}{'x', 'y', 'p'}); }
+ elsif (defined $self->{'xdev'} || defined $self->{'ydev'})
+ {
+ $out = pack('n*', 3, @{$self}{'x', 'y'});
+ if (defined $self->{'xdev'})
+ {
+ $out .= pack('n2', 10, 0);
+ $out .= $self->{'xdev'}->out($fh, 1);
+ $yoff = length($out) - 10;
+ }
+ else
+ { $out .= pack('n2', 0, 0); }
+ if (defined $self->{'ydev'})
+ {
+ $yoff = 10 unless $yoff;
+ substr($out, 8, 2) = pack('n', $yoff);
+ $out .= $self->{'ydev'}->out($fh, 1);
+ }
+ } else
+ { $out = pack('n3', 1, @{$self}{'x', 'y'}); }
+ $fh->print($out) unless $style;
+ $out;
+}
+
+
+=head2 $a->out_xml($context)
+
+Outputs the anchor in XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($end);
+
+ $fh->print("$depth<anchor x='$self->{'x'}' y='$self->{'y'}'");
+ $fh->print(" p='$self->{'p'}'") if defined ($self->{'p'});
+ $end = (defined $self->{'xdev'} || defined $self->{'ydev'} || defined $self->{'xid'} || defined $self->{'yid'});
+ unless ($end)
+ {
+ $fh->print("/>\n");
+ return $self;
+ }
+
+ if (defined $self->{'xdev'})
+ {
+ $fh->print("$depth$context->{'indent'}<xdev>\n");
+ $self->{'xdev'}->out_xml($context, $depth . ($context->{'indent'} x 2));
+ $fh->print("$depth$context->{'indent'}</xdev>\n");
+ }
+
+ if (defined $self->{'ydev'})
+ {
+ $fh->print("$depth$context->{'indent'}<ydev>\n");
+ $self->{'ydev'}->out_xml($context, $depth . ($context->{'indent'} x 2));
+ $fh->print("$depth$context->{'indent'}</ydev>\n");
+ }
+
+ if (defined $self->{'xid'} || defined $self->{'yid'})
+ {
+ $fh->print("$depth$context->{'indent'}<mmaster");
+ $fh->print(" xid='$self->{'xid'}'") if defined ($self->{'xid'});
+ $fh->print(" yid='$self->{'yid'}'") if defined ($self->{'yid'});
+ $fh->print("/>\n");
+ }
+ $fh->print("$depth</anchor>\n");
+ $self;
+}
+
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Bsln.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Bsln.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Bsln.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,163 @@
+package Font::TTF::Bsln;
+
+=head1 NAME
+
+Font::TTF::AAT::Bsln - Baseline table in a font
+
+=head1 DESCRIPTION
+
+=head1 INSTANCE VARIABLES
+
+=item version
+
+=item xformat
+
+=item defaultBaseline
+
+=item deltas
+
+=item stdGlyph
+
+=item ctlPoints
+
+=item lookupFormat
+
+=item lookup
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+
+use Font::TTF::AATutils;
+use Font::TTF::Utils;
+require Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $fh);
+
+ $self->SUPER::read or return $self;
+
+ $fh = $self->{' INFILE'};
+ $fh->read($dat, 8);
+ my ($version, $format, $defaultBaseline) = TTF_Unpack("fSS", $dat);
+
+ if ($format == 0 or $format == 1) {
+ $fh->read($dat, 64);
+ $self->{'deltas'} = [TTF_Unpack("s*", $dat)];
+ }
+ elsif ($format == 2 or $format == 3) {
+ $fh->read($dat, 2);
+ $self->{'stdGlyph'} = unpack("n", $dat);
+ $fh->read($dat, 64);
+ $self->{'ctlPoints'} = unpack("n*", $dat);
+ }
+ else {
+ die "unknown table format";
+ }
+
+ if ($format == 1 or $format == 3) {
+ my $len = $self->{' LENGTH'} - ($fh->tell() - $self->{' OFFSET'});
+ my ($lookupFormat, $lookup) = AAT_read_lookup($fh, 2, $len, $defaultBaseline);
+ $self->{'lookupFormat'} = $lookupFormat;
+ $self->{'lookup'} = $lookup;
+ }
+
+ $self->{'version'} = $version;
+ $self->{'format'} = $format;
+ $self->{'defaultBaseline'} = $defaultBaseline;
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ my $format = $self->{'format'};
+ my $defaultBaseline = $self->{'defaultBaseline'};
+ $fh->print(TTF_Pack("fSS", $self->{'version'}, $format, $defaultBaseline));
+
+ AAT_write_lookup($fh, $self->{'lookupFormat'}, $self->{'lookup'}, 2, $defaultBaseline) if ($format == 1 or $format == 3);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ $self->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ my $format = $self->{'format'};
+ $fh->printf("version %f\nformat %d\ndefaultBaseline %d\n", $self->{'version'}, $format, $self->{'defaultBaseline'});
+ if ($format == 0 or $format == 1) {
+ $fh->printf("\tdeltas:\n");
+ my $deltas = $self->{'deltas'};
+ foreach (0 .. 31) {
+ $fh->printf("\t\t%d: %d%s\n", $_, $deltas->[$_], defined baselineName_($_) ? "\t# " . baselineName_($_) : "");
+ }
+ }
+ if ($format == 2 or $format == 3) {
+ $fh->printf("\tstdGlyph = %d\n", $self->{'stdGlyph'});
+ my $ctlPoints = $self->{'ctlPoints'};
+ foreach (0 .. 31) {
+ $fh->printf("\t\t%d: %d%s\n", $_, $ctlPoints->[$_], defined baselineName_($_) ? "\t# " . baselineName_($_) : "");
+ }
+ }
+ if ($format == 1 or $format == 3) {
+ $fh->printf("lookupFormat %d\n", $self->{'lookupFormat'});
+ my $lookup = $self->{'lookup'};
+ foreach (sort { $a <=> $b } keys %$lookup) {
+ $fh->printf("\tglyph %d: %d%s\n", $_, $lookup->{$_}, defined baselineName_($_) ? "\t# " . baselineName_($_) : "");
+ }
+ }
+}
+
+sub baselineName_
+{
+ my ($b) = @_;
+ my @baselines = ( 'Roman', 'Ideographic centered', 'Ideographic low', 'Hanging', 'Math' );
+ $baselines[$b];
+}
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Changes
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Changes 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Changes 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,108 @@
+Note. The version number implies a release point. Thus changes that go into a
+version occur above the version number, not after it.
+
+* 0.05
+** cmap
+ debug reverse()
+ provide scripts as .pl instead of .bat to placate Unix world
+ rename makefile.pl to Makefile.PL to keep Unix happy
+ Add ttfremap script
+
+* 0.06 .. 0.08
+ Fixes to get this stuff working in Unix
+
+* 0.09
+ Never released
+
+* 0.10
+** cmap
+ Make reverse return the lowest codepoint that matches rather than
+ the highest
+** font
+ Use IO::File everywhere to allow passing in of psuedo-file objects
+ rather than file names
+** Utils
+ Debug FDot2.14 conversion
+
+* 0.11
+** cmap
+ Don't store empty entries in the cmap
+
+* 0.12
+Various changes to reduce warnings
+
+** glyph
+ Add update_bbox
+ Do full glyph writes if loca read rather than glyf read
+ Get glyph update working usefully. Clarify glyf->read
+
+* 0.13
+
+** glyph
+ Debug update_bbox for compound glyphs
+ Add empty() to clear to unread state (allows apps to save memory)
+
+** OS/2
+ update update() to account for new cmap structure
+
+** Post
+ Correct mu to pi in Postscript name list. The list now follows the
+ MS convention for good or ill.
+
+** Table
+ Add empty() to clear a table to its unread state
+
+** Scripts
+*** psfix
+ Added. Creates Post table based on cmap information
+
+*** eurofix
+ Added bullet hacking and generally backwards, forwards, all
+ ways mapping.
+
+*** ttfenc
+ Now supports the difference between MS post name list and TeXs
+
+* 0.14
+
+ Sort out mix up over CVS mess
+
+* 0.15
+
+** Table
+ read_dat no longer marks table as read
+
+** Cvt_
+ Mark table as read when read
+
+** Fpgm
+ Mark table as read when read
+
+** Prep
+ Mark table as read when read
+
+** Font
+ Add support for Mac sfnt version code ('true')
+ Be stricter on out @fontlist, only output tables that exist
+
+* 0.16
+
+** Install
+ add pmake support
+
+** glyph
+ tidy up pod
+
+** kern
+ tidy up pod
+
+** name
+ add utf8 support
+
+* 0.17
+
+** Utils
+ Debug TTF_bininfo >>= seems to have stopped working!
+
+* 0.18
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cmap.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cmap.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cmap.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,478 @@
+package Font::TTF::Cmap;
+
+=head1 NAME
+
+Font::TTF::Cmap - Character map table
+
+=head1 DESCRIPTION
+
+Looks after the character map. For ease of use, the actual cmap is held in
+a hash against codepoint. Thus for a given table:
+
+ $gid = $font->{'cmap'}{'Tables'}[0]{'val'}{$code};
+
+Note that C<$code> should be a true value (0x1234) rather than a string representation.
+
+=head1 INSTANCE VARIABLES
+
+The instance variables listed here are not preceeded by a space due to their
+emulating structural information in the font.
+
+=over 4
+
+=item Num
+
+Number of subtables in this table
+
+=item Tables
+
+An array of subtables ([0..Num-1])
+
+=back
+
+Each subtables also has its own instance variables which are, again, not
+preceeded by a space.
+
+=over 4
+
+=item Platform
+
+The platform number for this subtable
+
+=item Encoding
+
+The encoding number for this subtable
+
+=item Format
+
+Gives the stored format of this subtable
+
+=item Ver
+
+Gives the version (or language) information for this subtable
+
+=item val
+
+A hash keyed by the codepoint value (not a string) storing the glyph id
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+
+
+=head2 $t->read
+
+Reads the cmap into memory. Format 4 subtables read the whole subtable and
+fill in the segmented array accordingly.
+
+Format 2 subtables are not read at all.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $i, $j, $k, $id, @ids, $s);
+ my ($start, $end, $range, $delta, $form, $len, $num, $ver, $sg);
+ my ($fh) = $self->{' INFILE'};
+
+ $self->SUPER::read or return $self;
+ $fh->read($dat, 4);
+ $self->{'Num'} = unpack("x2n", $dat);
+ $self->{'Tables'} = [];
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = {};
+ $fh->read($dat, 8);
+ ($s->{'Platform'}, $s->{'Encoding'}, $s->{'LOC'}) = (unpack("nnN", $dat));
+ $s->{'LOC'} += $self->{' OFFSET'};
+ push(@{$self->{'Tables'}}, $s);
+ }
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ $fh->seek($s->{'LOC'}, 0);
+ $fh->read($dat, 2);
+ $form = unpack("n", $dat);
+
+ $s->{'Format'} = $form;
+ if ($form == 0)
+ {
+ my ($j) = 0;
+
+ $fh->read($dat, 4);
+ ($len, $s->{'Ver'}) = unpack('n2', $dat);
+ $fh->read($dat, 256);
+ $s->{'val'} = {map {$j++; ($_ ? ($j - 1, $_) : ())} unpack("C*", $dat)};
+ } elsif ($form == 6)
+ {
+ my ($start, $ecount);
+
+ $fh->read($dat, 8);
+ ($len, $s->{'Ver'}, $start, $ecount) = unpack('n4', $dat);
+ $fh->read($dat, $ecount << 1);
+ $s->{'val'} = {map {$start++; ($_ ? ($start - 1, $_) : ())} unpack("n*", $dat)};
+ } elsif ($form == 2)
+ {
+# no idea what to do here yet
+ } elsif ($form == 4)
+ {
+ $fh->read($dat, 12);
+ ($len, $s->{'Ver'}, $num) = unpack('n3', $dat);
+ $num >>= 1;
+ $fh->read($dat, $len - 14);
+ for ($j = 0; $j < $num; $j++)
+ {
+ $end = unpack("n", substr($dat, $j << 1, 2));
+ $start = unpack("n", substr($dat, ($j << 1) + ($num << 1) + 2, 2));
+ $delta = unpack("n", substr($dat, ($j << 1) + ($num << 2) + 2, 2));
+ $delta -= 65536 if $delta > 32767;
+ $range = unpack("n", substr($dat, ($j << 1) + $num * 6 + 2, 2));
+ for ($k = $start; $k <= $end; $k++)
+ {
+ if ($range == 0 || $range == 65535) # support the buggy FOG with its range=65535 for final segment
+ { $id = $k + $delta; }
+ else
+ { $id = unpack("n", substr($dat, ($j << 1) + $num * 6 +
+ 2 + ($k - $start) * 2 + $range, 2)) + $delta; }
+ $id -= 65536 if $id >= 65536;
+ $s->{'val'}{$k} = $id if ($id);
+ }
+ }
+ } elsif ($form == 8 || $form == 12)
+ {
+ $fh->read($dat, 10);
+ ($len, $s->{'Ver'}) = unpack('x2N2', $dat);
+ if ($form == 8)
+ {
+ $fh->read($dat, 8196);
+ $num = unpack("N", substr($dat, 8192, 4)); # don't need the map
+ } else
+ {
+ $fh->read($dat, 4);
+ $num = unpack("N", $dat);
+ }
+ $fh->read($dat, 12 * $num);
+ for ($j = 0; $j < $num; $j++)
+ {
+ ($start, $end, $sg) = unpack("N3", substr($dat, $j * 12, 12));
+ for ($k = $start; $k <= $end; $k++)
+ { $s->{'val'}{$k} = $sg++; }
+ }
+ } elsif ($form == 10)
+ {
+ $fh->read($dat, 18);
+ ($len, $s->{'Ver'}, $start, $num) = unpack('x2N4', $dat);
+ $fh->read($dat, $num << 1);
+ for ($j = 0; $j < $num; $j++)
+ { $s->{'val'}{$start + $j} = unpack("n", substr($dat, $j << 1, 2)); }
+ }
+ }
+ $self;
+}
+
+
+=head2 $t->ms_lookup($uni)
+
+Finds a Unicode table, giving preference to the MS one, and looks up the given
+Unicode codepoint in it to find the glyph id.
+
+=cut
+
+sub ms_lookup
+{
+ my ($self, $uni) = @_;
+
+ $self->find_ms || return undef unless (defined $self->{' mstable'});
+ return $self->{' mstable'}{'val'}{$uni};
+}
+
+
+=head2 $t->find_ms
+
+Finds the a Unicode table, giving preference to the Microsoft one, and sets the C<mstable> instance variable
+to it if found. Returns the table it finds.
+
+=cut
+sub find_ms
+{
+ my ($self) = @_;
+ my ($i, $s, $alt, $found);
+
+ return $self->{' mstable'} if defined $self->{' mstable'};
+ $self->read;
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ if ($s->{'Platform'} == 3)
+ {
+ $self->{' mstable'} = $s;
+ last if ($s->{'Encoding'} == 10);
+ $found = 1 if ($s->{'Encoding'} == 1);
+ } elsif ($s->{'Platform'} == 0 || ($s->{'Platform'} == 2 && $s->{'Encoding'} == 1))
+ { $alt = $s; }
+ }
+ $self->{' mstable'} = $alt if ($alt && !$found);
+ $self->{' mstable'};
+}
+
+
+=head2 $t->ms_enc
+
+Returns the encoding of the microsoft table (0 => symbol, etc.). Returns undef if there is
+no Microsoft cmap.
+
+=cut
+
+sub ms_enc
+{
+ my ($self) = @_;
+ my ($s);
+
+ return $self->{' mstable'}{'Encoding'}
+ if (defined $self->{' mstable'} && $self->{' mstable'}{'Platform'} == 3);
+
+ foreach $s (@{$self->{'Tables'}})
+ {
+ return $s->{'Encoding'} if ($s->{'Platform'} == 3);
+ }
+ return undef;
+}
+
+
+=head2 $t->out($fh)
+
+Writes out a cmap table to a filehandle. If it has not been read, then
+just copies from input file to output
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($loc, $s, $i, $base_loc, $j, @keys);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+
+ $self->{'Tables'} = [sort {$a->{'Platform'} <=> $b->{'Platform'}
+ || $a->{'Encoding'} <=> $b->{'Encoding'}
+ || $a->{'Ver'} <=> $b->{'Ver'}} @{$self->{'Tables'}}];
+ $self->{'Num'} = scalar @{$self->{'Tables'}};
+
+ $base_loc = $fh->tell();
+ $fh->print(pack("n2", 0, $self->{'Num'}));
+
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ { $fh->print(pack("nnN", $self->{'Tables'}[$i]{'Platform'}, $self->{'Tables'}[$i]{'Encoding'}, 0)); }
+
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ @keys = sort {$a <=> $b} keys %{$s->{'val'}};
+ $s->{' outloc'} = $fh->tell();
+ if ($s->{'Format'} < 8)
+ { $fh->print(pack("n3", $s->{'Format'}, 0, $s->{'Ver'})); } # come back for length
+ else
+ { $fh->print(pack("n2N2", $s->{'Format'}, 0, 0, $s->{'Ver'})); }
+
+ if ($s->{'Format'} == 0)
+ {
+ $fh->print(pack("C256", @{$s->{'val'}}{0 .. 255}));
+ } elsif ($s->{'Format'} == 6)
+ {
+ $fh->print(pack("n2", $keys[0], $keys[-1] - $keys[0] + 1));
+ $fh->print(pack("n*", @{$s->{'val'}}{$keys[0] .. $keys[-1]}));
+ } elsif ($s->{'Format'} == 2)
+ {
+ } elsif ($s->{'Format'} == 4)
+ {
+ my ($num, $sRange, $eSel, $eShift, @starts, @ends, $doff);
+ my (@deltas, $delta, @range, $flat, $k, $segs, $count, $newseg, $v);
+
+ push(@keys, 0xFFFF) unless ($keys[-1] == 0xFFFF);
+ $newseg = 1; $num = 0;
+ for ($j = 0; $j <= $#keys && $keys[$j] <= 0xFFFF; $j++)
+ {
+ $v = $s->{'val'}{$keys[$j]};
+ if ($newseg)
+ {
+ $delta = $v;
+ $doff = $j;
+ $flat = 1;
+ push(@starts, $keys[$j]);
+ $newseg = 0;
+ }
+ $delta = 0 if ($delta + $j - $doff != $v);
+ $flat = 0 if ($v == 0);
+ if ($j == $#keys || $keys[$j] + 1 != $keys[$j+1])
+ {
+ push (@ends, $keys[$j]);
+ push (@deltas, $delta ? $delta - $keys[$doff] : 0);
+ push (@range, $flat);
+ $num++;
+ $newseg = 1;
+ }
+ }
+
+ ($num, $sRange, $eSel, $eShift) = Font::TTF::Utils::TTF_bininfo($num, 2);
+ $fh->print(pack("n4", $num * 2, $sRange, $eSel, $eShift));
+ $fh->print(pack("n*", @ends));
+ $fh->print(pack("n", 0));
+ $fh->print(pack("n*", @starts));
+ $fh->print(pack("n*", @deltas));
+
+ $count = 0;
+ for ($j = 0; $j < $num; $j++)
+ {
+ $delta = $deltas[$j];
+ if ($delta != 0 && $range[$j] == 1)
+ { $range[$j] = 0; }
+ else
+ {
+ $range[$j] = ($count + $num - $j) << 1;
+ $count += $ends[$j] - $starts[$j] + 1;
+ }
+ }
+
+ $fh->print(pack("n*", @range));
+
+ for ($j = 0; $j < $num; $j++)
+ {
+ next if ($range[$j] == 0);
+ $fh->print(pack("n*", @{$s->{'val'}}{$starts[$j] .. $ends[$j]}));
+ }
+ } elsif ($s->{'Format'} == 8 || $s->{'Format'} == 12)
+ {
+ my (@jobs, $start, $current, $curr_glyf, $map);
+
+ $map = "\000" x 8192;
+ foreach $j (@keys)
+ {
+ if ($j > 0xFFFF)
+ {
+ if (defined $s->{'val'}{$j >> 16})
+ { $s->{'Format'} = 12; }
+ vec($map, $j >> 16, 1) = 1;
+ }
+ if ($j != $current + 1 || $s->{'val'}{$j} != $curr_glyf + 1)
+ {
+ push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
+ $start = $j; $current = $j; $curr_glyf = $s->{'val'}{$j};
+ }
+ $current = $j;
+ $curr_glyf = $s->{'val'}{$j};
+ }
+ push (@jobs, [$start, $current, $curr_glyf - ($current - $start)]) if (defined $start);
+ $fh->print($map) if ($s->{'Format'} == 8);
+ $fh->print(pack('N', $#jobs + 1));
+ foreach $j (@jobs)
+ { $fh->print(pack('N3', @{$j})); }
+ } elsif ($s->{'Format'} == 10)
+ {
+ $fh->print(pack('N2', $keys[0], $keys[-1] - $keys[0] + 1));
+ $fh->print(pack('n*', $s->{'val'}{$keys[0] .. $keys[-1]}));
+ }
+
+ $loc = $fh->tell();
+ if ($s->{'Format'} < 8)
+ {
+ $fh->seek($s->{' outloc'} + 2, 0);
+ $fh->print(pack("n", $loc - $s->{' outloc'}));
+ } else
+ {
+ $fh->seek($s->{' outloc'} + 4, 0);
+ $fh->print(pack("N", $loc - $s->{' outloc'}));
+ }
+ $fh->seek($base_loc + 8 + ($i << 3), 0);
+ $fh->print(pack("N", $s->{' outloc'} - $base_loc));
+ $fh->seek($loc, 0);
+ }
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $name, $val)
+
+Outputs the elements of the cmap in XML. We only need to process val here
+
+=cut
+
+sub XML_element
+{
+ my ($self, $context, $depth, $k, $val) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($i);
+
+ return $self if ($k eq 'LOC');
+ return $self->SUPER::XML_element($context, $depth, $k, $val) unless ($k eq 'val');
+
+ $fh->print("$depth<mappings>\n");
+ foreach $i (sort {$a <=> $b} keys %{$val})
+ { $fh->printf("%s<map code='%04X' glyph='%s'/>\n", $depth . $context->{'indent'}, $i, $val->{$i}); }
+ $fh->print("$depth</mappings>\n");
+ $self;
+}
+
+=head2 @map = $t->reverse([$num])
+
+Returns a reverse map of the table of given number or the Unicode
+cmap. I.e. given a glyph gives the Unicode value for it.
+
+=cut
+
+sub reverse
+{
+ my ($self, $tnum) = @_;
+ my ($table) = defined $tnum ? $self->{'Tables'}[$tnum] : $self->find_ms;
+ my (@res, $code, $gid);
+
+ while (($code, $gid) = each(%{$table->{'val'}}))
+ { $res[$gid] = $code unless (defined $res[$gid] && $res[$gid] > 0 && $res[$gid] < $code); }
+ @res;
+}
+
+
+=head2 is_unicode($index)
+
+Returns whether the table of a given index is known to be a unicode table
+(as specified in the specifications)
+
+=cut
+
+sub is_unicode
+{
+ my ($self, $index) = @_;
+ my ($pid, $eid) = ($self->{'Tables'}[$index]{'Platform'}, $self->{'Tables'}[$index]{'Encoding'});
+
+ return ($pid == 3 || $pid == 0 || ($pid == 2 && $eid == 1));
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+No support for format 2 tables (MBCS)
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Coverage.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Coverage.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Coverage.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,253 @@
+package Font::TTF::Coverage;
+
+=head1 TITLE
+
+Font::TTF::Coverage - Opentype coverage and class definition objects
+
+=head1 DESCRIPTION
+
+Coverage tables and class definition objects are virtually identical concepts
+in OpenType. Their difference comes purely in their storage. Therefore we can
+say that a coverage table is a class definition in which the class definition
+for each glyph is the corresponding index in the coverage table. The resulting
+data structure is that a Coverage table has the following fields:
+
+=item cover
+
+A boolean to indicate whether this table is a coverage table (TRUE) or a
+class definition (FALSE)
+
+=item val
+
+A hash of glyph ids against values (either coverage index or class value)
+
+=item fmt
+
+The storage format used is given here, but is recalculated when the table
+is written out.
+
+=item count
+
+A count of the elements in a coverage table for use with add. Each subsequent
+addition is added with the current count and increments the count.
+
+=head1 METHODS
+
+=cut
+
+=head2 new($isCover [, vals])
+
+Creates a new coverage table or class definition table, depending upon the
+value of $isCover. if $isCover then vals may be a list of glyphs to include in order.
+If no $isCover, then vals is a hash of glyphs against class values.
+
+=cut
+
+sub new
+{
+ my ($class) = shift;
+ my ($isCover) = shift;
+ my ($self) = {};
+
+ $self->{'cover'} = $isCover;
+ $self->{'count'} = 0;
+ if ($isCover)
+ {
+ my ($v);
+ foreach $v (@_)
+ { $self->{'val'}{$v} = $self->{'count'}++; }
+ }
+ else
+ { $self->{'val'} = {@_}; }
+ bless $self, $class;
+}
+
+
+=head2 read($fh)
+
+Reads the coverage/class table from the given file handle
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat, $fmt, $num, $i, $c);
+
+ $fh->read($dat, 4);
+ ($fmt, $num) = unpack("n2", $dat);
+ $self->{'fmt'} = $fmt;
+
+ if ($self->{'cover'})
+ {
+ if ($fmt == 1)
+ {
+ $fh->read($dat, $num << 1);
+ map {$self->{'val'}{$_} = $i++} unpack("n*", $dat);
+ } elsif ($fmt == 2)
+ {
+ $fh->read($dat, $num * 6);
+ for ($i = 0; $i < $num; $i++)
+ {
+ ($first, $last, $c) = unpack("n3", substr($dat, $i * 6, 6));
+ map {$self->{'val'}{$_} = $c++} ($first .. $last);
+ }
+ }
+ } elsif ($fmt == 1)
+ {
+ $fh->read($dat, 2);
+ $first = $num;
+ ($num) = unpack("n", $dat);
+ $fh->read($dat, $num << 1);
+ map {$self->{'val'}{$first++} = $_} unpack("n*", $dat);
+ } elsif ($fmt == 2)
+ {
+ $fh->read($dat, $num * 6);
+ for ($i = 0; $i < $num; $i++)
+ {
+ ($first, $last, $c) = unpack("n3", substr($dat, $i * 6, 6));
+ map {$self->{'val'}{$_} = $c} ($first .. $last);
+ }
+ }
+ $self;
+}
+
+
+=head2 out($fh, $state)
+
+Writes the coverage/class table to the given file handle. If $state is 1 then
+the output string is returned rather than being output to a filehandle.
+
+=cut
+
+sub out
+{
+ my ($self, $fh, $state) = @_;
+ my ($g, $eff, $grp, $out);
+ my ($shipout) = ($state ? sub {$out .= $_[0];} : sub {$fh->print($_[0]);});
+ my (@gids) = sort {$a <=> $b} keys %{$self->{'val'}};
+
+ $fmt = 1; $grp = 1;
+ for ($i = 1; $i <= $#gids; $i++)
+ {
+ if ($self->{'val'}{$gids[$i]} < $self->{'val'}{$gids[$i-1]} && $self->{'cover'})
+ {
+ $fmt = 2;
+ last;
+ } elsif ($gids[$i] == $gids[$i-1] + 1)
+ { $eff++; }
+ else
+ { $grp++; }
+ }
+ if ($self->{'cover'})
+ { $fmt = 2 if ($eff / $grp > 4); }
+ else
+ { $fmt = 2 if ($grp > 1); }
+
+ if ($fmt == 1 && $self->{'cover'})
+ {
+ my ($last) = 0;
+ &$shipout(pack('n2', 1, scalar @gids));
+ &$shipout(pack('n*', @gids));
+ } elsif ($fmt == 1)
+ {
+ my ($last) = $gids[0];
+ &$shipout(pack("n3", 1, $last, $gids[-1] - $last + 1));
+ foreach $g (@gids)
+ {
+ if ($g > $last + 1)
+ { &$shipout(pack('n*', 0 x ($g - $last - 1))); }
+ &$shipout(pack('n', $self->{'val'}{$g}));
+ $last = $g;
+ }
+ } else
+ {
+ my ($start, $end, $ind, $numloc, $endloc, $num);
+ &$shipout(pack("n2", 2, 0));
+ $numloc = $fh->tell() - 2 unless $state;
+
+ $start = 0; $end = 0; $num = 0;
+ while ($end < $#gids)
+ {
+ if ($gids[$end + 1] == $gids[$end] + 1
+ && $self->{'val'}{$gids[$end + 1]}
+ == $self->{'val'}{$gids[$end]}
+ + ($self->{'cover'} ? 1 : 0))
+ {
+ $end++;
+ next;
+ }
+
+ &$shipout(pack("n3", $gids[$start], $gids[$end],
+ $self->{'val'}{$gids[$start]}));
+ $start = $end + 1;
+ $end++;
+ $num++;
+ }
+ &$shipout(pack("n3", $gids[$start], $gids[$end],
+ $self->{'val'}{$gids[$start]}));
+ $num++;
+ if ($state)
+ { substr($out, 2, 2) = pack('n', $num); }
+ else
+ {
+ $endloc = $fh->tell();
+ $fh->seek($numloc, 0);
+ $fh->print(pack("n", $num));
+ $fh->seek($endloc, 0);
+ }
+ }
+ return ($state ? $out : $self);
+}
+
+
+=head2 $c->add($glyphid)
+
+Adds a glyph id to the coverage table incrementing the count so that each subsequent addition
+has the next sequential number. Returns the index number of the glyphid added
+
+=cut
+
+sub add
+{
+ my ($self, $gid) = @_;
+
+ return $self->{'val'}{$gid} if (defined $self->{'val'}{$gid});
+ $self->{'val'}{$gid} = $self->{'count'};
+ return $self->{'count'}++;
+}
+
+
+=head2 $c->out_xml($context)
+
+Outputs this coverage/class in XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+
+ $fh->print("$depth<" . ($self->{'cover'} ? 'coverage' : 'class') . ">\n");
+ foreach $gid (sort {$a <=> $b} keys %{$self->{'val'}})
+ {
+ $fh->printf("$depth$context->{'indent'}<gref glyph='%s' val='%s'/>\n", $gid, $self->{'val'}{$gid});
+ }
+ $fh->print("$depth</" . ($self->{'cover'} ? 'coverage' : 'class') . ">\n");
+ $self;
+}
+
+sub release
+{ }
+
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cvt_.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cvt_.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Cvt_.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,81 @@
+package Font::TTF::Cvt_;
+
+=head1 NAME
+
+Font::TTF::Cvt_ - Control Value Table in a TrueType font
+
+=head1 DESCRIPTION
+
+This is a minimal class adding nothing beyond a table, but is a repository
+for cvt type information for those processes brave enough to address hinting.
+
+=head1 INSTANCE VARIABLES
+
+=over 4
+
+=item val
+
+This is an array of CVT values. Thus access to the CVT is via:
+
+ $f->{'cvt_'}{'val'}[$num];
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+
+$VERSION = 0.0001;
+
+=head2 $t->read
+
+Reads the CVT table into both the tables C<' dat'> variable and the C<val>
+array.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+
+ $self->read_dat || return undef;
+ $self->{' read'} = 1;
+ $self->{'val'} = [TTF_Unpack("s*", $self->{' dat'})];
+ $self;
+}
+
+
+=head2 $t->update
+
+Updates the RAM file copy C<' dat'> to be the same as the array.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+
+ return undef unless ($self->{' read'} && $#{$self->{'val'}} >= 0);
+ $self->{' dat'} = TTF_Pack("s*", @{$self->{'val'}});
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Delta.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Delta.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Delta.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,160 @@
+package Font::TTF::Delta;
+
+=head1 TITLE
+
+SIL::TTF::Delta - Opentype Device tables
+
+=head1 DESCRIPTION
+
+Each device table corresponds to a set of deltas for a particular point over
+a range of ppem values.
+
+=item first
+
+The first ppem value in the range
+
+=item last
+
+The last ppem value in the range
+
+=item val
+
+This is an array of deltas corresponding to each ppem in the range between
+first and last inclusive.
+
+=item fmt
+
+This is the fmt used (log2 of number bits per value) when the device table was
+read. It is recalculated on output.
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use Font::TTF::Utils;
+
+=head2 new
+
+Creates a new device table
+
+=cut
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ bless $self, $class;
+}
+
+
+=head2 read
+
+Reads a device table from the given IO object at the current location
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat, $fmt, $num, $i, $j, $mask);
+
+ $fh->read($dat, 6);
+ ($self->{'first'}, $self->{'last'}, $fmt) = TTF_Unpack("S3", $dat);
+ $self->{'fmt'} = $fmt;
+
+ $fmt = 1 << $fmt;
+ $num = ((($self->{'last'} - $self->{'first'} + 1) * $fmt) + 15) >> 8;
+ $fh->read($dat, $num);
+
+ $mask = (0xffff << (16 - $fmt)) & 0xffff;
+ $j = 0;
+ for ($i = $self->{'first'}; $i <= $self->{'last'}; $i++)
+ {
+ if ($j == 0)
+ {
+ $num = TTF_Unpack("S", substr($dat, 0, 2));
+ substr($dat, 0, 2) = '';
+ }
+ push (@{$self->{'val'}}, ($num & $mask) >> (16 - $fmt));
+ $num <<= $fmt;
+ $j += $fmt;
+ $j = 0 if ($j >= 16);
+ }
+ $self;
+}
+
+
+=head2 out($fh, $style)
+
+Outputs a device table to the given IO object at the current location, or just
+returns the data to be output if $style != 0
+
+=cut
+
+sub out
+{
+ my ($self, $fh, $style) = @_;
+ my ($dat, $fmt, $num, $mask, $j, $f, $out);
+
+ foreach $f (@{$self->{'val'}})
+ {
+ my ($tfmt) = $f > 0 ? $f + 1 : -$f;
+ $fmt = $tfmt if $tfmt > $fmt;
+ }
+
+ if ($fmt > 8)
+ { $fmt = 3; }
+ elsif ($fmt > 2)
+ { $fmt = 2; }
+ else
+ { $fmt = 1; }
+
+ $out = TTF_Pack("S3", $self->{'first'}, $self->{'last'}, $fmt);
+
+ $fmt = 1 << $fmt;
+ $mask = 0xffff >> (16 - $fmt);
+ $j = 0; $dat = 0;
+ foreach $f (@{$self->{'val'}})
+ {
+ $dat |= ($f & $mask) << (16 - $fmt - $j);
+ $j += $fmt;
+ if ($j >= 16)
+ {
+ $j = 0;
+ $out .= TTF_Pack("S", $dat);
+ $dat = 0;
+ }
+ }
+ $out .= pack('n', $dat) if ($j > 0);
+ $fh->print($out) unless $style;
+ $out;
+}
+
+
+=head2 $d->out_xml($context)
+
+Outputs a delta in XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+
+ $fh->printf("%s<delta first='%s' last='%s'>\n", $depth, $self->{'first'}, $self->{'last'});
+ $fh->print("$depth$context->{'indent'}" . join (' ', @{$self->{'val'}}) . "\n") if defined ($self->{'val'});
+ $fh->print("$depth</delta>\n");
+}
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fdsc.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fdsc.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fdsc.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,125 @@
+package Font::TTF::Fdsc;
+
+=head1 NAME
+
+Font::TTF::AAT::Fdsc - Font Descriptors table in a font
+
+=head1 DESCRIPTION
+
+=head1 INSTANCE VARIABLES
+
+=item version
+
+=item descriptors
+
+Hash keyed by descriptor tags
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields);
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $fh, $numDescs, $tag, $descs);
+
+ $self->SUPER::read or return $self;
+
+ $fh = $self->{' INFILE'};
+ $fh->read($dat, 4);
+ $self->{'version'} = TTF_Unpack("f", $dat);
+
+ $fh->read($dat, 4);
+
+ foreach (1 .. unpack("N", $dat)) {
+ $fh->read($tag, 4);
+ $fh->read($dat, 4);
+ $descs->{$tag} = ($tag eq 'nalf') ? unpack("N", $dat) : TTF_Unpack("f", $dat);
+ }
+
+ $self->{'descriptors'} = $descs;
+
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($descs);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $fh->print(TTF_Pack("f", $self->{'version'}));
+
+ $descs = $self->{'descriptors'} or {};
+
+ $fh->print(pack("N", scalar keys %$descs));
+ foreach (sort keys %$descs) {
+ $fh->print($_);
+ $fh->print(($_ eq 'nalf') ? pack("N", $descs->{$_}) : TTF_Pack("f", $descs->{$_}));
+ }
+
+ $self;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+ my ($descs, $k);
+
+ $self->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $descs = $self->{'descriptors'};
+ foreach $k (sort keys %$descs) {
+ if ($k eq 'nalf') {
+ $fh->printf("Descriptor '%s' = %d\n", $k, $descs->{$k});
+ }
+ else {
+ $fh->printf("Descriptor '%s' = %f\n", $k, $descs->{$k});
+ }
+ }
+
+ $self;
+}
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Feat.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Feat.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Feat.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,191 @@
+package Font::TTF::Feat;
+
+=head1 NAME
+
+Font::TTF::Feat - Font Features
+
+=head1 DESCRIPTION
+
+=head1 INSTANCE VARIABLES
+
+=over 4
+
+=item version
+
+=item features
+
+An array of hashes of the following form
+
+=over 8
+
+=item feature
+
+feature id number
+
+=item name
+
+name index in name table
+
+=item exclusive
+
+exclusive flag
+
+=item settings
+
+hash of setting number against name string index
+
+=back
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+
+use Font::TTF::Utils;
+
+require Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the features from the TTF file into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($featureCount, $features);
+
+ $self->SUPER::read_dat or return $self;
+
+ ($self->{'version'}, $featureCount) = TTF_Unpack("fS", $self->{' dat'});
+
+ $features = [];
+ foreach (1 .. $featureCount) {
+ my ($feature, $nSettings, $settingTable, $featureFlags, $nameIndex)
+ = TTF_Unpack("SSLSS", substr($self->{' dat'}, $_ * 12, 12));
+ push @$features,
+ {
+ 'feature' => $feature,
+ 'name' => $nameIndex,
+ 'exclusive' => (($featureFlags & 0x8000) != 0),
+ 'settings' => { TTF_Unpack("S*", substr($self->{' dat'}, $settingTable, $nSettings * 4)) }
+ };
+ }
+ $self->{'features'} = $features;
+
+ delete $self->{' dat'}; # no longer needed, and may become obsolete
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the features to a TTF file
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($features, $numFeatures, $settings, $featuresData, $settingsData);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $features = $self->{'features'};
+ $numFeatures = @$features;
+
+ foreach (@$features) {
+ $settings = $_->{'settings'};
+ $featuresData .= TTF_Pack("SSLSS",
+ $_->{'feature'},
+ scalar keys %$settings,
+ 12 + 12 * $numFeatures + length $settingsData,
+ ($_->{'exclusive'} ? 0x8000 : 0x0000),
+ $_->{'name'});
+ foreach (sort {$a <=> $b} keys %$settings) {
+ $settingsData .= TTF_Pack("SS", $_, $settings->{$_});
+ }
+ }
+
+ $fh->print(TTF_Pack("fSSL", $self->{'version'}, $numFeatures, 0, 0));
+ $fh->print($featuresData);
+ $fh->print($settingsData);
+
+ $self;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+ my ($names, $features, $settings);
+
+ $self->read;
+
+ $names = $self->{' PARENT'}->{'name'};
+ $names->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $features = $self->{'features'};
+ foreach (@$features) {
+ $fh->printf("Feature %d, %s, name %d # '%s'\n",
+ $_->{'feature'},
+ ($_->{'exclusive'} ? "exclusive" : "additive"),
+ $_->{'name'},
+ $names->{'strings'}[$_->{'name'}][1][0]{0});
+ $settings = $_->{'settings'};
+ foreach (sort { $a <=> $b } keys %$settings) {
+ $fh->printf("\tSetting %d, name %d # '%s'\n",
+ $_, $settings->{$_}, $names->{'strings'}[$settings->{$_}][1][0]{0});
+ }
+ }
+
+ $self;
+}
+
+sub settingName
+{
+ my ($self, $feature, $setting) = @_;
+
+ $self->read;
+
+ my $names = $self->{' PARENT'}->{'name'};
+ $names->read;
+
+ my $features = $self->{'features'};
+ my ($featureEntry) = grep { $_->{'feature'} == $feature } @$features;
+ my $featureName = $names->{'strings'}[$featureEntry->{'name'}][1][0]{0};
+ my $settingName = $featureEntry->{'exclusive'}
+ ? $names->{'strings'}[$featureEntry->{'settings'}->{$setting}][1][0]{0}
+ : $names->{'strings'}[$featureEntry->{'settings'}->{$setting & ~1}][1][0]{0}
+ . (($setting & 1) == 0 ? " On" : " Off");
+
+ ($featureName, $settingName);
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fmtx.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fmtx.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fmtx.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,108 @@
+package Font::TTF::Fmtx;
+
+=head1 NAME
+
+Font::TTF::Fmtx - Font Metrics table
+
+=head1 DESCRIPTION
+
+This is a simple table with just standards specified instance variables
+
+=head1 INSTANCE VARIABLES
+
+ version
+ glyphIndex
+ horizontalBefore
+ horizontalAfter
+ horizontalCaretHead
+ horizontalCaretBase
+ verticalBefore
+ verticalAfter
+ verticalCaretHead
+ verticalCaretBase
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'version' => 'f',
+ 'glyphIndex' => 'L',
+ 'horizontalBefore' => 'c',
+ 'horizontalAfter' => 'c',
+ 'horizontalCaretHead' => 'c',
+ 'horizontalCaretBase' => 'c',
+ 'verticalBefore' => 'c',
+ 'verticalAfter' => 'c',
+ 'verticalCaretHead' => 'c',
+ 'verticalCaretBase' => 'c');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory as instance variables
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read or return $self;
+ init unless defined $fields{'glyphIndex'};
+ $self->{' INFILE'}->read($dat, 16);
+
+ TTF_Read_Fields($self, $dat, \%fields);
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $fh->print(TTF_Out_Fields($self, \%fields, 16));
+ $self;
+}
+
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Font.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Font.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Font.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,747 @@
+package Font::TTF::Font;
+
+=head1 NAME
+
+Font::TTF::Font - Memory representation of a font
+
+=head1 SYNOPSIS
+
+Here is the regression test (you provide your own font). Run it once and then
+again on the output of the first run. There should be no differences between
+the outputs of the two runs.
+
+ $f = Font::TTF::Font->open($ARGV[0]);
+
+ # force a read of all the tables
+ $f->tables_do(sub { $_[0]->read; });
+
+ # force read of all glyphs (use read_dat to use lots of memory!)
+ # $f->{'loca'}->glyphs_do(sub { $_[0]->read; });
+ $f->{'loca'}->glyphs_do(sub { $_[0]->read_dat; });
+ # NB. no need to $g->update since $f->{'glyf'}->out will do it for us
+
+ $f->out($ARGV[1]);
+ $f->release; # clear up memory forcefully!
+
+=head1 DESCRIPTION
+
+A Truetype font consists of a header containing a directory of tables which
+constitute the rest of the file. This class holds that header and directory and
+also creates objects of the appropriate type for each table within the font.
+Note that it does not read each table into memory, but creates a short reference
+which can be read using the form:
+
+ $f->{$tablename}->read;
+
+Classes are included that support many of the different TrueType tables. For
+those for which no special code exists, the table type C<table> is used, which
+defaults to L<Font::TTF::Table>. The current tables which are supported are:
+
+ table Font::TTF::Table - for unknown tables
+ GDEF Font::TTF::GDEF
+ GPOS Font::TTF::GPOS
+ GSUB Font::TTF::GSUB
+ LTSH Font::TTF::LTSH
+ OS/2 Font::TTF::OS_2
+ PCLT Font::TTF::PCLT
+ bsln Font::TTF::Bsln
+ cmap Font::TTF::Cmap - see also Font::TTF::OldCmap
+ cvt Font::TTF::Cvt_
+ fdsc Font::TTF::Fdsc
+ feat Font::TTF::Feat
+ fmtx Font::TTF::Fmtx
+ fpgm Font::TTF::Fpgm
+ glyf Font::TTF::Glyf - see also Font::TTF::Glyph
+ hdmx Font::TTF::Hdmx
+ head Font::TTF::Head
+ hhea Font::TTF::Hhea
+ hmtx Font::TTF::Hmtx
+ kern Font::TTF::Kern - see alternative Font::TTF::AATKern
+ loca Font::TTF::Loca
+ maxp Font::TTF::Maxp
+ mort Font::TTF::Mort - see also Font::TTF::OldMort
+ name Font::TTF::Name
+ post Font::TTF::Post
+ prep Font::TTF::Prep
+ prop Font::TTF::Prop
+ vhea Font::TTF::Vhea
+ vmtx Font::TTF::Vmtx
+
+Links are:
+
+L<Font::TTF::Table> L<Font::TTF::GDEF> L<Font::TTF::GPOS> L<Font::TTF::GSUB> L<Font::TTF::LTSH>
+L<Font::TTF::OS_2> L<Font::TTF::PCLT> L<Font::TTF::Bsln> L<Font::TTF::Cmap> L<Font::TTF::Cvt_>
+L<Font::TTF::Fdsc> L<Font::TTF::Feat> L<Font::TTF::Fmtx> L<Font::TTF::Fpgm> L<Font::TTF::Glyf>
+L<Font::TTF::Hdmx> L<Font::TTF::Head> L<Font::TTF::Hhea> L<Font::TTF::Hmtx> L<Font::TTF::Kern>
+L<Font::TTF::Loca> L<Font::TTF::Maxp> L<Font::TTF::Mort> L<Font::TTF::Name> L<Font::TTF::Post>
+L<Font::TTF::Prep> L<Font::TTF::Prop> L<Font::TTF::Vhea> L<Font::TTF::Vmtx> L<Font::TTF::OldCmap>
+L<Font::TTF::Glyph> L<Font::TTF::AATKern> L<Font::TTF::OldMort>
+
+
+=head1 INSTANCE VARIABLES
+
+Instance variables begin with a space (and have lengths greater than the 4
+characters which make up table names).
+
+=over
+
+=item nocsum
+
+This is used during output to disable the creation of the file checksum in the
+head table. For example, during DSIG table creation, this flag will be set to
+ensure that the file checksum is left at zero.
+
+=item fname (R)
+
+Contains the filename of the font which this object was read from.
+
+=item INFILE (P)
+
+The file handle which reflects the source file for this font.
+
+=item OFFSET (P)
+
+Contains the offset from the beginning of the read file of this particular
+font directory, thus providing support for TrueType Collections.
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use IO::File;
+
+use strict;
+use vars qw(%tables $VERSION $dumper);
+use Symbol();
+
+require 5.004;
+
+$VERSION = 0.34; # MJPH 22-MAY-2003 Update PSNames to latest AGL
+# $VERSION = 0.33; # MJPH 9-OCT-2002 Support CFF OpenType (just by version=='OTTO'?!)
+# $VERSION = 0.32; # MJPH 2-OCT-2002 Bug fixes to TTFBuilder, new methods and some
+# extension table support in Ttopen and Coverage
+# $VERSION = 0.31; # MJPH 1-JUL-2002 fix read format 12 cmap (bart at cs.pdx.edu)
+# improve surrogate support in ttfremap
+# fix return warn to return warn,undef
+# ensure correct indexToLocFormat
+# $VERSION = 0.30; # MJPH 28-MAY-2002 add updated release
+# $VERSION = 0.29; # MJPH 9-APR-2002 update ttfbuilder, sort out surrogates
+# $VERSION = 0.28; # MJPH 13-MAR-2002 update ttfbuilder, add Font::TTF::Cmap::ms_enc()
+# $VERSION = 0.27; # MJPH 6-FEB-2002 update ttfbuilder, support no fpgm, no more __DATA__
+# $VERSION = 0.26; # MJPH 19-SEP-2001 Update ttfbuilder
+# $VERSION = 0.25; # MJPH 18-SEP-2001 problems in update of head
+# $VERSION = 0.24; # MJPH 1-AUG-2001 Sort out update
+# $VERSION = 0.23; # GST 30-MAY-2001 Memory leak fixed
+# $VERSION = 0.22; # MJPH 09-APR-2001 Ensure all of AAT stuff included
+# $VERSION = 0.21; # MJPH 23-MAR-2001 Improve Opentype support
+# $VERSION = 0.20; # MJPH 13-JAN-2001 Add XML output and some of XML input, AAT & OT tables
+# $VERSION = 0.19; # MJPH 29-SEP-2000 Add cmap::is_unicode, debug makefile.pl
+# $VERSION = 0.18; # MJPH 21-JUL-2000 Debug Utils::TTF_bininfo
+# $VERSION = 0.17; # MJPH 16-JUN-2000 Add utf8 support to names
+# $VERSION = 0.16; # MJPH 26-APR-2000 Mark read tables as read, tidy up POD
+# $VERSION = 0.15; # MJPH 5-FEB-2000 Ensure right versions released
+# $VERSION = 0.14; # MJPH 11-SEP-1999 Sort out Unixisms, agian!
+# $VERSION = 0.13; # MJPH 9-SEP-1999 Add empty, debug update_bbox
+# $VERSION = 0.12; # MJPH 22-JUL-1999 Add update_bbox
+# $VERSION = 0.11; # MJPH 7-JUL-1999 Don't store empties in cmaps
+# $VERSION = 0.10; # MJPH 21-JUN-1999 Use IO::File
+# $VERSION = 0.09; # MJPH 9-JUN-1999 Add 5.004 require, minor tweeks in cmap
+# $VERSION = 0.08; # MJPH 19-MAY-1999 Sort out line endings for Unix
+# $VERSION = 0.07; # MJPH 28-APR-1999 Get the regression tests to work
+# $VERSION = 0.06; # MJPH 26-APR-1999 Start to add to CVS, correct MANIFEST.SKIP
+# $VERSION = 0.05; # MJPH 13-APR-1999 See changes for 0.05
+# $VERSION = 0.04; # MJPH 13-MAR-1999 Tidy up Tarball
+# $VERSION = 0.03; # MJPH 9-MAR-1999 Move to Font::TTF for CPAN
+# $VERSION = 0.02; # MJPH 12-FEB-1999 Add support for ' nocsum' for DSIGS
+# $VERSION = 0.0001;
+
+%tables = (
+ 'table' => 'Font::TTF::Table',
+ 'GDEF' => 'Font::TTF::GDEF',
+ 'GPOS' => 'Font::TTF::GPOS',
+ 'GSUB' => 'Font::TTF::GSUB',
+ 'LTSH' => 'Font::TTF::LTSH',
+ 'OS/2' => 'Font::TTF::OS_2',
+ 'PCLT' => 'Font::TTF::PCLT',
+ 'bsln' => 'Font::TTF::Bsln',
+ 'cmap' => 'Font::TTF::Cmap',
+ 'cvt ' => 'Font::TTF::Cvt_',
+ 'fdsc' => 'Font::TTF::Fdsc',
+ 'feat' => 'Font::TTF::Feat',
+ 'fmtx' => 'Font::TTF::Fmtx',
+ 'fpgm' => 'Font::TTF::Fpgm',
+ 'glyf' => 'Font::TTF::Glyf',
+ 'hdmx' => 'Font::TTF::Hdmx',
+ 'head' => 'Font::TTF::Head',
+ 'hhea' => 'Font::TTF::Hhea',
+ 'hmtx' => 'Font::TTF::Hmtx',
+ 'kern' => 'Font::TTF::Kern',
+ 'loca' => 'Font::TTF::Loca',
+ 'maxp' => 'Font::TTF::Maxp',
+ 'mort' => 'Font::TTF::Mort',
+ 'name' => 'Font::TTF::Name',
+ 'post' => 'Font::TTF::Post',
+ 'prep' => 'Font::TTF::Prep',
+ 'prop' => 'Font::TTF::Prop',
+ 'vhea' => 'Font::TTF::Vhea',
+ 'vmtx' => 'Font::TTF::Vmtx',
+ );
+
+# This is special code because I am fed up of every time I x a table in the debugger
+# I get the whole font printed. Thus substitutes my 3 line change to dumpvar into
+# the debugger. Clunky, but nice. You are welcome to a copy if you want one.
+
+BEGIN {
+ my ($p);
+
+ foreach $p (@INC)
+ {
+ if (-f "$p/mydumpvar.pl")
+ {
+ $dumper = 'mydumpvar.pl';
+ last;
+ }
+ }
+ $dumper ||= 'dumpvar.pl';
+}
+
+sub main::dumpValue
+{ do $dumper; &main::dumpValue; }
+
+
+=head2 Font::TTF::Font->AddTable($tablename, $class)
+
+Adds the given class to be used when representing the given table name. It also
+'requires' the class for you.
+
+=cut
+
+sub AddTable
+{
+ my ($class, $table, $useclass) = @_;
+
+ $tables{$table} = $useclass;
+# $useclass =~ s|::|/|oig;
+# require "$useclass.pm";
+}
+
+
+=head2 Font::TTF::Font->Init
+
+For those people who like making fonts without reading them. This subroutine
+will require all the table code for the various table types for you. Not
+needed if using Font::TTF::Font::read before using a table.
+
+=cut
+
+sub Init
+{
+ my ($class) = @_;
+ my ($t);
+
+ foreach $t (keys %tables)
+ {
+ $t =~ s|::|/|oig;
+ require "$t.pm";
+ }
+}
+
+=head2 Font::TTF::Font->new(%props)
+
+Creates a new font object and initialises with the given properties. This is
+primarily for use when a TTF is embedded somewhere. Notice that the properties
+are automatically preceded by a space when inserted into the object. This is in
+order that fields do not clash with tables.
+
+=cut
+
+sub new
+{
+ my ($class, %props) = @_;
+ my ($self) = {};
+
+ bless $self, $class;
+
+ foreach (keys %props)
+ { $self->{" $_"} = $props{$_}; }
+ $self;
+}
+
+
+=head2 Font::TTF::Font->open($fname)
+
+Reads the header and directory for the given font file and creates appropriate
+objects for each table in the font.
+
+=cut
+
+sub open
+{
+ my ($class, $fname) = @_;
+ my ($fh);
+ my ($self) = {};
+
+ unless (ref($fname))
+ {
+ $fh = IO::File->new($fname) or return undef;
+ binmode $fh;
+ } else
+ { $fh = $fname; }
+
+ $self->{' INFILE'} = $fh;
+ $self->{' fname'} = $fname;
+ $self->{' OFFSET'} = 0;
+ bless $self, $class;
+
+ $self->read;
+}
+
+=head2 $f->read
+
+Reads a Truetype font directory starting from the current location in the file.
+This has been separated from the C<open> function to allow support for embedded
+TTFs for example in TTCs. Also reads the C<head> and C<maxp> tables immediately.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($dat, $i, $ver, $dir_num, $type, $name, $check, $off, $len, $t);
+
+ $fh->seek($self->{' OFFSET'}, 0);
+ $fh->read($dat, 12);
+ ($ver, $dir_num) = unpack("Nn", $dat);
+ $ver == 1 << 16 || $ver == unpack('N', 'OTTO') || $ver == 0x74727565 or return undef; # support Mac sfnts
+
+ for ($i = 0; $i < $dir_num; $i++)
+ {
+ $fh->read($dat, 16) || die "Reading table entry";
+ ($name, $check, $off, $len) = unpack("a4NNN", $dat);
+ $self->{$name} = $self->{' PARENT'}->find($self, $name, $check, $off, $len) && next
+ if (defined $self->{' PARENT'});
+ $type = $tables{$name} || 'Font::TTF::Table';
+ $t = $type;
+ if ($^O eq "MacOS")
+ { $t =~ s/^|::/:/oig; }
+ else
+ { $t =~ s|::|/|oig; }
+ require "$t.pm";
+ $self->{$name} = $type->new(PARENT => $self,
+ NAME => $name,
+ INFILE => $fh,
+ OFFSET => $off,
+ LENGTH => $len,
+ CSUM => $check);
+ }
+
+ foreach $t ('head', 'maxp')
+ { $self->{$t}->read if defined $self->{$t}; }
+
+ $self;
+}
+
+
+=head2 $f->out($fname [, @tablelist])
+
+Writes a TTF file consisting of the tables in tablelist. The list is checked to
+ensure that only tables that exist are output. (This means that you can't have
+non table information stored in the font object with key length of exactly 4)
+
+In many cases the user simply wants to output all the tables in alphabetical order.
+This can be done by not including a @tablelist, in which case the subroutine will
+output all the defined tables in the font in alphabetical order.
+
+Returns $f on success and undef on failure, including warnings.
+
+All output files must include the C<head> table.
+
+=cut
+
+sub out
+{
+ my ($self, $fname, @tlist) = @_;
+ my ($fh);
+ my ($dat, $numTables, $sRange, $eSel);
+ my (%dir, $k, $mloc, $count);
+ my ($csum, $lsum, $msum, $loc, $oldloc, $len, $shift);
+
+ unless (ref($fname))
+ {
+ $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname for writing"), undef;
+ binmode $fh;
+ } else
+ { $fh = $fname; }
+
+ $self->{' oname'} = $fname;
+ $self->{' outfile'} = $fh;
+
+ if ($self->{' wantsig'})
+ {
+ $self->{' nocsum'} = 1;
+# $self->{'head'}{'checkSumAdjustment'} = 0;
+ $self->{' tempDSIG'} = $self->{'DSIG'};
+ $self->{' tempcsum'} = $self->{'head'}{' CSUM'};
+ delete $self->{'DSIG'};
+ @tlist = sort {$self->{$a}{' OFFSET'} <=> $self->{$b}{' OFFSET'}}
+ grep (length($_) == 4 && defined $self->{$_}, keys %$self) if ($#tlist < 0);
+ }
+ elsif ($#tlist < 0)
+ { @tlist = sort keys %$self; }
+
+ @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
+ $numTables = $#tlist + 1;
+ $numTables++ if ($self->{' wantsig'});
+
+ ($numTables, $sRange, $eSel, $shift) = Font::TTF::Utils::TTF_bininfo($numTables, 16);
+ $dat = pack("Nnnnn", 1 << 16, $numTables, $sRange, $eSel, $shift);
+ $fh->print($dat);
+ $msum = unpack("%32N*", $dat);
+
+# reserve place holders for each directory entry
+ foreach $k (@tlist)
+ {
+ $dir{$k} = pack("A4NNN", $k, 0, 0, 0);
+ $fh->print($dir{$k});
+ }
+
+ $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
+
+ $loc = $fh->tell();
+ if ($loc & 3)
+ {
+ $fh->print(substr("\000" x 4, $loc & 3));
+ $loc += 4 - ($loc & 3);
+ }
+
+ foreach $k (@tlist)
+ {
+ $oldloc = $loc;
+ $self->{$k}->out($fh);
+ $loc = $fh->tell();
+ $len = $loc - $oldloc;
+ if ($loc & 3)
+ {
+ $fh->print(substr("\000" x 4, $loc & 3));
+ $loc += 4 - ($loc & 3);
+ }
+ $fh->seek($oldloc, 0);
+ $csum = 0; $mloc = $loc;
+ while ($mloc > $oldloc)
+ {
+ $count = ($mloc - $oldloc > 4096) ? 4096 : $mloc - $oldloc;
+ $fh->read($dat, $count);
+ $csum += unpack("%32N*", $dat);
+# this line ensures $csum stays within 32 bit bounds, clipping as necessary
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
+ $mloc -= $count;
+ }
+ $dir{$k} = pack("A4NNN", $k, $csum, $oldloc, $len);
+ $msum += $csum + unpack("%32N*", $dir{$k});
+ if ($msum > 0xffffffff) { $msum -= 0xffffffff; $msum--; }
+ $fh->seek($loc, 0);
+ }
+
+ unless ($self->{' nocsum'}) # assuming we want a file checksum
+ {
+# Now we need to sort out the head table's checksum
+ if (!defined $dir{'head'})
+ { # you have to have a head table
+ $fh->close();
+ return warn("No 'head' table to output in $fname"), undef;
+ }
+ ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
+ $fh->seek($loc + 8, 0);
+ $fh->read($dat, 4);
+ $lsum = unpack("N", $dat);
+ if ($lsum != 0)
+ {
+ $csum -= $lsum;
+ if ($csum < 0) { $csum += 0xffffffff; $csum++; }
+ $msum -= $lsum * 2; # twice (in head and in csum)
+ while ($msum < 0) { $msum += 0xffffffff; $msum++; }
+ }
+ $lsum = 0xB1B0AFBA - $msum;
+ $fh->seek($loc + 8, 0);
+ $fh->print(pack("N", $lsum));
+ $dir{'head'} = pack("A4NNN", 'head', $csum, $loc, $len);
+ } elsif ($self->{' wantsig'})
+ {
+ if (!defined $dir{'head'})
+ { # you have to have a head table
+ $fh->close();
+ return warn("No 'head' table to output in $fname"), undef;
+ }
+ ($csum, $loc, $len) = unpack("x4NNN", $dir{'head'});
+ $fh->seek($loc + 8, 0);
+ $fh->print(pack("N", 0));
+# $dir{'head'} = pack("A4NNN", 'head', $self->{' tempcsum'}, $loc, $len);
+ }
+
+# Now we can output the directory again
+ if ($self->{' wantsig'})
+ { @tlist = sort @tlist; }
+ $fh->seek(12, 0);
+ foreach $k (@tlist)
+ { $fh->print($dir{$k}); }
+ $fh->print(pack('A4NNN', '', 0, 0, 0)) if ($self->{' wantsig'});
+ $fh->close();
+ $self;
+}
+
+
+=head2 $f->out_xml($filename [, @tables])
+
+Outputs the font in XML format
+
+=cut
+
+sub out_xml
+{
+ my ($self, $fname, @tlist) = @_;
+ my ($fh, $context, $numTables, $k);
+
+ $context->{'indent'} = ' ' x 4;
+
+ unless (ref($fname))
+ {
+ $fh = IO::File->new("+>$fname") || return warn("Unable to open $fname"), undef;
+ binmode $fh;
+ } else
+ { $fh = $fname; }
+
+ unless (scalar @tlist > 0)
+ {
+ @tlist = sort keys %$self;
+ @tlist = grep(length($_) == 4 && defined $self->{$_}, @tlist);
+ }
+ $numTables = $#tlist + 1;
+
+ $context->{'fh'} = $fh;
+ $fh->print("<?xml version='1.0' encoding='UTF-8'?>\n");
+ $fh->print("<font tables='$numTables'>\n\n");
+
+ foreach $k (@tlist)
+ {
+ $fh->print("<table name='$k'>\n");
+ $self->{$k}->out_xml($context, $context->{'indent'});
+ $fh->print("</table>\n");
+ }
+
+ $fh->print("</font>\n");
+ $fh->close;
+ $self;
+}
+
+
+=head2 $f->XML_start($context, $tag, %attrs)
+
+Handles start messages from the XML parser. Of particular interest to us are <font> and
+<table>.
+
+=cut
+
+sub XML_start
+{
+ my ($self, $context, $tag, %attrs) = @_;
+ my ($name, $type, $t);
+
+ if ($tag eq 'font')
+ { $context->{'tree'}[-1] = $self; }
+ elsif ($tag eq 'table')
+ {
+ $name = $attrs{'name'};
+ unless (defined $self->{$name})
+ {
+ $type = $tables{$name} || 'Font::TTF::Table';
+ $t = $type;
+ if ($^O eq "MacOS")
+ { $t =~ s/^|::/:/oig; }
+ else
+ { $t =~ s|::|/|oig; }
+ require "$t.pm";
+ $self->{$name} = $type->new('PARENT' => $self, 'NAME' => $name, 'read' => 1);
+ }
+ $context->{'receiver'} = ($context->{'tree'}[-1] = $self->{$name});
+ }
+ $context;
+}
+
+
+sub XML_end
+{
+ my ($self) = @_;
+ my ($context, $tag, %attrs) = @_;
+ my ($i);
+
+ return undef unless ($tag eq 'table' && $attrs{'name'} eq 'loca');
+ if (defined $context->{'glyphs'} && $context->{'glyphs'} ne $self->{'loca'}{'glyphs'})
+ {
+ for ($i = 0; $i <= $#{$context->{'glyphs'}}; $i++)
+ { $self->{'loca'}{'glyphs'}[$i] = $context->{'glyphs'}[$i] if defined $context->{'glyphs'}[$i]; }
+ $context->{'glyphs'} = $self->{'loca'}{'glyphs'};
+ }
+ return undef;
+}
+
+=head2 $f->update
+
+Sends update to all the tables in the font and then resets all the isDirty
+flags on each table. The data structure in now consistent as a font (we hope).
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+
+ $self->tables_do(sub { $_[0]->update; });
+
+ $self;
+}
+
+=head2 $f->dirty
+
+Dirties all the tables in the font
+
+=cut
+
+sub dirty
+{ $_[0]->tables_do(sub { $_[0]->dirty; }); $_[0]; }
+
+=head2 $f->tables_do(&func)
+
+Calls &func for each table in the font. Calls the table in alphabetical sort
+order as per the order in the directory:
+
+ &func($table, $name);
+
+=cut
+
+sub tables_do
+{
+ my ($self, $func) = @_;
+ my ($t);
+
+ foreach $t (sort grep {length($_) == 4} keys %$self)
+ { &$func($self->{$t}, $t); }
+ $self;
+}
+
+
+=head2 $f->release
+
+Releases ALL of the memory used by the TTF font and all of its component
+objects. After calling this method, do B<NOT> expect to have anything left in
+the C<Font::TTF::Font> object.
+
+B<NOTE>, that it is important that you call this method on any
+C<Font::TTF::Font> object when you wish to destruct it and free up its memory.
+Internally, we track things in a structure that can result in circular
+references, and without calling 'C<release()>' these will not properly get
+cleaned up by Perl. Once you've called this method, though, don't expect to be
+able to do anything else with the C<Font::TTF::Font> object; it'll have B<no>
+internal state whatsoever.
+
+B<Developer note:> As part of the brute-force cleanup done here, this method
+will throw a warning message whenever unexpected key values are found within
+the C<Font::TTF::Font> object. This is done to help ensure that any unexpected
+and unfreed values are brought to your attention so that you can bug us to keep
+the module updated properly; otherwise the potential for memory leaks due to
+dangling circular references will exist.
+
+=cut
+
+sub release
+{
+ my ($self) = @_;
+
+# delete stuff that we know we can, here
+
+ my @tofree = map { delete $self->{$_} } keys %{$self};
+
+ while (my $item = shift @tofree)
+ {
+ my $ref = ref($item);
+ if (UNIVERSAL::can($item, 'release'))
+ { $item->release(); }
+ elsif ($ref eq 'ARRAY')
+ { push( @tofree, @{$item} ); }
+ elsif (UNIVERSAL::isa($ref, 'HASH'))
+ { release($item); }
+ }
+
+# check that everything has gone - it better had!
+ foreach my $key (keys %{$self})
+ { warn ref($self) . " still has '$key' key left after release.\n"; }
+}
+
+1;
+
+=head1 BUGS
+
+Bugs abound aplenty I am sure. There is a lot of code here and plenty of scope.
+The parts of the code which haven't been implemented yet are:
+
+=over 4
+
+=item Post
+
+Version 4 format types are not supported yet.
+
+=item Cmap
+
+Format type 2 (MBCS) has not been implemented yet and therefore may cause
+somewhat spurious results for this table type.
+
+=item Kern
+
+Only type 0 & type 2 tables are supported (type 1 & type 3 yet to come).
+
+=item TTC
+
+The current Font::TTF::Font::out method does not support the writing of TrueType
+Collections.
+
+=back
+
+In addition there are weaknesses or features of this module library
+
+=over 4
+
+=item *
+
+There is very little (or no) error reporting. This means that if you have
+garbled data or garbled data structures, then you are liable to generate duff
+fonts.
+
+=item *
+
+The exposing of the internal data structures everywhere means that doing
+radical re-structuring is almost impossible. But it stop the code from becoming
+ridiculously large.
+
+=back
+
+Apart from these, I try to keep the code in a state of "no known bugs", which
+given the amount of testing this code has had, is not a guarantee of high
+quality, yet.
+
+For more details see the appropriate class files.
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org
+
+Copyright Martin Hosken 1998.
+
+No warranty or expression of effectiveness, least of all regarding anyone's
+safety, is implied in this software or documentation.
+
+=head2 Licensing
+
+The Perl TTF module is licensed under the Perl Artistic License.
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fpgm.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fpgm.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Fpgm.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,87 @@
+package Font::TTF::Fpgm;
+
+=head1 NAME
+
+Font::TTF::Fpgm - Font program in a TrueType font. Called when a font is loaded
+
+=head1 DESCRIPTION
+
+This is a minimal class adding nothing beyond a table, but is a repository
+for fpgm type information for those processes brave enough to address hinting.
+
+=cut
+
+use strict;
+use vars qw(@ISA $VERSION);
+
+ at ISA = qw(Font::TTF::Table);
+
+$VERSION = 0.0001;
+
+=head2 $t->read
+
+Reading this table is simply a process of reading all the data into the RAM
+copy. Nothing more is done with it.
+
+=cut
+
+sub read
+{
+ $_[0]->read_dat;
+ $_[0]->{' read'} = 1;
+}
+
+=head2 $t->out_xml($context, $depth)
+
+Outputs Fpgm program as XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($dat);
+
+ $self->read;
+ $dat = Font::TTF::Utils::XML_binhint($self->{' dat'});
+ $dat =~ s/\n(?!$)/\n$depth$context->{'indent'}/omg;
+ $fh->print("$depth<code>\n");
+ $fh->print("$depth$context->{'indent'}$dat");
+ $fh->print("$depth</code>\n");
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Parse all that hinting code
+
+=cut
+
+sub XML_end
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag eq 'code')
+ {
+ $self->{' dat'} = Font::TTF::Utils::XML_hintbin($context->{'text'});
+ return $context;
+ } else
+ { return $self->SUPER::XML_end(@_); }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GDEF.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GDEF.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GDEF.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,310 @@
+package Font::TTF::GDEF;
+
+=head1 NAME
+
+Font::TTF::Gdef - Opentype GDEF table support
+
+=head1 DESCRIPTION
+
+The GDEF table contains various global lists of information which are apparantly
+used in other places in an OpenType renderer. But precisely where is open to
+speculation...
+
+=head1 INSTANCE VARIABLES
+
+There are 4 tables in the GDEF table, each with their own structure:
+
+=over 4
+
+=item GLYPH
+
+This is an L<Font::TTF::Coverage> Class Definition table containing information
+as to what type each glyph is.
+
+=item ATTACH
+
+The attach table consists of a coverage table and then attachment points for
+each glyph in the coverage table:
+
+=over 8
+
+=item COVERAGE
+
+This is a coverage table
+
+=item POINTS
+
+This is an array of point elements. Each element is an array of curve points
+corresponding to the attachment points on that glyph. The order of the curve points
+in the array corresponds to the attachment point number specified in the MARKS
+coverage table (see below).
+
+=back
+
+=item LIG
+
+This contains the ligature caret positioning information for ligature glyphs
+
+=over 8
+
+=item COVERAGE
+
+A coverage table to say which glyphs are ligatures
+
+=item LIGS
+
+An array of elements for each ligature. Each element is an array of information
+for each caret position in the ligature (there being number of components - 1 of
+these, generally)
+
+=over 12
+
+=item FMT
+
+This is the format of the information and is important to provide the semantics
+for the value. This value must be set correctly before output
+
+=item VAL
+
+The value which has meaning according to FMT
+
+=item DEVICE
+
+For FMT = 3, a device table is also referenced which is stored here
+
+=back
+
+=back
+
+=item MARKS
+
+Due to confusion in the GDEF specification, this field is currently withdrawn until
+the confusion is resolved. That way, perhaps this stuff will work!
+
+This class definition table stores the mark attachment point numbers for each
+attachment mark, to indicate which attachment point the mark attaches to on its
+base glyph.
+
+=back
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use Font::TTF::Table;
+use Font::TTF::Utils;
+use Font::TTF::Ttopen;
+use vars qw(@ISA $new_gdef);
+
+ at ISA = qw(Font::TTF::Table);
+$new_gdef = 1;
+
+=head2 $t->read
+
+Reads the table into the data structure
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($boff) = $self->{' OFFSET'};
+ my ($dat, $goff, $loff, $aoff, $moff, $r, $s, $bloc);
+
+ $self->SUPER::read or return $self;
+ $bloc = $fh->tell();
+ $fh->read($dat, 10);
+ ($self->{'Version'}, $goff, $aoff, $loff) = TTF_Unpack('fS3', $dat);
+ if ($new_gdef)
+ {
+ $fh->read($dat, 12);
+ ($self->{'Version'}, $goff, $aoff, $loff, $moff) = TTF_Unpack('fS4', $dat);
+ }
+
+ if ($goff > 0)
+ {
+ $fh->seek($goff + $boff, 0);
+ $self->{'GLYPH'} = Font::TTF::Coverage->new(0)->read($fh);
+ }
+
+ if ($new_gdef && $moff > 0)
+ {
+ $fh->seek($moff + $boff, 0);
+ $self->{'MARKS'} = Font::TTF::Coverage->new(0)->read($fh);
+ }
+
+ if ($aoff > 0)
+ {
+ my ($off, $gcount, $pcount);
+
+ $fh->seek($aoff + $boff, 0);
+ $fh->read($dat, 4);
+ ($off, $gcount) = TTF_Unpack('SS', $dat);
+ $fh->read($dat, $gcount << 1);
+
+ $fh->seek($aoff + $boff + $off, 0);
+ $self->{'ATTACH'}{'COVERAGE'} = Font::TTF::Coverage->new(1)->read($fh);
+
+ foreach $r (TTF_Unpack('S*', $dat))
+ {
+ unless ($r)
+ {
+ push (@{$self->{'ATTACH'}{'POINTS'}}, []);
+ next;
+ }
+ $fh->seek($aoff + $boff + $r, 0);
+ $fh->read($dat, 2);
+ $pcount = TTF_Unpack('S', $dat);
+ $fh->read($dat, $pcount << 1);
+ push (@{$self->{'ATTACH'}{'POINTS'}}, [TTF_Unpack('S*', $dat)]);
+ }
+ }
+
+ if ($loff > 0)
+ {
+ my ($lcount, $off, $ccount, $srec, $comp);
+
+ $fh->seek($loff + $boff, 0);
+ $fh->read($dat, 4);
+ ($off, $lcount) = TTF_Unpack('SS', $dat);
+ $fh->read($dat, $lcount << 1);
+
+ $fh->seek($off + $loff + $boff, 0);
+ $self->{'LIG'}{'COVERAGE'} = Font::TTF::Coverage->new(1)->read($fh);
+
+ foreach $r (TTF_Unpack('S*', $dat))
+ {
+ $fh->seek($r + $loff + $boff, 0);
+ $fh->read($dat, 2);
+ $ccount = TTF_Unpack('S', $dat);
+ $fh->read($dat, $ccount << 1);
+
+ $srec = [];
+ foreach $s (TTF_Unpack('S*', $dat))
+ {
+ $comp = {};
+ $fh->seek($s + $r + $loff + $boff, 0);
+ $fh->read($dat, 4);
+ ($comp->{'FMT'}, $comp->{'VAL'}) = TTF_Unpack('S*', $dat);
+ if ($comp->{'FMT'} == 3)
+ {
+ $fh->read($dat, 2);
+ $off = TTF_Unpack('S', $dat);
+ if (defined $self->{' CACHE'}{$off + $s + $r})
+ { $comp->{'DEVICE'} = $self->{' CACHE'}{$off + $s + $r}; }
+ else
+ {
+ $fh->seek($off + $s + $r + $loff + $boff, 0);
+ $comp->{'DEVICE'} = Font::TTF::Delta->new->read($fh);
+ $self->{' CACHE'}{$off + $s + $r} = $comp->{'DEVICE'};
+ }
+ }
+ push (@$srec, $comp);
+ }
+ push (@{$self->{'LIG'}{'LIGS'}}, $srec);
+ }
+ }
+
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes out this table.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($goff, $aoff, $loff, $moff, @offs, $loc1, $coff, $loc);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $loc = $fh->tell();
+ if ($new_gdef)
+ { $fh->print(TTF_Pack('fSSSS', $self->{'Version'}, 0, 0, 0, 0)); }
+ else
+ { $fh->print(TTF_Pack('fSSS', $self->{'Version'}, 0, 0, 0)); }
+
+ if (defined $self->{'GLYPH'})
+ {
+ $goff = $fh->tell() - $loc;
+ $self->{'GLYPH'}->out($fh);
+ }
+
+ if (defined $self->{'ATTACH'})
+ {
+ my ($r);
+
+ $aoff = $fh->tell() - $loc;
+ $fh->print(pack('n*', (0) x ($#{$self->{'ATTACH'}{'POINTS'}} + 3)));
+ foreach $r (@{$self->{'ATTACH'}{'POINTS'}})
+ {
+ push (@offs, $fh->tell() - $loc - $aoff);
+ $fh->print(pack('n*', $#{$r} + 1, @$r));
+ }
+ $coff = $fh->tell() - $loc - $aoff;
+ $self->{'ATTACH'}{'COVERAGE'}->out($fh);
+ $loc1 = $fh->tell();
+ $fh->seek($aoff + $loc, 0);
+ $fh->print(pack('n*', $coff, $#offs + 1, @offs));
+ $fh->seek($loc1, 0);
+ }
+
+ if (defined $self->{'LIG'})
+ {
+ my (@reftables, $ltables, $i, $j, $out, $r, $s);
+
+ $ltables = {};
+ $loff = $fh->tell() - $loc;
+ $out = pack('n*',
+ Font::TTF::Ttopen->ref_cache($self->{'LIG'}{'COVERAGE'}, $ltables, 0),
+ 0, $#{$self->{'LIG'}{'LIGS'}} + 1,
+ (0) x ($#{$self->{'LIG'}{'LIGS'}} + 1));
+ push (@reftables, [$ltables, 0]);
+ $i = 0;
+ foreach $r (@{$self->{'LIG'}{'LIGS'}})
+ {
+ $ltables = {};
+ $loc1 = length($out);
+ substr($out, ($i << 1) + 4, 2) = TTF_Pack('S', $loc1);
+ $out .= pack('n*', $#{$r} + 1, (0) x ($#{$r} + 1));
+ @offs = (); $j = 0;
+ foreach $s (@$r)
+ {
+ substr($out, ($j << 1) + 2 + $loc1, 2) =
+ TTF_Pack('S', length($out) - $loc1);
+ $out .= TTF_Pack('SS', $s->{'FMT'}, $s->{'VAL'});
+ $out .= pack('n', Font::TTF::Ttopen->ref_cache($s->{'DEVICE'},
+ $ltables, length($out))) if ($s->{'FMT'} == 3);
+ $j++;
+ }
+ push (@reftables, [$ltables, $loc1]);
+ $i++;
+ }
+ Font::TTF::Ttopen::out_final($fh, $out, \@reftables);
+ }
+
+ if ($new_gdef && defined $self->{'MARKS'})
+ {
+ $moff = $fh->tell() - $loc;
+ $self->{'MARKS'}->out($fh);
+ }
+
+ $loc1 = $fh->tell();
+ $fh->seek($loc + 4, 0);
+ if ($new_gdef)
+ { $fh->print(TTF_Pack('S4', $goff, $aoff, $loff, $moff)); }
+ else
+ { $fh->print(TTF_Pack('S3', $goff, $aoff, $loff)); }
+ $fh->seek($loc1, 0);
+ $self;
+}
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GPOS.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GPOS.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GPOS.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,667 @@
+package Font::TTF::GPOS;
+
+=head1 TITLE
+
+Font::TTF::GPOS - Support for Opentype GPOS tables in conjunction with TTOpen
+
+=head1 DESCRIPTION
+
+The GPOS table is one of the most complicated tables in the TTF spec and the
+corresponding data structure abstraction is also not trivial. While much of the
+structure of a GPOS is shared with a GSUB table via the L<Font::TTF::Ttopen>
+
+=head1 INSTANCE VARIABLES
+
+Here we describe the additions and lookup specific information for GPOS tables.
+Unfortunately there is no one abstraction which seems to work comfortable for
+all GPOS tables, so we will also examine how the variables are used for different
+lookup types.
+
+The following are the values allowed in the ACTION_TYPE and MATCH_TYPE variables:
+
+=over 4
+
+=item ACTION_TYPE
+
+This can take any of the following values
+
+=over 8
+
+=item a
+
+The ACTION is an array of anchor tables
+
+=item o
+
+Offset. There is no RULE array. The ADJUST variable contains a value record (see
+later in this description)
+
+=item v
+
+The ACTION is a value record.
+
+=item p
+
+Pair adjustment. The ACTION contains an array of two value records for the matched
+two glyphs.
+
+=item e
+
+Exit and Entry records. The ACTION contains an array of two anchors corresponding
+to the exit and entry anchors for the glyph.
+
+=item l
+
+Indicates a lookup based contextual rule as per the GSUB table.
+
+=back
+
+=item MATCH_TYPE
+
+This can take any of the following values
+
+=over 8
+
+=item g
+
+A glyph array
+
+=item c
+
+An array of class values
+
+=item o
+
+An array of coverage tables
+
+=back
+
+=back
+
+The following variables are added for Attachment Positioning Subtables:
+
+=over 4
+
+=item MATCH
+
+This contains an array of glyphs to match against for all RULES. It is much like
+having the same MATCH string in all RULES. In the cases it is used so far, it only
+ever contains one element.
+
+=item MARKS
+
+This contains a Mark array consisting of each element being a subarray of two
+elements:
+
+=over 8
+
+=item CLASS
+
+The class that this mark uses on its base
+
+=item ANCHOR
+
+The anchor with which to attach this mark glyph
+
+=back
+
+The base table for mark to base, ligature or mark attachment positioning is
+structured with the ACTION containing an array of anchors corresponding to each
+attachment class. For ligatures, there is more than one RULE in the RULE array
+corresponding to each glyph in the coverage table.
+
+=back
+
+Other variables which are provided for informational purposes are:
+
+=over 4
+
+=item VFMT
+
+Value format for the adjustment of the glyph matched by the coverage table.
+
+=item VFMT2
+
+Value format used in pair adjustment for the second glyph in the pair
+
+=back
+
+=head2 Value Records
+
+There is a subtype used in GPOS tables called a value record. It is used to adjust
+the position of a glyph from its default position. The value record is variable
+length with a bitfield at the beginning to indicate which of the following
+entries are included. The bitfield is not stored since it is recalculated at
+write time.
+
+=over 4
+
+=item XPlacement
+
+Horizontal adjustment for placement (not affecting other unattached glyphs)
+
+=item YPlacement
+
+Vertical adjustment for placement (not affecting other unattached glyphs)
+
+=item XAdvance
+
+Adjust the advance width glyph (used only in horizontal writing systems)
+
+=item YAdvance
+
+Adjust the vertical advance (used only in vertical writing systems)
+
+=item XPlaDevice
+
+Device table for device specific adjustment of horizontal placement
+
+=item YPlaDevice
+
+Device table for device specific adjustment of vertical placement
+
+=item XAdvDevice
+
+Device table for device specific adjustment of horizontal advance
+
+=item YAdDevice
+
+Device table for device specific adjustment of vertical advance
+
+=item XIdPlacement
+
+Horizontal placement metric id (for Multiple Master fonts - but that's all I know!)
+
+=item YIdPlacement
+
+Vertical placement metric id
+
+=item XIdAdvance
+
+Horizontal advance metric id
+
+=item YIdAdvance
+
+Vertical advance metric id
+
+=back
+
+=head1 CORRESPONDANCE TO LAYOUT TYPES
+
+Here is what is stored in the ACTION_TYPE and MATCH_TYPE for each of the known
+GPOS subtable types:
+
+ 1.1 1.2 2.1 2.2 3 4 5 6 7.1 7.2 7.3 8.1 8.2 8.3
+ ACTION_TYPE o v p p e a a a l l l l l l
+ MATCH_TYPE g c g c o g c o
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use Font::TTF::Ttopen;
+use Font::TTF::Delta;
+use Font::TTF::Anchor;
+use Font::TTF::Utils;
+use vars qw(@ISA);
+
+ at ISA = qw(Font::TTF::Ttopen);
+
+
+=head2 read_sub
+
+Reads the subtable into the data structures
+
+=cut
+
+sub read_sub
+{
+ my ($self, $fh, $main_lookup, $sindex) = @_;
+ my ($type) = $main_lookup->{'TYPE'};
+ my ($loc) = $fh->tell();
+ my ($lookup) = $main_lookup->{'SUB'}[$sindex];
+ my ($dat, $mcount, $scount, $i, $j, $count, $fmt, $fmt2, $cover, $srec, $subst);
+ my ($c1, $c2, $s, $moff, $boff);
+
+
+ if ($type == 8)
+ {
+ $fh->read($dat, 4);
+ ($fmt, $cover) = TTF_Unpack('S2', $dat);
+ if ($fmt < 3)
+ {
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ }
+ } else
+ {
+ $fh->read($dat, 6);
+ ($fmt, $cover, $count) = TTF_Unpack("S3", $dat);
+ }
+ unless ($fmt == 3 && ($type == 7 || $type == 8))
+ { $lookup->{'COVERAGE'} = $self->read_cover($cover, $loc, $lookup, $fh, 1); }
+
+ $lookup->{'FORMAT'} = $fmt;
+ if ($type == 1 && $fmt == 1)
+ {
+ $lookup->{'VFMT'} = $count;
+ $lookup->{'ADJUST'} = $self->read_value($count, $loc, $lookup, $fh);
+ $lookup->{'ACTION_TYPE'} = 'o';
+ } elsif ($type == 1 && $fmt == 2)
+ {
+ $lookup->{'VFMT'} = $count;
+ $fh->read($dat, 2);
+ $mcount = unpack('n', $dat);
+ for ($i = 0; $i < $mcount; $i++)
+ { push (@{$lookup->{'RULES'}}, [{'ACTION'} =>
+ [$self->read_value($count, $loc, $lookup, $fh)]]); }
+ $self->{'ACTION_TYPE'} = 'v';
+ } elsif ($type == 2 && $fmt == 1)
+ {
+ $lookup->{'VFMT'} = $count;
+ $fh->read($dat, 4);
+ ($fmt2, $mcount) = unpack('n2', $dat);
+ $lookup->{'VFMT2'} = $fmt2;
+ $fh->read($dat, $mcount << 1);
+ foreach $s (unpack('n*', $dat))
+ {
+ $fh->seek($loc + $s, 0);
+ $fh->read($dat, 2);
+ $scount = TTF_Unpack('S', $dat);
+ $subst = [];
+ for ($i = 0; $i < $scount; $i++)
+ {
+ $srec = {};
+ $fh->read($dat, 2);
+ $srec->{'MATCH'} = [TTF_Unpack('S', $dat)];
+ $srec->{'ACTION'} = [$self->read_value($count, $loc, $lookup, $fh),
+ $self->read_value($fmt2, $loc, $lookup, $fh)];
+ push (@$subst, $srec);
+ }
+ push (@{$lookup->{'RULES'}}, $subst);
+ }
+ $lookup->{'ACTION_TYPE'} = 'p';
+ $lookup->{'MATCH_TYPE'} = 'g';
+ } elsif ($type == 2 && $fmt == 2)
+ {
+ $fh->read($dat, 10);
+ ($lookup->{'VFMT2'}, $c1, $c2, $mcount, $scount) = TTF_Unpack('S*', $dat);
+ $lookup->{'CLASS'} = $self->read_cover($c1, $loc, $lookup, $fh, 0);
+ $lookup->{'MATCH'} = [$self->read_cover($c2, $loc, $lookup, $fh, 0)];
+ $lookup->{'VFMT'} = $count;
+ for ($i = 0; $i < $mcount; $i++)
+ {
+ $subst = [];
+ for ($j = 0; $j < $scount; $j++)
+ {
+ $srec = {};
+ $srec->{'ACTION'} = [$self->read_value($lookup->{'VFMT'}, $loc, $lookup, $fh),
+ $self->read_value($lookup->{'VFMT2'}, $loc, $lookup, $fh)];
+ push (@$subst, $srec);
+ }
+ push (@{$lookup->{'RULES'}}, $subst);
+ }
+ $lookup->{'ACTION_TYPE'} = 'p';
+ $lookup->{'MATCH_TYPE'} = 'c';
+ } elsif ($type == 3 && $fmt == 1)
+ {
+ $fh->read($dat, $count << 2);
+ for ($i = 0; $i < $count; $i++)
+ { push (@{$lookup->{'RULES'}}, [{'ACTION' =>
+ [$self->read_anchor(TTF_Unpack('S', substr($dat, $i << 2, 2)),
+ $loc, $lookup, $fh),
+ $self->read_anchor(TTF_Unpack('S', substr($dat, ($i << 2) + 2, 2)),
+ $loc, $lookup, $fh)]}]); }
+ $lookup->{'ACTION_TYPE'} = 'e';
+ } elsif ($type == 4 || $type == 5 || $type == 6)
+ {
+ my (@offs, $mloc, $thisloc, $ncomp, $k);
+
+ $lookup->{'MATCH'} = [$lookup->{'COVERAGE'}];
+ $lookup->{'COVERAGE'} = $self->read_cover($count, $loc, $lookup, $fh, 1);
+ $fh->read($dat, 6);
+ ($mcount, $moff, $boff) = TTF_Unpack('S*', $dat);
+ $fh->seek($loc + $moff, 0);
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ for ($i = 0; $i < $count; $i++)
+ {
+ $fh->read($dat, 4);
+ push (@{$lookup->{'MARKS'}}, [TTF_Unpack('S', $dat),
+ $self->read_anchor(TTF_Unpack('S', substr($dat, 2, 2)) + $moff,
+ $loc, $lookup, $fh)]);
+ }
+ $fh->seek($loc + $boff, 0);
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ $mloc = $fh->tell() - 2;
+ $thisloc = $mloc;
+ if ($type == 5)
+ {
+ $fh->read($dat, $count << 1);
+ @offs = TTF_Unpack('S*', $dat);
+ }
+ for ($i = 0; $i < $count; $i++)
+ {
+ if ($type == 5)
+ {
+ $thisloc = $mloc + $offs[$i];
+ $fh->seek($thisloc, 0);
+ $fh->read($dat, 2);
+ $ncomp = TTF_Unpack('S', $dat);
+ } else
+ { $ncomp = 1; }
+ for ($j = 0; $j < $ncomp; $j++)
+ {
+ $subst = [];
+ $fh->read($dat, $mcount << 1);
+ for ($k = 0; $k < $mcount; $k++)
+ { push (@$subst, $self->read_anchor(TTF_Unpack('S', substr($dat, $k << 1, 2)) + $thisloc - $loc,
+ $loc, $lookup, $fh)); }
+
+ push (@{$lookup->{'RULES'}[$i]}, {'ACTION' => $subst});
+ }
+ }
+ $lookup->{'ACTION_TYPE'} = 'a';
+ } elsif ($type == 7 || $type == 8)
+ { $self->read_context($lookup, $fh, $type - 2, $fmt, $cover, $count, $loc); }
+ $lookup;
+}
+
+
+=head2 $t->extension
+
+Returns the table type number for the extension table
+
+=cut
+
+sub extension
+{ return 9; }
+
+
+=head2 $t->out_sub
+
+Outputs the subtable to the given filehandle
+
+=cut
+
+sub out_sub
+{
+ my ($self, $fh, $main_lookup, $index) = @_;
+ my ($type) = $main_lookup->{'TYPE'};
+ my ($lookup) = $main_lookup->{'SUB'}[$index];
+ my ($fmt) = $lookup->{'FORMAT'};
+ my ($out, $r, $s, $t, $i, $j, $vfmt, $vfmt2, $loc1);
+ my ($num) = $#{$lookup->{'RULES'}} + 1;
+ my ($ctables) = {};
+ my ($mtables) = {};
+ my (@reftables);
+
+ if ($type == 1 && $fmt == 1)
+ {
+ $out = pack('n2', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2));
+ $vfmt = $self->fmt_value($lookup->{'ADJUST'});
+ $out .= pack('n', $vfmt) . $self->out_value($lookup->{'ADJUST'}, $vfmt, $ctables, 6);
+ } elsif ($type == 1 && $fmt == 2)
+ {
+ $vfmt = 0;
+ foreach $r (@{$lookup->{'RULES'}})
+ { $vfmt |= $self->fmt_value($r->[0]{'ACTION'}[0]); }
+ $out = pack('n4', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $vfmt, $#{$lookup->{'RULES'}} + 1);
+ foreach $r (@{$lookup->{'RULES'}})
+ { $out .= $self->out_value($r->[0]{'ACTION'}[0], $vfmt, $ctables, length($out)); }
+ } elsif ($type == 2 && $fmt < 3)
+ {
+ $vfmt = 0;
+ $vfmt2 = 0;
+ foreach $r (@{$lookup->{'RULES'}})
+ {
+ foreach $t (@$r)
+ {
+ $vfmt |= $self->fmt_value($t->{'ACTION'}[0]);
+ $vfmt2 |= $self->fmt_value($t->{'ACTION'}[1]);
+ }
+ }
+ if ($fmt == 1)
+ {
+ $out = pack('n5', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $vfmt, $vfmt2, $#{$lookup->{'RULES'}} + 1);
+ } else
+ {
+ $out = pack('n8', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $vfmt, $vfmt2,
+ Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 1),
+ Font::TTF::Ttopen::ref_cache($lookup->{'MATCH'}[0], $ctables, 1),
+ $#{$lookup->{'RULES'}} + 1, $#{$lookup->{'RULES'}[0]} + 1);
+ }
+ foreach $r (@{$lookup->{'RULES'}})
+ {
+ $out .= $#{$r} + 1 if ($fmt == 1);
+ foreach $t (@$r)
+ {
+ $out .= pack('n', $t->{'MATCH'}[0]) if ($fmt == 1);
+ $out .= $self->out_value($t->{'ACTION'}[0], $vfmt, $ctables, length($out))
+ . $self->out_value($t->{'ACTION'}[1], $vfmt2, $ctables, length($out) + 2);
+ }
+ }
+ } elsif ($type == 3 && $fmt == 1)
+ {
+ $out = pack('n3', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $#{$lookup->{'RULES'}} + 1);
+ foreach $r (@{$lookup->{'RULES'}})
+ {
+ $out .= pack('n2', Font::TTF::Ttopen::ref_cache($r->[0]{'ACTION'}[0], $ctables, length($out)),
+ Font::TTF::Ttopen::ref_cache($r->[0]{'ACTION'}[1], $ctables, length($out) + 2));
+ }
+ } elsif ($type == 4 || $type == 5 || $type == 6)
+ {
+ my ($loc_off, $loc_t, $ltables);
+
+ $out = pack('n7', $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'MATCH'}[0], $ctables, 2),
+ Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 4),
+ $#{$lookup->{'RULES'}[0][0]{'ACTION'}} + 1, 12, ($#{$lookup->{'MARKS'}} + 4) << 2,
+ $#{$lookup->{'MARKS'}} + 1);
+ foreach $r (@{$lookup->{'MARKS'}})
+ { $out .= pack('n2', $r->[0], Font::TTF::Ttopen::ref_cache($r->[1], $mtables, length($out) + 2)); }
+ push (@reftables, [$mtables, 12]);
+
+ $loc_t = length($out);
+ substr($out, 10, 2) = pack('n', $loc_t);
+ $out .= pack('n', $#{$lookup->{'RULES'}} + 1);
+ if ($type == 5)
+ {
+ $loc1 = length($out);
+ $out .= pack('n*', (0) x ($#{$lookup->{'RULES'}} + 1));
+ }
+ $ltables = {};
+ for ($i = 0; $i <= $#{$lookup->{'RULES'}}; $i++)
+ {
+ if ($type == 5)
+ {
+ $ltables = {};
+ $loc_t = length($out);
+ substr($out, $loc1 + ($i << 1), 2) = TTF_Pack('S', $loc_t - $loc1 + 2);
+ }
+
+ $r = $lookup->{'RULES'}[$i];
+ $out .= pack('n', $#{$r} + 1) if ($type == 5);
+ foreach $t (@$r)
+ {
+ foreach $s (@{$t->{'ACTION'}})
+ { $out .= pack('n', Font::TTF::Ttopen::ref_cache($s, $ltables, length($out))); }
+ }
+ push (@reftables, [$ltables, $loc_t]) if ($type == 5);
+ }
+ push (@reftables, [$ltables, $loc_t]) unless ($type == 5);
+ } elsif ($type == 7 || $type == 8)
+ { $out = $self->out_context($lookup, $fh, $type - 2, $fmt, $ctables, $out, $num); }
+ push (@reftables, [$ctables, 0]);
+ Font::TTF::Ttopen::out_final($fh, $out, \@reftables);
+ $lookup;
+}
+
+
+=head2 $t->read_value($format, $base, $lookup, $fh)
+
+Reads a value record from the current location in the file, according to the
+format given.
+
+=cut
+
+sub read_value
+{
+ my ($self, $fmt, $base, $lookup, $fh) = @_;
+ my ($flag) = 1;
+ my ($res) = {};
+ my ($s, $i, $dat);
+
+ $s = 0;
+ for ($i = 0; $i < 12; $i++)
+ {
+ $s++ if ($flag & $fmt);
+ $flag <<= 1;
+ }
+
+ $fh->read($dat, $s << 1);
+ $flag = 1; $i = 0;
+ foreach $s (qw(XPlacement YPlacement XAdvance YAdvance))
+ {
+ $res->{$s} = TTF_Unpack('s', substr($dat, $i++ << 1, 2)) if ($fmt & $flag);
+ $flag <<= 1;
+ }
+
+ foreach $s (qw(XPlaDevice YPlaDevice XAdvDevice YAdvDevice))
+ {
+ if ($fmt & $flag)
+ { $res->{$s} = $self->read_delta(TTF_Unpack('S', substr($i++ << 1, 2)),
+ $base, $lookup, $fh); }
+ $flag <<= 1;
+ }
+
+ foreach $s (qw(XIdPlacement YIdPlacement XIdAdvance YIdAdvance))
+ {
+ $res->{$s} = TTF_Unpack('S', substr($dat, $i++ << 1, 2)) if ($fmt & $flag);
+ $flag <<= 1;
+ }
+ $res;
+}
+
+
+=head2 $t->read_delta($offset, $base, $lookup, $fh)
+
+Reads a delta (device table) at the given offset if it hasn't already been read.
+Store the offset and item in the lookup cache ($lookup->{' CACHE'})
+
+=cut
+
+sub read_delta
+{
+ my ($self, $offset, $base, $lookup, $fh) = @_;
+ my ($loc) = $fh->tell();
+ my ($res, $str);
+
+ return undef unless $offset;
+ $str = sprintf("%X", $base + $offset);
+ return $lookup->{' CACHE'}{$str} if defined $lookup->{' CACHE'}{$str};
+ $fh->seek($base + $offset, 0);
+ $res = Font::TTF::Delta->new->read($fh);
+ $fh->seek($loc, 0);
+ $lookup->{' CACHE'}{$str} = $res;
+ return $res;
+}
+
+
+=head2 $t->read_anchor($offset, $base, $lookup, $fh)
+
+Reads an Anchor table at the given offset if it hasn't already been read.
+
+=cut
+
+sub read_anchor
+{
+ my ($self, $offset, $base, $lookup, $fh) = @_;
+ my ($loc) = $fh->tell();
+ my ($res, $str);
+
+ return undef unless $offset;
+ $str = sprintf("%X", $base + $offset);
+ return $lookup->{' CACHE'}{$str} if defined $lookup->{' CACHE'}{$str};
+ $fh->seek($base + $offset, 0);
+ $res = Font::TTF::Anchor->new->read($fh);
+ $fh->seek($loc, 0);
+ $lookup->{' CACHE'}{$str} = $res;
+ return $res;
+}
+
+
+=head2 $t->fmt_value
+
+Returns the value format for a given value record
+
+=cut
+
+sub fmt_value
+{
+ my ($self, $value) = @_;
+ my ($fmt) = 0;
+ my ($n);
+
+ foreach $n (reverse qw(XPlacement YPlacement XAdvance YAdvance XPlaDevice YPlaDevice
+ XAdvDevice YAdvDevice XIdPlacement YIdPlacement XIdAdvance
+ YIdAdvance))
+ {
+ $fmt <<= 1;
+ $fmt |= 1 if (defined $value->{$n} && (ref $value->{$n} || $value->{$n}));
+ }
+ $fmt;
+}
+
+
+=head2 $t->out_value
+
+Returns the output string for the outputting of the value for a given format. Also
+updates the offset cache for any device tables referenced.
+
+=cut
+
+sub out_value
+{
+ my ($self, $value, $fmt, $tables, $offset) = @_;
+ my ($n, $flag, $out);
+
+ $flag = 1;
+ foreach $n (qw(XPlacement YPlacement XAdvance YAdvance))
+ {
+ $out .= pack('n', $value->{$n}) if ($flag & $fmt);
+ $flag <<= 1;
+ }
+ foreach $n (qw(XPlaDevice YPlaDevice XAdvDevice YAdvDevice))
+ {
+ if ($flag & $fmt)
+ {
+ $out .= pack('n', Font::TTF::Ttopen::ref_cache(
+ $value->{$n}, $tables, $offset + length($out)));
+ }
+ $flag <<= 1;
+ }
+ foreach $n (qw(XIdPlacement YIdPlacement XIdAdvance YIdAdvance))
+ {
+ $out .= pack('n', $value->{$n}) if ($flag & $fmt);
+ $flag <<= 1;
+ }
+ $out;
+}
+
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GSUB.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GSUB.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/GSUB.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,246 @@
+package Font::TTF::GSUB;
+
+=head1 NAME
+
+Font::TTF::GSUB - Module support for the GSUB table in conjunction with TTOpen
+
+=head1 DESCRIPTION
+
+Handles the GSUB subtables in relation to Ttopen tables. Due to the variety of
+different lookup types, the data structures are not all that straightforward,
+although I have tried to make life easy for myself when using this!
+
+=head1 INSTANCE VARIABLES
+
+The structure of a GSUB table is the same as that given in L<Font::TTF::Ttopen>.
+Here we give some of the semantics specific to GSUB lookups.
+
+=over 4
+
+=item ACTION_TYPE
+
+This is a string taking one of 4 values indicating the nature of the information
+in the ACTION array of the rule:
+
+=over 8
+
+=item g
+
+The action contains a string of glyphs to replace the match string by
+
+=item l
+
+The action array contains a list of lookups and offsets to run, in order, on
+the matched string
+
+=item a
+
+The action array is an unordered set of optional replacements for the matched
+glyph. The application should make the selection somehow.
+
+=item o
+
+The action array is empty (in fact there is no rule array for this type of
+rule) and the ADJUST value should be added to the glyph id to find the replacement
+glyph id value
+
+=back
+
+=item MATCH_TYPE
+
+This indicates which type of information the various MATCH arrays (MATCH, PRE,
+POST) hold in the rule:
+
+=over 8
+
+=item g
+
+The array holds a string of glyph ids which should match exactly
+
+=item c
+
+The array holds a sequence of class definitions which each glyph should
+correspondingly match to
+
+=item o
+
+The array holds offsets to coverage tables
+
+=back
+
+=back
+
+=head1 CORRESPONDANCE TO LAYOUT TYPES
+
+The following table gives the values for ACTION_TYPE and MATCH_TYPE for each
+of the 11 different lookup types found in the GSUB table definition I have:
+
+ 1.1 1.2 2 3 4 5.1 5.2 5.3 6.1 6.2 6.3
+ ACTION_TYPE o g g a g l l l l l l
+ MATCH_TYPE g g c o g c o
+
+Hopefully, the rest of the uses of the variables should make sense from this
+table.
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::Ttopen;
+
+ at ISA = qw(Font::TTF::Ttopen);
+
+=head2 $t->read_sub($fh, $lookup, $index)
+
+Asked by the superclass to read in from the given file the indexth subtable from
+lookup number lookup. The file is positioned ready for the read.
+
+=cut
+
+sub read_sub
+{
+ my ($self, $fh, $main_lookup, $sindex) = @_;
+ my ($type) = $main_lookup->{'TYPE'};
+ my ($loc) = $fh->tell();
+ my ($lookup) = $main_lookup->{'SUB'}[$sindex];
+ my ($dat, $s, @subst, $t, $fmt, $cover, $count, $mcount, $scount, $i, $gid);
+ my (@srec);
+
+ if ($type == 6)
+ {
+ $fh->read($dat, 4);
+ ($fmt, $cover) = TTF_Unpack('S2', $dat);
+ if ($fmt < 3)
+ {
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ }
+ } else
+ {
+ $fh->read($dat, 6);
+ ($fmt, $cover, $count) = TTF_Unpack("S3", $dat);
+ }
+ unless ($fmt == 3 && ($type == 5 || $type == 6))
+ { $lookup->{'COVERAGE'} = $self->read_cover($cover, $loc, $lookup, $fh, 1); }
+
+ $lookup->{'FORMAT'} = $fmt;
+ if ($type == 1 && $fmt == 1)
+ {
+ $lookup->{'ADJUST'} = $count;
+ $lookup->{'ACTION_TYPE'} = 'o';
+ } elsif ($type == 1 && $fmt == 2)
+ {
+ $fh->read($dat, $count << 1);
+ @subst = TTF_Unpack('S*', $dat);
+ foreach $s (@subst)
+ { push(@{$lookup->{'RULES'}}, [{'ACTION' => [$s]}]); }
+ $lookup->{'ACTION_TYPE'} = 'g';
+ } elsif ($type == 2 || $type == 3)
+ {
+ $fh->read($dat, $count << 1); # number of offsets
+ foreach $s (TTF_Unpack('S*', $dat))
+ {
+ $fh->seek($loc + $s, 0);
+ $fh->read($dat, 2);
+ $t = TTF_Unpack('S', $dat);
+ $fh->read($dat, $t << 1);
+ push(@{$lookup->{'RULES'}}, [{'ACTION' => [TTF_Unpack('S*', $dat)]}]);
+ }
+ $lookup->{'ACTION_TYPE'} = ($type == 2 ? 'g' : 'a');
+ } elsif ($type == 4)
+ {
+ $fh->read($dat, $count << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ {
+ @subst = ();
+ $fh->seek($loc + $s, 0);
+ $fh->read($dat, 2);
+ $t = TTF_Unpack('S', $dat);
+ $fh->read($dat, $t << 1);
+ foreach $t (TTF_Unpack('S*', $dat))
+ {
+ $fh->seek($loc + $s + $t, 0);
+ $fh->read($dat, 4);
+ ($gid, $mcount) = TTF_Unpack('S2', $dat);
+ $fh->read($dat, ($mcount - 1) << 1);
+ push(@subst, {'ACTION' => [$gid], 'MATCH' => [TTF_Unpack('S*', $dat)]});
+ }
+ push(@{$lookup->{'RULES'}}, [@subst]);
+ }
+ $lookup->{'ACTION_TYPE'} = 'g';
+ $lookup->{'MATCH_TYPE'} = 'g';
+ } elsif ($type == 5 || $type == 6)
+ { $self->read_context($lookup, $fh, $type, $fmt, $cover, $count, $loc); }
+ $lookup;
+}
+
+
+=head2 $t->extension
+
+Returns the table type number for the extension table
+
+=cut
+
+sub extension
+{ return 7; }
+
+
+=head2 $t->out_sub($fh, $lookup, $index)
+
+Passed the filehandle to output to, suitably positioned, the lookup and subtable
+index, this function outputs the subtable to $fh at that point.
+
+=cut
+
+sub out_sub
+{
+ my ($self, $fh, $main_lookup, $index) = @_;
+ my ($type) = $main_lookup->{'TYPE'};
+ my ($lookup) = $main_lookup->{'SUB'}[$index];
+ my ($fmt) = $lookup->{'FORMAT'};
+ my ($out, $r, $t, $i, $j, $offc, $offd, $numd);
+ my ($num) = $#{$lookup->{'RULES'}} + 1;
+ my ($ctables) = {};
+
+ if ($type == 1)
+ {
+ $out = pack("nn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2));
+ if ($fmt == 1)
+ { $out .= pack("n", $lookup->{'ADJUST'}); }
+ else
+ {
+ $out .= pack("n", $num);
+ foreach $r (@{$lookup->{'RULES'}})
+ { $out .= pack("n", $r->[0]{'ACTION'}[0]); }
+ }
+ } elsif ($type == 2 || $type == 3)
+ {
+ $out = pack("nnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $num);
+ $out .= pack('n*', 0 x $num);
+ $offc = length($out);
+ for ($i = 0; $i < $num; $i++)
+ {
+ $out .= pack("n*", $#{$lookup->{'RULES'}[$i][0]{'ACTION'}} + 1,
+ @{$lookup->{'RULES'}[$i][0]{'ACTION'}});
+ substr($out, ($i << 1) + 6, 2) = pack('n', $offc);
+ $offc = length($out);
+ }
+ } elsif ($type == 4 || $type == 5 || $type == 6)
+ { $out = $self->out_context($lookup, $fh, $type, $fmt, $ctables, $out, $num); }
+ Font::TTF::Ttopen::out_final($fh, $out, [[$ctables, 0]]);
+ $lookup;
+}
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyf.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyf.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyf.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,158 @@
+package Font::TTF::Glyf;
+
+=head1 NAME
+
+Font::TTF::Glyf - The Glyf data table
+
+=head1 DESCRIPTION
+
+This is a stub table. The real data is held in the loca table. If you want to get a glyf
+look it up in the loca table as C<$f->{'loca'}{'glyphs'}[$num]>. It won't be here!
+
+The difference between reading this table as opposed to the loca table is that
+reading this table will cause updated glyphs to be written out rather than just
+copying the glyph information from the input file. This causes font writing to be
+slower. So read the glyf as opposed to the loca table if you want to change glyf
+data. Read the loca table only if you are just wanting to read the glyf information.
+
+This class is used when writing the glyphs though.
+
+=head1 METHODS
+
+=cut
+
+
+use strict;
+use vars qw(@ISA);
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the C<loca> table instead!
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+
+ $self->{' PARENT'}{'loca'}->read;
+ $self->{' read'} = 1;
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes out all the glyphs in the parent's location table, calculating a new
+output location for each one.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($i, $loca, $offset, $numGlyphs);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $loca = $self->{' PARENT'}{'loca'}{'glyphs'};
+ $numGlyphs = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ $offset = 0;
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ next unless defined $loca->[$i];
+ $loca->[$i]->update;
+ $loca->[$i]{' OUTLOC'} = $offset;
+ $loca->[$i]->out($fh);
+ $offset += $loca->[$i]{' OUTLEN'};
+ }
+ $self->{' PARENT'}{'head'}{'indexToLocFormat'} = ($offset >= 0x20000);
+ $self;
+}
+
+
+=head2 $t->out_xml($context, $depth)
+
+Outputs all the glyphs in the glyph table just where they are supposed to be output!
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($loca, $i, $numGlyphs);
+
+ $loca = $self->{' PARENT'}{'loca'}{'glyphs'};
+ $numGlyphs = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $context->{'gid'} = $i;
+ $loca->[$i]->out_xml($context, $depth) if (defined $loca->[$i]);
+ }
+
+ $self;
+}
+
+
+=head2 $t->XML_start($context, $tag, %attrs)
+
+Pass control to glyphs as they occur
+
+=cut
+
+sub XML_start
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag eq 'glyph')
+ {
+ $context->{'tree'}[-1] = Font::TTF::Glyph->new(read => 2, PARENT => $self->{' PARENT'});
+ $context->{'receiver'} = $context->{'tree'}[-1];
+ }
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Collect up glyphs and put them into the loca table
+
+=cut
+
+sub XML_end
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag eq 'glyph')
+ {
+ unless (defined $context->{'glyphs'})
+ {
+ if (defined $self->{' PARENT'}{'loca'})
+ { $context->{'glyphs'} = $self->{' PARENT'}{'loca'}{'glyphs'}; }
+ else
+ { $context->{'glyphs'} = []; }
+ }
+ $context->{'glyphs'}[$attrs{'gid'}] = $context->{'tree'}[-1];
+ return $context;
+ } else
+ { return $self->SUPER::XML_end(@_); }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyph.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyph.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Glyph.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,815 @@
+package Font::TTF::Glyph;
+
+=head1 NAME
+
+Font::TTF::Glyph - Holds a single glyph's information
+
+=head1 DESCRIPTION
+
+This is a single glyph description as held in a TT font. On creation only its
+header is read. Thus you can get the bounding box of each glyph without having
+to read all the other information.
+
+=head1 INSTANCE VARIABLES
+
+In addition to the named variables in a glyph header (C<xMin> etc.), there are
+also all capital instance variables for holding working information, mostly
+from the location table.
+
+The standard attributes each glyph has are:
+
+ numberOfContours
+ xMin
+ yMin
+ xMax
+ yMax
+
+There are also other, derived, instance variables for each glyph which are read
+when the whole glyph is read (via C<read_dat>):
+
+=over 4
+
+=item instLen
+
+Number of bytes in the hinting instructions (Warning this variable is deprecated,
+use C<length($g->{'hints'})> instead).
+
+=item hints
+
+The string containing the hinting code for the glyph
+
+=back
+
+In addition there are other attribute like instance variables for simple glyphs:
+
+=over 4
+
+For each contour there is:
+
+=over 4
+
+=item endPoints
+
+An array of endpoints for each contour in the glyph. There are
+C<numberOfContours> contours in a glyph. The number of points in a glyph is
+equal to the highest endpoint of a contour.
+
+=back
+
+There are also a number of arrays indexed by point number
+
+=over 4
+
+=item flags
+
+The flags associated with reading this point. The flags for a point are
+recalculated for a point when it is C<update>d. Thus the flags are not very
+useful. The only important bit is bit 0 which indicates whether the point is
+an 'on' curve point, or an 'off' curve point.
+
+=item x
+
+The absolute x co-ordinate of the point.
+
+=item y
+
+The absolute y co-ordinate of the point
+
+=back
+
+=back
+
+For composite glyphs there are other variables
+
+=over 4
+
+=item metric
+
+This holds the component number (not its glyph number) of the component from
+which the metrics for this glyph should be taken.
+
+=item comps
+
+This is an array of hashes for each component. Each hash has a number of
+elements:
+
+=over 4
+
+=item glyph
+
+The glyph number of the glyph which comprises this component of the composite.
+
+=item args
+
+An array of two arguments which may be an x, y co-ordinate or two attachment
+points (one on the base glyph the other on the component). See flags for details.
+
+=item flag
+
+The flag for this component
+
+=item scale
+
+A 4 number array for component scaling. This allows stretching, rotating, etc.
+Note that scaling applies to placement co-ordinates (rather than attachment points)
+before locating rather than after.
+
+=back
+
+=item numPoints
+
+This is a generated value which contains the number of components read in for this
+compound glyph.
+
+=back
+
+The private instance variables are:
+
+=over 4
+
+=item INFILE (P)
+
+The input file form which to read any information
+
+=item LOC (P)
+
+Location relative to the start of the glyf table in the read file
+
+=item BASE (P)
+
+The location of the glyf table in the read file
+
+=item LEN (P)
+
+This is the number of bytes required by the glyph. It should be kept up to date
+by calling the C<update> method whenever any of the glyph content changes.
+
+=item OUTLOC (P)
+
+Location relative to the start of the glyf table. This variable is only active
+whilst the output process is going on. It is used to inform the location table
+where the glyph's location is, since the glyf table is output before the loca
+table due to alphabetical ordering.
+
+=item OUTLEN (P)
+
+This indicates the length of the glyph data when it is output. This more
+accurately reflects the internal memory form than the C<LEN> variable which
+only reflects the read file length. The C<OUTLEN> variable is only set after
+calling C<out> or C<out_dat>.
+
+=back
+
+=head2 Editing
+
+If you want to edit a glyph in some way, then you should read_dat the glyph, then
+make your changes and then update the glyph or set the $g->{' isdirty'} variable.
+It is the application's duty to ensure that the following instance variables are
+correct, from which update will calculate the rest, including the bounding box
+information.
+
+ numPoints
+ numberOfContours
+ endPoints
+ x, y, flags (only flags bit 0)
+ instLen
+ hints
+
+For components, the numPoints, x, y, endPoints & flags are not required but
+the following information is required for each component.
+
+ flag (bits 2, 10, 11, 12)
+ glyph
+ args
+ scale
+ metric (glyph instance variable)
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(%fields @field_info);
+use Font::TTF::Utils;
+use Font::TTF::Table;
+
+ at field_info = (
+ 'numberOfContours' => 's',
+ 'xMin' => 's',
+ 'yMin' => 's',
+ 'xMax' => 's',
+ 'yMax' => 's');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head1 Font::TTF::Glyph->new(%parms)
+
+Creates a new glyph setting various instance variables
+
+=cut
+
+sub new
+{
+ my ($class, %parms) = @_;
+ my ($self) = {};
+ my ($p);
+
+ bless $self, $class;
+ foreach $p (keys %parms)
+ { $self->{" $p"} = $parms{$p}; }
+ init unless defined $fields{'xMin'};
+ $self;
+}
+
+
+=head2 $g->read
+
+Reads the header component of the glyph (bounding box, etc.) and also the
+glyph content, but into a data field rather than breaking it down into
+its constituent structures. Use read_dat for this.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($dat);
+
+ return $self if $self->{' read'};
+ $self->{' read'} = 1;
+ $fh->seek($self->{' LOC'} + $self->{' BASE'}, 0);
+ $fh->read($self->{' DAT'}, $self->{' LEN'});
+ TTF_Read_Fields($self, $self->{' DAT'}, \%fields);
+ $self;
+}
+
+
+=head2 $g->read_dat
+
+Reads the contents of the glyph (components and curves, etc.) from the memory
+store C<DAT> into structures within the object. Then, to indicate where the
+master form of the data is, it deletes the C<DAT> instance variable.
+
+=cut
+
+sub read_dat
+{
+ my ($self) = @_;
+ my ($dat, $num, $max, $i, $flag, $len, $val, $val1, $fp);
+
+ return $self if $self->{' read'} > 1;
+ $self->read unless $self->{' read'};
+ $dat = $self->{' DAT'};
+ $fp = 10;
+ $num = $self->{'numberOfContours'};
+ if ($num > 0)
+ {
+ $self->{'endPoints'} = [unpack("n*", substr($dat, $fp, $num << 1))];
+ $fp += $num << 1;
+ $max = 0;
+ foreach (@{$self->{'endPoints'}})
+ { $max = $_ if $_ > $max; }
+ $max++;
+ $self->{'numPoints'} = $max;
+ $self->{'instLen'} = unpack("n", substr($dat, $fp));
+ $self->{'hints'} = substr($dat, $fp + 2, $self->{'instLen'});
+ $fp += 2 + $self->{'instLen'};
+# read the flags array
+ for ($i = 0; $i < $max; $i++)
+ {
+ $flag = unpack("C", substr($dat, $fp++));
+ $self->{'flags'}[$i] = $flag;
+ if ($flag & 8)
+ {
+ $len = unpack("C", substr($dat, $fp++));
+ while ($len-- > 0)
+ {
+ $i++;
+ $self->{'flags'}[$i] = $flag;
+ }
+ }
+ }
+#read the x array
+ for ($i = 0; $i < $max; $i++)
+ {
+ $flag = $self->{'flags'}[$i];
+ if ($flag & 2)
+ {
+ $val = unpack("C", substr($dat, $fp++));
+ $val = -$val unless ($flag & 16);
+ } elsif ($flag & 16)
+ { $val = 0; }
+ else
+ {
+ $val = TTF_Unpack("s", substr($dat, $fp));
+ $fp += 2;
+ }
+ $self->{'x'}[$i] = $i == 0 ? $val : $self->{'x'}[$i - 1] + $val;
+ }
+#read the y array
+ for ($i = 0; $i < $max; $i++)
+ {
+ $flag = $self->{'flags'}[$i];
+ if ($flag & 4)
+ {
+ $val = unpack("C", substr($dat, $fp++));
+ $val = -$val unless ($flag & 32);
+ } elsif ($flag & 32)
+ { $val = 0; }
+ else
+ {
+ $val = TTF_Unpack("s", substr($dat, $fp));
+ $fp += 2;
+ }
+ $self->{'y'}[$i] = $i == 0 ? $val : $self->{'y'}[$i - 1] + $val;
+ }
+ }
+
+# compound glyph
+ elsif ($num < 0)
+ {
+ $flag = 1 << 5; # cheat to get the loop going
+ for ($i = 0; $flag & 32; $i++)
+ {
+ ($flag, $self->{'comps'}[$i]{'glyph'}) = unpack("n2", substr($dat, $fp));
+ $fp += 4;
+ $self->{'comps'}[$i]{'flag'} = $flag;
+ if ($flag & 1) # ARGS1_AND_2_ARE_WORDS
+ {
+ $self->{'comps'}[$i]{'args'} = [TTF_Unpack("s2", substr($dat, $fp))];
+ $fp += 4;
+ } else
+ {
+ $self->{'comps'}[$i]{'args'} = [unpack("c2", substr($dat, $fp))];
+ $fp += 2;
+ }
+
+ if ($flag & 8)
+ {
+ $val = TTF_Unpack("F", substr($dat, $fp));
+ $fp += 2;
+ $self->{'comps'}[$i]{'scale'} = [$val, 0, 0, $val];
+ } elsif ($flag & 64)
+ {
+ ($val, $val1) = TTF_Unpack("F2", substr($dat, $fp));
+ $fp += 4;
+ $self->{'comps'}[$i]{'scale'} = [$val, 0, 0, $val1];
+ } elsif ($flag & 128)
+ {
+ $self->{'comps'}[$i]{'scale'} = [TTF_Unpack("F4", substr($dat, $fp))];
+ $fp += 8;
+ }
+ $self->{'metric'} = $i if ($flag & 512);
+ }
+ $self->{'numPoints'} = $i;
+ if ($flag & 256) # HAVE_INSTRUCTIONS
+ {
+ $self->{'instLen'} = unpack("n", substr($dat, $fp));
+ $self->{'hints'} = substr($dat, $fp + 2, $self->{'instLen'});
+ $fp += 2 + $self->{'instLen'};
+ }
+ }
+ return undef if ($fp > length($dat));
+ $self->{' read'} = 2;
+ $self;
+}
+
+
+=head2 $g->out($fh)
+
+Writes the glyph data to outfile
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ $self->read unless $self->{' read'};
+ $self->update if $self->{' isDirty'};
+ $fh->print($self->{' DAT'});
+ $self->{' OUTLEN'} = length($self->{' DAT'});
+ $self;
+}
+
+
+=head2 $g->out_xml($context, $depth)
+
+Outputs an XML description of the glyph
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($addr) = ($self =~ m/\((.+)\)$/o);
+ my ($k, $ndepth);
+
+ if ($context->{'addresses'}{$addr})
+ {
+ $context->{'fh'}->printf("%s<glyph gid='%s' id_ref='%s'/>\n", $depth, $context->{'gid'}, $addr);
+ return $self;
+ }
+ else
+ {
+ $context->{'fh'}->printf("%s<glyph gid='%s' id='%s'>\n", $depth, $context->{'gid'}, $addr);
+ }
+
+ $ndepth = $depth . $context->{'indent'};
+ $self->read_dat;
+ foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
+ {
+ $self->XML_element($context, $ndepth, $k, $self->{$k});
+ }
+ $context->{'fh'}->print("$depth</glyph>\n");
+ delete $context->{'done_points'};
+ $self;
+}
+
+
+sub XML_element
+{
+ my ($self, $context, $depth, $key, $val) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($dind) = $depth . $context->{'indent'};
+ my ($i);
+
+ if ($self->{'numberOfContours'} >= 0 && ($key eq 'x' || $key eq 'y' || $key eq 'flags'))
+ {
+ return $self if ($context->{'done_points'});
+ $context->{'done_points'} = 1;
+
+ $fh->print("$depth<points>\n");
+ for ($i = 0; $i <= $#{$self->{'flags'}}; $i++)
+ { $fh->printf("%s<point x='%s' y='%s' flags='0x%02X'/>\n", $dind,
+ $self->{'x'}[$i], $self->{'y'}[$i], $self->{'flags'}[$i]); }
+ $fh->print("$depth</points>\n");
+ }
+ elsif ($key eq 'hints')
+ {
+ my ($dat);
+ $fh->print("$depth<hints>\n");
+# Font::TTF::Utils::XML_hexdump($context, $depth . $context->{'indent'}, $self->{'hints'});
+ $dat = Font::TTF::Utils::XML_binhint($self->{'hints'});
+ $dat =~ s/\n(?!$)/\n$depth$context->{'indent'}/mg;
+ $fh->print("$depth$context->{'indent'}$dat");
+ $fh->print("$depth</hints>\n");
+ }
+ else
+ { return Font::TTF::Table::XML_element(@_); }
+
+ $self;
+}
+
+
+=head2 $g->update
+
+Generates a C<$self->{'DAT'}> from the internal structures, if the data has
+been read into structures in the first place. If you are building a glyph
+from scratch you will need to set the instance variable C<' read'> to 2 (or
+something > 1) for the update to work.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($dat, $loc, $len, $flag, $x, $y, $i, $comp, $num);
+
+ return $self unless (defined $self->{' read'} && $self->{' read'} > 1);
+ $self->update_bbox;
+ $self->{' DAT'} = TTF_Out_Fields($self, \%fields, 10);
+ $num = $self->{'numberOfContours'};
+ if ($num > 0)
+ {
+ $self->{' DAT'} .= pack("n*", @{$self->{'endPoints'}});
+ $len = $self->{'instLen'};
+ $self->{' DAT'} .= pack("n", $len);
+ $self->{' DAT'} .= pack("a" . $len, substr($self->{'hints'}, 0, $len)) if ($len > 0);
+ for ($i = 0; $i < $self->{'numPoints'}; $i++)
+ {
+ $flag = $self->{'flags'}[$i] & 1;
+ if ($i == 0)
+ {
+ $x = $self->{'x'}[$i];
+ $y = $self->{'y'}[$i];
+ } else
+ {
+ $x = $self->{'x'}[$i] - $self->{'x'}[$i - 1];
+ $y = $self->{'y'}[$i] - $self->{'y'}[$i - 1];
+ }
+ $flag |= 16 if ($x == 0);
+ $flag |= 32 if ($y == 0);
+ if (($flag & 16) == 0 && $x < 256 && $x > -256)
+ {
+ $flag |= 2;
+ $flag |= 16 if ($x >= 0);
+ }
+ if (($flag & 32) == 0 && $y < 256 && $y > -256)
+ {
+ $flag |= 4;
+ $flag |= 32 if ($y >= 0);
+ }
+ $self->{' DAT'} .= pack("C", $flag); # sorry no repeats
+ $self->{'flags'}[$i] = $flag;
+ }
+ for ($i = 0; $i < $self->{'numPoints'}; $i++)
+ {
+ $flag = $self->{'flags'}[$i];
+ $x = $self->{'x'}[$i] - (($i == 0) ? 0 : $self->{'x'}[$i - 1]);
+ if (($flag & 18) == 0)
+ { $self->{' DAT'} .= TTF_Pack("s", $x); }
+ elsif (($flag & 18) == 18)
+ { $self->{' DAT'} .= pack("C", $x); }
+ elsif (($flag & 18) == 2)
+ { $self->{' DAT'} .= pack("C", -$x); }
+ }
+ for ($i = 0; $i < $self->{'numPoints'}; $i++)
+ {
+ $flag = $self->{'flags'}[$i];
+ $y = $self->{'y'}[$i] - (($i == 0) ? 0 : $self->{'y'}[$i - 1]);
+ if (($flag & 36) == 0)
+ { $self->{' DAT'} .= TTF_Pack("s", $y); }
+ elsif (($flag & 36) == 36)
+ { $self->{' DAT'} .= pack("C", $y); }
+ elsif (($flag & 36) == 4)
+ { $self->{' DAT'} .= pack("C", -$y); }
+ }
+ }
+
+ elsif ($num < 0)
+ {
+ for ($i = 0; $i <= $#{$self->{'comps'}}; $i++)
+ {
+ $comp = $self->{'comps'}[$i];
+ $flag = $comp->{'flag'} & 7158; # bits 2,10,11,12
+ $flag |= 1 unless ($comp->{'args'}[0] > -129 && $comp->{'args'}[0] < 128
+ && $comp->{'args'}[1] > -129 && $comp->{'args'}[1] < 128);
+ if (defined $comp->{'scale'})
+ {
+ if ($comp->{'scale'}[1] == 0 && $comp->{'scale'}[2] == 0)
+ {
+ if ($comp->{'scale'}[0] == $comp->{'scale'}[3])
+ { $flag |= 8 unless ($comp->{'scale'}[0] == 0
+ || abs(abs($comp->{'scale'}[0]) - 1.) < .001); }
+ else
+ { $flag |= 64; }
+ } else
+ { $flag |= 128; }
+ }
+
+ $flag |= 512 if (defined $self->{'metric'} && $self->{'metric'} == $i);
+ if ($i == $#{$self->{'comps'}})
+ { $flag |= 256 if (defined $self->{'instLen'} && $self->{'instLen'} > 0); }
+ else
+ { $flag |= 32; }
+
+ $self->{' DAT'} .= pack("n", $flag);
+ $self->{' DAT'} .= pack("n", $comp->{'glyph'});
+ $comp->{'flag'} = $flag;
+
+ if ($flag & 1)
+ { $self->{' DAT'} .= TTF_Pack("s2", @{$comp->{'args'}}); }
+ else
+ { $self->{' DAT'} .= pack("CC", @{$comp->{'args'}}); }
+
+ if ($flag & 8)
+ { $self->{' DAT'} .= TTF_Pack("F", $comp->{'scale'}[0]); }
+ elsif ($flag & 64)
+ { $self->{' DAT'} .= TTF_Pack("F2", $comp->{'scale'}[0], $comp->{'scale'}[3]); }
+ elsif ($flag & 128)
+ { $self->{' DAT'} .= TTF_Pack("F4", @{$comp->{'scale'}}); }
+ }
+ if (defined $self->{'instLen'} && $self->{'instLen'} > 0)
+ {
+ $len = $self->{'instLen'};
+ $self->{' DAT'} .= pack("n", $len);
+ $self->{' DAT'} .= pack("a" . $len, substr($self->{'hints'}, 0, $len));
+ }
+ }
+ $self->{' DAT'} .= "\000" if (length($self->{' DAT'}) & 1);
+ $self->{' OUTLEN'} = length($self->{' DAT'});
+ $self->{' read'} = 2; # changed from 1 to 2 so we don't read_dat() again
+# we leave numPoints and instLen since maxp stats use this
+ $self;
+}
+
+
+=head2 $g->update_bbox
+
+Updates the bounding box for this glyph according to the points in the glyph
+
+=cut
+
+sub update_bbox
+{
+ my ($self) = @_;
+ my ($num, $maxx, $minx, $maxy, $miny, $i, $comp, $x, $y, $compg);
+
+ return $self unless $self->{' read'} > 1; # only if read_dat done
+ $miny = $minx = 65537; $maxx = $maxy = -65537;
+ $num = $self->{'numberOfContours'};
+ if ($num > 0)
+ {
+ for ($i = 0; $i < $self->{'numPoints'}; $i++)
+ {
+ ($x, $y) = ($self->{'x'}[$i], $self->{'y'}[$i]);
+
+ $maxx = $x if ($x > $maxx);
+ $minx = $x if ($x < $minx);
+ $maxy = $y if ($y > $maxy);
+ $miny = $y if ($y < $miny);
+ }
+ }
+
+ elsif ($num < 0)
+ {
+ foreach $comp (@{$self->{'comps'}})
+ {
+ my ($gnx, $gny, $gxx, $gxy);
+ my ($sxx, $sxy, $syx, $syy);
+
+ $compg = $self->{' PARENT'}{'loca'}{'glyphs'}[$comp->{'glyph'}]->read->update_bbox;
+ ($gnx, $gny, $gxx, $gxy) = @{$compg}{'xMin', 'yMin', 'xMax', 'yMax'};
+ if (defined $comp->{'scale'})
+ {
+ ($sxx, $sxy, $syx, $syy) = @{$comp->{'scale'}};
+ ($gnx, $gny, $gxx, $gxy) = ($gnx*$sxx+$gny*$syx + $comp->{'args'}[0],
+ $gnx*$sxy+$gny*$syy + $comp->{'args'}[1],
+ $gxx*$sxx+$gxy*$syx + $comp->{'args'}[0],
+ $gxx*$sxy+$gxy*$syy + $comp->{'args'}[1]);
+ } elsif ($comp->{'args'}[0] || $comp->{'args'}[1])
+ {
+ $gnx += $comp->{'args'}[0];
+ $gny += $comp->{'args'}[1];
+ $gxx += $comp->{'args'}[0];
+ $gxy += $comp->{'args'}[1];
+ }
+ $maxx = $gxx if $gxx > $maxx;
+ $minx = $gnx if $gnx < $minx;
+ $maxy = $gxy if $gxy > $maxy;
+ $miny = $gny if $gny < $miny;
+ }
+ }
+ $self->{'xMax'} = $maxx;
+ $self->{'xMin'} = $minx;
+ $self->{'yMax'} = $maxy;
+ $self->{'yMin'} = $miny;
+ $self;
+}
+
+
+=head2 $g->maxInfo
+
+Returns lots of information about a glyph so that the C<maxp> table can update
+itself.
+
+=cut
+
+sub maxInfo
+{
+ my ($self) = @_;
+ my (@res, $i, @n);
+
+ $self->read_dat; # make sure we've read some data
+ $res[4] = length($self->{'hints'}) if defined $self->{'hints'};
+ if ($self->{'numberOfContours'} > 0)
+ {
+ $res[2] = $res[0] = $self->{'numPoints'};
+ $res[3] = $res[1] = $self->{'numberOfContours'};
+ $res[6] = 1;
+ } elsif ($self->{'numberOfContours'} < 0)
+ {
+ $res[6] = 1;
+ for ($i = 0; $i <= $#{$self->{'comps'}}; $i++)
+ {
+ @n = $self->{' PARENT'}{'loca'}{'glyphs'}[$self->{'comps'}[$i]{'glyph'}]->maxInfo;
+ $res[2] += $n[2] == 0 ? $n[0] : $n[2];
+ $res[3] += $n[3] == 0 ? $n[1] : $n[3];
+ $res[5]++;
+ $res[6] = $n[6] + 1 if ($n[6] >= $res[6]);
+ }
+ }
+ @res;
+}
+
+=head2 $g->empty
+
+Empties the glyph of all information to the level of not having been read.
+Useful for saving memory in apps with many glyphs being read
+
+=cut
+
+sub empty
+{
+ my ($self) = @_;
+ my (%keep) = map {(" $_" => 1)} ('LOC', 'OUTLOC', 'PARENT', 'INFILE', 'BASE',
+ 'OUTLEN', 'LEN');
+ map {delete $self->{$_} unless $keep{$_}} keys %$self;
+
+ $self;
+}
+
+
+=head2 $g->get_points
+
+This method creates point information for a compound glyph. The information is
+stored in the same place as if the glyph was not a compound, but since
+numberOfContours is negative, the glyph is still marked as being a compound
+
+=cut
+
+sub get_points
+{
+ my ($self) = @_;
+ my ($comp, $compg, $nump, $e, $i);
+
+ $self->read_dat;
+ return undef unless ($self->{'numberOfContours'} < 0);
+
+ foreach $comp (@{$self->{'comps'}})
+ {
+ $compg = $self->{' PARENT'}{'loca'}{'glyphs'}[$comp->{'glyph'}]->read;
+ $compg->get_points;
+
+ for ($i = 0; $i < $compg->{'numPoints'}; $i++)
+ {
+ my ($x, $y) = ($compg->{'x'}[$i], $compg->{'y'}[$i]);
+ if (defined $comp->{'scale'})
+ {
+ ($x, $y) = ($x * $comp->{'scale'}[0] + $y * $comp->{'scale'}[2],
+ $x * $comp->{'scale'}[1] + $y * $comp->{'scale'}[3]);
+ }
+ if (defined $comp->{'args'})
+ { ($x, $y) = ($x + $comp->{'args'}[0], $y + $comp->{'args'}[1]); }
+ push (@{$self->{'x'}}, $x);
+ push (@{$self->{'y'}}, $y);
+ }
+ foreach $e (@{$compg->{'endPoints'}})
+ { push (@{$self->{'endPoints'}}, $e + $nump); }
+ $nump += $compg->{'numPoints'};
+ }
+ $self->{'numPoints'} = $nump;
+ $self;
+}
+
+
+=head2 $g->get_refs
+
+Returns an array of all the glyph ids that are used to make up this glyph. That
+is all the compounds and their references and so on. If this glyph is not a
+compound, then returns an empty array
+
+=cut
+
+sub get_refs
+{
+ my ($self) = @_;
+ my (@res, $g);
+
+ $self->read_dat;
+ return unless ($self->{'numberOfContours'} < 0);
+ foreach $g (@{$self->{'comps'}})
+ {
+ my (@list) = $self->{' PARENT'}{'loca'}{'glyphs'}[$g->{'glyph'}]->get_points;
+ push (@res, $g->{'glyph'});
+ push (@res, @list) if ($list[0]);
+ }
+ return @res;
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+The instance variables used here are somewhat clunky and inconsistent with
+the other tables.
+
+=item *
+
+C<update> doesn't re-calculate the bounding box or C<numberOfContours>.
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hdmx.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hdmx.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hdmx.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,149 @@
+package Font::TTF::Hdmx;
+
+=head1 NAME
+
+Font::TTF::Hdmx - Horizontal device metrics
+
+=head1 DESCRIPTION
+
+The table consists of an hash of device metric tables indexed by the ppem for
+that subtable. Each subtable consists of an array of advance widths in pixels
+for each glyph at that ppem (horizontally).
+
+=head1 INSTANCE VARIABLES
+
+Individual metrics are accessed using the following referencing:
+
+ $f->{'hdmx'}{$ppem}[$glyph_num]
+
+In addition there is one instance variable:
+
+=over 4
+
+=item Num
+
+Number of device tables.
+
+=back
+
+=head2 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+
+ at ISA = qw(Font::TTF::Table);
+
+
+=head2 $t->read
+
+Reads the table into data structures
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($numg, $ppem, $i, $numt, $dat, $len);
+
+ $numg = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ $self->SUPER::read or return $self;
+
+ $fh->read($dat, 8);
+ ($self->{'Version'}, $numt, $len) = unpack("nnN", $dat);
+ $self->{'Num'} = $numt;
+
+ for ($i = 0; $i < $numt; $i++)
+ {
+ $fh->read($dat, $len);
+ $ppem = unpack("C", $dat);
+ $self->{$ppem} = [unpack("C$numg", substr($dat, 2))];
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Outputs the device metrics for this font
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($numg, $i, $pad, $len, $numt, @ppem, $max);
+
+ return $self->SUPER::out($fh) unless ($self->{' read'});
+
+ $numg = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ @ppem = grep(/^\d+$/, sort {$a <=> $b} keys %$self);
+ $pad = "\000" x (3 - ($numg + 1) % 4);
+ $len = $numg + 2 + length($pad);
+ $fh->print(pack("nnN", 0, $#ppem + 1, $len));
+ for $i (@ppem)
+ {
+ $max = 0;
+ foreach (@{$self->{$i}}[0..($numg - 1)])
+ { $max = $_ if $_ > $max; }
+ $fh->print(pack("C*", $i, $max, @{$self->{$i}}[0..($numg - 1)]) . $pad);
+ }
+ $self;
+}
+
+
+=head2 $t->tables_do(&func)
+
+For each subtable it calls &sub($ref, $ppem)
+
+=cut
+
+sub tables_do
+{
+ my ($self, $func) = @_;
+ my ($i);
+
+ foreach $i (grep(/^\d+$/, %$self))
+ { &$func($self->{$i}, $i); }
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $value)
+
+Outputs device metrics a little more tidily
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $value) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($i);
+
+ return $self->SUPER::XML_element(@_) if (ref($value) ne 'ARRAY');
+ $fh->print("$depth<metrics ppem='$key'>\n");
+ for ($i = 0; $i <= $#{$value}; $i += 25)
+ {
+ $fh->print("$depth$context->{'indent'}". join(' ', @{$value}[$i .. $i + 24]) . "\n");
+ }
+ $fh->print("$depth</metrics>\n");
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Head.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Head.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Head.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,250 @@
+package Font::TTF::Head;
+
+=head1 NAME
+
+Font::TTF::Head - The head table for a TTF Font
+
+=head1 DESCRIPTION
+
+This is a very basic table with just instance variables as described in the
+TTF documentation, using the same names. One of the most commonly used is
+C<unitsPerEm>.
+
+=head1 INSTANCE VARIABLES
+
+The C<head> table has no internal instance variables beyond those common to all
+tables and those specified in the standard:
+
+ version
+ fontRevision
+ checkSumAdjustment
+ magicNumber
+ flags
+ unitsPerEm
+ created
+ modified
+ xMin
+ yMin
+ xMax
+ yMax
+ macStyle
+ lowestRecPPEM
+ fontDirectionHint
+ indexToLocFormat
+ glyphDataFormat
+
+The two dates are held as an array of two unsigned longs (32-bits)
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'version' => 'f',
+ 'fontRevision' => 'f',
+ 'checkSumAdjustment' => 'L',
+ 'magicNumber' => 'L',
+ 'flags' => 'S',
+ 'unitsPerEm' => 'S',
+ 'created' => 'L2',
+ 'modified' => 'L2',
+ 'xMin' => 's',
+ 'yMin' => 's',
+ 'xMax' => 's',
+ 'yMax' => 's',
+ 'macStyle' => 'S',
+ 'lowestRecPPEM' => 'S',
+ 'fontDirectionHint' => 's',
+ 'indexToLocFormat' => 's',
+ 'glyphDataFormat' => 's');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory thanks to some utility functions
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read || return $self;
+
+ init unless defined $fields{'Ascender'};
+ $self->{' INFILE'}->read($dat, 54);
+
+ TTF_Read_Fields($self, $dat, \%fields);
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying. If in memory
+(which is usually) the checkSumAdjustment field is set to 0 as per the default
+if the file checksum is not to be considered.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'}; # this is never true
+# $self->{'checkSumAdjustment'} = 0 unless $self->{' PARENT'}{' wantsig'};
+ $fh->print(TTF_Out_Fields($self, \%fields, 54));
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $value)
+
+Handles date process for the XML exporter
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $value) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($output, @time);
+ my (@month) = qw(JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC);
+
+ return $self->SUPER::XML_element(@_) unless ($key eq 'created' || $key eq 'modified');
+
+ @time = gmtime($self->getdate($key eq 'created'));
+ $output = sprintf("%d/%s/%d %d:%d:%d", $time[3], $month[$time[4]], $time[5] + 1900,
+ $time[2], $time[1], $time[0]);
+ $fh->print("$depth<$key>$output</$key>\n");
+ $self;
+}
+
+
+=head2 $t->update
+
+Updates the head table based on the glyph data and the hmtx table
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($num, $i, $loc, $hmtx);
+ my ($xMin, $yMin, $xMax, $yMax, $lsbx);
+
+ return undef unless ($self->SUPER::update);
+
+ $num = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ return undef unless (defined $self->{' PARENT'}{'hmtx'} && defined $self->{' PARENT'}{'loca'});
+ $hmtx = $self->{' PARENT'}{'hmtx'}->read;
+
+ $self->{' PARENT'}{'loca'}->update;
+ $hmtx->update; # if we updated, then the flags will be set anyway.
+ $lsbx = 1;
+ for ($i = 0; $i < $num; $i++)
+ {
+ $loc = $self->{' PARENT'}{'loca'}{'glyphs'}[$i];
+ next unless defined $loc;
+ $loc->read->update_bbox;
+ $xMin = $loc->{'xMin'} if ($loc->{'xMin'} < $xMin || $i == 0);
+ $yMin = $loc->{'yMin'} if ($loc->{'yMin'} < $yMin || $i == 0);
+ $xMax = $loc->{'xMax'} if ($loc->{'xMax'} > $xMax);
+ $yMax = $loc->{'yMax'} if ($loc->{'yMax'} > $yMax);
+ $lsbx &= ($loc->{'xMin'} == $hmtx->{'lsb'}[$i]);
+ }
+ $self->{'xMin'} = $xMin;
+ $self->{'yMin'} = $yMin;
+ $self->{'xMax'} = $xMax;
+ $self->{'yMax'} = $yMax;
+ if ($lsbx)
+ { $self->{'flags'} |= 2; }
+ else
+ { $self->{'flags'} &= ~2; }
+ $self;
+}
+
+
+=head2 $t->getdate($is_create)
+
+Converts font modification time (or creation time if $is_create is set) to a 32-bit integer as returned
+from time(). Returns undef if the value is out of range, either before the epoch or after the maximum
+storable time.
+
+=cut
+
+sub getdate
+{
+ my ($self, $is_create) = @_;
+ my ($arr) = $self->{$is_create ? 'created' : 'modified'};
+
+ $arr->[1] -= 2082844800; # seconds between 1/Jan/1904 and 1/Jan/1970 (midnight)
+ if ($arr->[1] < 0)
+ {
+ $arr->[1] += 0xFFFFFFF; $arr->[1]++;
+ $arr->[0]--;
+ }
+ return undef if $arr->[0] != 0;
+ return $arr->[1];
+}
+
+
+=head2 $t->setdate($time, $is_create)
+
+Sets the time information for modification (or creation time if $is_create is set) according to the 32-bit
+time information.
+
+=cut
+
+sub setdate
+{
+ my ($self, $time, $is_create) = @_;
+ my (@arr);
+
+ $arr[1] = $time;
+ if ($arr[1] >= 0x83DA4F80)
+ {
+ $arr[1] -= 0xFFFFFFFF;
+ $arr[1]--;
+ $arr[0]++;
+ }
+ $arr[1] += 2082844800;
+ $self->{$is_create ? 'created' : 'modified'} = \@arr;
+ $self;
+}
+
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hhea.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hhea.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hhea.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,162 @@
+package Font::TTF::Hhea;
+
+=head1 NAME
+
+TTF:Hhea - Horizontal Header table
+
+=head1 DESCRIPTION
+
+This is a simplte table with just standards specified instance variables
+
+=head1 INSTANCE VARIABLES
+
+ version
+ Ascender
+ Descender
+ LineGap
+ advanceWidthMax
+ minLeftSideBearing
+ minRightSideBearing
+ xMaxExtent
+ caretSlopeRise
+ caretSlopeRun
+ metricDataFormat
+ numberOfHMetrics
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'version' => 'f',
+ 'Ascender' => 's',
+ 'Descender' => 's',
+ 'LineGap' => 's',
+ 'advanceWidthMax' => 'S',
+ 'minLeftSideBearing' => 's',
+ 'minRightSideBearing' => 's',
+ 'xMaxExtent' => 's',
+ 'caretSlopeRise' => 's',
+ 'caretSlopeRun' => 's',
+ 'metricDataFormat' => '+10s',
+ 'numberOfHMetrics' => 'S');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory as instance variables
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read or return $self;
+ init unless defined $fields{'Ascender'};
+ $self->{' INFILE'}->read($dat, 36);
+
+ TTF_Read_Fields($self, $dat, \%fields);
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $self->{'numberOfHMetrics'} = $self->{' PARENT'}{'hmtx'}->numMetrics || $self->{'numberOfHMetrics'};
+ $fh->print(TTF_Out_Fields($self, \%fields, 36));
+ $self;
+}
+
+
+=head2 $t->update
+
+Updates various parameters in the hhea table from the hmtx table, assuming
+the C<hmtx> table is dirty.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($hmtx) = $self->{' PARENT'}{'hmtx'};
+ my ($glyphs);
+ my ($num);
+ my ($i, $maw, $mlsb, $mrsb, $mext, $aw, $lsb, $ext);
+
+ return undef unless ($self->SUPER::update);
+ return undef unless (defined $hmtx && defined $self->{' PARENT'}{'loca'});
+
+ $hmtx->read->update;
+ $self->{' PARENT'}{'loca'}->read->update;
+ $glyphs = $self->{' PARENT'}{'loca'}{'glyphs'};
+ $num = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ return undef unless ($hmtx->{' isDirty'} || $self->{' PARENT'}{'loca'}{' isDirty'});
+
+ for ($i = 0; $i < $num; $i++)
+ {
+ $aw = $hmtx->{'advance'}[$i];
+ $lsb = $hmtx->{'lsb'}[$i];
+ if (defined $glyphs->[$i])
+ { $ext = $lsb + $glyphs->[$i]->read->{'xMax'} - $glyphs->[$i]{'xMin'}; }
+ else
+ { $ext = $aw; }
+ $maw = $aw if ($aw > $maw);
+ $mlsb = $lsb if ($lsb < $mlsb or $i == 0);
+ $mrsb = $aw - $ext if ($aw - $ext < $mrsb or $i == 0);
+ $mext = $ext if ($ext > $mext);
+ }
+ $self->{'advanceWidthMax'} = $maw;
+ $self->{'minLeftSideBearing'} = $mlsb;
+ $self->{'minRightSideBearing'} = $mrsb;
+ $self->{'xMaxExtent'} = $mext;
+ $self->{'numberOfHMetrics'} = $hmtx->numMetrics;
+ $self;
+}
+
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hmtx.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hmtx.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Hmtx.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,214 @@
+package Font::TTF::Hmtx;
+
+=head1 NAME
+
+Font::TTF::Hmtx - Horizontal Metrics
+
+=head1 DESCRIPTION
+
+Contains the advance width and left side bearing for each glyph. Given the
+compressability of the data onto disk, this table uses information from
+other tables, and thus must do part of its output during the output of
+other tables
+
+=head1 INSTANCE VARIABLES
+
+The horizontal metrics are kept in two arrays by glyph id. The variable names
+do not start with a space
+
+=over 4
+
+=item advance
+
+An array containing the advance width for each glyph
+
+=item lsb
+
+An array containing the left side bearing for each glyph
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+require Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+
+
+=head2 $t->read
+
+Reads the horizontal metrics from the TTF file into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($numh, $numg);
+
+ $numh = $self->{' PARENT'}{'hhea'}->read->{'numberOfHMetrics'};
+ $numg = $self->{' PARENT'}{'maxp'}->read->{'numGlyphs'};
+ $self->_read($numg, $numh, "advance", "lsb");
+}
+
+sub _read
+{
+ my ($self, $numg, $numh, $tAdv, $tLsb) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($i, $dat);
+
+ $self->SUPER::read or return $self;
+
+ for ($i = 0; $i < $numh; $i++)
+ {
+ $fh->read($dat, 4);
+ ($self->{$tAdv}[$i], $self->{$tLsb}[$i]) = unpack("nn", $dat);
+ $self->{$tLsb}[$i] -= 65536 if ($self->{$tLsb}[$i] >= 32768);
+ }
+
+ $i--;
+ while ($i++ < $numg)
+ {
+ $fh->read($dat, 2);
+ $self->{$tAdv}[$i] = $self->{$tAdv}[$numh - 1];
+ $self->{$tLsb}[$i] = unpack("n", $dat);
+ $self->{$tLsb}[$i] -= 65536 if ($self->{$tLsb}[$i] >= 32768);
+ }
+ $self;
+}
+
+=head2 $t->numMetrics
+
+Calculates again the number of long metrics required to store the information
+here. Returns undef if the table has not been read.
+
+=cut
+
+sub numMetrics
+{
+ my ($self) = @_;
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ my ($i);
+
+ return undef unless $self->{' read'};
+
+ for ($i = $numg - 2; $i >= 0; $i--)
+ { last if ($self->{'advance'}[$i] != $self->{'advance'}[$i + 1]); }
+
+ return $i + 2;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the metrics to a TTF file. Assumes that the C<hhea> has updated the
+numHMetrics from here
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ my ($numh) = $self->{' PARENT'}{'hhea'}->read->{'numberOfHMetrics'};
+ $self->_out($fh, $numg, $numh, "advance", "lsb");
+}
+
+sub _out
+{
+ my ($self, $fh, $numg, $numh, $tAdv, $tLsb) = @_;
+ my ($i, $lsb);
+
+ return $self->SUPER::out($fh) unless ($self->{' read'});
+
+ for ($i = 0; $i < $numg; $i++)
+ {
+ $lsb = $self->{$tLsb}[$i];
+ $lsb += 65536 if $lsb < 0;
+ if ($i >= $numh)
+ { $fh->print(pack("n", $lsb)); }
+ else
+ { $fh->print(pack("n2", $self->{$tAdv}[$i], $lsb)); }
+ }
+ $self;
+}
+
+
+=head2 $t->update
+
+Updates the lsb values from the xMin from the each glyph
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ my ($i);
+
+ return undef unless ($self->SUPER::update);
+# lsb & xMin must always be the same, regardless of any flags!
+# return $self unless ($self->{' PARENT'}{'head'}{'flags'} & 2); # lsb & xMin the same
+
+ $self->{' PARENT'}{'loca'}->update;
+ for ($i = 0; $i < $numg; $i++)
+ {
+ my ($g) = $self->{' PARENT'}{'loca'}{'glyphs'}[$i];
+ if ($g)
+ { $self->{'lsb'}[$i] = $g->read->update_bbox->{'xMin'}; }
+ else
+ { $self->{'lsb'}[$i] = 0; }
+ }
+ $self->{' PARENT'}{'head'}{'flags'} |= 2;
+ $self;
+}
+
+
+=head2 $t->out_xml($context, $depth)
+
+Outputs the table in XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ my ($addr) = ($self =~ m/\((.+)\)$/o);
+ my ($i);
+
+ if ($context->{'addresses'}{$addr})
+ {
+ $fh->printf("%s<%s id_ref='%s'/>\n", $depth, $context->{'name'}, $addr);
+ return $self;
+ }
+ else
+ { $fh->printf("%s<%s id='%s'>\n", $depth, $context->{'name'}, $addr); }
+
+ $self->read;
+
+ for ($i = 0; $i < $numg; $i++)
+ { $fh->print("$depth$context->{'indent'}<width adv='$self->{'advance'}[$i]' lsb='$self->{'lsb'}[$i]'/>\n"); }
+
+ $fh->print("$depth</$context->{'name'}>\n");
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/ClassArray.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/ClassArray.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/ClassArray.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,152 @@
+package Font::TTF::Kern::ClassArray;
+
+=head1 NAME
+
+Font::TTF::Kern::ClassArray
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Kern::Subtable);
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+
+ my $subtableStart = $fh->tell() - 8;
+ my $dat;
+ $fh->read($dat, 8);
+ my ($rowWidth, $leftClassTable, $rightClassTable, $array) = unpack("nnnn", $dat);
+
+ $fh->seek($subtableStart + $leftClassTable, IO::File::SEEK_SET);
+ $fh->read($dat, 4);
+ my ($firstGlyph, $nGlyphs) = unpack("nn", $dat);
+ $fh->read($dat, $nGlyphs * 2);
+ my $leftClasses = [];
+ foreach (TTF_Unpack("S*", $dat)) {
+ push @{$leftClasses->[($_ - $array) / $rowWidth]}, $firstGlyph++;
+ }
+
+ $fh->seek($subtableStart + $rightClassTable, IO::File::SEEK_SET);
+ $fh->read($dat, 4);
+ ($firstGlyph, $nGlyphs) = unpack("nn", $dat);
+ $fh->read($dat, $nGlyphs * 2);
+ my $rightClasses = [];
+ foreach (TTF_Unpack("S*", $dat)) {
+ push @{$rightClasses->[$_ / 2]}, $firstGlyph++;
+ }
+
+ $fh->seek($subtableStart + $array, IO::File::SEEK_SET);
+ $fh->read($dat, $self->{'length'} - $array);
+
+ my $offset = 0;
+ my $kernArray = [];
+ while ($offset < length($dat)) {
+ push @$kernArray, [ TTF_Unpack("s*", substr($dat, $offset, $rowWidth)) ];
+ $offset += $rowWidth;
+ }
+
+ $self->{'leftClasses'} = $leftClasses;
+ $self->{'rightClasses'} = $rightClasses;
+ $self->{'kernArray'} = $kernArray;
+
+ $fh->seek($subtableStart + $self->{'length'}, IO::File::SEEK_SET);
+
+ $self;
+}
+
+=head2 $t->out_sub($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out_sub
+{
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+
+}
+
+sub dumpXML
+{
+ my ($self, $fh) = @_;
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+ $fh->printf("<leftClasses>\n");
+ $self->dumpClasses($self->{'leftClasses'}, $fh);
+ $fh->printf("</leftClasses>\n");
+
+ $fh->printf("<rightClasses>\n");
+ $self->dumpClasses($self->{'rightClasses'}, $fh);
+ $fh->printf("</rightClasses>\n");
+
+ $fh->printf("<kernArray>\n");
+ my $kernArray = $self->{'kernArray'};
+ foreach (0 .. $#$kernArray) {
+ $fh->printf("<row index=\"%s\">\n", $_);
+ my $row = $kernArray->[$_];
+ foreach (0 .. $#$row) {
+ $fh->printf("<val index=\"%s\" v=\"%s\"/>\n", $_, $row->[$_]);
+ }
+ $fh->printf("</row>\n");
+ }
+ $fh->printf("</kernArray>\n");
+}
+
+sub type
+{
+ return 'kernClassArray';
+}
+
+
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/CompactClassArray.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/CompactClassArray.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/CompactClassArray.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,93 @@
+package Font::TTF::Kern::CompactClassArray;
+
+=head1 NAME
+
+Font::TTF::AAT::Kern::CompactClassArray
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Kern::Subtable);
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+
+ die "incomplete";
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out_sub
+{
+ my ($self, $fh) = @_;
+
+ die "incomplete";
+
+ $self;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ die "incomplete";
+}
+
+
+sub type
+{
+ return 'kernCompactClassArray';
+}
+
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/OrderedList.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/OrderedList.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/OrderedList.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,108 @@
+package Font::TTF::Kern::OrderedList;
+
+=head1 NAME
+
+Font::TTF::Kern::OrderedList
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Kern::Subtable);
+
+sub new
+{
+ my ($class, @options) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+
+ my $dat;
+ $fh->read($dat, 8);
+ my ($nPairs, $searchRange, $entrySelector, $rangeShift) = unpack("nnnn", $dat);
+
+ my $pairs = [];
+ foreach (1 .. $nPairs) {
+ $fh->read($dat, 6);
+ my ($left, $right, $kern) = TTF_Unpack("SSs", $dat);
+ push @$pairs, { 'left' => $left, 'right' => $right, 'kern' => $kern } if $kern != 0;
+ }
+
+ $self->{'kernPairs'} = $pairs;
+
+ $self;
+}
+
+=head2 $t->out_sub($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out_sub
+{
+ my ($self, $fh) = @_;
+
+ my $pairs = $self->{'kernPairs'};
+ $fh->print(pack("nnnn", TTF_bininfo(scalar @$pairs, 6)));
+
+ foreach (sort { $a->{'left'} <=> $b->{'left'} or $a->{'right'} <=> $b->{'right'} } @$pairs) {
+ $fh->print(TTF_Pack("SSs", $_->{'left'}, $_->{'right'}, $_->{'kern'}));
+ }
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub dumpXML
+{
+ my ($self, $fh) = @_;
+
+ my $postVal = $self->post()->{'VAL'};
+
+ $fh = 'STDOUT' unless defined $fh;
+ foreach (@{$self->{'kernPairs'}}) {
+ $fh->printf("<pair l=\"%s\" r=\"%s\" v=\"%s\"/>\n", $postVal->[$_->{'left'}], $postVal->[$_->{'right'}], $_->{'kern'});
+ }
+}
+
+
+sub type
+{
+ return 'kernOrderedList';
+}
+
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/StateTable.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/StateTable.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/StateTable.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,142 @@
+package Font::TTF::Kern::StateTable;
+
+=head1 NAME
+
+Font::TTF::Kern::StateTable
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Kern::Subtable;
+
+ at ISA = qw(Font::TTF::Kern::Subtable);
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my $stTableStart = $fh->tell();
+
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 0);
+
+ foreach (@$entries) {
+ my $flags = $_->{'flags'};
+ delete $_->{'flags'};
+ $_->{'push'} = 1 if $flags & 0x8000;
+ $_->{'noAdvance'} = 1 if $flags & 0x4000;
+ $flags &= ~0xC000;
+ if ($flags != 0) {
+ my $kernList = [];
+ $fh->seek($stTableStart + $flags, IO::File::SEEK_SET);
+ while (1) {
+ $fh->read($dat, 2);
+ my $k = TTF_Unpack("s", $dat);
+ push @$kernList, ($k & ~1);
+ last if ($k & 1) != 0;
+ }
+ $_->{'kernList'} = $kernList;
+ }
+ }
+
+ $self->{'classes'} = $classes;
+ $self->{'states'} = $states;
+ $self->{'entries'} = $entries;
+
+ $fh->seek($stTableStart - 8 + $self->{'length'}, IO::File::SEEK_SET);
+
+ $self;
+}
+
+=head2 $t->out_sub($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out_sub
+{
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+}
+
+sub dumpXML
+{
+ my ($self, $fh) = @_;
+
+ $fh->printf("<classes>\n");
+ $self->dumpClasses($self->{'classes'}, $fh);
+ $fh->printf("</classes>\n");
+
+ $fh->printf("<states>\n");
+ my $states = $self->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("<state index=\"%s\">\n", $_);
+ my $members = $states->[$_];
+ foreach (0 .. $#$members) {
+ my $m = $members->[$_];
+ $fh->printf("<m index=\"%s\" nextState=\"%s\"", $_, $m->{'nextState'});
+ $fh->printf(" push=\"1\"") if $m->{'push'};
+ $fh->printf(" noAdvance=\"1\"") if $m->{'noAdvance'};
+ if (exists $m->{'kernList'}) {
+ $fh->printf(">");
+ foreach (@{$m->{'kernList'}}) {
+ $fh->printf("<kern v=\"%s\"/>", $_);
+ }
+ $fh->printf("</m>\n");
+ }
+ else {
+ $fh->printf("/>\n");
+ }
+ }
+ $fh->printf("</state>\n");
+ }
+ $fh->printf("</states>\n");
+}
+
+sub type
+{
+ return 'kernStateTable';
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/Subtable.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/Subtable.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern/Subtable.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,174 @@
+package Font::TTF::Kern::Subtable;
+
+=head1 NAME
+
+Font::TTF::Kern::Subtable
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+require Font::TTF::Kern::OrderedList;
+require Font::TTF::Kern::StateTable;
+require Font::TTF::Kern::ClassArray;
+require Font::TTF::Kern::CompactClassArray;
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+
+ bless $self, $class;
+}
+
+sub create
+{
+ my ($class, $type, $coverage, $length) = @_;
+
+ $class = ref($class) || $class;
+
+ my $subclass;
+ if ($type == 0) {
+ $subclass = 'Font::TTF::Kern::OrderedList';
+ }
+ elsif ($type == 1) {
+ $subclass = 'Font::TTF::Kern::StateTable';
+ }
+ elsif ($type == 2) {
+ $subclass = 'Font::TTF::Kern::ClassArray';
+ }
+ elsif ($type == 3) {
+ $subclass = 'Font::TTF::Kern::CompactClassArray';
+ }
+
+ my @options;
+ push @options,'vertical' if ($coverage & 0x8000) != 0;
+ push @options,'crossStream' if ($coverage & 0x4000) != 0;
+ push @options,'variation' if ($coverage & 0x2000) != 0;
+
+ my ($subTable) = $subclass->new(@options);
+
+ map { $subTable->{$_} = 1 } @options;
+
+ $subTable->{'type'} = $type;
+ $subTable->{'length'} = $length;
+
+ $subTable;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ my $subtableStart = $fh->tell();
+ my $type = $self->{'type'};
+ my $coverage = $type;
+ $coverage += 0x4000 if $self->{'direction'} eq 'RL';
+ $coverage += 0x2000 if $self->{'orientation'} eq 'VH';
+ $coverage += 0x8000 if $self->{'orientation'} eq 'V';
+
+ $fh->print(TTF_Pack("SSL", 0, $coverage, $self->{'subFeatureFlags'})); # placeholder for length
+
+ $self->out_sub($fh);
+
+ my $length = $fh->tell() - $subtableStart;
+ my $padBytes = (4 - ($length & 3)) & 3;
+ $fh->print(pack("C*", (0) x $padBytes));
+ $length += $padBytes;
+ $fh->seek($subtableStart, IO::File::SEEK_SET);
+ $fh->print(pack("n", $length));
+ $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub post
+{
+ my ($self) = @_;
+
+ my $post = $self->{' PARENT'}{' PARENT'}{'post'};
+ if (defined $post) {
+ $post->read;
+ }
+ else {
+ $post = {};
+ }
+
+ return $post;
+}
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+ $fh = 'STDOUT' unless defined $fh;
+}
+
+=head2 $t->print_classes($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print_classes
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ my $classes = $self->{'classes'};
+ foreach (0 .. $#$classes) {
+ my $class = $classes->[$_];
+ if (defined $class) {
+ $fh->printf("\t\tClass %d:\t%s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$class));
+ }
+ }
+}
+
+sub dumpClasses
+{
+ my ($self, $classes, $fh) = @_;
+ my $post = $self->post();
+
+ foreach (0 .. $#$classes) {
+ my $c = $classes->[$_];
+ if ($#$c > -1) {
+ $fh->printf("<class n=\"%s\">\n", $_);
+ foreach (@$c) {
+ $fh->printf("<g index=\"%s\" name=\"%s\"/>\n", $_, $post->{'VAL'}[$_]);
+ }
+ $fh->printf("</class>\n");
+ }
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Kern.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,293 @@
+package Font::TTF::Kern;
+
+=head1 NAME
+
+Font::TTF::Kern - Kerning tables
+
+=head1 DESCRIPTION
+
+Kerning tables are held as an ordered collection of subtables each giving
+incremental information regarding the kerning of various pairs of glyphs.
+
+The basic structure of the kerning data structure is:
+
+ $kern = $f->{'kern'}{'tables'}[$tnum]{'kerns'}{$leftnum}{$rightnum};
+
+Due to the possible complexity of some kerning tables the above information
+is insufficient. Reference also needs to be made to the type of the table and
+the coverage field.
+
+=head1 INSTANCE VARIABLES
+
+The instance variables for a kerning table are relatively straightforward.
+
+=over 4
+
+=item Version
+
+Version number of the kerning table
+
+=item Num
+
+Number of subtables in the kerning table
+
+=item tables
+
+Array of subtables in the kerning table
+
+=over 4
+
+Each subtable has a number of instance variables.
+
+=item kern
+
+A two level hash array containing kerning values. The indexing is left
+value and then right value. In the case of type 2 tables, the indexing
+is via left class and right class. It may seem using hashes is strange,
+but most tables are not type 2 and this method saves empty array values.
+
+=item type
+
+Stores the table type. Only type 0 and type 2 tables are specified for
+TrueType so far.
+
+=item coverage
+
+A bit field of coverage information regarding the kerning value. See the
+TrueType specification for details.
+
+=item Version
+
+Contains the version number of the table.
+
+=item Num
+
+Number of kerning pairs in this type 0 table.
+
+=item left
+
+An array indexed by glyph - left_first which returns a class number for
+the glyph in type 2 tables.
+
+=item right
+
+An array indexed by glyph - right_first which returns a class number for
+the glyph in type 2 tables.
+
+=item left_first
+
+the glyph number of the first element in the left array for type 2 tables.
+
+=item right_first
+
+the glyph number of the first element in the right array for type 2 tables.
+
+=item num_left
+
+Number of left classes
+
+=item num_right
+
+Number of right classes
+
+=back
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the whole kerning table into structures
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($dat, $i, $numt, $len, $cov, $t);
+
+ $self->SUPER::read or return $self;
+
+ $fh->read($dat, 4);
+ ($self->{'Version'}, $numt) = unpack("n2", $dat);
+ $self->{'Num'} = $numt;
+
+ for ($i = 0; $i < $numt; $i++)
+ {
+ $t = {};
+ $fh->read($dat, 6);
+ ($t->{'Version'}, $len, $cov) = unpack("n3", $dat);
+ $t->{'coverage'} = $cov & 255;
+ $t->{'type'} = $cov >> 8;
+ $fh->read($dat, $len - 6);
+ if ($t->{'Version'} == 0)
+ {
+ my ($j);
+
+ $t->{'Num'} = unpack("n", $dat);
+ for ($j = 0; $j < $t->{'Num'}; $j++)
+ {
+ my ($f, $l, $v) = TTF_Unpack("SSs", substr($dat, $j * 6 + 8, 6));
+ $t->{'kern'}{$f}{$l} = $v;
+ }
+ } elsif ($t->{'Version'} == 2)
+ {
+ my ($wid, $off, $numg, $maxl, $maxr, $j);
+
+ $wid = unpack("n", $dat);
+ $off = unpack("n", substr($dat, 2));
+ ($t->{'left_first'}, $numg) = unpack("n2", substr($dat, $off));
+ $t->{'left'} = [unpack("C$numg", substr($dat, $off + 4))];
+ foreach (@{$t->{'left'}})
+ {
+ $_ /= $wid;
+ $maxl = $_ if ($_ > $maxl);
+ }
+ $t->{'left_max'} = $maxl;
+
+ $off = unpack("n", substr($dat, 4));
+ ($t->{'right_first'}, $numg) = unpack("n2", substr($dat, $off));
+ $t->{'right'} = [unpack("C$numg", substr($dat, $off + 4))];
+ foreach (@{$t->{'right'}})
+ {
+ $_ >>= 1;
+ $maxr = $_ if ($_ > $maxr);
+ }
+ $t->{'right_max'} = $maxr;
+
+ $off = unpack("n", substr($dat, 6));
+ for ($j = 0; $j <= $maxl; $j++)
+ {
+ my ($k) = 0;
+
+ map { $t->{'kern'}{$j}{$k} = $_ if $_; $k++; }
+ unpack("n$maxr", substr($dat, $off + $wid * $j));
+ }
+ }
+ push (@{$self->{'tables'}}, $t);
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Outputs the kerning tables to the given file
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($i, $l, $r, $loc, $loc1, $t);
+
+ return $self->SUPER::out($fh) unless ($self->{' read'});
+
+ $fh->print(pack("n2", $self->{'Version'}, $self->{'Num'}));
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $t = $self->{'tables'}[$i];
+ $loc = $fh->tell();
+
+ $fh->print(pack("nnn", $t->{'Version'}, 0, $t->{'coverage'}));
+ if ($t->{'Version'} == 0)
+ {
+ my ($dat);
+ foreach $l (sort {$a <=> $b} keys %{$t->{'kern'}})
+ {
+ foreach $r (sort {$a <=> $b} keys %{$t->{'kern'}{$l}})
+ { $dat .= TTF_Pack("SSs", $l, $r, $t->{'kern'}{$l}{$r}); }
+ }
+ $fh->print(TTF_Pack("SSSS", Font::TTF::Utils::TTF_bininfo(length($dat) / 6, 6)));
+ $fh->print($dat);
+ } elsif ($t->{'Version'} == 2)
+ {
+ my ($arr);
+
+ $fh->print(pack("nnnn", $t->{'right_max'} << 1, 8, ($#{$t->{'left'}} + 7) << 1,
+ ($#{$t->{'left'}} + $#{$t->{'right'}} + 10) << 1));
+
+ $fh->print(pack("nn", $t->{'left_first'}, $#{$t->{'left'}} + 1));
+ foreach (@{$t->{'left'}})
+ { $fh->print(pack("C", $_ * (($t->{'left_max'} + 1) << 1))); }
+
+ $fh->print(pack("nn", $t->{'right_first'}, $#{$t->{'right'}} + 1));
+ foreach (@{$t->{'right'}})
+ { $fh->print(pack("C", $_ << 1)); }
+
+ $arr = "\000\000" x (($t->{'left_max'} + 1) * ($t->{'right_max'} + 1));
+ foreach $l (keys %{$t->{'kern'}})
+ {
+ foreach $r (keys %{$t->{'kern'}{$l}})
+ { substr($arr, ($l * ($t->{'left_max'} + 1) + $r) << 1, 2)
+ = pack("n", $t->{'kern'}{$l}{$r}); }
+ }
+ $fh->print($arr);
+ }
+ $loc1 = $fh->tell();
+ $fh->seek($loc + 2, 0);
+ $fh->print(pack("n", $loc1 - $loc));
+ $fh->seek($loc1, 0);
+ }
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $value)
+
+Handles outputting the kern hash into XML a little more tidily
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $value) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($f, $l);
+
+ return $self->SUPER::XML_element(@_) unless ($key eq 'kern');
+ $fh->print("$depth<kern-table>\n");
+ foreach $f (sort {$a <=> $b} keys %{$value})
+ {
+ foreach $l (sort {$a <=> $b} keys %{$value->{$f}})
+ { $fh->print("$depth$context->{'indent'}<adjust first='$f' last='$l' dist='$value->{$f}{$l}'/>\n"); }
+ }
+ $fh->print("$depth</kern-table>\n");
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+Only supports kerning table types 0 & 2.
+
+=item *
+
+No real support functions to I<do> anything with the kerning tables yet.
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/LTSH.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/LTSH.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/LTSH.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,88 @@
+package Font::TTF::LTSH;
+
+=head1 NAME
+
+Font::TTF::LTSH - Linear Threshold table
+
+=head1 DESCRIPTION
+
+Holds the linear threshold for each glyph. This is the ppem value at which a
+glyph's metrics become linear. The value is set to 1 if a glyph's metrics are
+always linear.
+
+=head1 INSTANCE VARIABLES
+
+=over 4
+
+=item glyphs
+
+An array of ppem values. One value per glyph
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($numg, $dat);
+
+ $self->SUPER::read or return $self;
+
+ $fh->read($dat, 4);
+ ($self->{'Version'}, $numg) = unpack("nn", $dat);
+ $self->{'Num'} = $numg;
+
+ $fh->read($dat, $numg);
+ $self->{'glyphs'} = [unpack("C$numg", $dat)];
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Outputs the LTSH to the given fh.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ return $self->SUPER::out($fh) unless ($self->{' read'});
+
+ $fh->print(pack("nn", 0, $numg));
+ $fh->print(pack("C$numg", @{$self->{'glyphs'}}));
+ $self;
+}
+
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Loca.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Loca.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Loca.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,183 @@
+package Font::TTF::Loca;
+
+=head1 NAME
+
+Font::TTF::Loca - the Locations table, which is intimately tied to the glyf table
+
+=head1 DESCRIPTION
+
+The location table holds the directory of locations of each glyph within the
+glyf table. Due to this relationship and the unimportance of the actual locations
+when it comes to holding glyphs in memory, reading the location table results
+in the creation of glyph objects for each glyph and stores them here.
+So if you are looking for glyphs, don't look in the C<glyf> table, look here
+instead.
+
+Things get complicated if you try to change the glyph list within the one table.
+The recommendation is to create another clean location object to replace this
+table in the font, ensuring that the old table is read first and to transfer
+or copy glyphs across from the read table to the new table.
+
+=head1 INSTANCE VARIABLES
+
+The instance variables do not start with a space
+
+=over 4
+
+=item glyphs
+
+An array of glyph objects for each glyph.
+
+=item glyphtype
+
+A string containing the class name to create for each new glyph. If empty,
+defaults to L<Font::TTF::Glyph>.
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+ at ISA = qw(Font::TTF::Table);
+
+require Font::TTF::Glyph;
+
+
+=head2 $t->new
+
+Creates a new location table making sure it has a glyphs array
+
+=cut
+
+sub new
+{
+ my ($class) = shift;
+ my ($res) = $class->SUPER::new(@_);
+ $res->{'glyphs'} = [];
+ $res;
+}
+
+=head2 $t->read
+
+Reads the location table creating glyph objects (L<Font::TTF::Glyph>) for each glyph
+allowing their later reading.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($locFmt) = $self->{' PARENT'}{'head'}->read->{'indexToLocFormat'};
+ my ($numGlyphs) = $self->{' PARENT'}{'maxp'}->read->{'numGlyphs'};
+ my ($glyfLoc) = $self->{' PARENT'}{'glyf'}{' OFFSET'};
+ my ($dat, $last, $i, $loc);
+
+ $self->SUPER::read or return $self;
+ $fh->read($dat, $locFmt ? 4 : 2);
+ $last = unpack($locFmt ? "N" : "n", $dat);
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $fh->read($dat, $locFmt ? 4 : 2);
+ $loc = unpack($locFmt ? "N" : "n", $dat);
+ $self->{'glyphs'}[$i] = ($self->{'glyphtype'} || "Font::TTF::Glyph")->new(
+ LOC => $last << ($locFmt ? 0 : 1),
+ OUTLOC => $last << ($locFmt ? 0 : 1),
+ PARENT => $self->{' PARENT'},
+ INFILE => $fh,
+ BASE => $glyfLoc,
+ OUTLEN => ($loc - $last) << ($locFmt ? 0 : 1),
+ LEN => ($loc - $last) << ($locFmt ? 0 : 1)) if ($loc != $last);
+ $last = $loc;
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the location table out to $fh. Notice that not having read the location
+table implies that the glyf table has not been read either, so the numbers in
+the location table are still valid. Let's hope that C<maxp/numGlyphs> and
+C<head/indexToLocFmt> haven't changed otherwise we are in big trouble.
+
+The function uses the OUTLOC location in the glyph calculated when the glyf
+table was attempted to be output.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($locFmt) = $self->{' PARENT'}{'head'}->read->{'indexToLocFormat'};
+ my ($numGlyphs) = $self->{' PARENT'}{'maxp'}->read->{'numGlyphs'};
+ my ($count, $i, $offset, $g);
+
+ return $self->SUPER::out($fh) unless ($self->{' read'});
+
+ $count = 0;
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $g = ($self->{'glyphs'}[$i]) || "";
+ unless ($g)
+ {
+ $count++;
+ next;
+ } else
+ {
+ if ($locFmt)
+ { $fh->print(pack("N", $g->{' OUTLOC'}) x ($count + 1)); }
+ else
+ { $fh->print(pack("n", $g->{' OUTLOC'} >> 1) x ($count + 1)); }
+ $count = 0;
+ $offset = $g->{' OUTLOC'} + $g->{' OUTLEN'};
+ }
+ }
+ $fh->print(pack($locFmt ? "N" : "n", ($locFmt ? $offset: $offset >> 1)) x ($count + 1));
+}
+
+
+=head2 $t->out_xml($context, $depth)
+
+No need to output a loca table, this is dynamically generated
+
+=cut
+
+sub out_xml
+{ return $_[0]; }
+
+
+=head2 $t->glyphs_do(&func)
+
+Calls func for each glyph in this location table in numerical order:
+
+ &func($glyph, $glyph_num)
+
+=cut
+
+sub glyphs_do
+{
+ my ($self, $func) = @_;
+ my ($i);
+
+ for ($i = 0; $i <= $#{$self->{'glyphs'}}; $i++)
+ { &$func($self->{'glyphs'}[$i], $i) if defined $self->{'glyphs'}[$i]; }
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Manual.pod
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Manual.pod 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Manual.pod 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,214 @@
+
+=head1 TITLE
+
+Manual.pod - Information regarding the whole module set
+
+=head1 INTRODUCTION
+
+This document looks at the whole issue of how the various modules in the
+TrueType Font work together. As such it is partly information on this font
+system and partly information on TrueType fonts in general.
+
+Due to the inter-relation between so many tables in a TrueType font, different
+tables will make expectations as to which other tables exist. At the very least
+a font should consist of a C<head> table and a C<maxp> table. The system has
+been designed around the expectation that the necessary tables for font
+rendering in the Windows environment exist. But inter table dependencies have
+been kept to what are considered necessary.
+
+This module set is not meant as a simple to use, mindless, font editing suite,
+but as a low-level, get your hands dirty, know what you are doing, set of
+classes for those who understand the intricacies (and there are many) of
+TrueType fonts. To this end, if you get something wrong in the data structures,
+etc. then this module set won't tell you and will happily create fonts which
+don't work.
+
+At the time of writing, not every TrueType table in existence has been
+implemented! Only the core basic tables of TrueType 1.0 (i.e. no embedded bitmap
+tables, no postscript type tables, no OpenType tables and no GX tables) have
+been implemented. If you want to help by implementing another table or two, then
+please go ahead and send me your code. For a full list of tables, see
+L<Font::TTF::Font>.
+
+
+=head2 Design Principles
+
+PERL is not C++. C++ encourages methods to be written for changing and reading
+each instance variable in a class. If we did this in this PERL program the
+results would be rather large and slow. Instead, since most access will be read
+access, we expose as much of the inner storage of an object to user access
+directly via hash lookup. The advantage this gives are great. For example, by
+following an instance variable chain, looking up the C<yMax> parameter for a
+particular glyph becomes:
+
+ $f->{'loca'}{'glyphs'}[$glyph]{'yMax'}
+
+Or, if we are feeling very lazy and don't mind waiting:
+
+ $f->{'loca'}{'glyphs'}[$f->{'cmap'}->ms_lookup(0x41)]{'yMax'}
+
+The disadvantage of this method is that it behoves module users to behave
+themselves. Thus it does not hold your hand and ensure that if you make a change
+to a table, that the table is marked as I<dirty>, or that other tables are
+updated accordingly.
+
+It is up to the application developer to understand the implications of the
+changes they make to a font, and to take the necessary action to ensure that the
+data they get out is what they want. Thus, you could go and change the C<yMax>
+value on a glyph and output a new font with this change, but it is up to you to
+ensure that the font's bounding box details in the C<head> table are correct,
+and even that your changing C<yMax> is well motivated.
+
+To help with using the system, each module (or table) will not only describe the
+methods it supports, which are relatively few, but also the instance variables
+it supports, which are many. Most of the variables directly reflect table
+attributes as specified in the OpenType specification, available from Microsoft
+(L<http::/www.microsoft.com/typography>), Adobe and Apple. A list of the names
+used is also given in each module, but not necessarily with any further
+description. After all, this code is not a TrueType manual as well!
+
+
+=head2 Conventions
+
+There are various conventions used in this system.
+
+Firstly we consider the documentation conventions regarding instance variables.
+Each instance variable is marked indicating whether it is a B<(P)>rivate
+variable which users of the module are not expected to read and certainly not
+write to or a B<(R)>ead only variable which users may well want to read but not
+write to.
+
+
+=head1 METHODS
+
+This section examines various methods and how the various modules work with
+these methods.
+
+
+=head2 read and read_dat
+
+Before the data structures for a table can be accessed, they need to be filled
+in from somewhere. The usual way to do this is to read an existing TrueType
+font. This may be achieved by:
+
+ $f = Font::TTF::Font->open($filename) || die "Unable to read $filename";
+
+This will open an existing font and read its directory header. Notice that at
+this point, none of the tables in the font have been read. (Actually, the
+C<head> and C<maxp> tables are read at this point too since they contain the
+commonly required parameters of):
+
+ $f->{'head'}{'unitsPerEm'}
+ $f->{'maxp'}{'numGlyphs'}
+
+In order to be able to access information from a table, it is first necessary to
+C<read> it. Consider trying to find the advance width of a space character
+(U+0020). The following code should do it:
+
+ $f = Font::TTF::Font->open($ARGV[0]);
+ $snum = $f->{'cmap'}->ms_lookup(0x0020);
+ $sadv = $f->{'hmtx'}{'advance'}[$snum];
+ print $sadv;
+
+This would result in the value zero being printed, which is far from correct.
+But why? The first line would correctly read the font directory. The second line
+would, incidently, correctly locate the space character in the Windows cmap
+(assuming a non symbol encoded font). The third line would not succeed in its
+task since the C<hmtx> table has not been filled in from the font file. To
+achieve what we want we would first need to cause it to be read:
+
+ $f->{'hmtx'}->read;
+ $sadv = $f->{'hmtx'}{'advance'}[$snum];
+
+Or for those who are too lazy to write multiple lines, C<read> returns the
+object it reads. Thus we could write:
+
+ $sadv = $f->{'hmtx'}->read->{'advance'}[$snum];
+
+Why, if we always have to read tables before accessing information from them,
+did we not have to do this for the C<cmap> table? The answer lies in the method
+call. It senses that the table hasn't been read and reads it for us. This will
+generally happen with all method calls, it is only when we do direct data access
+that we have to take the responsibility to read the table first.
+
+Reading a table does not necessarily result in all the data being placed into
+internal data structures. In the case of a simple table C<read> is sufficient.
+In fact, the normal case is that C<read_dat> reads the data from the file into
+an instance variable called C<' dat'> (including the space) and not into the
+data structures.
+
+This is true except for the C<glyph> class which represents a single glyph. Here
+the process is reversed. Reading a C<glyph> reads the data for the glyph into
+the C<' dat'> instance variable and sets various header attributes for the glyph
+(C<xMin>, C<numContours>, etc.). The data is converted out of the variable into
+data structures via the C<read_dat> method.
+
+The aim, therefore, is that C<read> should do the natural thing (read into data
+structures for those tables and elements for which it is helpful -- all except
+C<glyph> at present) and C<read_dat> should do the unnatural thing: read just
+the binary data for normal tables and convert binary data to data structures for
+C<glyph>s.
+
+In summary, therefore, use C<read> unless you want to hack around with the
+internals of glyphs in which case see L<Font::TTF::Glyph> for more details.
+
+
+=head2 update
+
+The aim of this method is to allow the various data elements in a C<read> font
+to update themselves. All tables know how to update themselves. All tables also
+contain information which cannot be I<updated> but is new knowledge in the font.
+As a result, certain tables do nothing when they are updated. We can, therefore,
+build an update hierarchy of tables, with the independent tables at the bottom
+and C<Font> at the top:
+
+ +--loca
+ |
+ glyf--+--maxp
+ |
+ +---+--head
+ |
+ hmtx------+--hhea
+
+ cmap-----OS/2
+
+ name--
+
+ post--
+
+There is an important universal dependency which it is up to the user to
+keep up to date. This is C<maxp/numOfGlyphs> which is used to iterate over all
+the glyphs. Note that the glyphs themselves are not held in the C<glyph> table
+but in the C<loca> table, so adding glyphs, etc. automatically involves keeping
+the C<loca> table up to date.
+
+=head2 Creating fonts
+
+Suppose we were creating a font from scratch. How much information do we need
+to supply and how much will C<update> do for us?
+
+The following information is required:
+
+ $f->{'loca'}{'glyphs'}
+ $f->{'head'}{'upem'}
+ $f->{'maxp'}{'numGlyphs'} (doesn't come from $f->{'loca'}{'glyphs'})
+ $f->{'hmtx'}{'advance'}
+ $f->{'post'}['format'}
+ $f->{'post'}{'VAL'}
+ $f->{'cmap'}
+ $f->{'name'}
+
+Pretty much everything else is calculated for you. Details of what is needed
+for a glyph may be found in L<Font::TTF::Glyph>. Once we have all the
+information we need (and there is lots more that you could add) then we simply
+
+ $f->dirty; # mark all tables dirty
+ $f->update; # update the font
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Maxp.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Maxp.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Maxp.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,177 @@
+package Font::TTF::Maxp;
+
+=head1 NAME
+
+Font::TTF::Maxp - Maximum Profile table in a font
+
+=head1 DESCRIPTION
+
+A collection of useful instance variables following the TTF standard. Probably
+the most used being C<numGlyphs>. Note that this particular value is
+foundational and should be kept up to date by the application, it is not updated
+by C<update>.
+
+Handles table versions 0.5, 1.0
+
+=head1 INSTANCE VARIABLES
+
+No others beyond those specified in the standard:
+
+ numGlyphs
+ maxPoints
+ maxContours
+ maxCompositePoints
+ maxCompositeContours
+ maxZones
+ maxTwilightPoints
+ maxStorage
+ maxFunctionDefs
+ maxInstructionDefs
+ maxStackElements
+ maxSizeOfInstructions
+ maxComponentElements
+ maxComponentDepth
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'numGlyphs' => 'S',
+ 'maxPoints' => 'S',
+ 'maxContours' => 'S',
+ 'maxCompositePoints' => 'S',
+ 'maxCompositeContours' => 'S',
+ 'maxZones' => 'S',
+ 'maxTwilightPoints' => 'S',
+ 'maxStorage' => 'S',
+ 'maxFunctionDefs' => 'S',
+ 'maxInstructionDefs' => 'S',
+ 'maxStackElements' => 'S',
+ 'maxSizeOfInstructions' => 'S',
+ 'maxComponentElements' => 'S',
+ 'maxComponentDepth' => 'S');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read or return $self;
+
+ init unless defined $fields{'numGlyphs'}; # any key would do
+ $self->{' INFILE'}->read($dat, 4);
+ $self->{'version'} = TTF_Unpack("f", $dat);
+
+ if ($self->{'version'} == 0.5)
+ {
+ $self->{' INFILE'}->read($dat, 2);
+ $self->{'numGlyphs'} = unpack("n", $dat);
+ } else
+ {
+ $self->{' INFILE'}->read($dat, 28);
+ TTF_Read_Fields($self, $dat, \%fields);
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+ $fh->print(TTF_Pack("f", $self->{'version'}));
+
+ if ($self->{'version'} == 0.5)
+ { $fh->print(pack("n", $self->{'numGlyphs'})); }
+ else
+ { $fh->print(TTF_Out_Fields($self, \%fields, 28)); }
+ $self;
+}
+
+
+=head2 $t->update
+
+Calculates all the maximum values for a font based on the glyphs in the font.
+Only those fields which require hinting code interpretation are ignored and
+left as they were read.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($i, $num, @n, @m, $j);
+ my (@name) = qw(maxPoints maxContours maxCompositePoints maxCompositeContours
+ maxSizeOfInstructions maxComponentElements maxComponentDepth);
+
+ return undef unless ($self->SUPER::update);
+ return undef if ($self->{'version'} == 0.5); # only got numGlyphs
+ return undef unless (defined $self->{' PARENT'}{'loca'});
+ $self->{' PARENT'}{'loca'}->update;
+ $num = $self->{'numGlyphs'};
+
+ for ($i = 0; $i < $num; $i++)
+ {
+ my ($g) = $self->{' PARENT'}{'loca'}{'glyphs'}[$i] || next;
+
+ @n = $g->maxInfo($self->{' PARENT'}{'loca'}{'glyphs'});
+
+ for ($j = 0; $j <= $#n; $j++)
+ { $m[$j] = $n[$j] if $n[$j] > $m[$j]; }
+ }
+
+ foreach ('prep', 'fpgm')
+ { $m[4] = length($self->{' PARENT'}{$_}{' dat'})
+ if (defined $self->{' PARENT'}{$_}
+ && length($self->{' PARENT'}{$_}{' dat'}) > $m[4]);
+ }
+
+ for ($j = 0; $j <= $#name; $j++)
+ { $self->{$name[$j]} = $m[$j]; }
+ $self;
+}
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Chain.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Chain.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Chain.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,195 @@
+package Font::TTF::Mort::Chain;
+
+=head1 NAME
+
+Font::TTF::Mort::Chain
+
+=cut
+
+use strict;
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Mort::Subtable;
+
+=head2 $t->new
+
+=cut
+
+sub new
+{
+ my ($class, %parms) = @_;
+ my ($self) = {};
+ my ($p);
+
+ $class = ref($class) || $class;
+ foreach $p (keys %parms)
+ { $self->{" $p"} = $parms{$p}; }
+ bless $self, $class;
+}
+
+=head2 $t->read($fh)
+
+Reads the chain into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my $chainStart = $fh->tell();
+ $fh->read($dat, 12);
+ my ($defaultFlags, $chainLength, $nFeatureEntries, $nSubtables) = TTF_Unpack("LLSS", $dat);
+
+ my $featureEntries = [];
+ foreach (1 .. $nFeatureEntries) {
+ $fh->read($dat, 12);
+ my ($featureType, $featureSetting, $enableFlags, $disableFlags) = TTF_Unpack("SSLL", $dat);
+ push @$featureEntries, {
+ 'type' => $featureType,
+ 'setting' => $featureSetting,
+ 'enable' => $enableFlags,
+ 'disable' => $disableFlags
+ };
+ }
+
+ my $subtables = [];
+ foreach (1 .. $nSubtables) {
+ my $subtableStart = $fh->tell();
+
+ $fh->read($dat, 8);
+ my ($length, $coverage, $subFeatureFlags) = TTF_Unpack("SSL", $dat);
+ my $type = $coverage & 0x0007;
+
+ my $subtable = Font::TTF::Mort::Subtable->create($type, $coverage, $subFeatureFlags, $length);
+ $subtable->read($fh);
+ $subtable->{' PARENT'} = $self;
+
+ push @$subtables, $subtable;
+ $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
+ }
+
+ $self->{'defaultFlags'} = $defaultFlags;
+ $self->{'featureEntries'} = $featureEntries;
+ $self->{'subtables'} = $subtables;
+
+ $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ my $chainStart = $fh->tell();
+ my ($featureEntries, $subtables) = ($_->{'featureEntries'}, $_->{'subtables'});
+ $fh->print(TTF_Pack("LLSS", $_->{'defaultFlags'}, 0, scalar @$featureEntries, scalar @$subtables)); # placeholder for length
+
+ foreach (@$featureEntries) {
+ $fh->print(TTF_Pack("SSLL", $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'}));
+ }
+
+ foreach (@$subtables) {
+ $_->out($fh);
+ }
+
+ my $chainLength = $fh->tell() - $chainStart;
+ $fh->seek($chainStart + 4, IO::File::SEEK_SET);
+ $fh->print(pack("N", $chainLength));
+ $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the chain
+
+=cut
+
+sub feat
+{
+ my ($self) = @_;
+
+ my $feat = $self->{' PARENT'}{' PARENT'}{'feat'};
+ if (defined $feat) {
+ $feat->read;
+ }
+ else {
+ $feat = {};
+ }
+
+ return $feat;
+}
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ $fh->printf("version %f\n", $self->{'version'});
+
+ my $defaultFlags = $self->{'defaultFlags'};
+ $fh->printf("chain: defaultFlags = %08x\n", $defaultFlags);
+
+ my $feat = $self->feat();
+ my $featureEntries = $self->{'featureEntries'};
+ foreach (@$featureEntries) {
+ $fh->printf("\tfeature %d, setting %d : enableFlags = %08x, disableFlags = %08x # '%s: %s'\n",
+ $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'},
+ $feat->settingName($_->{'type'}, $_->{'setting'}));
+ }
+
+ my $subtables = $self->{'subtables'};
+ foreach (@$subtables) {
+ my $type = $_->{'type'};
+ my $subFeatureFlags = $_->{'subFeatureFlags'};
+ $fh->printf("\n\t%s table, %s, %s, subFeatureFlags = %08x # %s (%s)\n",
+ subtable_type_($type), $_->{'direction'}, $_->{'orientation'}, $subFeatureFlags,
+ "Default " . ((($subFeatureFlags & $defaultFlags) != 0) ? "On" : "Off"),
+ join(", ",
+ map {
+ join(": ", $feat->settingName($_->{'type'}, $_->{'setting'}) )
+ } grep { ($_->{'enable'} & $subFeatureFlags) != 0 } @$featureEntries
+ ) );
+
+ $_->print($fh);
+ }
+}
+
+sub subtable_type_
+{
+ my ($val) = @_;
+ my ($res);
+
+ my @types = (
+ 'Rearrangement',
+ 'Contextual',
+ 'Ligature',
+ undef,
+ 'Non-contextual',
+ 'Insertion',
+ );
+ $res = $types[$val] or ('Undefined (' . $val . ')');
+
+ $res;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Contextual.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Contextual.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Contextual.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,156 @@
+package Font::TTF::Mort::Contextual;
+
+=head1 NAME
+
+Font::TTF::Mort::Contextual
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Mort::Subtable;
+
+ at ISA = qw(Font::TTF::AAT::Mort::Subtable);
+
+sub new
+{
+ my ($class, $direction, $orientation, $subFeatureFlags) = @_;
+ my ($self) = {
+ 'direction' => $direction,
+ 'orientation' => $orientation,
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
+
+ $fh->seek($stateTableStart, IO::File::SEEK_SET);
+ $fh->read($dat, 10);
+ my ($stateSize, $classTable, $stateArray, $entryTable, $mappingTables) = unpack("nnnnn", $dat);
+ my $limits = [$classTable, $stateArray, $entryTable, $mappingTables, $self->{'length'} - 8];
+
+ foreach (@$entries) {
+ my $actions = $_->{'actions'};
+ foreach (@$actions) {
+ $_ = $_ ? $_ - ($mappingTables / 2) : undef;
+ }
+ }
+
+ $self->{'classes'} = $classes;
+ $self->{'states'} = $states;
+ $self->{'mappings'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $mappingTables, $limits))];
+
+ $self;
+}
+
+=head2 $t->pack_sub()
+
+=cut
+
+sub pack_sub
+{
+ my ($self) = @_;
+
+ my ($dat) = pack("nnnnn", (0) x 5); # placeholders for stateSize, classTable, stateArray, entryTable, mappingTables
+
+ my $classTable = length($dat);
+ my $classes = $self->{'classes'};
+ $dat .= AAT_pack_classes($classes);
+
+ my $stateArray = length($dat);
+ my $states = $self->{'states'};
+ my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
+ sub {
+ my $actions = $_->{'actions'};
+ ( $_->{'flags'}, @$actions )
+ }
+ );
+ $dat .= $dat1;
+
+ my $entryTable = length($dat);
+ my $offset = ($entryTable + 8 * @$entries) / 2;
+ foreach (@$entries) {
+ my ($nextState, $flags, @parts) = split /,/;
+ $dat .= pack("nnnn", $nextState, $flags, map { $_ eq "" ? 0 : $_ + $offset } @parts);
+ }
+
+ my $mappingTables = length($dat);
+ my $mappings = $self->{'mappings'};
+ $dat .= pack("n*", @$mappings);
+
+ $dat1 = pack("nnnnn", $stateSize, $classTable, $stateArray, $entryTable, $mappingTables);
+ substr($dat, 0, length($dat1)) = $dat1;
+
+ return $dat;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $self->print_classes($fh);
+
+ $fh->print("\n");
+ my $states = $self->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ my $actions = $_->{'actions'};
+ $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $mappings = $self->{'mappings'};
+ foreach (0 .. $#$mappings) {
+ $fh->printf("\t\tMapping %d: %d [%s]\n", $_, $mappings->[$_], $post->{'VAL'}[$mappings->[$_]]);
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Insertion.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Insertion.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Insertion.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,178 @@
+package Font::TTF::Mort::Insertion;
+
+=head1 NAME
+
+Font::TTF::Mort::Insertion
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Mort::Subtable);
+
+sub new
+{
+ my ($class, $direction, $orientation, $subFeatureFlags) = @_;
+ my ($self) = {
+ 'direction' => $direction,
+ 'orientation' => $orientation,
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my $subtableStart = $fh->tell();
+
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
+
+ my %insertListHash;
+ my $insertLists;
+ foreach (@$entries) {
+ my $flags = $_->{'flags'};
+ my @insertCount = (($flags & 0x03e0) >> 5, ($flags & 0x001f));
+ my $actions = $_->{'actions'};
+ foreach (0 .. 1) {
+ if ($insertCount[$_] > 0) {
+ $fh->seek($stateTableStart + $actions->[$_], IO::File::SEEK_SET);
+ $fh->read($dat, $insertCount[$_] * 2);
+ if (not defined $insertListHash{$dat}) {
+ push @$insertLists, [unpack("n*", $dat)];
+ $insertListHash{$dat} = $#$insertLists;
+ }
+ $actions->[$_] = $insertListHash{$dat};
+ }
+ else {
+ $actions->[$_] = undef;
+ }
+ }
+ }
+
+ $self->{'classes'} = $classes;
+ $self->{'states'} = $states;
+ $self->{'insertLists'} = $insertLists;
+
+ $self;
+}
+
+=head2 $t->pack_sub()
+
+=cut
+
+sub pack_sub
+{
+ my ($self) = @_;
+
+ my ($dat) = pack("nnnn", (0) x 4);
+
+ my $classTable = length($dat);
+ my $classes = $self->{'classes'};
+ $dat .= AAT_pack_classes($classes);
+
+ my $stateArray = length($dat);
+ my $states = $self->{'states'};
+ my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
+ sub {
+ my $actions = $_->{'actions'};
+ ( $_->{'flags'}, @$actions )
+ }
+ );
+ $dat .= $dat1;
+
+ my $entryTable = length($dat);
+ my $offset = ($entryTable + 8 * @$entries);
+ my @insListOffsets;
+ my $insertLists = $self->{'insertLists'};
+ foreach (@$insertLists) {
+ push @insListOffsets, $offset;
+ $offset += 2 * scalar @$_;
+ }
+ foreach (@$entries) {
+ my ($nextState, $flags, @lists) = split /,/;
+ $flags &= ~0x03ff;
+ $flags |= (scalar @{$insertLists->[$lists[0]]}) << 5 if $lists[0] ne '';
+ $flags |= (scalar @{$insertLists->[$lists[1]]}) if $lists[1] ne '';
+ $dat .= pack("nnnn", $nextState, $flags,
+ map { $_ eq '' ? 0 : $insListOffsets[$_] } @lists);
+ }
+
+ foreach (@$insertLists) {
+ $dat .= pack("n*", @$_);
+ }
+
+ $dat1 = pack("nnnn", $stateSize, $classTable, $stateArray, $entryTable);
+ substr($dat, 0, length($dat1)) = $dat1;
+
+ return $dat;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $self->print_classes($fh);
+
+ $fh->print("\n");
+ my $states = $self->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ my $actions = $_->{'actions'};
+ $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $insertLists = $self->{'insertLists'};
+ foreach (0 .. $#$insertLists) {
+ my $insertList = $insertLists->[$_];
+ $fh->printf("\t\tList %d: %s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$insertList));
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Ligature.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Ligature.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Ligature.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,245 @@
+package Font::TTF::Mort::Ligature;
+
+=head1 NAME
+
+Font::TTF::Mort::Ligature
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Mort::Subtable);
+
+sub new
+{
+ my ($class, $direction, $orientation, $subFeatureFlags) = @_;
+ my ($self) = {
+ 'direction' => $direction,
+ 'orientation' => $orientation,
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 0);
+
+ $fh->seek($stateTableStart, IO::File::SEEK_SET);
+ $fh->read($dat, 14);
+ my ($stateSize, $classTable, $stateArray, $entryTable,
+ $ligActionTable, $componentTable, $ligatureTable) = unpack("nnnnnnn", $dat);
+ my $limits = [$classTable, $stateArray, $entryTable, $ligActionTable, $componentTable, $ligatureTable, $self->{'length'} - 8];
+
+ my %actions;
+ my $actionLists;
+ foreach (@$entries) {
+ my $offset = $_->{'flags'} & 0x3fff;
+ $_->{'flags'} &= ~0x3fff;
+ if ($offset != 0) {
+ if (not defined $actions{$offset}) {
+ $fh->seek($stateTableStart + $offset, IO::File::SEEK_SET);
+ my $actionList;
+ while (1) {
+ $fh->read($dat, 4);
+ my $action = unpack("N", $dat);
+ my ($last, $store, $component) = (($action & 0x80000000) != 0, ($action & 0xC0000000) != 0, ($action & 0x3fffffff));
+ $component -= 0x40000000 if $component > 0x1fffffff;
+ $component -= $componentTable / 2;
+ push @$actionList, { 'store' => $store, 'component' => $component };
+ last if $last;
+ }
+ push @$actionLists, $actionList;
+ $actions{$offset} = $#$actionLists;
+ }
+ $_->{'actions'} = $actions{$offset};
+ }
+ }
+
+ $self->{'componentTable'} = $componentTable;
+ my $components = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $componentTable, $limits))];
+ foreach (@$components) {
+ $_ = ($_ - $ligatureTable) . " +" if $_ >= $ligatureTable;
+ }
+ $self->{'components'} = $components;
+
+ $self->{'ligatureTable'} = $ligatureTable;
+ $self->{'ligatures'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $ligatureTable, $limits))];
+
+ $self->{'classes'} = $classes;
+ $self->{'states'} = $states;
+ $self->{'actionLists'} = $actionLists;
+
+ $self;
+}
+
+=head2 $t->pack_sub($fh)
+
+=cut
+
+sub pack_sub
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $dat .= pack("nnnnnnn", (0) x 7); # placeholders for stateSize, classTable, stateArray, entryTable, actionLists, components, ligatures
+
+ my $classTable = length($dat);
+ my $classes = $self->{'classes'};
+ $dat .= AAT_pack_classes($classes);
+
+ my $stateArray = length($dat);
+ my $states = $self->{'states'};
+
+ my ($dat1, $stateSize, $entries) = AAT_pack_states($classes, $stateArray, $states,
+ sub {
+ ( $_->{'flags'} & 0xc000, $_->{'actions'} )
+ }
+ );
+ $dat .= $dat1;
+
+ my $actionLists = $self->{'actionLists'};
+ my %actionListOffset;
+ my $actionListDataLength = 0;
+ my @actionListEntries;
+ foreach (0 .. $#$entries) {
+ my ($nextState, $flags, $offset) = split(/,/, $entries->[$_]);
+ if ($offset eq "") {
+ $offset = undef;
+ }
+ else {
+ if (defined $actionListOffset{$offset}) {
+ $offset = $actionListOffset{$offset};
+ }
+ else {
+ $actionListOffset{$offset} = $actionListDataLength;
+ my $list = $actionLists->[$offset];
+ $actionListDataLength += 4 * @$list;
+ push @actionListEntries, $list;
+ $offset = $actionListOffset{$offset};
+ }
+ }
+ $entries->[$_] = [ $nextState, $flags, $offset ];
+ }
+ my $entryTable = length($dat);
+ my $ligActionLists = ($entryTable + @$entries * 4 + 3) & ~3;
+ foreach (@$entries) {
+ $_->[2] += $ligActionLists if defined $_->[2];
+ $dat .= pack("nn", $_->[0], $_->[1] + $_->[2]);
+ }
+ $dat .= pack("C*", (0) x ($ligActionLists - $entryTable - @$entries * 4));
+
+ die "internal error" unless length($dat) == $ligActionLists;
+
+ my $componentTable = length($dat) + $actionListDataLength;
+ my $actionList;
+ foreach $actionList (@actionListEntries) {
+ foreach (0 .. $#$actionList) {
+ my $action = $actionList->[$_];
+ my $val = $action->{'component'} + $componentTable / 2;
+ $val += 0x40000000 if $val < 0;
+ $val &= 0x3fffffff;
+ $val |= 0x40000000 if $action->{'store'};
+ $val |= 0x80000000 if $_ == $#$actionList;
+ $dat .= pack("N", $val);
+ }
+ }
+
+ die "internal error" unless length($dat) == $componentTable;
+
+ my $components = $self->{'components'};
+ my $ligatureTable = $componentTable + @$components * 2;
+ $dat .= pack("n*", map { (index($_, '+') >= 0 ? $ligatureTable : 0) + $_ } @$components);
+
+ my $ligatures = $self->{'ligatures'};
+ $dat .= pack("n*", @$ligatures);
+
+ $dat1 = pack("nnnnnnn", $stateSize, $classTable, $stateArray, $entryTable, $ligActionLists, $componentTable, $ligatureTable);
+ substr($dat, 0, length($dat1)) = $dat1;
+
+ return $dat;
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $self->print_classes($fh);
+
+ $fh->print("\n");
+ my $states = $self->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, defined $_->{'actions'} ? $_->{'actions'} : "=");
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $actionLists = $self->{'actionLists'};
+ foreach (0 .. $#$actionLists) {
+ $fh->printf("\t\tList %d:\t", $_);
+ my $actionList = $actionLists->[$_];
+ $fh->printf("%s\n", join(", ", map { ($_->{'component'} . ($_->{'store'} ? "*" : "") ) } @$actionList));
+ }
+
+ my $ligatureTable = $self->{'ligatureTable'};
+
+ $fh->print("\n");
+ my $components = $self->{'components'};
+ foreach (0 .. $#$components) {
+ $fh->printf("\t\tComponent %d: %s\n", $_, $components->[$_]);
+ }
+
+ $fh->print("\n");
+ my $ligatures = $self->{'ligatures'};
+ foreach (0 .. $#$ligatures) {
+ $fh->printf("\t\tLigature %d: %d [%s]\n", $_, $ligatures->[$_], $post->{'VAL'}[$ligatures->[$_]]);
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Noncontextual.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Noncontextual.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Noncontextual.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,95 @@
+package Font::TTF::Mort::Noncontextual;
+
+=head1 NAME
+
+Font::TTF::Mort::Noncontextual
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Mort::Subtable);
+
+sub new
+{
+ my ($class, $direction, $orientation, $subFeatureFlags) = @_;
+ my ($self) = {
+ 'direction' => $direction,
+ 'orientation' => $orientation,
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+ my ($dat);
+
+ my ($format, $lookup) = AAT_read_lookup($fh, 2, $self->{'length'} - 8, undef);
+ $self->{'format'} = $format;
+ $self->{'lookup'} = $lookup;
+
+ $self;
+}
+
+=head2 $t->pack_sub($fh)
+
+=cut
+
+sub pack_sub
+{
+ my ($self) = @_;
+
+ return AAT_pack_lookup($self->{'format'}, $self->{'lookup'}, 2, undef);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ my $lookup = $self->{'lookup'};
+ $fh->printf("\t\tLookup format %d\n", $self->{'format'});
+ if (defined $lookup) {
+ foreach (sort { $a <=> $b } keys %$lookup) {
+ $fh->printf("\t\t\t%d [%s] -> %d [%s])\n", $_, $post->{'VAL'}[$_], $lookup->{$_}, $post->{'VAL'}[$lookup->{$_}]);
+ }
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Rearrangement.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Rearrangement.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Rearrangement.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,107 @@
+package Font::TTF::Mort::Rearrangement;
+
+=head1 NAME
+
+Font::TTF::Mort::Rearrangement
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Mort::Subtable);
+
+sub new
+{
+ my ($class, $direction, $orientation, $subFeatureFlags) = @_;
+ my ($self) = {
+ 'direction' => $direction,
+ 'orientation' => $orientation,
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ $class = ref($class) || $class;
+ bless $self, $class;
+}
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self, $fh) = @_;
+
+ my ($classes, $states) = AAT_read_state_table($fh, 0);
+ $self->{'classes'} = $classes;
+ $self->{'states'} = $states;
+
+ $self;
+}
+
+=head2 $t->pack_sub()
+
+=cut
+
+sub pack_sub
+{
+ my ($self) = @_;
+
+ return AAT_pack_state_table($self->{'classes'}, $self->{'states'}, 0);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my $post = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $self->print_classes($fh);
+
+ $fh->print("\n");
+ my $states = $self->{'states'};
+ my @verbs = ( "0", "Ax->xA", "xD->Dx", "AxD->DxA",
+ "ABx->xAB", "ABx->xBA", "xCD->CDx", "xCD->DCx",
+ "AxCD->CDxA", "AxCD->DCxA", "ABxD->DxAB", "ABxD->DxBA",
+ "ABxCD->CDxAB", "ABxCD->CDxBA", "ABxCD->DCxAB", "ABxCD->DCxBA");
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "<" if ($_->{'flags'} & 0x8000);
+ $flags .= ">" if ($_->{'flags'} & 0x2000);
+ $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, $verbs[($_->{'flags'} & 0x000f)]);
+ }
+ $fh->print("\n");
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Subtable.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Subtable.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort/Subtable.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,199 @@
+package Font::TTF::Mort::Subtable;
+
+=head1 NAME
+
+Font::TTF::Mort::Subtable
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+require Font::TTF::Mort::Rearrangement;
+require Font::TTF::Mort::Contextual;
+require Font::TTF::Mort::Ligature;
+require Font::TTF::Mort::Noncontextual;
+require Font::TTF::Mort::Insertion;
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = {};
+
+ $class = ref($class) || $class;
+
+ bless $self, $class;
+}
+
+sub create
+{
+ my ($class, $type, $coverage, $subFeatureFlags, $length) = @_;
+
+ $class = ref($class) || $class;
+
+ my $subclass;
+ if ($type == 0) {
+ $subclass = 'Font::TTF::Mort::Rearrangement';
+ }
+ elsif ($type == 1) {
+ $subclass = 'Font::TTF::Mort::Contextual';
+ }
+ elsif ($type == 2) {
+ $subclass = 'Font::TTF::Mort::Ligature';
+ }
+ elsif ($type == 4) {
+ $subclass = 'Font::TTF::Mort::Noncontextual';
+ }
+ elsif ($type == 5) {
+ $subclass = 'Font::TTF::Mort::Insertion';
+ }
+
+ my ($self) = $subclass->new(
+ (($coverage & 0x4000) ? 'RL' : 'LR'),
+ (($coverage & 0x2000) ? 'VH' : ($coverage & 0x8000) ? 'V' : 'H'),
+ $subFeatureFlags
+ );
+
+ $self->{'type'} = $type;
+ $self->{'length'} = $length;
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ my ($subtableStart) = $fh->tell();
+ my ($type) = $self->{'type'};
+ my ($coverage) = $type;
+ $coverage += 0x4000 if $self->{'direction'} eq 'RL';
+ $coverage += 0x2000 if $self->{'orientation'} eq 'VH';
+ $coverage += 0x8000 if $self->{'orientation'} eq 'V';
+
+ $fh->print(TTF_Pack("SSL", 0, $coverage, $self->{'subFeatureFlags'})); # placeholder for length
+
+ my ($dat) = $self->pack_sub();
+ $fh->print($dat);
+
+ my ($length) = $fh->tell() - $subtableStart;
+ my ($padBytes) = (4 - ($length & 3)) & 3;
+ $fh->print(pack("C*", (0) x $padBytes));
+ $length += $padBytes;
+ $fh->seek($subtableStart, IO::File::SEEK_SET);
+ $fh->print(pack("n", $length));
+ $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub post
+{
+ my ($self) = @_;
+
+ my ($post) = $self->{' PARENT'}{' PARENT'}{' PARENT'}{'post'};
+ if (defined $post) {
+ $post->read;
+ }
+ else {
+ $post = {};
+ }
+
+ return $post;
+}
+
+sub feat
+{
+ my ($self) = @_;
+
+ return $self->{' PARENT'}->feat();
+}
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ my ($feat) = $self->feat();
+ my ($post) = $self->post();
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ my ($type) = $self->{'type'};
+ my ($subFeatureFlags) = $self->{'subFeatureFlags'};
+ my ($defaultFlags) = $self->{' PARENT'}{'defaultFlags'};
+ my ($featureEntries) = $self->{' PARENT'}{'featureEntries'};
+ $fh->printf("\n\t%s table, %s, %s, subFeatureFlags = %08x # %s (%s)\n",
+ subtable_type_($type), $_->{'direction'}, $_->{'orientation'}, $subFeatureFlags,
+ "Default " . ((($subFeatureFlags & $defaultFlags) != 0) ? "On" : "Off"),
+ join(", ",
+ map {
+ join(": ", $feat->settingName($_->{'type'}, $_->{'setting'}) )
+ } grep { ($_->{'enable'} & $subFeatureFlags) != 0 } @$featureEntries
+ ) );
+}
+
+sub subtable_type_
+{
+ my ($val) = @_;
+ my ($res);
+
+ my (@types) = (
+ 'Rearrangement',
+ 'Contextual',
+ 'Ligature',
+ undef,
+ 'Non-contextual',
+ 'Insertion',
+ );
+ $res = $types[$val] or ('Undefined (' . $val . ')');
+
+ $res;
+}
+
+=head2 $t->print_classes($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print_classes
+{
+ my ($self, $fh) = @_;
+
+ my ($post) = $self->post();
+
+ my ($classes) = $self->{'classes'};
+ foreach (0 .. $#$classes) {
+ my $class = $classes->[$_];
+ if (defined $class) {
+ $fh->printf("\t\tClass %d:\t%s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$class));
+ }
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Mort.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,108 @@
+package Font::TTF::Mort;
+
+=head1 NAME
+
+Font::TTF::Mort - Glyph Metamorphosis table in a font
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Mort::Chain;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $fh, $numChains);
+
+ $self->SUPER::read or return $self;
+
+ $fh = $self->{' INFILE'};
+
+ $fh->read($dat, 8);
+ ($self->{'version'}, $numChains) = TTF_Unpack("fL", $dat);
+
+ my $chains = [];
+ foreach (1 .. $numChains) {
+ my $chain = new Font::TTF::Mort::Chain->new;
+ $chain->read($fh);
+ $chain->{' PARENT'} = $self;
+ push @$chains, $chain;
+ }
+
+ $self->{'chains'} = $chains;
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ my $chains = $self->{'chains'};
+ $fh->print(TTF_Pack("fL", $self->{'version'}, scalar @$chains));
+
+ foreach (@$chains) {
+ $_->out($fh);
+ }
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ $self->read unless $self->{' read'};
+ my $feat = $self->{' PARENT'}->{'feat'};
+ $feat->read;
+ my $post = $self->{' PARENT'}->{'post'};
+ $post->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $fh->printf("version %f\n", $self->{'version'});
+
+ my $chains = $self->{'chains'};
+ foreach (@$chains) {
+ $_->print($fh);
+ }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Name.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Name.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Name.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,472 @@
+package Font::TTF::Name;
+
+=head1 NAME
+
+Font::TTF::Name - String table for a TTF font
+
+=head1 DESCRIPTION
+
+Strings are held by number, platform, encoding and language. Strings are
+accessed as:
+
+ $f->{'name'}{'strings'}[$number][$platform_id][$encoding_id]{$language_id}
+
+Notice that the language is held in an associative array due to its sparse
+nature on some platforms such as Microsoft ($pid = 3). Notice also that the
+array order is different from the stored array order (platform, encoding,
+language, number) to allow for easy manipulation of strings by number (which is
+what I guess most people will want to do).
+
+By default, C<$Font::TTF::Name::utf8> is set to 1, and strings will be stored as UTF8 wherever
+possible. The method C<is_utf8> can be used to find out if a string in a particular
+platform and encoding will be returned as UTF8. Unicode strings are always
+converted if utf8 is requested. Otherwise, strings are stored according to platform:
+
+ ***WARNING NON-UTF8 is deprecated and utf8 strings has become the default***
+
+You now have to set <$Font::TTF::Name::utf8> to 0 to get the old behaviour.
+
+=over 4
+
+=item Apple Unicode (platform id = 0)
+
+Data is stored as network ordered UCS2. There is no encoding id for this platform
+but there are language ids as per Mac language ids.
+
+=item Mac (platform id = 1)
+
+Data is stored as 8-bit binary data, leaving the interpretation to the user
+according to encoding id.
+
+=item Unicode (platform id = 2)
+
+Currently stored as 16-bit network ordered UCS2. Upon release of Perl 5.005 this
+will change to utf8 assuming current UCS2 semantics for all encoding ids.
+
+=item Windows (platform id = 3)
+
+As per Unicode, the data is currently stored as 16-bit network ordered UCS2. Upon
+release of Perl 5.005 this will change to utf8 assuming current UCS2 semantics for
+all encoding ids.
+
+=back
+
+=head1 INSTANCE VARIABLES
+
+=over 4
+
+=item strings
+
+An array of arrays, etc.
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA $VERSION @apple_encs @apple_encodings $utf8 $cp_1252 @cp_1252);
+use Font::TTF::Table;
+use Font::TTF::Utils;
+ at ISA = qw(Font::TTF::Table);
+
+$utf8 = 1;
+
+{
+ my ($count, $i);
+ eval {require Compress::Zlib;};
+ unless ($@)
+ {
+ for ($i = 0; $i <= $#apple_encs; $i++)
+ {
+ $apple_encodings[0][$i] = [unpack("n*", Compress::Zlib::uncompress(unpack("u", $apple_encs[$i])))]
+ if (defined $apple_encs[$i]);
+ $count = 0;
+ $apple_encodings[1][$i] = {map({$_ => $count++} @{$apple_encodings[0][$i]})};
+ }
+ $cp_1252[0] = [unpack("n*", Compress::Zlib::uncompress(unpack("u", $cp_1252)))];
+ $count = 0;
+ $cp_1252[1] = {map({$_ => $count++} @{$cp_1252[0]})};
+ }
+}
+
+
+$VERSION = 1.1; # MJPH 17-JUN-2000 Add utf8 support
+# $VERSION = 1.001; # MJPH 10-AUG-1998 Put $number first in list
+
+=head2 $t->read
+
+Reads all the names into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($dat, $num, $stroff, $i, $pid, $eid, $lid, $nid, $len, $off, $here);
+
+ $self->SUPER::read or return $self;
+ $fh->read($dat, 6);
+ ($num, $stroff) = unpack("x2nn", $dat);
+ for ($i = 0; $i < $num; $i++)
+ {
+ $fh->read($dat, 12);
+ ($pid, $eid, $lid, $nid, $len, $off) = unpack("n6", $dat);
+ $here = $fh->tell();
+ $fh->seek($self->{' OFFSET'} + $stroff + $off, 0);
+ $fh->read($dat, $len);
+ if ($utf8)
+ {
+ if ($pid == 1 && defined $apple_encodings[0][$eid])
+ { $dat = TTF_word_utf8(pack("n*", map({$apple_encodings[0][$eid][$_]} unpack("C*", $dat)))); }
+ elsif ($pid == 2 && $eid == 2 && defined @cp_1252)
+ { $dat = TTF_word_utf8(pack("n*", map({$cp_1252[0][$_]} unpack("C*", $dat)))); }
+ elsif ($pid == 0 || $pid == 3 || ($pid == 2 && $eid == 1))
+ { $dat = TTF_word_utf8($dat); }
+ }
+ $self->{'strings'}[$nid][$pid][$eid]{$lid} = $dat;
+ $fh->seek($here, 0);
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes out all the strings
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($pid, $eid, $lid, $nid, $todo, @todo);
+ my ($len, $offset, $loc, $stroff, $endloc, $str_trans);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $loc = $fh->tell();
+ $fh->print(pack("n3", 0, 0, 0));
+ foreach $nid (0 .. $#{$self->{'strings'}})
+ {
+ foreach $pid (0 .. $#{$self->{'strings'}[$nid]})
+ {
+ foreach $eid (0 .. $#{$self->{'strings'}[$nid][$pid]})
+ {
+ foreach $lid (sort keys %{$self->{'strings'}[$nid][$pid][$eid]})
+ {
+ $str_trans = $self->{'strings'}[$nid][$pid][$eid]{$lid};
+ if ($utf8)
+ {
+ if ($pid == 1 && defined $apple_encodings[1][$eid])
+ { $str_trans = pack("C*",
+ map({$apple_encodings[1][$eid]{$_} || "?"} unpack("n*",
+ TTF_utf8_word($str_trans)))); }
+ elsif ($pid == 2 && $eid == 2 && defined @cp_1252)
+ { $str_trans = pack("C*",
+ map({$cp_1252[1][$eid]{$_} || "?"} unpack("n*",
+ TTF_utf8_word($str_trans)))); }
+ elsif ($pid == 2 && $eid == 0)
+ { $str_trans =~ s/[\xc0-\xff][\x80-\xbf]+/?/og; }
+ elsif ($pid == 0 || $pid == 3 || ($pid == 2 && $eid == 1))
+ { $str_trans = TTF_utf8_word($str_trans); }
+ }
+ push (@todo, [$pid, $eid, $lid, $nid, $str_trans]);
+ }
+ }
+ }
+ }
+
+ $offset = 0;
+ @todo = (sort {$a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] || $a->[2] <=> $a->[2]
+ || $a->[3] <=> $b->[3]} @todo);
+ foreach $todo (@todo)
+ {
+ $len = length($todo->[4]);
+ $fh->print(pack("n6", @{$todo}[0..3], $len, $offset));
+ $offset += $len;
+ }
+
+ $stroff = $fh->tell() - $loc;
+ foreach $todo (@todo)
+ { $fh->print($todo->[4]); }
+
+ $endloc = $fh->tell();
+ $fh->seek($loc, 0);
+ $fh->print(pack("n3", 0, $#todo + 1, $stroff));
+ $fh->seek($endloc, 0);
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $value)
+
+Outputs the string element in nice XML (which is all the table really!)
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $value) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($nid, $pid, $eid, $lid);
+
+ return $self->SUPER::XML_element(@_) unless ($key eq 'strings');
+
+ foreach $nid (0 .. $#{$self->{'strings'}})
+ {
+ next unless ref($self->{'strings'}[$nid]);
+# $fh->print("$depth<strings id='$nid'>\n");
+ foreach $pid (0 .. $#{$self->{'strings'}[$nid]})
+ {
+ foreach $eid (0 .. $#{$self->{'strings'}[$nid][$pid]})
+ {
+ foreach $lid (sort {$a <=> $b} keys %{$self->{'strings'}[$nid][$pid][$eid]})
+ {
+ $fh->printf("%s<string id='%s' platform='%s' encoding='%s' language='%s'>\n%s%s%s\n%s</string>\n",
+ $depth, $nid, $pid, $eid, $lid, $depth,
+ $context->{'indent'}, $self->{'strings'}[$nid][$pid][$eid]{$lid}, $depth);
+ }
+ }
+ }
+# $fh->print("$depth</strings>\n");
+ }
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Store strings in the right place
+
+=cut
+
+sub XML_end
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag eq 'string')
+ {
+ $self->{'strings'}[$attrs{'id'}][$attrs{'platform'}][$attrs{'encoding'}]{$attrs{'language'}}
+ = $context->{'text'};
+ return $context;
+ }
+ else
+ { return $self->SUPER::XML_end(@_); }
+}
+
+=head2 is_utf8($pid, $eid)
+
+Returns whether a string of a given platform and encoding is going to be in UTF8
+
+=cut
+
+sub is_utf8
+{
+ my ($self, $pid, $eid) = @_;
+
+ return ($utf8 && ($pid == 0 || $pid == 3 || ($pid == 2 && ($eid != 2 || defined @cp_1252))
+ || ($pid == 1 && defined $apple_encodings[$eid])));
+}
+
+
+=head2 find_name($nid)
+
+Hunts down a name in all the standard places and returns the string and for an
+array context the pid, eid & lid as well
+
+=cut
+
+sub find_name
+{
+ my ($self, $nid) = @_;
+ my ($res, $pid, $eid, $lid, $look, $k);
+
+ my (@lookup) = ([3, 1, 1033], [3, 1, -1], [3, 0, 1033], [3, 0, -1], [2, 1, -1], [2, 2, -1], [2, 0, -1],
+ [0, 0, 0], [1, 0, 0]);
+ foreach $look (@lookup)
+ {
+ ($pid, $eid, $lid) = @$look;
+ if ($lid == -1)
+ {
+ foreach $k (keys %{$self->{'strings'}[$nid][$pid][$eid]})
+ {
+ if (($res = $self->{strings}[$nid][$pid][$eid]{$k}) ne '')
+ {
+ $lid = $k;
+ last;
+ }
+ }
+ } else
+ { $res = $self->{strings}[$nid][$pid][$eid]{$lid} }
+ if ($res ne '')
+ { return wantarray ? ($res, $pid, $eid, $lid) : $res; }
+ }
+ return '';
+}
+
+
+BEGIN {
+ at apple_encs = (
+<<'EOT',
+M>)RES==NCW$`@.'G_S5Q*L(!#?+K1VO4:.W6IJA-:\^BM?>L>1&NP(A0Q$BL
+M<*!62ZV8Z1)[K]BE$MR#O,=/7OW]7T&*6"NMI4K31EOMM)>N at XXZZ2Q#IBZZ
+MZJ:['GKJ)4NVWOKHJ]\_/\!`@PR68XBAALDUW`@CC3+:&&.-,UZ>?!-,-,ED
+M4TPUS70SS#3+;`7FF&N>0D7F6V"A119;8JEEEEMAI5566V.M==;;H-A&FVRV
+MQ5;;_OTONJ3<%;?<5^NQ1YYXYJGG7GKME3?>>N^=#S[ZY(O/OOKNFU]^JO<[
+M!$?LLMO>$#OAH4-*4F+'[(L+E*F,6SH:%\9%]C@>1W&CN&%2:9QNO]-))5ZH
+M<]9.!^/DQ/8X-V[@@#,AS0ZE+KB7R$ODA\:A26@>6H2FH9D?J17^)(I#3C at 8
+MLD)V?:(^"BE.AN30,F0XK\(Y5UUVW0TW77/'W;H_;JM6HRJ1&95%M0Y'E5%5
+.5.U4]""JB<K_`B>`?E$`
+EOT
+
+undef,
+undef,
+undef,
+<<'EOT',
+M>)RES[=/%```1O$WO8G_@$'J';W70Z2WHS>5WJN%8D6%D;BZ,3*P,;#C2D(8
+M,9&)08V)+4*(1((X2'(#[.:;7[[\*./_%D,L<<230"(!@B213`JII)%.!IED
+MD4T.N>213P&%%%%,B!)N4LJMR[Z<"BJIHIH::JFCG@;"--)$,RVTTD8['732
+M13>WN<-=>NBECWX&&&2(848898QQ)IADBFEFF.4>]WG`0^:89X%%'O&8)SSE
+M&<]9X at 4O><4R*Y?_.ZRSRQ[[''#(1S[PB<]NL\D7OO&5[_S at 9TR`(XXYX1=O
+M.>4W9_SAG`O^7OF=O>XW*N)WV!%''7/<"2>=<MH90D9'_-X(AHTUSG at 33#1@
+MT"2333'5--/-,-,LL\TQUSSS+;#0(HL-7?DMM\)*JZRVQEKKK+?!L(TVV6R+
+9K;;9;H<K+KGJ>S?<\K5O(G[7?/</+>Y>'```
+EOT
+
+<<'EOT',
+M>)RED$LSEW$`A9_-^00L,H-^(=>4Y%^2J'1Q*Y+[I2(BHA`B?!%J6EM1*28S
+M;9II[/PI*7*_%TUN\_*VZ%W:FN9LSYEGGD,\_Q?#$?SP)X"C!!)$,"&$$L8Q
+MPCG."2(X222GB,+%:<X0S5EB.$<LYXES]A>XR"42N,P5KG*-1))()H54KG.#
+M--*Y20:WR"2+;'+()8]\"BBDB-O<X2[%E'"/4LJX3SD5/*"2*AY230V/>$PM
+M==3SA`8::>(IS;3PC%;::'?X'^W#?&(0-Z-,,,,TL\PSQP)+K+#,*C]9XQ?K
+M_.8/FVRPQ0[;[+&+S=_]_J;KX/Y6I?&U.JQ.Z[GU0 at -VBNTR@;Q4G]ZI5V_U
+MQG at 83^-M?,PAXV6'VF'ZH&Z]4H_>J]]IO=:0W!K6B#[KBT;U56/ZIN\:UX1^
+?:%)3FM:,9C6G>2UH44M:UHI6'?<BYX,"6O\!%-%\5```
+EOT
+
+<<'EOT',
+M>)RES5=OSG$`0.$CYR.(A(3DUS]J4WOO59O6;&F+UMY[7R&(V'N^4ETZ=*"J
+M:M:H=>E*0D1B)7HC1KC0[R#G^LEA,/]7((Z(EK2B-?&TH2WM:$\'.M*)SG0A
+M@:YTHSL]Z$DO>M.'OO2C/P,8R*`&/X2A#&,X(QC)*$:3R!C&,H[Q3&`BDYC,
+M%))(9BK3F,X,9C*+%%*9S1S22">#N<QC/IEDL8"%+&(Q2UC*,I:S at I6L8C5K
+M6,LZUK.!C6QB,UO8RC:VLZ/A7TL5Y=11P6O>N(MWO.>#.\GG(Y_YQ!>^DAT7
+M\8WZ$%$3$OC.#W(IYC=_^!N"1SWF*<]ZP1AO*:'`;*^0%V502J6'*8LRHRQR
+M/.)Q3WC2TY[QG+D6FF^!19ZGR(M>BA*]3"'5(9Z8.>:YVSV-DD/CT"0T#RU"
+MT]",G^YUG_L]8+$E7O6%!WUIF>4^]9K7?6R%E59YQUM6>]L:[WK/5][WH;7>
+4M,X'/O&1-WSF<P]9^BOV#YW%>_\`
+EOT
+
+<<'EOT',
+M>)RERT=.%5``0-&+7K'&!B(@X/L/^/3>ZZ?SZ=*K@`KVWOL:U!68.#!&8G2@
+M$Q?F5/=@SOB0XO\$$D2**:&4)&644T$E55130RUUU--`(TTTTT(K;;3302==
+M=--#[[_?1S\###+$,".,DF:,<2:89(II9KC`+'/,L\`B2RRSPBIKK+/!13;9
+M8IM+7.8*.^QRE6M<YP8WN<5M[G"7>]SG`0]YQ&.>\)1G/.<%+WG%:][PEI0G
+M/>5IL\SVC#F>-=<\\SUG at 846>=Y at PFBQ)9::M,QR*ZRTRFIKK+4N!+[[CD]\
+M#I%?9O*-+XGH/N?BMON=CT7\B#MQUR5^^MY#ZH('7?:PJQYQS14/L!?S,S[$
+M=,SD*[]#DH\>==UC;K at 8LD)V*`B%(3?D\2<4>=Q-3[B5R#'#66>LM\%&FVRV
+GQ5;;;+?#3KOLML=>4_;9[X"##CGLB*.F'7/<"2>=<CKL_06V`DD#
+EOT
+
+undef,
+<<'EOT',
+M>)RED-DVUG$`1;=:U*Y%0C)5O^^/SSS/F>>9#"$JE7D>"D6\3S=>Q^MPU^JF
+M&^M<G[7//G1ROP1B1.130"%QBBBFA%+***>"2JJHIH9:ZJBG at 4:::*:%M[32
+M1CL==_TNNNFAES[Z&6"0(889890QQIE at DG=,,<T,L[QGCGD6^,`B2WSD$Y]9
+MY at M?^<8*JZRQS@:;;+'-#KOLL<\!AQQQS'=^<,(I9_SD%^=<\)M+KN[X-U%:
+M2`\9(2MDAWB(^,-U+/KKYYJ'_W_`!!_XT$23?.1C]8E/3?&9J2:;9KH9/O>%
+MF;XTRVQSS#7/5[[VC<&8D?D66&C<(HLML=0RRZVPTBJ7K;;&6NNLM\%&FVRV
+L):388:===MMCKP,..F2_(XXZYK#CMKGZS[YU-]QTRVUWW'7/?0]N`4(?0WT`
+EOT
+
+<<'EOT',
+M>)RED,5.0U$415=(D.X!$"ANMX^VN+M#D>+N[H4"Q5W^APF_PZ\PY.9-"`-&
+MY.3LG>-"#_\3 at P^'8OP$"%)"*6644T$E55130RUUU--`(TTTTT(K;;3302==
+M=-OZ7OH(T<\`@PP19I at 11AECG`DFF6*:&6:98YX%%EEBF15666.=#3;98IL=
+M=MECGP,.B7#$,5%...6,&.=<<,D5U]QPRQWW//#($\^\\,J;G?_II)ETXS79
+M)L<$C<,['S[GYSY=?FWK6E>Z^?L'BK,:KP0E*DD>R?6E*-7E='DM9BA36<I6
+MCG*5IWP5J%!%,O+)4;'\"BBH$I7:S')5J%)5JE:-M6JMUKM]FM1LL55M)EG=
+GZE&O^A1R(V$-NSRF<8L3ZO3L_]KN4!$=Z5A1G>A49XKI_!M<9D8J
+EOT
+
+<<'EOT',
+M>)RED,E3SW$8QU_77@<''+A]^Y5(2-F7+"%92\B^ES5ES]H,)L(8&21E*UNH
+M&"8T8ZS3I(FS_T"$_`L^-^/D8)YY/^]Y/\L\"Y/Y/XN()T8"B0P at B8$,(IG!
+MI#"$H0PCE>&DD<X(1C**T8QA+.,8SP0FDL&DT#^%J60RC>G,((N99#.+V<QA
+M+O.83PZY+""/A2QB,?DL82G+6,X*5K**U:QA+>M8SP8**&0CF]C,%K:RC2*V
+M4TP).]C)+G:SA[WLHY3]'.`@ASC,$<K"_,^QWE&?J&_4+^H?)44Q[M,<'_MS
+M7USAOS[@48]YW')/>-(*3WG:,R%ZSDK/!K[@1<][R2HO6^T5:ZSUJM>\[@UO
+M6F>]M[SM'>]ZSX90_\"'-MIDLX^">ASPQ*?!M_C,Y[ZP->KE*U_[QK>^\WW(
+CM/O!ML"=?K3#3[Z,*_AKOR]V^=5O=OO='_ZTQU^_`2-%:*``
+EOT
+
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+<<'EOT',
+M>)REC]=.E&$`1(\%&W at 4004%_7:!I?>.Z-+[TJL*=K"`BH`*J,_"+2'A!7PW
+MX;\2[LG<3#*9G!F2G$V!&'$***2(!,644$H9Y5102175U%!+'?4TT$@3S;30
+M2AN/:.<Q3Z)^!YUTT4T/O?31SP"###',""E&&6.<"2:98IH99IECG at 6>\HSG
+M+++$"U[RBM>\X2WO6&:%]WS@(Y]898W/?.$KZWQC at TVV^,X/?K+-#KO\XC=_
+M(OX!?T/"`0<=<MB1$Q?R0KXIDB%NK?TVV&B3S:?RG)`;]?<\YWDO>-$T+WG9
+M*U[UFNEF>%V]X4TSO666V=[VCG?-,==[WC?/?!_XT&#,N`466F3"8DLLM<QR
+M*ZRTRFIK(GJ=]?_Y+;;:]N\HI(>LD&W2#COMLML>>^V+=IX\2<7BCCGNA)-.
+0.>V,L\XY[P*'[!\#D^='L@``
+EOT
+
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+undef,
+);
+
+$cp_1252 = (
+<<'EOT',
+M>)P-SD-B'5```,#YJ6VE>DEM&[\VD]JVF?H./4'-U+93V[9M:SV;$141(Y74
+MTD at KG?0RR"B3S++(*IOL<L at IE]SRR"N?_`J(55`AA1515!`G7C'%E5!2*:65
+M458YY550426555%5-=754%,MM=515SWU-=!05".--=%4,\VUT%(KK;715COM
+M==!1)YTE2-1%5]UTUT-/O?361U_]]#?`0(,,-L10PPPWPDBCC#;&6..,-\%$
+MDTPVQ5333)=DAIEFF6V.N>:%9-$0&YD?BH22(82XF)10.3(@U(DDB$;F_/]%
+M0_Y0(!0*A4-\R!5RQ]R*BX\,#'4CB?]];B3)`@LMLM at 22RVSW`HKK;):LC76
+M6F>]#3;:9+,MMMIFNQUVVF6W/?;:9[\##CKDL"-2''7,<2><=,II9YQUSGD7
+M7'3)95=<=<UU-]QTRVUWW'7/?0\\],AC3SSUS',OO/3*:V^\]<Y['WSTR6=?
+1?/7-=S_\],MO?_S]!Y==>0@`
+EOT
+);
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+Unicode type strings will be stored in utf8 for all known platforms,
+once Perl 5.6 has been released and I can find all the mapping tables, etc.
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OS_2.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OS_2.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OS_2.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,306 @@
+package Font::TTF::OS_2;
+
+=head1 NAME
+
+Font::TTF::OS_2 - the OS/2 table in a TTF font
+
+=head1 DESCRIPTION
+
+The OS/2 table has two versions and forms, one an extension of the other. This
+module supports both forms and the switching between them.
+
+=head1 INSTANCE VARIABLES
+
+No other variables than those in table and those in the standard:
+
+ Version
+ xAvgCharWidth
+ usWeightClass
+ usWidthClass
+ fsType
+ ySubscriptXSize
+ ySubScriptYSize
+ ySubscriptXOffset
+ ySubscriptYOffset
+ ySuperscriptXSize
+ ySuperscriptYSize
+ ySuperscriptXOffset
+ ySuperscriptYOffset
+ yStrikeoutSize
+ yStrikeoutPosition
+ sFamilyClass
+ bFamilyType
+ bSerifStyle
+ bWeight
+ bProportion
+ bContrast
+ bStrokeVariation
+ bArmStyle
+ bLetterform
+ bMidline
+ bXheight
+ ulUnicodeRange1
+ ulUnicodeRange2
+ ulUnicodeRange3
+ ulUnicodeRange4
+ achVendID
+ fsSelection
+ usFirstCharIndex
+ usLastCharIndex
+ sTypoAscender
+ sTypoDescender
+ sTypoLineGap
+ usWinAscent
+ usWinDescent
+ ulCodePageRange1
+ ulCodePageRange2
+ xHeight
+ CapHeight
+ defaultChar
+ breakChar
+ maxLookups
+
+Notice that versions 0, 1 & 2 of the table are supported. Notice also that the
+Panose variable has been broken down into its elements.
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA @fields @lens @field_info);
+use Font::TTF::Table;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'xAvgCharWidth' => 's',
+ 'usWeightClass' => 'S',
+ 'usWidthClass' => 'S',
+ 'fsType' => 's',
+ 'ySubscriptXSize' => 's',
+ 'ySubScriptYSize' => 's',
+ 'ySubscriptXOffset' => 's',
+ 'ySubscriptYOffset' => 's',
+ 'ySuperscriptXSize' => 's',
+ 'ySuperscriptYSize' => 's',
+ 'ySuperscriptXOffset' => 's',
+ 'ySuperscriptYOffset' => 's',
+ 'yStrikeoutSize' => 's',
+ 'yStrikeoutPosition' => 's',
+ 'sFamilyClass' => 's',
+ 'bFamilyType' => 'C',
+ 'bSerifStyle' => 'C',
+ 'bWeight' => 'C',
+ 'bProportion' => 'C',
+ 'bContrast' => 'C',
+ 'bStrokeVariation' => 'C',
+ 'bArmStyle' => 'C',
+ 'bLetterform' => 'C',
+ 'bMidline' => 'C',
+ 'bXheight' => 'C',
+ 'ulUnicodeRange1' => 'L',
+ 'ulUnicodeRange2' => 'L',
+ 'ulUnicodeRange3' => 'L',
+ 'ulUnicodeRange4' => 'L',
+ 'achVendID' => 'L',
+ 'fsSelection' => 'S',
+ 'usFirstCharIndex' => 'S',
+ 'usLastCharIndex' => 'S',
+ 'sTypoAscender' => 'S',
+ 'sTypoDescender' => 's',
+ 'sTypoLineGap' => 'S',
+ 'usWinAscent' => 'S',
+ 'usWinDescent' => 'S',
+ '' => '',
+ 'ulCodePageRange1' => 'L',
+ 'ulCodePageRange2' => 'L',
+ '' => '',
+ 'xHeight' => 's',
+ 'CapHeight' => 's',
+ 'defaultChar' => 'S',
+ 'breakChar' => 'S',
+ 'maxLookups' => 's');
+
+use Font::TTF::Utils;
+
+sub init
+{
+ my ($k, $v, $c, $n, $i, $t, $j);
+
+ $n = 0;
+ @lens = (76, 84, 94);
+ for ($j = 0; $j < $#field_info; $j += 2)
+ {
+ if ($field_info[$j] eq '')
+ {
+ $n++;
+ next;
+ }
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$j], $c, $field_info[$j+1]);
+ next unless defined $k && $k ne "";
+ for ($i = $n; $i < 3; $i++)
+ { $fields[$i]{$k} = $v; }
+ }
+}
+
+
+=head2 $t->read
+
+Reads in the various values from disk (see details of OS/2 table)
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $ver);
+
+ $self->SUPER::read or return $self;
+
+ init unless defined $fields[2]{'xAvgCharWidth'};
+ $self->{' INFILE'}->read($dat, 2);
+ $ver = unpack("n", $dat);
+ $self->{'Version'} = $ver;
+ if ($ver < 3)
+ {
+ $self->{' INFILE'}->read($dat, $lens[$ver]);
+ TTF_Read_Fields($self, $dat, $fields[$ver]);
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($ver);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $ver = $self->{'Version'};
+ $fh->print(pack("n", $ver));
+ $fh->print(TTF_Out_Fields($self, $fields[$ver], $lens[$ver]));
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $value)
+
+Tidies up the hex values to output them in hex
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $value) = @_;
+ my ($fh) = $context->{'fh'};
+
+ if ($key =~ m/^ul(?:Unicode|CodePage)Range\d$/o)
+ { $fh->printf("%s<%s>%08X</%s>\n", $depth, $key, $value, $key); }
+ elsif ($key eq 'achVendID')
+ { $fh->printf("%s<%s name='%s'/>\n", $depth, $key, pack('N', $value)); }
+ else
+ { return $self->SUPER::XML_element(@_); }
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Now handle them on the way back in
+
+=cut
+
+sub XML_end
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag =~ m/^ul(?:Unicode|CodePage)Range\d$/o)
+ { return hex($context->{'text'}); }
+ elsif ($tag eq 'achVendID')
+ { return unpack('N', $attrs{'name'}); }
+ else
+ { return $self->SUPER::XML_end(@_); }
+}
+
+=head2 $t->update
+
+Updates the OS/2 table by getting information from other sources:
+
+Updates the C<firstChar> and C<lastChar> values based on the MS table in the
+cmap.
+
+Updates the sTypoAscender, sTypoDescender & sTypoLineGap to be the same values
+as Ascender, Descender and Linegap from the hhea table (assuming it is dirty)
+and also sets usWinAscent to be the sum of Ascender+Linegap and usWinDescent to
+be the negative of Descender.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($map, @keys, $table);
+
+ return undef unless ($self->SUPER::update);
+
+ $self->{' PARENT'}{'cmap'}->update;
+ $map = $self->{' PARENT'}{'cmap'}->find_ms || return undef;
+
+ @keys = sort {$a <=> $b} keys %{$map->{'val'}};
+
+ $self->{'usFirstCharIndex'} = $keys[0];
+ $self->{'usLastCharIndex'} = $keys[-1];
+
+ $table = $self->{' PARENT'}{'hhea'}->read;
+
+ # try any way we can to get some real numbers passed around!
+ if ($table->{'Ascender'} != 0 || $table->{'Descender'} != 0)
+ {
+ $self->{'sTypoAscender'} = $table->{'Ascender'};
+ $self->{'sTypoDescender'} = $table->{'Descender'};
+ $self->{'sTypoLineGap'} = $table->{'Linegap'};
+ $self->{'usWinAscent'} = $self->{'sTypoAscender'} + $self->{'sTypoLineGap'};
+ $self->{'usWinDescent'} = -$self->{'sTypoDescender'};
+ }
+ elsif ($self->{'sTypoAscender'} != 0 || $self->{'sTypoDescender'} != 0)
+ {
+ $table->{'Ascender'} = $self->{'sTypoAscender'};
+ $table->{'Descender'} = $self->{'sTypoDescender'};
+ $table->{'Linegap'} = $self->{'sTypoLineGap'};
+ $self->{'usWinAscent'} = $self->{'sTypoAscender'} + $self->{'sTypoLineGap'};
+ $self->{'usWinDescent'} = -$self->{'sTypoDescender'};
+ }
+ elsif ($self->{'usWinAscent'} != 0 || $self->{'usWinDescent'} != 0)
+ {
+ $self->{'sTypoAscender'} = $table->{'Ascender'} = $self->{'usWinAscent'};
+ $self->{'sTypoDescender'} = $table->{'Descender'} = -$self->{'usWinDescent'};
+ $self->{'sTypoLineGap'} = $table->{'Linegap'} = 0;
+ }
+
+ $self->{'Version'} = 1 if (defined $self->{'ulCodePageRange1'} && $self->{'Version'} < 1);
+ $self->{'Version'} = 2 if (defined $self->{'maxLookups'} && $self->{'Version'} < 2);
+
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldCmap.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldCmap.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldCmap.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,358 @@
+package Font::TTF::OldCmap;
+
+=head1 NAME
+
+Font::TTF::OldCmap - Character map table
+
+This module is deprecated
+
+=head1 DESCRIPTION
+
+Looks after the character map. The primary structure used for handling a cmap
+is the L<Font::TTF::Segarr> which handles the segmented arrays of format 4 tables,
+and in a simpler form for format 0 tables.
+
+Due to the complexity of working with segmented arrays, most of the handling of
+such arrays is via methods rather than via instance variables.
+
+One important feature of a format 4 table is that it always contains a segment
+with a final address of 0xFFFF. If you are creating a table from scratch this is
+important (although L<Font::TTF::Segarr> can work quite happily without it).
+
+
+=head1 INSTANCE VARIABLES
+
+The instance variables listed here are not preceeded by a space due to their
+emulating structural information in the font.
+
+=over 4
+
+=item Num
+
+Number of subtables in this table
+
+=item Tables
+
+An array of subtables ([0..Num-1])
+
+=back
+
+Each subtables also has its own instance variables which are, again, not
+preceeded by a space.
+
+=over 4
+
+=item Platform
+
+The platform number for this subtable
+
+=item Encoding
+
+The encoding number for this subtable
+
+=item Format
+
+Gives the stored format of this subtable
+
+=item Ver
+
+Gives the version (or language) information for this subtable
+
+=item val
+
+This points to a L<Font::TTF::Segarr> which contains the content of the particular
+subtable.
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+require Font::TTF::Table;
+require Font::TTF::Segarr;
+
+ at ISA = qw(Font::TTF::Table);
+
+
+=head2 $t->read
+
+Reads the cmap into memory. Format 4 subtables read the whole subtable and
+fill in the segmented array accordingly.
+
+Format 2 subtables are not read at all.
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $i, $j, $k, $id, @ids, $s);
+ my ($start, $end, $range, $delta, $form, $len, $num, $ver);
+ my ($fh) = $self->{' INFILE'};
+
+ $self->SUPER::read or return $self;
+ $fh->read($dat, 4);
+ $self->{'Num'} = unpack("x2n", $dat);
+ $self->{'Tables'} = [];
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = {};
+ $fh->read($dat, 8);
+ ($s->{'Platform'}, $s->{'Encoding'}, $s->{'LOC'}) = (unpack("nnN", $dat));
+ $s->{'LOC'} += $self->{' OFFSET'};
+ push(@{$self->{'Tables'}}, $s);
+ }
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ $fh->seek($s->{'LOC'}, 0);
+ $fh->read($dat, 6);
+ ($form, $len, $ver) = (unpack("n3", $dat));
+
+ $s->{'Format'} = $form;
+ $s->{'Ver'} = $ver;
+ if ($form == 0)
+ {
+ $s->{'val'} = Font::TTF::Segarr->new;
+ $fh->read($dat, 256);
+ $s->{'val'}->fastadd_segment(0, 2, unpack("C*", $dat));
+ $s->{'Start'} = 0;
+ $s->{'Num'} = 256;
+ } elsif ($form == 6)
+ {
+ my ($start, $ecount);
+
+ $fh->read($dat, 4);
+ ($start, $ecount) = unpack("n2", $dat);
+ $fh->read($dat, $ecount << 1);
+ $s->{'val'} = Font::TTF::Segarr->new;
+ $s->{'val'}->fastadd_segment($start, 2, unpack("n*", $dat));
+ $s->{'Start'} = $start;
+ $s->{'Num'} = $ecount;
+ } elsif ($form == 2)
+ {
+# no idea what to do here yet
+ } elsif ($form == 4)
+ {
+ $fh->read($dat, 8);
+ $num = unpack("n", $dat);
+ $num >>= 1;
+ $fh->read($dat, $len - 14);
+ $s->{'val'} = Font::TTF::Segarr->new;
+ for ($j = 0; $j < $num; $j++)
+ {
+ $end = unpack("n", substr($dat, $j << 1, 2));
+ $start = unpack("n", substr($dat, ($j << 1) + ($num << 1) + 2, 2));
+ $delta = unpack("n", substr($dat, ($j << 1) + ($num << 2) + 2, 2));
+ $delta -= 65536 if $delta > 32767;
+ $range = unpack("n", substr($dat, ($j << 1) + $num * 6 + 2, 2));
+ @ids = ();
+ for ($k = $start; $k <= $end; $k++)
+ {
+ if ($range == 0)
+ { $id = $k + $delta; }
+ else
+ { $id = unpack("n", substr($dat, ($j << 1) + $num * 6 +
+ 2 + ($k - $start) * 2 + $range, 2)) + $delta; }
+ $id -= 65536 if $id > 65536;
+ push (@ids, $id);
+ }
+ $s->{'val'}->fastadd_segment($start, 0, @ids);
+ }
+ $s->{'val'}->tidy;
+ $s->{'Num'} = 0x10000; # always ends here
+ $s->{'Start'} = $s->{'val'}[0]{'START'};
+ }
+ }
+ $self;
+}
+
+
+=head2 $t->ms_lookup($uni)
+
+Given a Unicode value in the MS table (Platform 3, Encoding 1) locates that
+table and looks up the appropriate glyph number from it.
+
+=cut
+
+sub ms_lookup
+{
+ my ($self, $uni) = @_;
+
+ $self->find_ms || return undef unless (defined $self->{' mstable'});
+ return $self->{' mstable'}{'val'}->at($uni);
+}
+
+
+=head2 $t->find_ms
+
+Finds the Microsoft Unicode table and sets the C<mstable> instance variable
+to it if found. Returns the table it finds.
+
+=cut
+sub find_ms
+{
+ my ($self) = @_;
+ my ($i, $s, $alt);
+
+ return $self->{' mstable'} if defined $self->{' mstable'};
+ $self->read;
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ if ($s->{'Platform'} == 3)
+ {
+ $self->{' mstable'} = $s;
+ last if ($s->{'Encoding'} == 1);
+ } elsif ($s->{'Platform'} == 0 || ($s->{'Platform'} == 2 && $s->{'Encoding'} == 1))
+ { $self->{' mstable'} = $s; }
+ }
+ $self->{' mstable'};
+}
+
+
+=head2 $t->out($fh)
+
+Writes out a cmap table to a filehandle. If it has not been read, then
+just copies from input file to output
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($loc, $s, $i, $base_loc, $j);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $base_loc = $fh->tell();
+ $fh->print(pack("n2", 0, $self->{'Num'}));
+
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ { $fh->print(pack("nnN", $self->{'Tables'}[$i]{'Platform'}, $self->{'Tables'}[$i]{'Encoding'}, 0)); }
+
+ for ($i = 0; $i < $self->{'Num'}; $i++)
+ {
+ $s = $self->{'Tables'}[$i];
+ $s->{'val'}->tidy;
+ $s->{' outloc'} = $fh->tell();
+ $fh->print(pack("n3", $s->{'Format'}, 0, $s->{'Ver'})); # come back for length
+ if ($s->{'Format'} == 0)
+ {
+ $fh->print(pack("C256", $s->{'val'}->at(0, 256)));
+ } elsif ($s->{'Format'} == 6)
+ {
+ $fh->print(pack("n2", $s->{'Start'}, $s->{'Num'}));
+ $fh->print(pack("n*", $s->{'val'}->at($s->{'Start'}, $s->{'Num'})));
+ } elsif ($s->{'Format'} == 2)
+ {
+ } elsif ($s->{'Format'} == 4)
+ {
+ my ($num, $sRange, $eSel);
+ my (@deltas, $delta, @range, $flat, $k, $segs, $count);
+
+ $num = $#{$s->{'val'}} + 1;
+ $segs = $s->{'val'};
+ for ($sRange = 1, $eSel = 0; $sRange <= $num; $eSel++)
+ { $sRange <<= 1;}
+ $eSel--;
+ $fh->print(pack("n4", $num * 2, $sRange, $eSel, ($num * 2) - $sRange));
+ $fh->print(pack("n*", map {$_->{'START'} + $_->{'LEN'} - 1} @$segs));
+ $fh->print(pack("n", 0));
+ $fh->print(pack("n*", map {$_->{'START'}} @$segs));
+
+ for ($j = 0; $j < $num; $j++)
+ {
+ $delta = $segs->[$j]{'VAL'}[0]; $flat = 1;
+ for ($k = 1; $k < $segs->[$j]{'LEN'}; $k++)
+ {
+ if ($segs->[$j]{'VAL'}[$k] == 0)
+ { $flat = 0; }
+ if ($delta + $k != $segs->[$j]{'VAL'}[$k])
+ {
+ $delta = 0;
+ last;
+ }
+ }
+ push (@range, $flat);
+ push (@deltas, ($delta ? $delta - $segs->[$j]{'START'} : 0));
+ }
+ $fh->print(pack("n*", @deltas));
+
+ $count = 0;
+ for ($j = 0; $j < $num; $j++)
+ {
+ $delta = $deltas[$j];
+ if ($delta != 0 && $range[$j] == 1)
+ { $range[$j] = 0; }
+ else
+ {
+ $range[$j] = ($count + $num - $j) << 1;
+ $count += $segs->[$j]{'LEN'};
+ }
+ }
+
+ $fh->print(pack("n*", @range));
+
+ for ($j = 0; $j < $num; $j++)
+ {
+ next if ($range[$j] == 0);
+ for ($k = 0; $k < $segs->[$j]{'LEN'}; $k++)
+ { $fh->print(pack("n", $segs->[$j]{'VAL'}[$k])); }
+ }
+ }
+
+ $loc = $fh->tell();
+ $fh->seek($s->{' outloc'} + 2, 0);
+ $fh->print(pack("n", $loc - $s->{' outloc'}));
+ $fh->seek($base_loc + 8 + ($i << 3), 0);
+ $fh->print(pack("N", $s->{' outloc'} - $base_loc));
+ $fh->seek($loc, 0);
+ }
+ $self;
+}
+
+
+=head2 @map = $t->reverse([$num])
+
+Returns a reverse map of the table of given number or the Microsoft
+cmap. I.e. given a glyph gives the Unicode value for it.
+
+=cut
+
+sub reverse
+{
+ my ($self, $tnum) = @_;
+ my ($table) = defined $tnum ? $self->{'Tables'}[$tnum] : $self->find_ms;
+ my (@res, $i, $s, $first);
+
+ foreach $s (@{$table->{'val'}})
+ {
+ $first = $s->{'START'};
+ map {$res[$_] = $first unless $res[$_]; $first++;} @{$s->{'VAL'}};
+ }
+ @res;
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+No support for format 2 tables (MBCS)
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldMort.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldMort.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/OldMort.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,705 @@
+package Font::TTF::OldMort;
+
+=head1 NAME
+
+Font::TTF::OldMort - Glyph Metamorphosis table in a font
+
+=head1 DESCRIPTION
+
+=head1 INSTANCE VARIABLES
+
+=item version
+
+table version number (Fixed: currently 1.0)
+
+=item chains
+
+list of metamorphosis chains, each of which has its own fields:
+
+=over
+
+=item defaultFlags
+
+chain's default subfeature flags (UInt32)
+
+=item featureEntries
+
+list of feature entries, each of which has fields:
+
+=over
+
+=item type
+
+=item setting
+
+=item enable
+
+=item disable
+
+=back
+
+=item subtables
+
+list of metamorphosis subtables, each of which has fields:
+
+=over
+
+=item type
+
+subtable type (0: rearrangement; 1: contextual substitution; 2: ligature;
+4: non-contextual substitution; 5: insertion)
+
+=item direction
+
+processing direction ('LR' or 'RL')
+
+=item orientation
+
+applies to text in which orientation ('VH', 'V', or 'H')
+
+=item subFeatureFlags
+
+the subfeature flags controlling whether the table is used (UInt32)
+
+=back
+
+Further fields depend on the type of subtable:
+
+=over
+
+Rearrangement table:
+
+=over
+
+=item classes
+
+array of lists of glyphs
+
+=item states
+
+array of arrays of hashes{'nextState', 'flags'}
+
+=back
+
+Contextual substitution table:
+
+=over
+
+=item classes
+
+array of lists of glyphs
+
+=item states
+
+array of array of hashes{'nextState', 'flags', 'actions'}, where C<actions>
+is an array of two elements which are offsets to be added to [marked, current]
+glyph to get index into C<mappings> (or C<undef> if no mapping to be applied)
+
+=item mappings
+
+list of glyph codes mapped to through the state table mappings
+
+=back
+
+Ligature table:
+
+Non-contextual substitution table:
+
+Insertion table:
+
+=back
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $fh, $numChains);
+
+ $self->SUPER::read or return $self;
+
+ $fh = $self->{' INFILE'};
+
+ $fh->read($dat, 8);
+ ($self->{'version'}, $numChains) = TTF_Unpack("fL", $dat);
+
+ my $chains = [];
+ foreach (1 .. $numChains) {
+ my $chainStart = $fh->tell();
+ $fh->read($dat, 12);
+ my ($defaultFlags, $chainLength, $nFeatureEntries, $nSubtables) = TTF_Unpack("LLSS", $dat);
+ my $featureEntries = [];
+ foreach (1 .. $nFeatureEntries) {
+ $fh->read($dat, 12);
+ my ($featureType, $featureSetting, $enableFlags, $disableFlags) = TTF_Unpack("SSLL", $dat);
+ push @$featureEntries, {
+ 'type' => $featureType,
+ 'setting' => $featureSetting,
+ 'enable' => $enableFlags,
+ 'disable' => $disableFlags
+ };
+ }
+ my $subtables = [];
+ foreach (1 .. $nSubtables) {
+ my $subtableStart = $fh->tell();
+ $fh->read($dat, 8);
+ my ($length, $coverage, $subFeatureFlags) = TTF_Unpack("SSL", $dat);
+ my $type = $coverage & 0x0007;
+
+ my $subtable = {
+ 'type' => $type,
+ 'direction' => (($coverage & 0x4000) ? 'RL' : 'LR'),
+ 'orientation' => (($coverage & 0x2000) ? 'VH' : ($coverage & 0x8000) ? 'V' : 'H'),
+ 'subFeatureFlags' => $subFeatureFlags
+ };
+
+ if ($type == 0) { # rearrangement
+ my ($classes, $states) = AAT_read_state_table($fh, 0);
+ $subtable->{'classes'} = $classes;
+ $subtable->{'states'} = $states;
+ }
+
+ elsif ($type == 1) { # contextual
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
+
+ $fh->seek($stateTableStart, IO::File::SEEK_SET);
+ $fh->read($dat, 10);
+ my ($stateSize, $classTable, $stateArray, $entryTable, $mappingTables) = unpack("nnnnn", $dat);
+ my $limits = [$classTable, $stateArray, $entryTable, $mappingTables, $length - 8];
+
+ foreach (@$entries) {
+ my $actions = $_->{'actions'};
+ foreach (@$actions) {
+ $_ = $_ ? $_ - ($mappingTables / 2) : undef;
+ }
+ }
+
+ $subtable->{'classes'} = $classes;
+ $subtable->{'states'} = $states;
+ $subtable->{'mappings'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $mappingTables, $limits))];
+ }
+
+ elsif ($type == 2) { # ligature
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 0);
+
+ $fh->seek($stateTableStart, IO::File::SEEK_SET);
+ $fh->read($dat, 14);
+ my ($stateSize, $classTable, $stateArray, $entryTable,
+ $ligActionTable, $componentTable, $ligatureTable) = unpack("nnnnnnn", $dat);
+ my $limits = [$classTable, $stateArray, $entryTable, $ligActionTable, $componentTable, $ligatureTable, $length - 8];
+
+ my %actions;
+ my $actionLists;
+ foreach (@$entries) {
+ my $offset = $_->{'flags'} & 0x3fff;
+ $_->{'flags'} &= ~0x3fff;
+ if ($offset != 0) {
+ if (not defined $actions{$offset}) {
+ $fh->seek($stateTableStart + $offset, IO::File::SEEK_SET);
+ my $actionList;
+ while (1) {
+ $fh->read($dat, 4);
+ my $action = unpack("N", $dat);
+ my ($last, $store, $component) = (($action & 0x80000000) != 0, ($action & 0xC0000000) != 0, ($action & 0x3fffffff));
+ $component -= 0x40000000 if $component > 0x1fffffff;
+ $component -= $componentTable / 2;
+ push @$actionList, { 'store' => $store, 'component' => $component };
+ last if $last;
+ }
+ push @$actionLists, $actionList;
+ $actions{$offset} = $#$actionLists;
+ }
+ $_->{'actions'} = $actions{$offset};
+ }
+ }
+
+ $subtable->{'componentTable'} = $componentTable;
+ my $components = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $componentTable, $limits))];
+ foreach (@$components) {
+ $_ = ($_ - $ligatureTable) . " +" if $_ >= $ligatureTable;
+ }
+ $subtable->{'components'} = $components;
+
+ $subtable->{'ligatureTable'} = $ligatureTable;
+ $subtable->{'ligatures'} = [unpack("n*", AAT_read_subtable($fh, $stateTableStart, $ligatureTable, $limits))];
+
+ $subtable->{'classes'} = $classes;
+ $subtable->{'states'} = $states;
+ $subtable->{'actionLists'} = $actionLists;
+ }
+
+ elsif ($type == 4) { # non-contextual
+ my ($format, $lookup) = AAT_read_lookup($fh, 2, $length - 8, undef);
+ $subtable->{'format'} = $format;
+ $subtable->{'lookup'} = $lookup;
+ }
+
+ elsif ($type == 5) { # insertion
+ my $stateTableStart = $fh->tell();
+ my ($classes, $states, $entries) = AAT_read_state_table($fh, 2);
+
+ my %insertListHash;
+ my $insertLists;
+ foreach (@$entries) {
+ my $flags = $_->{'flags'};
+ my @insertCount = (($flags & 0x03e0) >> 5, ($flags & 0x001f));
+ my $actions = $_->{'actions'};
+ foreach (0 .. 1) {
+ if ($insertCount[$_] > 0) {
+ $fh->seek($stateTableStart + $actions->[$_], IO::File::SEEK_SET);
+ $fh->read($dat, $insertCount[$_] * 2);
+ if (not defined $insertListHash{$dat}) {
+ push @$insertLists, [unpack("n*", $dat)];
+ $insertListHash{$dat} = $#$insertLists;
+ }
+ $actions->[$_] = $insertListHash{$dat};
+ }
+ else {
+ $actions->[$_] = undef;
+ }
+ }
+ }
+
+ $subtable->{'classes'} = $classes;
+ $subtable->{'states'} = $states;
+ $subtable->{'insertLists'} = $insertLists;
+ }
+
+ else {
+ die "unknown subtable type";
+ }
+
+ push @$subtables, $subtable;
+ $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
+ }
+
+ push @$chains, {
+ 'defaultFlags' => $defaultFlags,
+ 'featureEntries' => $featureEntries,
+ 'subtables' => $subtables
+ };
+ $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
+ }
+
+ $self->{'chains'} = $chains;
+
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ my $chains = $self->{'chains'};
+ $fh->print(TTF_Pack("fL", $self->{'version'}, scalar @$chains));
+
+ foreach (@$chains) {
+ my $chainStart = $fh->tell();
+ my ($featureEntries, $subtables) = ($_->{'featureEntries'}, $_->{'subtables'});
+ $fh->print(TTF_Pack("LLSS", $_->{'defaultFlags'}, 0, scalar @$featureEntries, scalar @$subtables)); # placeholder for length
+
+ foreach (@$featureEntries) {
+ $fh->print(TTF_Pack("SSLL", $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'}));
+ }
+
+ foreach (@$subtables) {
+ my $subtableStart = $fh->tell();
+ my $type = $_->{'type'};
+ my $coverage = $type;
+ $coverage += 0x4000 if $_->{'direction'} eq 'RL';
+ $coverage += 0x2000 if $_->{'orientation'} eq 'VH';
+ $coverage += 0x8000 if $_->{'orientation'} eq 'V';
+
+ $fh->print(TTF_Pack("SSL", 0, $coverage, $_->{'subFeatureFlags'})); # placeholder for length
+
+ if ($type == 0) { # rearrangement
+ AAT_write_state_table($fh, $_->{'classes'}, $_->{'states'}, 0);
+ }
+
+ elsif ($type == 1) { # contextual
+ my $stHeader = $fh->tell();
+ $fh->print(pack("nnnnn", (0) x 5)); # placeholders for stateSize, classTable, stateArray, entryTable, mappingTables
+
+ my $classTable = $fh->tell() - $stHeader;
+ my $classes = $_->{'classes'};
+ AAT_write_classes($fh, $classes);
+
+ my $stateArray = $fh->tell() - $stHeader;
+ my $states = $_->{'states'};
+ my ($stateSize, $entries) = AAT_write_states($fh, $classes, $stateArray, $states,
+ sub {
+ my $actions = $_->{'actions'};
+ ( $_->{'flags'}, @$actions )
+ }
+ );
+
+ my $entryTable = $fh->tell() - $stHeader;
+ my $offset = ($entryTable + 8 * @$entries) / 2;
+ foreach (@$entries) {
+ my ($nextState, $flags, @parts) = split /,/;
+ $fh->print(pack("nnnn", $nextState, $flags, map { $_ eq "" ? 0 : $_ + $offset } @parts));
+ }
+
+ my $mappingTables = $fh->tell() - $stHeader;
+ my $mappings = $_->{'mappings'};
+ $fh->print(pack("n*", @$mappings));
+
+ my $loc = $fh->tell();
+ $fh->seek($stHeader, IO::File::SEEK_SET);
+ $fh->print(pack("nnnnn", $stateSize, $classTable, $stateArray, $entryTable, $mappingTables));
+ $fh->seek($loc, IO::File::SEEK_SET);
+ }
+
+ elsif ($type == 2) { # ligature
+ my $stHeader = $fh->tell();
+ $fh->print(pack("nnnnnnn", (0) x 7)); # placeholders for stateSize, classTable, stateArray, entryTable, actionLists, components, ligatures
+
+ my $classTable = $fh->tell() - $stHeader;
+ my $classes = $_->{'classes'};
+ AAT_write_classes($fh, $classes);
+
+ my $stateArray = $fh->tell() - $stHeader;
+ my $states = $_->{'states'};
+
+ my ($stateSize, $entries) = AAT_write_states($fh, $classes, $stateArray, $states,
+ sub {
+ ( $_->{'flags'} & 0xc000, $_->{'actions'} )
+ }
+ );
+
+ my $actionLists = $_->{'actionLists'};
+ my %actionListOffset;
+ my $actionListDataLength = 0;
+ my @actionListEntries;
+ foreach (0 .. $#$entries) {
+ my ($nextState, $flags, $offset) = split(/,/, $entries->[$_]);
+ if ($offset eq "") {
+ $offset = undef;
+ }
+ else {
+ if (defined $actionListOffset{$offset}) {
+ $offset = $actionListOffset{$offset};
+ }
+ else {
+ $actionListOffset{$offset} = $actionListDataLength;
+ my $list = $actionLists->[$offset];
+ $actionListDataLength += 4 * @$list;
+ push @actionListEntries, $list;
+ $offset = $actionListOffset{$offset};
+ }
+ }
+ $entries->[$_] = [ $nextState, $flags, $offset ];
+ }
+ my $entryTable = $fh->tell() - $stHeader;
+ my $ligActionLists = ($entryTable + @$entries * 4 + 3) & ~3;
+ foreach (@$entries) {
+ $_->[2] += $ligActionLists if defined $_->[2];
+ $fh->print(pack("nn", $_->[0], $_->[1] + $_->[2]));
+ }
+ $fh->print(pack("C*", (0) x ($ligActionLists - $entryTable - @$entries * 4)));
+
+ die "internal error" if $fh->tell() != $ligActionLists + $stHeader;
+
+ my $componentTable = $fh->tell() - $stHeader + $actionListDataLength;
+ my $actionList;
+ foreach $actionList (@actionListEntries) {
+ foreach (0 .. $#$actionList) {
+ my $action = $actionList->[$_];
+ my $val = $action->{'component'} + $componentTable / 2;
+ $val += 0x40000000 if $val < 0;
+ $val &= 0x3fffffff;
+ $val |= 0x40000000 if $action->{'store'};
+ $val |= 0x80000000 if $_ == $#$actionList;
+ $fh->print(pack("N", $val));
+ }
+ }
+
+ die "internal error" if $fh->tell() != $componentTable + $stHeader;
+
+ my $components = $_->{'components'};
+ my $ligatureTable = $componentTable + @$components * 2;
+ $fh->print(pack("n*", map { (index($_, '+') >= 0 ? $ligatureTable : 0) + $_ } @$components));
+
+ my $ligatures = $_->{'ligatures'};
+ $fh->print(pack("n*", @$ligatures));
+
+ my $loc = $fh->tell();
+ $fh->seek($stHeader, IO::File::SEEK_SET);
+ $fh->print(pack("nnnnnnn", $stateSize, $classTable, $stateArray, $entryTable, $ligActionLists, $componentTable, $ligatureTable));
+ $fh->seek($loc, IO::File::SEEK_SET);
+ }
+
+ elsif ($type == 4) { # non-contextual
+ AAT_write_lookup($fh, $_->{'format'}, $_->{'lookup'}, 2, undef);
+ }
+
+ elsif ($type == 5) { # insertion
+ }
+
+ else {
+ die "unknown subtable type";
+ }
+
+ my $length = $fh->tell() - $subtableStart;
+ my $padBytes = (4 - ($length & 3)) & 3;
+ $fh->print(pack("C*", (0) x $padBytes));
+ $length += $padBytes;
+ $fh->seek($subtableStart, IO::File::SEEK_SET);
+ $fh->print(pack("n", $length));
+ $fh->seek($subtableStart + $length, IO::File::SEEK_SET);
+ }
+
+ my $chainLength = $fh->tell() - $chainStart;
+ $fh->seek($chainStart + 4, IO::File::SEEK_SET);
+ $fh->print(pack("N", $chainLength));
+ $fh->seek($chainStart + $chainLength, IO::File::SEEK_SET);
+ }
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+
+ $self->read;
+ my $feat = $self->{' PARENT'}->{'feat'};
+ $feat->read;
+ my $post = $self->{' PARENT'}->{'post'};
+ $post->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $fh->printf("version %f\n", $self->{'version'});
+
+ my $chains = $self->{'chains'};
+ foreach (@$chains) {
+ my $defaultFlags = $_->{'defaultFlags'};
+ $fh->printf("chain: defaultFlags = %08x\n", $defaultFlags);
+
+ my $featureEntries = $_->{'featureEntries'};
+ foreach (@$featureEntries) {
+ $fh->printf("\tfeature %d, setting %d : enableFlags = %08x, disableFlags = %08x # '%s: %s'\n",
+ $_->{'type'}, $_->{'setting'}, $_->{'enable'}, $_->{'disable'},
+ $feat->settingName($_->{'type'}, $_->{'setting'}));
+ }
+
+ my $subtables = $_->{'subtables'};
+ foreach (@$subtables) {
+ my $type = $_->{'type'};
+ my $subFeatureFlags = $_->{'subFeatureFlags'};
+ $fh->printf("\n\t%s table, %s, %s, subFeatureFlags = %08x # %s (%s)\n",
+ subtable_type_($type), $_->{'direction'}, $_->{'orientation'}, $subFeatureFlags,
+ "Default " . ((($subFeatureFlags & $defaultFlags) != 0) ? "On" : "Off"),
+ join(", ",
+ map {
+ join(": ", $feat->settingName($_->{'type'}, $_->{'setting'}) )
+ } grep { ($_->{'enable'} & $subFeatureFlags) != 0 } @$featureEntries
+ ) );
+
+ if ($type == 0) { # rearrangement
+ print_classes_($fh, $_, $post);
+
+ $fh->print("\n");
+ my $states = $_->{'states'};
+ my @verbs = ( "0", "Ax->xA", "xD->Dx", "AxD->DxA",
+ "ABx->xAB", "ABx->xBA", "xCD->CDx", "xCD->DCx",
+ "AxCD->CDxA", "AxCD->DCxA", "ABxD->DxAB", "ABxD->DxBA",
+ "ABxCD->CDxAB", "ABxCD->CDxBA", "ABxCD->DCxAB", "ABxCD->DCxBA");
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "<" if ($_->{'flags'} & 0x8000);
+ $flags .= ">" if ($_->{'flags'} & 0x2000);
+ $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, $verbs[($_->{'flags'} & 0x000f)]);
+ }
+ $fh->print("\n");
+ }
+ }
+
+ elsif ($type == 1) { # contextual
+ print_classes_($fh, $_, $post);
+
+ $fh->print("\n");
+ my $states = $_->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ my $actions = $_->{'actions'};
+ $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $mappings = $_->{'mappings'};
+ foreach (0 .. $#$mappings) {
+ $fh->printf("\t\tMapping %d: %d [%s]\n", $_, $mappings->[$_], $post->{'VAL'}[$mappings->[$_]]);
+ }
+ }
+
+ elsif ($type == 2) { # ligature
+ print_classes_($fh, $_, $post);
+
+ $fh->print("\n");
+ my $states = $_->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ $fh->printf("\t(%s%d,%s)", $flags, $_->{'nextState'}, defined $_->{'actions'} ? $_->{'actions'} : "=");
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $actionLists = $_->{'actionLists'};
+ foreach (0 .. $#$actionLists) {
+ $fh->printf("\t\tList %d:\t", $_);
+ my $actionList = $actionLists->[$_];
+ $fh->printf("%s\n", join(", ", map { ($_->{'component'} . ($_->{'store'} ? "*" : "") ) } @$actionList));
+ }
+
+ my $ligatureTable = $_->{'ligatureTable'};
+
+ $fh->print("\n");
+ my $components = $_->{'components'};
+ foreach (0 .. $#$components) {
+ $fh->printf("\t\tComponent %d: %s\n", $_, $components->[$_]);
+ }
+
+ $fh->print("\n");
+ my $ligatures = $_->{'ligatures'};
+ foreach (0 .. $#$ligatures) {
+ $fh->printf("\t\tLigature %d: %d [%s]\n", $_, $ligatures->[$_], $post->{'VAL'}[$ligatures->[$_]]);
+ }
+ }
+
+ elsif ($type == 4) { # non-contextual
+ my $lookup = $_->{'lookup'};
+ $fh->printf("\t\tLookup format %d\n", $_->{'format'});
+ if (defined $lookup) {
+ foreach (sort { $a <=> $b } keys %$lookup) {
+ $fh->printf("\t\t\t%d [%s] -> %d [%s])\n", $_, $post->{'VAL'}[$_], $lookup->{$_}, $post->{'VAL'}[$lookup->{$_}]);
+ }
+ }
+ }
+
+ elsif ($type == 5) { # insertion
+ print_classes_($fh, $_, $post);
+
+ $fh->print("\n");
+ my $states = $_->{'states'};
+ foreach (0 .. $#$states) {
+ $fh->printf("\t\tState %d:", $_);
+ my $state = $states->[$_];
+ foreach (@$state) {
+ my $flags;
+ $flags .= "!" if ($_->{'flags'} & 0x4000);
+ $flags .= "*" if ($_->{'flags'} & 0x8000);
+ my $actions = $_->{'actions'};
+ $fh->printf("\t(%s%d,%s,%s)", $flags, $_->{'nextState'}, map { defined $_ ? $_ : "=" } @$actions);
+ }
+ $fh->print("\n");
+ }
+
+ $fh->print("\n");
+ my $insertLists = $_->{'insertLists'};
+ foreach (0 .. $#$insertLists) {
+ my $insertList = $insertLists->[$_];
+ $fh->printf("\t\tList %d: %s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$insertList));
+ }
+ }
+
+ else {
+ # unknown
+ }
+ }
+ }
+}
+
+sub print_classes_
+{
+ my ($fh, $subtable, $post) = @_;
+
+ my $classes = $subtable->{'classes'};
+ foreach (0 .. $#$classes) {
+ my $class = $classes->[$_];
+ if (defined $class) {
+ $fh->printf("\t\tClass %d:\t%s\n", $_, join(", ", map { $_ . " [" . $post->{'VAL'}[$_] . "]" } @$class));
+ }
+ }
+}
+
+sub subtable_type_
+{
+ my ($val) = @_;
+ my ($res);
+
+ my @types = (
+ 'Rearrangement',
+ 'Contextual',
+ 'Ligature',
+ undef,
+ 'Non-contextual',
+ 'Insertion',
+ );
+ $res = $types[$val] or ('Undefined (' . $val . ')');
+
+ $res;
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PCLT.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PCLT.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PCLT.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,121 @@
+package Font::TTF::PCLT;
+
+=head1 NAME
+
+Font::TTF::Pclt - PCLT TrueType font table
+
+=head1 DESCRIPTION
+
+The PCLT table holds various pieces HP-PCL specific information. Information
+here is generally not used by other software, except for the xHeight and
+CapHeight which are stored here (if the table exists in a font).
+
+=head1 INSTANCE VARIABLES
+
+Only from table and the standard:
+
+ version
+ FontNumber
+ Pitch
+ xHeight
+ Style
+ TypeFamily
+ CapHeight
+ SymbolSet
+ Typeface
+ CharacterComplement
+ FileName
+ StrokeWeight
+ WidthType
+ SerifStyle
+
+Notice that C<Typeface>, C<CharacterComplement> and C<FileName> return arrays
+of unsigned characters of the appropriate length
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'version' => 'f',
+ 'FontNumber' => 'L',
+ 'Pitch' => 'S',
+ 'xHeight' => 'S',
+ 'Style' => 'S',
+ 'TypeFamily' => 'S',
+ 'CapHeight' => 'S',
+ 'SymbolSet' => 'S',
+ 'Typeface' => 'C16',
+ 'CharacterComplement' => 'C8',
+ 'FileName' => 'C6',
+ 'StrokeWeight' => 'C',
+ 'WidthType' => 'C',
+ 'SerifStyle' => 'c');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory thanks to some utility functions
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read || return $self;
+
+ init unless defined $fields{'xHeight'};
+ $self->{' INFILE'}->read($dat, 54);
+
+ TTF_Read_Fields($self, $dat, \%fields);
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+ $fh->print(TTF_Out_Fields($self, \%fields, 54));
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PSNames.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PSNames.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/PSNames.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,910 @@
+package Font::TTF::PSNames;
+
+use strict;
+use vars qw(%names %doubles);
+
+%names = (
+ '0020' => 'space',
+ '0021' => 'exclam',
+ '0022' => 'quotedbl',
+ '0023' => 'numbersign',
+ '0024' => 'dollar',
+ '0025' => 'percent',
+ '0026' => 'ampersand',
+ '0027' => 'quotesingle',
+ '0028' => 'parenleft',
+ '0029' => 'parenright',
+ '002A' => 'asterisk',
+ '002B' => 'plus',
+ '002C' => 'comma',
+ '002D' => 'hyphen',
+ '002E' => 'period',
+ '002F' => 'slash',
+ '0030' => 'zero',
+ '0031' => 'one',
+ '0032' => 'two',
+ '0033' => 'three',
+ '0034' => 'four',
+ '0035' => 'five',
+ '0036' => 'six',
+ '0037' => 'seven',
+ '0038' => 'eight',
+ '0039' => 'nine',
+ '003A' => 'colon',
+ '003B' => 'semicolon',
+ '003C' => 'less',
+ '003D' => 'equal',
+ '003E' => 'greater',
+ '003F' => 'question',
+ '0040' => 'at',
+ '0041' => 'A',
+ '0042' => 'B',
+ '0043' => 'C',
+ '0044' => 'D',
+ '0045' => 'E',
+ '0046' => 'F',
+ '0047' => 'G',
+ '0048' => 'H',
+ '0049' => 'I',
+ '004A' => 'J',
+ '004B' => 'K',
+ '004C' => 'L',
+ '004D' => 'M',
+ '004E' => 'N',
+ '004F' => 'O',
+ '0050' => 'P',
+ '0051' => 'Q',
+ '0052' => 'R',
+ '0053' => 'S',
+ '0054' => 'T',
+ '0055' => 'U',
+ '0056' => 'V',
+ '0057' => 'W',
+ '0058' => 'X',
+ '0059' => 'Y',
+ '005A' => 'Z',
+ '005B' => 'bracketleft',
+ '005C' => 'backslash',
+ '005D' => 'bracketright',
+ '005E' => 'asciicircum',
+ '005F' => 'underscore',
+ '0060' => 'grave',
+ '0061' => 'a',
+ '0062' => 'b',
+ '0063' => 'c',
+ '0064' => 'd',
+ '0065' => 'e',
+ '0066' => 'f',
+ '0067' => 'g',
+ '0068' => 'h',
+ '0069' => 'i',
+ '006A' => 'j',
+ '006B' => 'k',
+ '006C' => 'l',
+ '006D' => 'm',
+ '006E' => 'n',
+ '006F' => 'o',
+ '0070' => 'p',
+ '0071' => 'q',
+ '0072' => 'r',
+ '0073' => 's',
+ '0074' => 't',
+ '0075' => 'u',
+ '0076' => 'v',
+ '0077' => 'w',
+ '0078' => 'x',
+ '0079' => 'y',
+ '007A' => 'z',
+ '007B' => 'braceleft',
+ '007C' => 'bar',
+ '007D' => 'braceright',
+ '007E' => 'asciitilde',
+# '00A0' => 'space',
+ '00A1' => 'exclamdown',
+ '00A2' => 'cent',
+ '00A3' => 'sterling',
+ '00A4' => 'currency',
+ '00A5' => 'yen',
+ '00A6' => 'brokenbar',
+ '00A7' => 'section',
+ '00A8' => 'dieresis',
+ '00A9' => 'copyright',
+ '00AA' => 'ordfeminine',
+ '00AB' => 'guillemotleft',
+ '00AC' => 'logicalnot',
+# '00AD' => 'hyphen',
+ '00AE' => 'registered',
+ '00AF' => 'macron',
+ '00B0' => 'degree',
+ '00B1' => 'plusminus',
+ '00B2' => 'twosuperior',
+ '00B3' => 'threesuperior',
+ '00B4' => 'acute',
+ '00B5' => 'mu',
+ '00B6' => 'paragraph',
+ '00B7' => 'periodcentered',
+ '00B8' => 'cedilla',
+ '00B9' => 'onesuperior',
+ '00BA' => 'ordmasculine',
+ '00BB' => 'guillemotright',
+ '00BC' => 'onequarter',
+ '00BD' => 'onehalf',
+ '00BE' => 'threequarters',
+ '00BF' => 'questiondown',
+ '00C0' => 'Agrave',
+ '00C1' => 'Aacute',
+ '00C2' => 'Acircumflex',
+ '00C3' => 'Atilde',
+ '00C4' => 'Adieresis',
+ '00C5' => 'Aring',
+ '00C6' => 'AE',
+ '00C7' => 'Ccedilla',
+ '00C8' => 'Egrave',
+ '00C9' => 'Eacute',
+ '00CA' => 'Ecircumflex',
+ '00CB' => 'Edieresis',
+ '00CC' => 'Igrave',
+ '00CD' => 'Iacute',
+ '00CE' => 'Icircumflex',
+ '00CF' => 'Idieresis',
+ '00D0' => 'Eth',
+ '00D1' => 'Ntilde',
+ '00D2' => 'Ograve',
+ '00D3' => 'Oacute',
+ '00D4' => 'Ocircumflex',
+ '00D5' => 'Otilde',
+ '00D6' => 'Odieresis',
+ '00D7' => 'multiply',
+ '00D8' => 'Oslash',
+ '00D9' => 'Ugrave',
+ '00DA' => 'Uacute',
+ '00DB' => 'Ucircumflex',
+ '00DC' => 'Udieresis',
+ '00DD' => 'Yacute',
+ '00DE' => 'Thorn',
+ '00DF' => 'germandbls',
+ '00E0' => 'agrave',
+ '00E1' => 'aacute',
+ '00E2' => 'acircumflex',
+ '00E3' => 'atilde',
+ '00E4' => 'adieresis',
+ '00E5' => 'aring',
+ '00E6' => 'ae',
+ '00E7' => 'ccedilla',
+ '00E8' => 'egrave',
+ '00E9' => 'eacute',
+ '00EA' => 'ecircumflex',
+ '00EB' => 'edieresis',
+ '00EC' => 'igrave',
+ '00ED' => 'iacute',
+ '00EE' => 'icircumflex',
+ '00EF' => 'idieresis',
+ '00F0' => 'eth',
+ '00F1' => 'ntilde',
+ '00F2' => 'ograve',
+ '00F3' => 'oacute',
+ '00F4' => 'ocircumflex',
+ '00F5' => 'otilde',
+ '00F6' => 'odieresis',
+ '00F7' => 'divide',
+ '00F8' => 'oslash',
+ '00F9' => 'ugrave',
+ '00FA' => 'uacute',
+ '00FB' => 'ucircumflex',
+ '00FC' => 'udieresis',
+ '00FD' => 'yacute',
+ '00FE' => 'thorn',
+ '00FF' => 'ydieresis',
+ '0100' => 'Amacron',
+ '0101' => 'amacron',
+ '0102' => 'Abreve',
+ '0103' => 'abreve',
+ '0104' => 'Aogonek',
+ '0105' => 'aogonek',
+ '0106' => 'Cacute',
+ '0107' => 'cacute',
+ '0108' => 'Ccircumflex',
+ '0109' => 'ccircumflex',
+ '010A' => 'Cdotaccent',
+ '010B' => 'cdotaccent',
+ '010C' => 'Ccaron',
+ '010D' => 'ccaron',
+ '010E' => 'Dcaron',
+ '010F' => 'dcaron',
+ '0110' => 'Dcroat',
+ '0111' => 'dcroat',
+ '0112' => 'Emacron',
+ '0113' => 'emacron',
+ '0114' => 'Ebreve',
+ '0115' => 'ebreve',
+ '0116' => 'Edotaccent',
+ '0117' => 'edotaccent',
+ '0118' => 'Eogonek',
+ '0119' => 'eogonek',
+ '011A' => 'Ecaron',
+ '011B' => 'ecaron',
+ '011C' => 'Gcircumflex',
+ '011D' => 'gcircumflex',
+ '011E' => 'Gbreve',
+ '011F' => 'gbreve',
+ '0120' => 'Gdotaccent',
+ '0121' => 'gdotaccent',
+ '0122' => 'Gcommaaccent',
+ '0123' => 'gcommaaccent',
+ '0124' => 'Hcircumflex',
+ '0125' => 'hcircumflex',
+ '0126' => 'Hbar',
+ '0127' => 'hbar',
+ '0128' => 'Itilde',
+ '0129' => 'itilde',
+ '012A' => 'Imacron',
+ '012B' => 'imacron',
+ '012C' => 'Ibreve',
+ '012D' => 'ibreve',
+ '012E' => 'Iogonek',
+ '012F' => 'iogonek',
+ '0130' => 'Idotaccent',
+ '0131' => 'dotlessi',
+ '0132' => 'IJ',
+ '0133' => 'ij',
+ '0134' => 'Jcircumflex',
+ '0135' => 'jcircumflex',
+ '0136' => 'Kcommaaccent',
+ '0137' => 'kcommaaccent',
+ '0138' => 'kgreenlandic',
+ '0139' => 'Lacute',
+ '013A' => 'lacute',
+ '013B' => 'Lcommaaccent',
+ '013C' => 'lcommaaccent',
+ '013D' => 'Lcaron',
+ '013E' => 'lcaron',
+ '013F' => 'Ldot',
+ '0140' => 'ldot',
+ '0141' => 'Lslash',
+ '0142' => 'lslash',
+ '0143' => 'Nacute',
+ '0144' => 'nacute',
+ '0145' => 'Ncommaaccent',
+ '0146' => 'ncommaaccent',
+ '0147' => 'Ncaron',
+ '0148' => 'ncaron',
+ '0149' => 'napostrophe',
+ '014A' => 'Eng',
+ '014B' => 'eng',
+ '014C' => 'Omacron',
+ '014D' => 'omacron',
+ '014E' => 'Obreve',
+ '014F' => 'obreve',
+ '0150' => 'Ohungarumlaut',
+ '0151' => 'ohungarumlaut',
+ '0152' => 'OE',
+ '0153' => 'oe',
+ '0154' => 'Racute',
+ '0155' => 'racute',
+ '0156' => 'Rcommaaccent',
+ '0157' => 'rcommaaccent',
+ '0158' => 'Rcaron',
+ '0159' => 'rcaron',
+ '015A' => 'Sacute',
+ '015B' => 'sacute',
+ '015C' => 'Scircumflex',
+ '015D' => 'scircumflex',
+ '015E' => 'Scedilla',
+ '015F' => 'scedilla',
+ '0160' => 'Scaron',
+ '0161' => 'scaron',
+ '0162' => 'Tcommaaccent',
+ '0163' => 'tcommaaccent',
+ '0164' => 'Tcaron',
+ '0165' => 'tcaron',
+ '0166' => 'Tbar',
+ '0167' => 'tbar',
+ '0168' => 'Utilde',
+ '0169' => 'utilde',
+ '016A' => 'Umacron',
+ '016B' => 'umacron',
+ '016C' => 'Ubreve',
+ '016D' => 'ubreve',
+ '016E' => 'Uring',
+ '016F' => 'uring',
+ '0170' => 'Uhungarumlaut',
+ '0171' => 'uhungarumlaut',
+ '0172' => 'Uogonek',
+ '0173' => 'uogonek',
+ '0174' => 'Wcircumflex',
+ '0175' => 'wcircumflex',
+ '0176' => 'Ycircumflex',
+ '0177' => 'ycircumflex',
+ '0178' => 'Ydieresis',
+ '0179' => 'Zacute',
+ '017A' => 'zacute',
+ '017B' => 'Zdotaccent',
+ '017C' => 'zdotaccent',
+ '017D' => 'Zcaron',
+ '017E' => 'zcaron',
+ '017F' => 'longs',
+ '0192' => 'florin',
+ '01A0' => 'Ohorn',
+ '01A1' => 'ohorn',
+ '01AF' => 'Uhorn',
+ '01B0' => 'uhorn',
+ '01E6' => 'Gcaron',
+ '01E7' => 'gcaron',
+ '01FA' => 'Aringacute',
+ '01FB' => 'aringacute',
+ '01FC' => 'AEacute',
+ '01FD' => 'aeacute',
+ '01FE' => 'Oslashacute',
+ '01FF' => 'oslashacute',
+ '0218' => 'Scommaaccent',
+ '0219' => 'scommaaccent',
+# '021A' => 'Tcommaaccent',
+# '021B' => 'tcommaaccent',
+ '02BC' => 'afii57929',
+ '02BD' => 'afii64937',
+ '02C6' => 'circumflex',
+ '02C7' => 'caron',
+# '02C9' => 'macron',
+ '02D8' => 'breve',
+ '02D9' => 'dotaccent',
+ '02DA' => 'ring',
+ '02DB' => 'ogonek',
+ '02DC' => 'tilde',
+ '02DD' => 'hungarumlaut',
+ '0300' => 'gravecomb',
+ '0301' => 'acutecomb',
+ '0303' => 'tildecomb',
+ '0309' => 'hookabovecomb',
+ '0323' => 'dotbelowcomb',
+ '0384' => 'tonos',
+ '0385' => 'dieresistonos',
+ '0386' => 'Alphatonos',
+ '0387' => 'anoteleia',
+ '0388' => 'Epsilontonos',
+ '0389' => 'Etatonos',
+ '038A' => 'Iotatonos',
+ '038C' => 'Omicrontonos',
+ '038E' => 'Upsilontonos',
+ '038F' => 'Omegatonos',
+ '0390' => 'iotadieresistonos',
+ '0391' => 'Alpha',
+ '0392' => 'Beta',
+ '0393' => 'Gamma',
+# '0394' => 'Delta',
+ '0395' => 'Epsilon',
+ '0396' => 'Zeta',
+ '0397' => 'Eta',
+ '0398' => 'Theta',
+ '0399' => 'Iota',
+ '039A' => 'Kappa',
+ '039B' => 'Lambda',
+ '039C' => 'Mu',
+ '039D' => 'Nu',
+ '039E' => 'Xi',
+ '039F' => 'Omicron',
+ '03A0' => 'Pi',
+ '03A1' => 'Rho',
+ '03A3' => 'Sigma',
+ '03A4' => 'Tau',
+ '03A5' => 'Upsilon',
+ '03A6' => 'Phi',
+ '03A7' => 'Chi',
+ '03A8' => 'Psi',
+# '03A9' => 'Omega',
+ '03AA' => 'Iotadieresis',
+ '03AB' => 'Upsilondieresis',
+ '03AC' => 'alphatonos',
+ '03AD' => 'epsilontonos',
+ '03AE' => 'etatonos',
+ '03AF' => 'iotatonos',
+ '03B0' => 'upsilondieresistonos',
+ '03B1' => 'alpha',
+ '03B2' => 'beta',
+ '03B3' => 'gamma',
+ '03B4' => 'delta',
+ '03B5' => 'epsilon',
+ '03B6' => 'zeta',
+ '03B7' => 'eta',
+ '03B8' => 'theta',
+ '03B9' => 'iota',
+ '03BA' => 'kappa',
+ '03BB' => 'lambda',
+# '03BC' => 'mu',
+ '03BD' => 'nu',
+ '03BE' => 'xi',
+ '03BF' => 'omicron',
+ '03C0' => 'pi',
+ '03C1' => 'rho',
+ '03C2' => 'sigma1',
+ '03C3' => 'sigma',
+ '03C4' => 'tau',
+ '03C5' => 'upsilon',
+ '03C6' => 'phi',
+ '03C7' => 'chi',
+ '03C8' => 'psi',
+ '03C9' => 'omega',
+ '03CA' => 'iotadieresis',
+ '03CB' => 'upsilondieresis',
+ '03CC' => 'omicrontonos',
+ '03CD' => 'upsilontonos',
+ '03CE' => 'omegatonos',
+ '03D1' => 'theta1',
+ '03D2' => 'Upsilon1',
+ '03D5' => 'phi1',
+ '03D6' => 'omega1',
+ '0401' => 'afii10023',
+ '0402' => 'afii10051',
+ '0403' => 'afii10052',
+ '0404' => 'afii10053',
+ '0405' => 'afii10054',
+ '0406' => 'afii10055',
+ '0407' => 'afii10056',
+ '0408' => 'afii10057',
+ '0409' => 'afii10058',
+ '040A' => 'afii10059',
+ '040B' => 'afii10060',
+ '040C' => 'afii10061',
+ '040E' => 'afii10062',
+ '040F' => 'afii10145',
+ '0410' => 'afii10017',
+ '0411' => 'afii10018',
+ '0412' => 'afii10019',
+ '0413' => 'afii10020',
+ '0414' => 'afii10021',
+ '0415' => 'afii10022',
+ '0416' => 'afii10024',
+ '0417' => 'afii10025',
+ '0418' => 'afii10026',
+ '0419' => 'afii10027',
+ '041A' => 'afii10028',
+ '041B' => 'afii10029',
+ '041C' => 'afii10030',
+ '041D' => 'afii10031',
+ '041E' => 'afii10032',
+ '041F' => 'afii10033',
+ '0420' => 'afii10034',
+ '0421' => 'afii10035',
+ '0422' => 'afii10036',
+ '0423' => 'afii10037',
+ '0424' => 'afii10038',
+ '0425' => 'afii10039',
+ '0426' => 'afii10040',
+ '0427' => 'afii10041',
+ '0428' => 'afii10042',
+ '0429' => 'afii10043',
+ '042A' => 'afii10044',
+ '042B' => 'afii10045',
+ '042C' => 'afii10046',
+ '042D' => 'afii10047',
+ '042E' => 'afii10048',
+ '042F' => 'afii10049',
+ '0430' => 'afii10065',
+ '0431' => 'afii10066',
+ '0432' => 'afii10067',
+ '0433' => 'afii10068',
+ '0434' => 'afii10069',
+ '0435' => 'afii10070',
+ '0436' => 'afii10072',
+ '0437' => 'afii10073',
+ '0438' => 'afii10074',
+ '0439' => 'afii10075',
+ '043A' => 'afii10076',
+ '043B' => 'afii10077',
+ '043C' => 'afii10078',
+ '043D' => 'afii10079',
+ '043E' => 'afii10080',
+ '043F' => 'afii10081',
+ '0440' => 'afii10082',
+ '0441' => 'afii10083',
+ '0442' => 'afii10084',
+ '0443' => 'afii10085',
+ '0444' => 'afii10086',
+ '0445' => 'afii10087',
+ '0446' => 'afii10088',
+ '0447' => 'afii10089',
+ '0448' => 'afii10090',
+ '0449' => 'afii10091',
+ '044A' => 'afii10092',
+ '044B' => 'afii10093',
+ '044C' => 'afii10094',
+ '044D' => 'afii10095',
+ '044E' => 'afii10096',
+ '044F' => 'afii10097',
+ '0451' => 'afii10071',
+ '0452' => 'afii10099',
+ '0453' => 'afii10100',
+ '0454' => 'afii10101',
+ '0455' => 'afii10102',
+ '0456' => 'afii10103',
+ '0457' => 'afii10104',
+ '0458' => 'afii10105',
+ '0459' => 'afii10106',
+ '045A' => 'afii10107',
+ '045B' => 'afii10108',
+ '045C' => 'afii10109',
+ '045E' => 'afii10110',
+ '045F' => 'afii10193',
+ '0462' => 'afii10146',
+ '0463' => 'afii10194',
+ '0472' => 'afii10147',
+ '0473' => 'afii10195',
+ '0474' => 'afii10148',
+ '0475' => 'afii10196',
+ '0490' => 'afii10050',
+ '0491' => 'afii10098',
+ '04D9' => 'afii10846',
+ '05B0' => 'afii57799',
+ '05B1' => 'afii57801',
+ '05B2' => 'afii57800',
+ '05B3' => 'afii57802',
+ '05B4' => 'afii57793',
+ '05B5' => 'afii57794',
+ '05B6' => 'afii57795',
+ '05B7' => 'afii57798',
+ '05B8' => 'afii57797',
+ '05B9' => 'afii57806',
+ '05BB' => 'afii57796',
+ '05BC' => 'afii57807',
+ '05BD' => 'afii57839',
+ '05BE' => 'afii57645',
+ '05BF' => 'afii57841',
+ '05C0' => 'afii57842',
+ '05C1' => 'afii57804',
+ '05C2' => 'afii57803',
+ '05C3' => 'afii57658',
+ '05D0' => 'afii57664',
+ '05D1' => 'afii57665',
+ '05D2' => 'afii57666',
+ '05D3' => 'afii57667',
+ '05D4' => 'afii57668',
+ '05D5' => 'afii57669',
+ '05D6' => 'afii57670',
+ '05D7' => 'afii57671',
+ '05D8' => 'afii57672',
+ '05D9' => 'afii57673',
+ '05DA' => 'afii57674',
+ '05DB' => 'afii57675',
+ '05DC' => 'afii57676',
+ '05DD' => 'afii57677',
+ '05DE' => 'afii57678',
+ '05DF' => 'afii57679',
+ '05E0' => 'afii57680',
+ '05E1' => 'afii57681',
+ '05E2' => 'afii57682',
+ '05E3' => 'afii57683',
+ '05E4' => 'afii57684',
+ '05E5' => 'afii57685',
+ '05E6' => 'afii57686',
+ '05E7' => 'afii57687',
+ '05E8' => 'afii57688',
+ '05E9' => 'afii57689',
+ '05EA' => 'afii57690',
+ '05F0' => 'afii57716',
+ '05F1' => 'afii57717',
+ '05F2' => 'afii57718',
+ '060C' => 'afii57388',
+ '061B' => 'afii57403',
+ '061F' => 'afii57407',
+ '0621' => 'afii57409',
+ '0622' => 'afii57410',
+ '0623' => 'afii57411',
+ '0624' => 'afii57412',
+ '0625' => 'afii57413',
+ '0626' => 'afii57414',
+ '0627' => 'afii57415',
+ '0628' => 'afii57416',
+ '0629' => 'afii57417',
+ '062A' => 'afii57418',
+ '062B' => 'afii57419',
+ '062C' => 'afii57420',
+ '062D' => 'afii57421',
+ '062E' => 'afii57422',
+ '062F' => 'afii57423',
+ '0630' => 'afii57424',
+ '0631' => 'afii57425',
+ '0632' => 'afii57426',
+ '0633' => 'afii57427',
+ '0634' => 'afii57428',
+ '0635' => 'afii57429',
+ '0636' => 'afii57430',
+ '0637' => 'afii57431',
+ '0638' => 'afii57432',
+ '0639' => 'afii57433',
+ '063A' => 'afii57434',
+ '0640' => 'afii57440',
+ '0641' => 'afii57441',
+ '0642' => 'afii57442',
+ '0643' => 'afii57443',
+ '0644' => 'afii57444',
+ '0645' => 'afii57445',
+ '0646' => 'afii57446',
+ '0647' => 'afii57470',
+ '0648' => 'afii57448',
+ '0649' => 'afii57449',
+ '064A' => 'afii57450',
+ '064B' => 'afii57451',
+ '064C' => 'afii57452',
+ '064D' => 'afii57453',
+ '064E' => 'afii57454',
+ '064F' => 'afii57455',
+ '0650' => 'afii57456',
+ '0651' => 'afii57457',
+ '0652' => 'afii57458',
+ '0660' => 'afii57392',
+ '0661' => 'afii57393',
+ '0662' => 'afii57394',
+ '0663' => 'afii57395',
+ '0664' => 'afii57396',
+ '0665' => 'afii57397',
+ '0666' => 'afii57398',
+ '0667' => 'afii57399',
+ '0668' => 'afii57400',
+ '0669' => 'afii57401',
+ '066A' => 'afii57381',
+ '066D' => 'afii63167',
+ '0679' => 'afii57511',
+ '067E' => 'afii57506',
+ '0686' => 'afii57507',
+ '0688' => 'afii57512',
+ '0691' => 'afii57513',
+ '0698' => 'afii57508',
+ '06A4' => 'afii57505',
+ '06AF' => 'afii57509',
+ '06BA' => 'afii57514',
+ '06D2' => 'afii57519',
+ '06D5' => 'afii57534',
+ '1E80' => 'Wgrave',
+ '1E81' => 'wgrave',
+ '1E82' => 'Wacute',
+ '1E83' => 'wacute',
+ '1E84' => 'Wdieresis',
+ '1E85' => 'wdieresis',
+ '1EF2' => 'Ygrave',
+ '1EF3' => 'ygrave',
+ '200C' => 'afii61664',
+ '200D' => 'afii301',
+ '200E' => 'afii299',
+ '200F' => 'afii300',
+ '2012' => 'figuredash',
+ '2013' => 'endash',
+ '2014' => 'emdash',
+ '2015' => 'afii00208',
+ '2017' => 'underscoredbl',
+ '2018' => 'quoteleft',
+ '2019' => 'quoteright',
+ '201A' => 'quotesinglbase',
+ '201B' => 'quotereversed',
+ '201C' => 'quotedblleft',
+ '201D' => 'quotedblright',
+ '201E' => 'quotedblbase',
+ '2020' => 'dagger',
+ '2021' => 'daggerdbl',
+ '2022' => 'bullet',
+ '2024' => 'onedotenleader',
+ '2025' => 'twodotenleader',
+ '2026' => 'ellipsis',
+ '202C' => 'afii61573',
+ '202D' => 'afii61574',
+ '202E' => 'afii61575',
+ '2030' => 'perthousand',
+ '2032' => 'minute',
+ '2033' => 'second',
+ '2039' => 'guilsinglleft',
+ '203A' => 'guilsinglright',
+ '203C' => 'exclamdbl',
+ '2044' => 'fraction',
+# '2070' => 'zerosuperior',
+# '2074' => 'foursuperior',
+# '2075' => 'fivesuperior',
+# '2076' => 'sixsuperior',
+# '2077' => 'sevensuperior',
+# '2078' => 'eightsuperior',
+# '2079' => 'ninesuperior',
+# '207D' => 'parenleftsuperior',
+# '207E' => 'parenrightsuperior',
+# '207F' => 'nsuperior',
+# '2080' => 'zeroinferior',
+# '2081' => 'oneinferior',
+# '2082' => 'twoinferior',
+# '2083' => 'threeinferior',
+# '2084' => 'fourinferior',
+# '2085' => 'fiveinferior',
+# '2086' => 'sixinferior',
+# '2087' => 'seveninferior',
+# '2088' => 'eightinferior',
+# '2089' => 'nineinferior',
+# '208D' => 'parenleftinferior',
+# '208E' => 'parenrightinferior',
+ '20A1' => 'colonmonetary',
+ '20A3' => 'franc',
+ '20A4' => 'lira',
+ '20A7' => 'peseta',
+ '20AA' => 'afii57636',
+ '20AB' => 'dong',
+ '20AC' => 'Euro',
+ '2105' => 'afii61248',
+ '2111' => 'Ifraktur',
+ '2113' => 'afii61289',
+ '2116' => 'afii61352',
+ '2118' => 'weierstrass',
+ '211C' => 'Rfraktur',
+ '211E' => 'prescription',
+ '2122' => 'trademark',
+ '2126' => 'Omega',
+ '212E' => 'estimated',
+ '2135' => 'aleph',
+ '2153' => 'onethird',
+ '2154' => 'twothirds',
+ '215B' => 'oneeighth',
+ '215C' => 'threeeighths',
+ '215D' => 'fiveeighths',
+ '215E' => 'seveneighths',
+ '2190' => 'arrowleft',
+ '2191' => 'arrowup',
+ '2192' => 'arrowright',
+ '2193' => 'arrowdown',
+ '2194' => 'arrowboth',
+ '2195' => 'arrowupdn',
+ '21A8' => 'arrowupdnbse',
+ '21B5' => 'carriagereturn',
+ '21D0' => 'arrowdblleft',
+ '21D1' => 'arrowdblup',
+ '21D2' => 'arrowdblright',
+ '21D3' => 'arrowdbldown',
+ '21D4' => 'arrowdblboth',
+ '2200' => 'universal',
+ '2202' => 'partialdiff',
+ '2203' => 'existential',
+ '2205' => 'emptyset',
+ '2206' => 'Delta',
+ '2207' => 'gradient',
+ '2208' => 'element',
+ '2209' => 'notelement',
+ '220B' => 'suchthat',
+ '220F' => 'product',
+ '2211' => 'summation',
+ '2212' => 'minus',
+# '2215' => 'fraction',
+ '2217' => 'asteriskmath',
+# '2219' => 'periodcentered',
+ '221A' => 'radical',
+ '221D' => 'proportional',
+ '221E' => 'infinity',
+ '221F' => 'orthogonal',
+ '2220' => 'angle',
+ '2227' => 'logicaland',
+ '2228' => 'logicalor',
+ '2229' => 'intersection',
+ '222A' => 'union',
+ '222B' => 'integral',
+ '2234' => 'therefore',
+ '223C' => 'similar',
+ '2245' => 'congruent',
+ '2248' => 'approxequal',
+ '2260' => 'notequal',
+ '2261' => 'equivalence',
+ '2264' => 'lessequal',
+ '2265' => 'greaterequal',
+ '2282' => 'propersubset',
+ '2283' => 'propersuperset',
+ '2284' => 'notsubset',
+ '2286' => 'reflexsubset',
+ '2287' => 'reflexsuperset',
+ '2295' => 'circleplus',
+ '2297' => 'circlemultiply',
+ '22A5' => 'perpendicular',
+ '22C5' => 'dotmath',
+ '2302' => 'house',
+ '2310' => 'revlogicalnot',
+ '2320' => 'integraltp',
+ '2321' => 'integralbt',
+ '2329' => 'angleleft',
+ '232A' => 'angleright',
+ '2500' => 'SF100000',
+ '2502' => 'SF110000',
+ '250C' => 'SF010000',
+ '2510' => 'SF030000',
+ '2514' => 'SF020000',
+ '2518' => 'SF040000',
+ '251C' => 'SF080000',
+ '2524' => 'SF090000',
+ '252C' => 'SF060000',
+ '2534' => 'SF070000',
+ '253C' => 'SF050000',
+ '2550' => 'SF430000',
+ '2551' => 'SF240000',
+ '2552' => 'SF510000',
+ '2553' => 'SF520000',
+ '2554' => 'SF390000',
+ '2555' => 'SF220000',
+ '2556' => 'SF210000',
+ '2557' => 'SF250000',
+ '2558' => 'SF500000',
+ '2559' => 'SF490000',
+ '255A' => 'SF380000',
+ '255B' => 'SF280000',
+ '255C' => 'SF270000',
+ '255D' => 'SF260000',
+ '255E' => 'SF360000',
+ '255F' => 'SF370000',
+ '2560' => 'SF420000',
+ '2561' => 'SF190000',
+ '2562' => 'SF200000',
+ '2563' => 'SF230000',
+ '2564' => 'SF470000',
+ '2565' => 'SF480000',
+ '2566' => 'SF410000',
+ '2567' => 'SF450000',
+ '2568' => 'SF460000',
+ '2569' => 'SF400000',
+ '256A' => 'SF540000',
+ '256B' => 'SF530000',
+ '256C' => 'SF440000',
+ '2580' => 'upblock',
+ '2584' => 'dnblock',
+ '2588' => 'block',
+ '258C' => 'lfblock',
+ '2590' => 'rtblock',
+ '2591' => 'ltshade',
+ '2592' => 'shade',
+ '2593' => 'dkshade',
+ '25A0' => 'filledbox',
+ '25A1' => 'H22073',
+ '25AA' => 'H18543',
+ '25AB' => 'H18551',
+ '25AC' => 'filledrect',
+ '25B2' => 'triagup',
+ '25BA' => 'triagrt',
+ '25BC' => 'triagdn',
+ '25C4' => 'triaglf',
+ '25CA' => 'lozenge',
+ '25CB' => 'circle',
+ '25CF' => 'H18533',
+ '25D8' => 'invbullet',
+ '25D9' => 'invcircle',
+ '25E6' => 'openbullet',
+ '263A' => 'smileface',
+ '263B' => 'invsmileface',
+ '263C' => 'sun',
+ '2640' => 'female',
+ '2642' => 'male',
+ '2660' => 'spade',
+ '2663' => 'club',
+ '2665' => 'heart',
+ '2666' => 'diamond',
+ '266A' => 'musicalnote',
+ '266B' => 'musicalnotedbl',
+ 'FB00' => 'ff',
+ 'FB01' => 'fi',
+ 'FB02' => 'fl',
+ 'FB03' => 'ffi',
+ 'FB04' => 'ffl',
+ 'FB1F' => 'afii57705',
+ 'FB2A' => 'afii57694',
+ 'FB2B' => 'afii57695',
+ 'FB35' => 'afii57723',
+ 'FB4B' => 'afii57700',
+);
+
+# %doubles = (map{$_ => "uni$_"} qw(0394 03A9 0162 2215 00AD 02C9 03BC 2219 00A0 0163));
+
+sub lookup
+{
+ my ($num, $noalt) = @_;
+ my ($val) = sprintf("%04X", $num);
+
+ if (defined $names{$val})
+ {
+ return $names{$val};
+# return $names{$val} if ($noalt);
+# return $doubles{$val} || $names{$val};
+ }
+ elsif ($num > 0xFFFF)
+ { return "u$val"; }
+ elsif ($num)
+ { return "uni$val"; }
+ else
+ { return ".notdef"; }
+}
+
+1;
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Post.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Post.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Post.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,305 @@
+package Font::TTF::Post;
+
+=head1 NAME
+
+Font::TTF::Post - Holds the Postscript names for each glyph
+
+=head1 DESCRIPTION
+
+Holds the postscript names for glyphs. Note that they are not held as an
+array, but as indexes into two lists. The first list is the standard Postscript
+name list defined by the TrueType standard. The second comes from the font
+directly.
+
+Looking up a glyph from a Postscript name or a name from a glyph number is
+achieved through methods rather than variable lookup.
+
+This class handles PostScript table types of 1, 2, 2.5 & 3, but not version 4.
+Support for version 2.5 is as per Apple spec rather than MS.
+
+The way to look up Postscript names or glyphs is:
+
+ $pname = $f->{'post'}{'VAL'}[$gnum];
+ $gnum = $f->{'post'}{'STRINGS'}{$pname};
+
+=head1 INSTANCE VARIABLES
+
+Due to different systems having different limitations, there are various class
+variables available to control what post table types can be written.
+
+=over 4
+
+=item $Font::TTF::Post::no25
+
+If set tells Font::TTF::Post::out to use table type 2 instead of 2.5 in case apps
+can't handle version 2.5.
+
+=item VAL
+
+Contains an array indexed by glyph number of Postscript names. This is used when
+writing out a font.
+
+=item STRINGS
+
+An associative array of Postscript names mapping to the highest glyph with that
+name. These may not be in sync with VAL.
+
+=back
+
+In addition there are the standard introductory variables defined in the
+standard:
+
+ FormatType
+ italicAngle
+ underlinePosition
+ underlineThickness
+ isFixedPitch
+ minMemType42
+ maxMemType42
+ minMemType1
+ maxMemType1
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA @base_set %base_set %fields $VERSION $no25 @field_info @base_set);
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+$no25 = 1; # officially deprecated format 2.5 tables in MS spec 1.3
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'FormatType' => 'f',
+ 'italicAngle' => 'f',
+ 'underlinePosition' => 's',
+ 'underlineThickness' => 's',
+ 'isFixedPitch' => 'L',
+ 'minMemType42' => 'L',
+ 'maxMemType42' => 'L',
+ 'minMemType1' => 'L',
+ 'maxMemType1' => 'L');
+ at base_set = qw(.notdef .null nonmarkingreturn space exclam quotedbl numbersign dollar percent ampersand quotesingle
+ parenleft parenright asterisk plus comma hyphen period slash zero one two three four five six
+ seven eight nine colon semicolon less equal greater question at A B C D E F G H I J K L M N O P Q
+ R S T U V W X Y Z bracketleft backslash bracketright asciicircum underscore grave a b c d e f g h
+ i j k l m n o p q r s t u v w x y z braceleft bar braceright asciitilde Adieresis Aring Ccedilla
+ Eacute Ntilde Odieresis Udieresis aacute agrave acircumflex adieresis atilde aring ccedilla eacute
+ egrave ecircumflex edieresis iacute igrave icircumflex idieresis ntilde oacute ograve ocircumflex
+ odieresis otilde uacute ugrave ucircumflex udieresis dagger degree cent sterling section bullet
+ paragraph germandbls registered copyright trademark acute dieresis notequal AE Oslash infinity
+ plusminus lessequal greaterequal yen mu partialdiff summation product pi integral ordfeminine
+ ordmasculine Omega ae oslash questiondown exclamdown logicalnot radical florin approxequal
+ Delta guillemotleft guillemotright ellipsis nonbreakingspace Agrave Atilde Otilde OE oe endash emdash
+ quotedblleft quotedblright quoteleft quoteright divide lozenge ydieresis Ydieresis fraction currency
+ guilsinglleft guilsinglright fi fl daggerdbl periodcentered quotesinglbase quotedblbase perthousand
+ Acircumflex Ecircumflex Aacute Edieresis Egrave Iacute Icircumflex Idieresis Igrave Oacute Ocircumflex
+ apple Ograve Uacute Ucircumflex Ugrave dotlessi circumflex tilde macron breve dotaccent
+ ring cedilla hungarumlaut ogonek caron Lslash lslash Scaron scaron Zcaron zcaron brokenbar Eth eth
+ Yacute yacute Thorn thorn minus multiply onesuperior twosuperior threesuperior onehalf onequarter
+ threequarters franc Gbreve gbreve Idotaccent Scedilla scedilla Cacute cacute Ccaron ccaron dcroat);
+
+$VERSION = 0.01; # MJPH 5-AUG-1998 Re-organise data structures
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+ $i = 0;
+ %base_set = map {$_ => $i++} @base_set;
+}
+
+
+=head2 $t->read
+
+Reads the Postscript table into memory from disk
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $dat1, $i, $off, $c, $maxoff, $form, $angle, $numGlyphs);
+ my ($fh) = $self->{' INFILE'};
+
+ $numGlyphs = $self->{' PARENT'}{'maxp'}->read->{'numGlyphs'};
+ $self->SUPER::read or return $self;
+ init unless ($fields{'FormatType'});
+ $fh->read($dat, 32);
+ TTF_Read_Fields($self, $dat, \%fields);
+
+ if (int($self->{'FormatType'} + .5) == 1)
+ {
+ for ($i = 0; $i < 258; $i++)
+ {
+ $self->{'VAL'}[$i] = $base_set[$i];
+ $self->{'STRINGS'}{$base_set[$i]} = $i unless (defined $self->{'STRINGS'}{$base_set[$i]});
+ }
+ } elsif (int($self->{'FormatType'} * 2 + .1) == 5)
+ {
+ $fh->read($dat, 2);
+ $numGlyphs = unpack("n", $dat);
+ $fh->read($dat, $numGlyphs);
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $off = unpack("c", substr($dat, $i, 1));
+ $self->{'VAL'}[$i] = $base_set[$i + $off];
+ $self->{'STRINGS'}{$base_set[$i + $off]} = $i unless (defined $self->{'STRINGS'}{$base_set[$i + $off]});
+ }
+ } elsif (int($self->{'FormatType'} + .5) == 2)
+ {
+ my (@strings);
+
+ $fh->read($dat, ($numGlyphs + 1) << 1);
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $off = unpack("n", substr($dat, ($i + 1) << 1, 2));
+ $maxoff = $off if (!defined $maxoff || $off > $maxoff);
+ }
+ for ($i = 0; $i < $maxoff - 257; $i++)
+ {
+ $fh->read($dat1, 1);
+ $off = unpack("C", $dat1);
+ $fh->read($dat1, $off);
+ $strings[$i] = $dat1;
+ }
+ for ($i = 0; $i < $numGlyphs; $i++)
+ {
+ $off = unpack("n", substr($dat, ($i + 1) << 1, 2));
+ if ($off > 257)
+ {
+ $self->{'VAL'}[$i] = $strings[$off - 258];
+ $self->{'STRINGS'}{$strings[$off - 258]} = $i;
+ }
+ else
+ {
+ $self->{'VAL'}[$i] = $base_set[$off];
+ $self->{'STRINGS'}{$base_set[$off]} = $i unless (defined $self->{'STRINGS'}{$base_set[$off]});
+ }
+ }
+ }
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes out a new Postscript name table from memory or copies from disk
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($i, $num);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $num = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ init unless ($fields{'FormatType'});
+
+ for ($i = $#{$self->{'VAL'}}; !defined $self->{'VAL'}[$i] && $i > 0; $i--)
+ { pop(@{$self->{'VAL'}}); }
+ if ($#{$self->{'VAL'}} < 0)
+ { $self->{'FormatType'} = 3; }
+ else
+ {
+ $self->{'FormatType'} = 1;
+ for ($i = 0; $i < $num; $i++)
+ {
+ if (!defined $base_set{$self->{'VAL'}[$i]})
+ {
+ $self->{'FormatType'} = 2;
+ last;
+ }
+ elsif ($base_set{$self->{'VAL'}[$i]} != $i)
+ { $self->{'FormatType'} = ($no25 ? 2 : 2.5); }
+ }
+ }
+
+ $fh->print(TTF_Out_Fields($self, \%fields, 32));
+
+ return $self if (int($self->{'FormatType'} + .4) == 3);
+
+ if (int($self->{'FormatType'} + .5) == 2)
+ {
+ my (@ind, $count);
+
+ $fh->print(pack("n", $num));
+ for ($i = 0; $i < $num; $i++)
+ {
+ if (defined $base_set{$self->{'VAL'}[$i]})
+ { $fh->print(pack("n", $base_set{$self->{'VAL'}[$i]})); }
+ else
+ {
+ $fh->print(pack("n", $count + 258));
+ $ind[$count++] = $i;
+ }
+ }
+ for ($i = 0; $i < $count; $i++)
+ {
+ $fh->print(pack("C", length($self->{'VAL'}[$ind[$i]])));
+ $fh->print($self->{'VAL'}[$ind[$i]]);
+ }
+ } elsif (int($self->{'FormatType'} * 2 + .5) == 5)
+ {
+ $fh->print(pack("n", $num));
+ for ($i = 0; $i < $num; $i++)
+ { $fh->print(pack("c", defined $base_set{$self->{'VAL'}[$i]} ?
+ $base_set{$self->{'VAL'}[$i]} - $i : -$i)); }
+ }
+
+ $self;
+}
+
+
+=head2 $t->XML_element($context, $depth, $key, $val)
+
+Outputs the names as one block of XML
+
+=cut
+
+sub XML_element
+{
+ my ($self) = shift;
+ my ($context, $depth, $key, $val) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($i);
+
+ return $self->SUPER::XML_element(@_) unless ($key eq 'STRINGS' || $key eq 'VAL');
+ return unless ($key eq 'VAL');
+
+ $fh->print("$depth<names>\n");
+ for ($i = 0; $i <= $#{$self->{'VAL'}}; $i++)
+ { $fh->print("$depth$context->{'indent'}<name post='$self->{'VAL'}[$i]' gid='$i'/>\n"); }
+ $fh->print("$depth</names>\n");
+ $self;
+}
+
+1;
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+No support for type 4 tables
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prep.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prep.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prep.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,89 @@
+package Font::TTF::Prep;
+
+=head1 NAME
+
+Font::TTF::Prep - Preparation hinting program. Called when ppem changes
+
+=head1 DESCRIPTION
+
+This is a minimal class adding nothing beyond a table, but is a repository
+for prep type information for those processes brave enough to address hinting.
+
+=cut
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+
+$VERSION = 0.0001;
+
+
+=head2 $t->read
+
+Reads the data using C<read_dat>.
+
+=cut
+
+sub read
+{
+ $_[0]->read_dat;
+ $_[0]->{' read'} = 1;
+}
+
+
+=head2 $t->out_xml($context, $depth)
+
+Outputs Prep program as XML
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($dat);
+
+ $self->read;
+ $dat = Font::TTF::Utils::XML_binhint($self->{' dat'});
+ $dat =~ s/\n(?!$)/\n$depth$context->{'indent'}/omg;
+ $fh->print("$depth<code>\n");
+ $fh->print("$depth$context->{'indent'}$dat");
+ $fh->print("$depth</code>\n");
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Parse all that hinting code
+
+=cut
+
+sub XML_end
+{
+ my ($self) = shift;
+ my ($context, $tag, %attrs) = @_;
+
+ if ($tag eq 'code')
+ {
+ $self->{' dat'} = Font::TTF::Utils::XML_hintbin($context->{'text'});
+ return $context;
+ } else
+ { return $self->SUPER::XML_end(@_); }
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prop.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prop.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Prop.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,154 @@
+package Font::TTF::Prop;
+
+=head1 NAME
+
+Font::TTF::Prop - Glyph Properties table in a font
+
+=head1 DESCRIPTION
+
+=head1 INSTANCE VARIABLES
+
+=item version
+
+=item default
+
+=item lookup
+
+Hash of property values keyed by glyph number
+
+=item lookupFormat
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+use Font::TTF::Utils;
+use Font::TTF::AATutils;
+use Font::TTF::Segarr;
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $fh);
+ my ($version, $lookupPresent, $default);
+
+ $self->SUPER::read or return $self;
+
+ $fh = $self->{' INFILE'};
+ $fh->read($dat, 8);
+ ($version, $lookupPresent, $default) = TTF_Unpack("fSS", $dat);
+
+ if ($lookupPresent) {
+ my ($format, $lookup) = AAT_read_lookup($fh, 2, $self->{' LENGTH'} - 8, $default);
+ $self->{'lookup'} = $lookup;
+ $self->{'format'} = $format;
+ }
+
+ $self->{'version'} = $version;
+ $self->{'default'} = $default;
+
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($default, $lookup);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $default = $self->{'default'};
+ $lookup = $self->{'lookup'};
+ $fh->print(TTF_Pack("fSS", $self->{'version'}, (defined $lookup ? 1 : 0), $default));
+
+ AAT_write_lookup($fh, $self->{'format'}, $lookup, 2, $default) if (defined $lookup);
+}
+
+=head2 $t->print($fh)
+
+Prints a human-readable representation of the table
+
+=cut
+
+sub print
+{
+ my ($self, $fh) = @_;
+ my ($lookup);
+
+ $self->read;
+
+ $fh = 'STDOUT' unless defined $fh;
+
+ $fh->printf("version %f\ndefault %04x # %s\n", $self->{'version'}, $self->{'default'}, meaning_($self->{'default'}));
+ $lookup = $self->{'lookup'};
+ if (defined $lookup) {
+ $fh->printf("format %d\n", $self->{'format'});
+ foreach (sort { $a <=> $b } keys %$lookup) {
+ $fh->printf("\t%d -> %04x # %s\n", $_, $lookup->{$_}, meaning_($lookup->{$_}));
+ }
+ }
+}
+
+sub meaning_
+{
+ my ($val) = @_;
+ my ($res);
+
+ my @types = (
+ "Strong left-to-right",
+ "Strong right-to-left",
+ "Arabic letter",
+ "European number",
+ "European number separator",
+ "European number terminator",
+ "Arabic number",
+ "Common number separator",
+ "Block separator",
+ "Segment separator",
+ "Whitespace",
+ "Other neutral");
+ $res = $types[$val & 0x001f] or ("Undefined [" . ($val & 0x001f) . "]");
+
+ $res .= ", floater" if $val & 0x8000;
+ $res .= ", hang left" if $val & 0x4000;
+ $res .= ", hang right" if $val & 0x2000;
+ $res .= ", attaches on right" if $val & 0x0080;
+ $res .= ", pair" if $val & 0x1000;
+ my $pairOffset = ($val & 0x0f00) >> 8;
+ $pairOffset = $pairOffset - 16 if $pairOffset > 7;
+ $res .= $pairOffset > 0 ? " +" . $pairOffset : $pairOffset < 0 ? " " . $pairOffset : "";
+
+ $res;
+}
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Jonathan Kew L<Jonathan_Kew at sil.org>. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Segarr.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Segarr.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Segarr.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,376 @@
+package Font::TTF::Segarr;
+
+=head1 NAME
+
+Font::TTF::Segarr - Segmented array
+
+=head1 DESCRIPTION
+
+Holds data either directly or indirectly as a series of arrays. This class
+looks after the set of arrays and masks the individual sub-arrays, thus saving
+a class, we hope.
+
+=head1 INSTANCE VARIABLES
+
+All instance variables do not start with a space.
+
+The segmented array is simply an array of segments
+
+Each segment is a more complex affair:
+
+=over 4
+
+=item START
+
+In terms of the array, the address for the 0th element in this segment.
+
+=item LEN
+
+Number of elements in this segment
+
+=item VAL
+
+The array which contains the elements
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@types $VERSION);
+$VERSION = 0.0001;
+
+ at types = ('', 'C', 'n', '', 'N');
+
+=head2 Font::TTF::Segarr->new($size)
+
+Creates a new segmented array with a given data size
+
+=cut
+
+sub new
+{
+ my ($class) = @_;
+ my ($self) = [];
+
+ bless $self, (ref($class) || $class);
+}
+
+
+=head2 $s->fastadd_segment($start, $is_sparse, @dat)
+
+Creates a new segment and adds it to the array assuming no overlap between
+the new segment and any others in the array. $is_sparse indicates whether the
+passed in array contains C<undef>s or not. If false no checking is done (which
+is faster, but riskier). If equal to 2 then 0 is considered undef as well.
+
+Returns the number of segments inserted.
+
+=cut
+
+sub fastadd_segment
+{
+ my ($self) = shift;
+ my ($start) = shift;
+ my ($sparse) = shift;
+ my ($p, $i, $seg, @seg);
+
+
+ if ($sparse)
+ {
+ for ($i = 0; $i <= $#_; $i++)
+ {
+ if (!defined $seg && (($sparse != 2 && defined $_[$i]) || $_[$i] != 0))
+ { $seg->{'START'} = $start + $i; $seg->{'VAL'} = []; }
+
+ if (defined $seg && (($sparse == 2 && $_[$i] == 0) || !defined $_[$i]))
+ {
+ $seg->{'LEN'} = $start + $i - $seg->{'START'};
+ push(@seg, $seg);
+ $seg = undef;
+ } elsif (defined $seg)
+ { push (@{$seg->{'VAL'}}, $_[$i]); }
+ }
+ if (defined $seg)
+ {
+ push(@seg, $seg);
+ $seg->{'LEN'} = $start + $i - $seg->{'START'};
+ }
+ } else
+ {
+ $seg->{'START'} = $start;
+ $seg->{'LEN'} = $#_ + 1;
+ $seg->{'VAL'} = [@_];
+ @seg = ($seg);
+ }
+
+ for ($i = 0; $i <= $#$self; $i++)
+ {
+ if ($self->[$i]{'START'} > $start)
+ {
+ splice(@$self, $i, 0, @seg);
+ return wantarray ? @seg : scalar(@seg);
+ }
+ }
+ push(@$self, @seg);
+ return wantarray ? @seg : scalar(@seg);
+}
+
+
+=head2 $s->add_segment($start, $overwrite, @dat)
+
+Creates a new segment and adds it to the array allowing for possible overlaps
+between the new segment and the existing ones. In the case of overlaps, elements
+from the new segment are deleted unless $overwrite is set in which case the
+elements already there are over-written.
+
+This method also checks the data coming in to see if it is sparse (i.e. contains
+undef values). Gaps cause new segments to be created or not to over-write existing
+values.
+
+=cut
+
+sub add_segment
+{
+ my ($self) = shift;
+ my ($start) = shift;
+ my ($over) = shift;
+ my ($seg, $i, $s, $offset, $j, $newi);
+
+ return $self->fastadd_segment($start, $over, @_) if ($#$self < 0);
+ $offset = 0;
+ for ($i = 0; $i <= $#$self && $offset <= $#_; $i++)
+ {
+ $s = $self->[$i];
+ if ($s->{'START'} <= $start + $offset) # only < for $offset == 0
+ {
+ if ($s->{'START'} + $s->{'LEN'} > $start + $#_)
+ {
+ for ($j = $offset; $j <= $#_; $j++)
+ {
+ if ($over)
+ { $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
+ else
+ { $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
+ }
+ $offset = $#_ + 1;
+ last;
+ } elsif ($s->{'START'} + $s->{'LEN'} > $start + $offset) # is $offset needed here?
+ {
+ for ($j = $offset; $j < $s->{'START'} + $s->{'LEN'} - $start; $j++)
+ {
+ if ($over)
+ { $s->{'VAL'}[$start - $s->{'START'} + $j] = $_[$j] if defined $_[$j]; }
+ else
+ { $s->{'VAL'}[$start - $s->{'START'} + $j] ||= $_[$j] if defined $_[$j]; }
+ }
+ $offset = $s->{'START'} + $s->{'LEN'} - $start;
+ }
+ } else # new seg please
+ {
+ if ($s->{'START'} > $start + $#_ + 1)
+ {
+ $i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $#_]) - 1;
+ $offset = $#_ + 1;
+ }
+ else
+ {
+ $i += $self->fastadd_segment($start + $offset, 1, @_[$offset .. $s->{'START'} - $start]) - 1;
+ $offset = $s->{'START'} - $start + 1;
+ }
+ }
+ }
+ if ($offset <= $#_)
+ {
+ $seg->{'START'} = $start + $offset;
+ $seg->{'LEN'} = $#_ - $offset + 1;
+ $seg->{'VAL'} = [@_[$offset .. $#_]];
+ push (@$self, $seg);
+ }
+ $self->tidy;
+}
+
+
+=head2 $s->tidy
+
+Merges any immediately adjacent segments
+
+=cut
+
+sub tidy
+{
+ my ($self) = @_;
+ my ($i, $sl, $s);
+
+ for ($i = 1; $i <= $#$self; $i++)
+ {
+ $sl = $self->[$i - 1];
+ $s = $self->[$i];
+ if ($s->{'START'} == $sl->{'START'} + $sl->{'LEN'})
+ {
+ $sl->{'LEN'} += $s->{'LEN'};
+ push (@{$sl->{'VAL'}}, @{$s->{'VAL'}});
+ splice(@$self, $i, 1);
+ $i--;
+ }
+ }
+ $self;
+}
+
+
+=head2 $s->at($addr, [$len])
+
+Looks up the data held at the given address by locating the appropriate segment
+etc. If $len > 1 then returns an array of values, spaces being filled with undef.
+
+=cut
+
+sub at
+{
+ my ($self, $addr, $len) = @_;
+ my ($i, $dat, $s, @res, $offset);
+
+ $len = 1 unless defined $len;
+ $offset = 0;
+ for ($i = 0; $i <= $#$self; $i++)
+ {
+ $s = $self->[$i];
+ next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset); # only fires on $offset == 0
+ if ($s->{'START'} > $addr + $offset)
+ {
+ push (@res, (undef) x ($s->{'START'} > $addr + $len ?
+ $len - $offset : $s->{'START'} - $addr - $offset));
+ $offset = $s->{'START'} - $addr;
+ }
+ last if ($s->{'START'} >= $addr + $len);
+
+ if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
+ {
+ push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} ..
+ $addr + $len - $s->{'START'} - 1]);
+ $offset = $len;
+ last;
+ } else
+ {
+ push (@res, @{$s->{'VAL'}}[$addr + $offset - $s->{'START'} .. $s->{'LEN'} - 1]);
+ $offset = $s->{'START'} + $s->{'LEN'} - $addr;
+ }
+ }
+ push (@res, (undef) x ($len - $offset)) if ($offset < $len);
+ return wantarray ? @res : $res[0];
+}
+
+
+=head2 $s->remove($addr, [$len])
+
+Removes the item or items from addr returning them as an array or the first
+value in a scalar context. This is very like C<at>, including padding with
+undef, but it deletes stuff as it goes.
+
+=cut
+
+sub remove
+{
+ my ($self, $addr, $len) = @_;
+ my ($i, $dat, $s, @res, $offset);
+
+ $len = 1 unless defined $len;
+ $offset = 0;
+ for ($i = 0; $i <= $#$self; $i++)
+ {
+ $s = $self->[$i];
+ next if ($s->{'START'} + $s->{'LEN'} < $addr + $offset);
+ if ($s->{'START'} > $addr + $offset)
+ {
+ push (@res, (undef) x ($s->{'START'} > $addr + $len ?
+ $len - $offset : $s->{'START'} - $addr - $offset));
+ $offset = $s->{'START'} - $addr;
+ }
+ last if ($s->{'START'} >= $addr + $len);
+
+ unless ($s->{'START'} == $addr + $offset)
+ {
+ my ($seg) = {};
+
+ $seg->{'START'} = $s->{'START'};
+ $seg->{'LEN'} = $addr + $offset - $s->{'START'};
+ $seg->{'VAL'} = [splice(@{$s->{'VAL'}}, 0, $addr + $offset - $s->{'START'})];
+ $s->{'LEN'} -= $addr + $offset - $s->{'START'};
+ $s->{'START'} = $addr + $offset;
+
+ splice(@$self, $i, 0, $seg);
+ $i++;
+ }
+
+ if ($s->{'START'} + $s->{'LEN'} >= $addr + $len)
+ {
+ push (@res, splice(@{$s->{'VAL'}}, 0, $len - $offset));
+ $s->{'LEN'} -= $len - $offset;
+ $s->{'START'} += $len - $offset;
+ $offset = $len;
+ last;
+ } else
+ {
+ push (@res, @{$s->{'VAL'}});
+ $offset = $s->{'START'} + $s->{'LEN'} - $addr;
+ splice(@$self, $i, 0);
+ $i--;
+ }
+ }
+ push (@res, (undef) x ($len - $offset)) if ($offset < $len);
+ return wantarray ? @res : $res[0];
+}
+
+
+=head2 $s->copy
+
+Deep copies this array
+
+=cut
+
+sub copy
+{
+ my ($self) = @_;
+ my ($res, $p);
+
+ $res = [];
+ foreach $p (@$self)
+ { push (@$res, $self->copy_seg($p)); }
+ $res;
+}
+
+
+=head2 $s->copy_seg($seg)
+
+Creates a deep copy of a segment
+
+=cut
+
+sub copy_seg
+{
+ my ($self, $seg) = @_;
+ my ($p, $res);
+
+ $res = {};
+ $res->{'VAL'} = [@{$seg->{'VAL'}}];
+ foreach $p (keys %$seg)
+ { $res->{$p} = $seg->{$p} unless defined $res->{$p}; }
+ $res;
+}
+
+
+1;
+
+=head1 BUGS
+
+No known bugs.
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Table.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Table.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Table.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,382 @@
+package Font::TTF::Table;
+
+=head1 NAME
+
+Font::TTF::Table - Superclass for tables and used for tables we don't have a class for
+
+=head1 DESCRIPTION
+
+Looks after the purely table aspects of a TTF table, such as whether the table
+has been read before, locating the file pointer, etc. Also copies tables from
+input to output.
+
+=head1 INSTANCE VARIABLES
+
+Instance variables start with a space
+
+=over 4
+
+=item read
+
+Flag which indicates that the table has already been read from file.
+
+=item dat
+
+Allows the creation of unspecific tables. Data is simply output to any font
+file being created.
+
+=item INFILE
+
+The read file handle
+
+=item OFFSET
+
+Location of the file in the input file
+
+=item LENGTH
+
+Length in the input directory
+
+=item CSUM
+
+Checksum read from the input file's directory
+
+=item PARENT
+
+The L<Font::TTF::Font> that table is part of
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw($VERSION);
+use Font::TTF::Utils;
+
+$VERSION = 0.0001;
+
+=head2 Font::TTF::Table->new(%parms)
+
+Creates a new table or subclass. Table instance variables are passed in
+at this point as an associative array.
+
+=cut
+
+sub new
+{
+ my ($class, %parms) = @_;
+ my ($self) = {};
+ my ($p);
+
+ $class = ref($class) || $class;
+ foreach $p (keys %parms)
+ { $self->{" $p"} = $parms{$p}; }
+ bless $self, $class;
+}
+
+
+=head2 $t->read
+
+Reads the table from the input file. Acts as a superclass to all true tables.
+This method marks the table as read and then just sets the input file pointer
+but does not read any data. If the table has already been read, then returns
+C<undef> else returns C<$self>
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+
+ return $self->read_dat if (ref($self) eq qq/__PACKAGE__/);
+ return undef if $self->{' read'};
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $self->{' read'} = 1;
+ $self;
+}
+
+
+=head2 $t->read_dat
+
+Reads the table into the C<dat> instance variable for those tables which don't
+know any better
+
+=cut
+
+sub read_dat
+{
+ my ($self) = @_;
+
+# can't just $self->read here otherwise those tables which start their read sub with
+# $self->read_dat are going to permanently loop
+ return undef if ($self->{' read'});
+# $self->{' read'} = 1; # Let read do this, now out will call us for subclasses
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $self->{' INFILE'}->read($self->{' dat'}, $self->{' LENGTH'});
+ $self;
+}
+
+=head2 $t->out($fh)
+
+Writes out the table to the font file. If there is anything in the
+C<data> instance variable then this is output, otherwise the data is copied
+from the input file to the output
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($dat, $i, $len, $count);
+
+ if (defined $self->{' dat'})
+ {
+ $fh->print($self->{' dat'});
+ return $self;
+ }
+
+ return undef unless defined $self->{' INFILE'};
+ $self->{' INFILE'}->seek($self->{' OFFSET'}, 0);
+ $len = $self->{' LENGTH'};
+ while ($len > 0)
+ {
+ $count = ($len > 4096) ? 4096 : $len;
+ $self->{' INFILE'}->read($dat, $count);
+ $fh->print($dat);
+ $len -= $count;
+ }
+ $self;
+}
+
+
+=head2 $t->out_xml($context)
+
+Outputs this table in XML format. The table is first read (if not already read) and then if
+there is no subclass, then the data is dumped as hex data
+
+=cut
+
+sub out_xml
+{
+ my ($self, $context, $depth) = @_;
+ my ($k);
+
+ if (ref($self) eq __PACKAGE__)
+ {
+ $self->read_dat;
+ Font::TTF::Utils::XML_hexdump($context, $depth, $self->{' dat'});
+ }
+ else
+ {
+ $self->read;
+ foreach $k (sort grep {$_ !~ m/^\s/o} keys %{$self})
+ {
+ $self->XML_element($context, $depth, $k, $self->{$k});
+ }
+ }
+ $self;
+}
+
+
+=head2 $t->XML_element
+
+Output a particular element based on its contents.
+
+=cut
+
+sub XML_element
+{
+ my ($self, $context, $depth, $k, $dat) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($ndepth, $d);
+
+ return unless defined $dat;
+
+ if (!ref($dat))
+ {
+ $fh->printf("%s<%s>%s</%s>\n", $depth, $k, $dat, $k);
+ return $self;
+ }
+
+ $fh->printf("%s<%s>\n", $depth, $k);
+ $ndepth = $depth . $context->{'indent'};
+
+ if (ref($dat) eq 'SCALAR')
+ { $self->XML_element($context, $ndepth, 'scalar', $$dat); }
+ elsif (ref($dat) eq 'ARRAY')
+ {
+ foreach $d (@{$dat})
+ { $self->XML_element($context, $ndepth, 'elem', $d); }
+ }
+ elsif (ref($dat) eq 'HASH')
+ {
+ foreach $d (sort grep {$_ !~ m/^\s/o} keys %{$dat})
+ { $self->XML_element($context, $ndepth, $d, $dat->{$d}); }
+ }
+ else
+ {
+ $context->{'name'} = ref($dat);
+ $context->{'name'} =~ s/^.*://o;
+ $dat->out_xml($context, $ndepth);
+ }
+
+ $fh->printf("%s</%s>\n", $depth, $k);
+ $self;
+}
+
+
+=head2 $t->XML_end($context, $tag, %attrs)
+
+Handles the default type of <data> for those tables which aren't subclassed
+
+=cut
+
+sub XML_end
+{
+ my ($self, $context, $tag, %attrs) = @_;
+ my ($dat, $addr);
+
+ return undef unless ($tag eq 'data');
+ $dat = $context->{'text'};
+ $dat =~ s/([0-9a-f]{2})\s*/hex($1)/oig;
+ if (defined $attrs{'addr'})
+ { $addr = hex($attrs{'addr'}); }
+ else
+ { $addr = length($self->{' dat'}); }
+ substr($self->{' dat'}, $addr, length($dat)) = $dat;
+ return $context;
+}
+
+
+=head2 $t->dirty($val)
+
+This sets the dirty flag to the given value or 1 if no given value. It returns the
+value of the flag
+
+=cut
+
+sub dirty
+{
+ my ($self, $val) = @_;
+ my ($res) = $self->{' isDirty'};
+
+ $self->{' isDirty'} = defined $val ? $val : 1;
+ $res;
+}
+
+=head2 $t->update
+
+Each table knows how to update itself. This consists of doing whatever work
+is required to ensure that the memory version of the table is consistent
+and that other parameters in other tables have been updated accordingly.
+I.e. by the end of sending C<update> to all the tables, the memory version
+of the font should be entirely consistent.
+
+Some tables which do no work indicate to themselves the need to update
+themselves by setting isDirty above 1. This method resets that accordingly.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+
+ if ($self->{' isDirty'})
+ {
+ $self->read;
+ $self->{' isDirty'} = 0;
+ return $self;
+ }
+ else
+ { return undef; }
+}
+
+
+=head2 $t->empty
+
+Clears a table of all data to the level of not having been read
+
+=cut
+
+sub empty
+{
+ my ($self) = @_;
+ my (%keep);
+
+ foreach (qw(INFILE LENGTH OFFSET CSUM PARENT))
+ { $keep{" $_"} = 1; }
+
+ map {delete $self->{$_} unless $keep{$_}} keys %$self;
+ $self;
+}
+
+
+=head2 $t->release
+
+Releases ALL of the memory used by this table, and all of its component/child
+objects. This method is called automatically by
+'C<Font::TTF::Font-E<GT>release>' (so you don't have to call it yourself).
+
+B<NOTE>, that it is important that this method get called at some point prior
+to the actual destruction of the object. Internally, we track things in a
+structure that can result in circular references, and without calling
+'C<release()>' these will not properly get cleaned up by Perl. Once this
+method has been called, though, don't expect to be able to do anything with the
+C<Font::TTF::Table> object; it'll have B<no> internal state whatsoever.
+
+B<Developer note:> As part of the brute-force cleanup done here, this method
+will throw a warning message whenever unexpected key values are found within
+the C<Font::TTF::Table> object. This is done to help ensure that any
+unexpected and unfreed values are brought to your attention so that you can bug
+us to keep the module updated properly; otherwise the potential for memory
+leaks due to dangling circular references will exist.
+
+=cut
+
+sub release
+{
+ my ($self) = @_;
+
+# delete stuff that we know we can, here
+
+ my @tofree = map { delete $self->{$_} } keys %{$self};
+
+ while (my $item = shift @tofree)
+ {
+ my $ref = ref($item);
+ if (UNIVERSAL::can($item, 'release'))
+ { $item->release(); }
+ elsif ($ref eq 'ARRAY')
+ { push( @tofree, @{$item} ); }
+ elsif (UNIVERSAL::isa($ref, 'HASH'))
+ { release($item); }
+ }
+
+# check that everything has gone - it better had!
+ foreach my $key (keys %{$self})
+ { warn ref($self) . " still has '$key' key left after release.\n"; }
+}
+
+
+sub __dumpvar__
+{
+ my ($self, $key) = @_;
+
+ return ($key eq ' PARENT' ? '...parent...' : $self->{$key});
+}
+
+1;
+
+=head1 BUGS
+
+No known bugs
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttc.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttc.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttc.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,164 @@
+package Font::TTF::Ttc;
+
+=head1 NAME
+
+Font::TTF::Ttc - Truetype Collection class
+
+=head1 DESCRIPTION
+
+A TrueType collection is a collection of TrueType fonts in one file in which
+tables may be shared between different directories. In order to support this,
+the TTC introduces the concept of a table being shared by different TrueType
+fonts. This begs the question of what should happen to the ' PARENT' property
+of a particular table. It is made to point to the first directory object which
+refers to it. It is therefore up to the application to sort out any confusion.
+Confusion only occurs if shared tables require access to non-shared tables.
+This should not happen since the shared tables are dealing with glyph
+information only and the private tables are dealing with encoding and glyph
+identification. Thus the general direction is from identification to glyph and
+not the other way around (at least not without knowledge of the particular
+context).
+
+=head1 INSTANCE VARIABLES
+
+The following instance variables are preceded by a space
+
+=over 4
+
+=item fname (P)
+
+Filename for this TrueType Collection
+
+=item INFILE (P)
+
+The filehandle of this collection
+
+=back
+
+The following instance variable does not start with a space
+
+=over 4
+
+=item directs
+
+An array of directories (Font::TTF::Font objects) for each sub-font in the directory
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw($VERSION);
+
+use IO::File;
+
+$VERSION = 0.0001;
+
+=head2 Font::TTF::Ttc->open($fname)
+
+Opens and reads the given filename as a TrueType Collection. Reading a collection
+involves reading each of the directories which go to make up the collection.
+
+=cut
+
+sub open
+{
+ my ($class, $fname) = @_;
+ my ($self) = {};
+ my ($fh);
+
+ unless (ref($fname))
+ {
+ $fh = IO::File->new($fname) or return undef;
+ binmode $fh;
+ } else
+ { $fh = $fname; }
+
+ bless $self, $class;
+ $self->{' INFILE'} = $fh;
+ $self->{' fname'} = $fname;
+ $fh->seek(0, 0);
+ $self->read;
+}
+
+
+=head2 $c->read
+
+Reads a Collection by reading all the directories in the collection
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($fh) = $self->{' INFILE'};
+ my ($dat, $ttc, $ver, $num, $i, $loc);
+
+ $fh->read($dat, 12);
+ ($ttc, $ver, $num) = unpack("A4N2", $dat);
+
+ return undef unless $ttc eq "ttcf";
+ $fh->read($dat, $num << 2);
+ for ($i = 0; $i < $num; $i++)
+ {
+ $loc = unpack("N", substr($dat, $i << 2, 4));
+ $self->{'directs'}[$i] = Font::TTF::Font->new('INFILE' => $fh,
+ 'PARENT' => $self,
+ 'OFFSET' => $loc) || return undef;
+ }
+ for ($i = 0; $i < $num; $i++)
+ { $self->{'directs'}[$i]->read; }
+ $self;
+}
+
+
+=head2 $c->find($direct, $name, $check, $off, $len)
+
+Hunts around to see if a table with the given characteristics of name, checksum,
+offset and length has been associated with a directory earlier in the list.
+Actually on checks the offset since no two tables can share the same offset in
+a TrueType font, collection or otherwise.
+
+=cut
+
+sub find
+{
+ my ($self, $direct, $name, $check, $off, $len) = @_;
+ my ($d);
+
+ foreach $d (@{$self->{'directs'}})
+ {
+ return undef if $d eq $direct;
+ next unless defined $d->{$name};
+ return $d->{$name} if ($d->{$name}{' OFFSET'} == $off);
+ }
+ undef; # wierd that the font passed is not in the list!
+}
+
+
+=head2 $c->DESTROY
+
+Closees any opened files by us
+
+=cut
+
+sub DESTROY
+{
+ my ($self) = @_;
+ close ($self->{' INFILE'});
+ undef;
+}
+
+=head1 BUGS
+
+No known bugs, but then not ever executed!
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttopen.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttopen.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Ttopen.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,1068 @@
+package Font::TTF::Ttopen;
+
+=head1 NAME
+
+Font::TTF::ttopen - Opentype superclass for standard Opentype lookup based tables
+(GSUB and GPOS)
+
+=head1 DESCRIPTION
+
+Handles all the script, lang, feature, lookup stuff for a
+L<Font::TTF::Gsub>/L<Font::TTF::Gpos> table leaving the class specifics to the
+subclass
+
+=head1 INSTANCE VARIABLES
+
+The instance variables of an opentype table form a complex sub-module hierarchy.
+
+=over 4
+
+=item Version
+
+This contains the version of the table as a floating point number
+
+=item SCRIPTS
+
+The scripts list is a hash of script tags. Each script tag (of the form
+$t->{'SCRIPTS'}{$tag}) has information below it.
+
+=over 8
+
+=item OFFSET
+
+This variable is preceeded by a space and gives the offset from the start of the
+table (not the table section) to the script table for this script
+
+=item REFTAG
+
+This variable is preceded by a space and gives a corresponding script tag to this
+one such that the offsets in the file are the same. When writing, it is up to the
+caller to ensure that the REFTAGs are set correctly, since these will be used to
+assume that the scripts are identical. Note that REFTAG must refer to a script which
+has no REFTAG of its own.
+
+=item DEFAULT
+
+This corresponds to the default language for this script, if there is one, and
+contains the same information as an itemised language
+
+=item LANG_TAGS
+
+This contains an array of language tag strings (each 4 bytes) corresponding to
+the languages listed by this script
+
+=item $lang
+
+Each language is a hash containing its information:
+
+=over 12
+
+=item OFFSET
+
+This variable is preceeded by a a space and gives the offset from the start of
+the whole table to the language table for this language
+
+=item REFTAG
+
+This variable is preceded by a space and has the same function as for the script
+REFTAG, only for the languages within a script.
+
+=item RE-ORDER
+
+This indicates re-ordering information, and has not been set. The value should
+always be 0.
+
+=item DEFAULT
+
+This holds the index of the default feature, if there is one, or -1 otherwise.
+
+=item FEATURES
+
+This is an array of feature indices which index into the FEATURES instance
+variable of the table
+
+=back
+
+=back
+
+=item FEATURES
+
+The features section of instance variables corresponds to the feature table in
+the opentype table.
+
+=over 8
+
+=item FEAT_TAGS
+
+This array gives the ordered list of feature tags for this table. It is used during
+reading and writing for converting between feature index and feature tag.
+
+=back
+
+The rest of the FEATURES variable is itself a hash based on the feature tag for
+each feature. Each feature has the following structure:
+
+=over 8
+
+=item OFFSET
+
+This attribute is preceeded by a space and gives the offset relative to the start of the whole
+table of this particular feature.
+
+=item PARMS
+
+This is an unused offset to the parameters for each feature
+
+=item LOOKUPS
+
+This is an array containing indices to lookups in the LOOKUP instance variable of the table
+
+=item INDEX
+
+This gives the feature index for this feature and is used during reading and writing for
+converting between feature tag and feature index.
+
+=back
+
+=item LOOKUP
+
+This variable is an array of lookups in order and is indexed via the features of a language of a
+script. Each lookup contains subtables and other information:
+
+=over 8
+
+=item OFFSET
+
+This name is preceeded by a space and contains the offset from the start of the table to this
+particular lookup
+
+=item TYPE
+
+This is a subclass specific type for a lookup. It stipulates the type of lookup and hence subtables
+within the lookup
+
+=item FLAG
+
+Holds the lookup flag bits
+
+=item SUB
+
+This holds an array of subtables which are subclass specific. Each subtable must have
+an OFFSET. The other variables described here are an abstraction used in both the
+GSUB and GPOS tables which are the target subclasses of this class.
+
+=over 12
+
+=item OFFSET
+
+This is preceeded by a space and gives the offset relative to the start of the table for this
+subtable
+
+=item FORMAT
+
+Gives the sub-table sub format for this GSUB subtable. It is assumed that this
+value is correct when it comes time to write the subtable.
+
+=item COVERAGE
+
+Most lookups consist of a coverage table corresponding to the first
+glyph to match. The offset of this coverage table is stored here and the coverage
+table looked up against the GSUB table proper. There are two lookups
+without this initial coverage table which is used to index into the RULES array.
+These lookups have one element in the RULES array which is used for the whole
+match.
+
+=item RULES
+
+The rules are a complex array. Each element of the array corresponds to an
+element in the coverage table (governed by the coverage index). If there is
+no coverage table, then there is considered to be only one element in the rules
+array. Each element of the array is itself an array corresponding to the
+possibly multiple string matches which may follow the initial glyph. Each
+element of this array is a hash with fixed keys corresponding to information
+needed to match a glyph string or act upon it. Thus the RULES element is an
+array of arrays of hashes which contain the following keys:
+
+=over 16
+
+=item MATCH
+
+This contains a sequence of elements held as an array. The elements may be
+glyph ids (gid), class ids (cids), or offsets to coverage tables. Each element
+corresponds to one glyph in the glyph string. See MATCH_TYPE for details of
+how the different element types are marked.
+
+=item PRE
+
+This array holds the sequence of elements preceeding the first match element
+and has the same form as the MATCH array.
+
+=item POST
+
+This array holds the sequence of elements to be tested for following the match
+string and is of the same form as the MATCH array.
+
+=item ACTION
+
+This array holds information regarding what should be done if a match is found.
+The array may either hold glyph ids (which are used to replace or insert or
+whatever glyphs in the glyph string) or 2 element arrays consisting of:
+
+=over 20
+
+=item OFFSET
+
+Offset from the start of the matched string that the lookup should start at
+when processing the substring.
+
+=item LOOKUP_INDEX
+
+The index to a lookup to be acted upon on the match string.
+
+=back
+
+=back
+
+=back
+
+=back
+
+=item CLASS
+
+For those lookups which use class categories rather than glyph ids for matching
+this is the offset to the class definition used to categories glyphs in the
+match string.
+
+=item PRE_CLASS
+
+This is the offset to the class definition for the before match glyphs
+
+=item POST_CLASS
+
+This is the offset to the class definition for the after match glyphs.
+
+=item ACTION_TYPE
+
+This string holds the type of information held in the ACTION variable of a RULE.
+It is subclass specific.
+
+=item MATCH_TYPE
+
+This holds the type of information in the MATCH array of a RULE. This is subclass
+specific.
+
+=item ADJUST
+
+This corresponds to a single action for all items in a coverage table. The meaning
+is subclass specific.
+
+=item CACHE
+
+This key starts with a space
+
+A hash of other tables (such as coverage tables, classes, anchors, device tables)
+based on the offset given in the subtable to that other information.
+Note that the documentation is particularly
+unhelpful here in that such tables are given as offsets relative to the
+beginning of the subtable not the whole GSUB table. This includes those items which
+are stored relative to another base within the subtable.
+
+=back
+
+
+=head1 METHODS
+
+=cut
+
+use Font::TTF::Table;
+use Font::TTF::Utils;
+use Font::TTF::Coverage;
+use strict;
+use vars qw(@ISA);
+
+ at ISA = qw(Font::TTF::Table);
+
+=head2 $t->read
+
+Reads the table passing control to the subclass to handle the subtable specifics
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat, $i, $l, $oScript, $oFeat, $oLook, $tag, $nScript, $off, $dLang, $nLang, $lTag);
+ my ($nFeat, $nLook, $nSub, $j, $temp);
+ my ($fh) = $self->{' INFILE'};
+ my ($moff) = $self->{' OFFSET'};
+
+ $self->SUPER::read or return $self;
+ $fh->read($dat, 10);
+ ($self->{'Version'}, $oScript, $oFeat, $oLook) = TTF_Unpack("fSSS", $dat);
+
+# read features first so that in the script/lang hierarchy we can use feature tags
+
+ $fh->seek($moff + $oFeat, 0);
+ $fh->read($dat, 2);
+ $nFeat = unpack("n", $dat);
+ $self->{'FEATURES'} = {};
+ $l = $self->{'FEATURES'};
+ $fh->read($dat, 6 * $nFeat);
+ for ($i = 0; $i < $nFeat; $i++)
+ {
+ ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
+ while (defined $l->{$tag})
+ {
+ if ($tag =~ m/(.*?)\s_(\d+)$/o)
+ { $tag = $1 . " _" . ($2 + 1); }
+ else
+ { $tag .= " _0"; }
+ }
+ $l->{$tag}{' OFFSET'} = $off + $oFeat;
+ $l->{$tag}{'INDEX'} = $i;
+ push (@{$l->{'FEAT_TAGS'}}, $tag);
+ }
+
+ foreach $tag (grep {length($_) == 4} keys %$l)
+ {
+ $fh->seek($moff + $l->{$tag}{' OFFSET'}, 0);
+ $fh->read($dat, 4);
+ ($l->{$tag}{'PARMS'}, $nLook) = unpack("n2", $dat);
+ $fh->read($dat, $nLook * 2);
+ $l->{$tag}{'LOOKUPS'} = [unpack("n*", $dat)];
+ }
+
+# Now the script/lang hierarchy
+
+ $fh->seek($moff + $oScript, 0);
+ $fh->read($dat, 2);
+ $nScript = unpack("n", $dat);
+ $self->{'SCRIPTS'} = {};
+ $l = $self->{'SCRIPTS'};
+ $fh->read($dat, 6 * $nScript);
+ for ($i = 0; $i < $nScript; $i++)
+ {
+ ($tag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
+ $off += $oScript;
+ foreach (keys %$l)
+ { $l->{$tag}{' REFTAG'} = $_ if ($l->{$_}{' OFFSET'} == $off
+ && !defined $l->{$_}{' REFTAG'}); }
+ $l->{$tag}{' OFFSET'} = $off;
+ }
+
+ foreach $tag (keys %$l)
+ {
+ next if ($l->{$tag}{' REFTAG'});
+ $fh->seek($moff + $l->{$tag}{' OFFSET'}, 0);
+ $fh->read($dat, 4);
+ ($dLang, $nLang) = unpack("n2", $dat);
+ $l->{$tag}{'DEFAULT'}{' OFFSET'} =
+ $dLang + $l->{$tag}{' OFFSET'} if $dLang;
+ $fh->read($dat, 6 * $nLang);
+ for ($i = 0; $i < $nLang; $i++)
+ {
+ ($lTag, $off) = unpack("a4n", substr($dat, $i * 6, 6));
+ $off += $l->{$tag}{' OFFSET'};
+ $l->{$tag}{$lTag}{' OFFSET'} = $off;
+ foreach (@{$l->{$tag}{'LANG_TAGS'}})
+ { $l->{$tag}{$lTag}{' REFTAG'} = $_ if ($l->{$tag}{$_}{' OFFSET'} == $off
+ && !$l->{$tag}{$_}{' REFTAG'}); }
+ push (@{$l->{$tag}{'LANG_TAGS'}}, $lTag);
+ }
+ foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
+ {
+ next unless defined $l->{$tag}{$lTag};
+ next if ($l->{$tag}{$lTag}{' REFTAG'});
+ $fh->seek($moff + $l->{$tag}{$lTag}{' OFFSET'}, 0);
+ $fh->read($dat, 6);
+ ($l->{$tag}{$lTag}{'RE-ORDER'}, $l->{$tag}{$lTag}{'DEFAULT'}, $nFeat)
+ = unpack("n3", $dat);
+ $fh->read($dat, $nFeat * 2);
+ $l->{$tag}{$lTag}{'FEATURES'} = [map {$self->{'FEATURES'}{'FEAT_TAGS'}[$_]} unpack("n*", $dat)];
+ }
+ foreach $lTag (@{$l->{$tag}{'LANG_TAGS'}}, 'DEFAULT')
+ {
+ next unless $l->{$tag}{$lTag}{' REFTAG'};
+ $temp = $l->{$tag}{$lTag}{' REFTAG'};
+ $l->{$tag}{$lTag} = ©($l->{$tag}{$temp});
+ $l->{$tag}{$lTag}{' REFTAG'} = $temp;
+ }
+ }
+ foreach $tag (keys %$l)
+ {
+ next unless $l->{$tag}{' REFTAG'};
+ $temp = $l->{$tag}{' REFTAG'};
+ $l->{$tag} = ©($l->{$temp});
+ $l->{$tag}{' REFTAG'} = $temp;
+ }
+
+# And finally the lookups
+
+ $fh->seek($moff + $oLook, 0);
+ $fh->read($dat, 2);
+ $nLook = unpack("n", $dat);
+ $fh->read($dat, $nLook * 2);
+ $i = 0;
+ map { $self->{'LOOKUP'}[$i++]{' OFFSET'} = $_; } unpack("n*", $dat);
+
+ for ($i = 0; $i < $nLook; $i++)
+ {
+ $l = $self->{'LOOKUP'}[$i];
+ $fh->seek($l->{' OFFSET'} + $moff + $oLook, 0);
+ $fh->read($dat, 6);
+ ($l->{'TYPE'}, $l->{'FLAG'}, $nSub) = unpack("n3", $dat);
+ $fh->read($dat, $nSub * 2);
+ $j = 0;
+ map { $l->{'SUB'}[$j]{' OFFSET'} = $_; } unpack("n*", $dat);
+ for ($j = 0; $j < $nSub; $j++)
+ {
+ $fh->seek($moff + $oLook + $l->{' OFFSET'} + $l->{'SUB'}[$j]{' OFFSET'}, 0);
+ $self->read_sub($fh, $l, $j);
+ }
+ }
+ return $self;
+}
+
+=head2 $t->read_sub($fh, $lookup, $index)
+
+This stub is to allow subclasses to read subtables of lookups in a table specific manner. A
+reference to the lookup is passed in along with the subtable index. The file is located at the
+start of the subtable to be read
+
+=cut
+
+sub read_sub
+{ }
+
+
+=head2 $t->extension()
+
+Returns the lookup number for the extension table that allows access to 32-bit offsets.
+
+=cut
+
+sub extension
+{ }
+
+
+=head2 $t->out($fh)
+
+Writes this Opentype table to the output calling $t->out_sub for each sub table
+at the appropriate point in the output. The assumption is that on entry the
+number of scripts, languages, features, lookups, etc. are all resolved and
+the relationships fixed. This includes a script's LANG_TAGS list and that all
+scripts and languages in their respective dictionaries either have a REFTAG or contain
+real data.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($i, $j, $base, $off, $tag, $t, $l, $lTag, $oScript, @script, @tags);
+ my ($end, $nTags, @offs, $oFeat, $oLook, $nSub, $nSubs, $big);
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+# First sort the features
+ $i = 0;
+ $self->{'FEATURES'}{'FEAT_TAGS'} = [sort grep {length($_) == 4 || m/\s_\d+$/o} %{$self->{'FEATURES'}}]
+ if (!defined $self->{'FEATURES'}{'FEAT_TAGS'});
+ foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
+ { $self->{'FEATURES'}{$t}{'INDEX'} = $i++; }
+
+ $base = $fh->tell();
+ $fh->print(TTF_Pack("f", $self->{'Version'}));
+ $fh->print(pack("n3", 10, 0, 0));
+ $oScript = $fh->tell() - $base;
+ @script = sort grep {length($_) == 4} keys %{$self->{'SCRIPTS'}};
+ $fh->print(pack("n", $#script + 1));
+ foreach $t (@script)
+ { $fh->print(pack("a4n", $t, 0)); }
+
+ $end = $fh->tell();
+ foreach $t (@script)
+ {
+ $fh->seek($end, 0);
+ $tag = $self->{'SCRIPTS'}{$t};
+ next if ($tag->{' REFTAG'});
+ $tag->{' OFFSET'} = tell($fh) - $base - $oScript;
+ $fh->print(pack("n2", 0, $#{$tag->{'LANG_TAGS'}} + 1));
+ foreach $lTag (sort @{$tag->{'LANG_TAGS'}})
+ { $fh->print(pack("a4n", $lTag, 0)); }
+ foreach $lTag (@{$tag->{'LANG_TAGS'}}, 'DEFAULT')
+ {
+ my ($def);
+ $l = $tag->{$lTag};
+ next if (!defined $l || $l->{' REFTAG'} ne '');
+ $l->{' OFFSET'} = tell($fh) - $base - $oScript - $tag->{' OFFSET'};
+ if (defined $l->{'DEFAULT'})
+# { $def = $self->{'FEATURES'}{$l->{'FEATURES'}[$l->{'DEFAULT'}]}{'INDEX'}; }
+ { $def = $l->{'DEFAULT'}; }
+ else
+ { $def = -1; }
+ $fh->print(pack("n*", $l->{'RE_ORDER'}, $def, $#{$l->{'FEATURES'}} + 1,
+ map {$self->{'FEATURES'}{$_}{'INDEX'}} @{$l->{'FEATURES'}}));
+ }
+ $end = $fh->tell();
+ if ($tag->{'DEFAULT'}{' REFTAG'} || defined $tag->{'DEFAULT'}{'FEATURES'})
+ {
+ $fh->seek($base + $oScript + $tag->{' OFFSET'}, 0);
+ $off = $tag->{'DEFAULT'}{' REFTAG'} ?
+ $tag->{$tag->{'DEFAULT'}{' REFTAG'}}{' OFFSET'} :
+ $tag->{'DEFAULT'}{' OFFSET'};
+ $fh->print(pack("n", $off));
+ }
+ $fh->seek($base + $oScript + $tag->{' OFFSET'} + 4, 0);
+ foreach (sort @{$tag->{'LANG_TAGS'}})
+ {
+ $off = $tag->{$_}{' REFTAG'} ? $tag->{$tag->{$_}{' REFTAG'}}{' OFFSET'} :
+ $tag->{$_}{' OFFSET'};
+ $fh->print(pack("a4n", $_, $off));
+ }
+ }
+ $fh->seek($base + $oScript + 2, 0);
+ foreach $t (@script)
+ {
+ $tag = $self->{'SCRIPTS'}{$t};
+ $off = $tag->{' REFTAG'} ? $tag->{$tag->{' REFTAG'}}{' OFFSET'} : $tag->{' OFFSET'};
+ $fh->print(pack("a4n", $t, $off));
+ }
+
+ $fh->seek($end, 0);
+ $oFeat = $end - $base;
+ $nTags = $#{$self->{'FEATURES'}{'FEAT_TAGS'}} + 1;
+ $fh->print(pack("n", $nTags));
+ $fh->print(pack("a4n", " ", 0) x $nTags);
+
+ foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
+ {
+ $tag = $self->{'FEATURES'}{$t};
+ $tag->{' OFFSET'} = tell($fh) - $base - $oFeat;
+ $fh->print(pack("n*", 0, $#{$tag->{'LOOKUPS'}} + 1, @{$tag->{'LOOKUPS'}}));
+ }
+ $end = $fh->tell();
+ $fh->seek($oFeat + $base + 2, 0);
+ foreach $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
+ { $fh->print(pack("a4n", $t, $self->{'FEATURES'}{$t}{' OFFSET'})); }
+
+ undef $big;
+ $fh->seek($end, 0);
+ $oLook = $end - $base;
+ $nTags = $#{$self->{'LOOKUP'}} + 1;
+ $fh->print(pack("n", $nTags));
+ $fh->print(pack("n", 0) x $nTags);
+ $end = $fh->tell();
+ foreach $tag (@{$self->{'LOOKUP'}})
+ { $nSubs += $self->num_sub($tag); }
+ for ($i = 0; $i < $nTags; $i++)
+ {
+ $fh->seek($end, 0);
+ $tag = $self->{'LOOKUP'}[$i];
+ $tag->{' OFFSET'} = $end - $base - $oLook;
+ if (!defined $big && $tag->{' OFFSET'} + ($nTags - $i) * 6 + $nSubs * 10 > 65535)
+ {
+ my ($k, $ext);
+ $ext = $self->extension();
+ $i--;
+ $tag = $self->{'LOOKUP'}[$i];
+ $end = $tag->{' OFFSET'} + $base + $oLook;
+ $fh->seek($end, 0);
+ $big = $i;
+ for ($j = $i; $j < $nTags; $j++)
+ {
+ $tag = $self->{'LOOKUP'}[$j];
+ $nSub = $self->num_sub($tag);
+ $fh->print(pack("nnn", $ext, $tag->{'FLAG'}, $nSub));
+ $fh->print(pack("n*", map {$_ * 8 + 6 + $nSub * 2} (1 .. $nSub)));
+ $tag->{' EXT_OFFSET'} = $fh->tell();
+ $tag->{' OFFSET'} = $tag->{' EXT_OFFSET'} - $nSub * 2 - 6 - $base - $oLook;
+ for ($k = 0; $k < $nSub; $k++)
+ { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, 0)); }
+ }
+ $tag = $self->{'LOOKUP'}[$i];
+ }
+ $nSub = $self->num_sub($tag);
+ if (!defined $big)
+ {
+ $fh->print(pack("nnn", $tag->{'TYPE'}, $tag->{'FLAG'}, $nSub));
+ $fh->print(pack("n", 0) x $nSub);
+ }
+ else
+ { $end = $tag->{' EXT_OFFSET'}; }
+ @offs = ();
+ for ($j = 0; $j < $nSub; $j++)
+ {
+ push(@offs, tell($fh) - $end);
+ $self->out_sub($fh, $tag, $j);
+ }
+ $end = $fh->tell();
+ if (!defined $big)
+ {
+ $fh->seek($tag->{' OFFSET'} + $base + $oLook + 6, 0);
+ $fh->print(pack("n*", @offs));
+ }
+ else
+ {
+ $fh->seek($tag->{' EXT_OFFSET'}, 0);
+ for ($j = 0; $j < $nSub; $j++)
+ { $fh->print(pack('nnN', 1, $tag->{'TYPE'}, $offs[$j] - $j * 8)); }
+ }
+ }
+ $fh->seek($oLook + $base + 2, 0);
+ $fh->print(pack("n*", map {$self->{'LOOKUP'}[$_]{' OFFSET'}} (0 .. $nTags - 1)));
+ $fh->seek($base + 6, 0);
+ $fh->print(pack('n2', $oFeat, $oLook));
+ $fh->seek($end, 0);
+ $self;
+}
+
+
+=head2 $t->num_sub($lookup)
+
+Asks the subclass to count the number of subtables for a particular lookup and to
+return that value. Used in out().
+
+=cut
+
+sub num_sub
+{
+ my ($self, $lookup) = @_;
+
+ return $#{$lookup->{'SUB'}} + 1;
+}
+
+
+=head2 $t->out_sub($fh, $lookup, $index)
+
+This stub is to allow subclasses to output subtables of lookups in a table specific manner. A
+reference to the lookup is passed in along with the subtable index. The file is located at the
+start of the subtable to be output
+
+=cut
+
+sub out_sub
+{ }
+
+
+=head1 Internal Functions & Methods
+
+Most of these methods are used by subclasses for handling such things as coverage
+tables.
+
+=head2 copy($ref)
+
+Internal function to copy the top level of a dictionary to create a new dictionary.
+Only the top level is copied.
+
+=cut
+
+sub copy
+{
+ my ($ref) = @_;
+ my ($res) = {};
+
+ foreach (keys %$ref)
+ { $res->{$_} = $ref->{$_}; }
+ $res;
+}
+
+
+=head2 $t->read_cover($cover_offset, $lookup_loc, $lookup, $fh, $is_cover)
+
+Reads a coverage table and stores the results in $lookup->{' CACHE'}, that is, if
+it hasn't been read already.
+
+=cut
+
+sub read_cover
+{
+ my ($self, $offset, $base, $lookup, $fh, $is_cover) = @_;
+ my ($loc) = $fh->tell();
+ my ($cover, $str);
+
+ return undef unless $offset;
+ $str = sprintf("%X", $base + $offset);
+ return $lookup->{' CACHE'}{$str} if defined $lookup->{' CACHE'}{$str};
+ $fh->seek($base + $offset, 0);
+ $cover = Font::TTF::Coverage->new($is_cover)->read($fh);
+ $fh->seek($loc, 0);
+ $lookup->{' CACHE'}{$str} = $cover;
+ return $cover;
+}
+
+
+=head2 ref_cache($obj, $cache, $offset)
+
+Internal function to keep track of the local positioning of subobjects such as
+coverage and class definition tables, and their offsets.
+What happens is that the cache is a hash of
+sub objects indexed by the reference (using a string mashing of the
+reference name which is valid for the duration of the reference) and holds a
+list of locations in the output string which should be filled in with the
+offset to the sub object when the final string is output in out_final.
+
+Uses tricks for Tie::Refhash
+
+=cut
+
+sub ref_cache
+{
+ my ($obj, $cache, $offset) = @_;
+
+ return 0 unless defined $obj;
+ $cache->{"$obj"}[0] = $obj unless defined $cache->{"$obj"};
+ push (@{$cache->{"$obj"}[1]}, $offset);
+ return 0;
+}
+
+
+=head2 out_final($fh, $out, $cache_list, $state)
+
+Internal function to actually output everything to the file handle given that
+now we know the offset to the first sub object to be output and which sub objects
+are to be output and what locations need to be updated, we can now
+generate everything. $cache_list is an array of two element arrays. The first element
+is a cache object, the second is an offset to be subtracted from each reference
+to that object made in the cache.
+
+If $state is 1, then the output is not sent to the filehandle and the return value
+is the string to be output. If $state is absent or 0 then output is not limited
+by storing in a string first and the return value is "";
+
+=cut
+
+sub out_final
+{
+ my ($fh, $out, $cache_list, $state) = @_;
+ my ($len) = length($out);
+ my ($base_loc) = $state ? 0 : $fh->tell();
+ my ($loc, $t, $r, $s, $master_cache, $offs, $str);
+
+ $fh->print($out) unless $state; # first output the current attempt
+ foreach $r (@$cache_list)
+ {
+ $offs = $r->[1];
+ foreach $t (sort keys %{$r->[0]})
+ {
+ $str = "$t";
+ if (!defined $master_cache->{$str})
+ {
+ $master_cache->{$str} = ($state ? length($out) : $fh->tell())
+ - $base_loc;
+ if ($state)
+ { $out .= $r->[0]{$str}[0]->out($fh, 1); }
+ else
+ { $r->[0]{$str}[0]->out($fh, 0); }
+ }
+ foreach $s (@{$r->[0]{$str}[1]})
+ { substr($out, $s, 2) = pack('n', $master_cache->{$str} - $offs); }
+ }
+ }
+ if ($state)
+ { return $out; }
+ else
+ {
+ $loc = $fh->tell();
+ $fh->seek($base_loc, 0);
+ $fh->print($out); # the corrected version
+ $fh->seek($loc, 0);
+ }
+}
+
+
+=head2 $self->read_context($lookup, $fh, $type, $fmt, $cover, $count, $loc)
+
+Internal method to read context (simple and chaining context) lookup subtables for
+the GSUB and GPOS table types. The assumed values for $type correspond to those
+for GSUB, so GPOS should adjust the values upon calling.
+
+=cut
+
+sub read_context
+{
+ my ($self, $lookup, $fh, $type, $fmt, $cover, $count, $loc) = @_;
+ my ($dat, $i, $s, $t, @subst, @srec, $mcount, $scount);
+
+ if ($type == 5 && $fmt < 3)
+ {
+ if ($fmt == 2)
+ {
+ $fh->read($dat, 2);
+ $lookup->{'CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0);
+ $count = TTF_Unpack('S', $dat);
+ }
+ $fh->read($dat, $count << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ {
+ if ($s == 0)
+ {
+ push (@{$lookup->{'RULES'}}, []);
+ next;
+ }
+ @subst = ();
+ $fh->seek($loc + $s, 0);
+ $fh->read($dat, 2);
+ $t = TTF_Unpack('S', $dat);
+ $fh->read($dat, $t << 1);
+ foreach $t (TTF_Unpack('S*', $dat))
+ {
+ $fh->seek($loc + $s + $t, 0);
+ @srec = ();
+ $fh->read($dat, 4);
+ ($mcount, $scount) = TTF_Unpack('S2', $dat);
+ $mcount--;
+ $fh->read($dat, ($mcount << 1) + ($scount << 2));
+ for ($i = 0; $i < $scount; $i++)
+ { push (@srec, [TTF_Unpack('S2', substr($dat,
+ ($mcount << 1) + ($i << 2), 4))]); }
+ push (@subst, {'ACTION' => [@srec],
+ 'MATCH' => [TTF_Unpack('S*',
+ substr($dat, 0, $mcount << 1))]});
+ }
+ push (@{$lookup->{'RULES'}}, [@subst]);
+ }
+ $lookup->{'ACTION_TYPE'} = 'l';
+ $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
+ } elsif ($type == 5 && $fmt == 3)
+ {
+ $fh->read($dat, ($cover << 1) + ($count << 2));
+ @subst = (); @srec = ();
+ for ($i = 0; $i < $cover; $i++)
+ { push (@subst, $self->read_cover(TTF_Unpack('S', substr($dat, $i << 1, 2)),
+ $loc, $lookup, $fh, 1)); }
+ for ($i = 0; $i < $count; $i++)
+ { push (@srec, [TTF_Unpack('S2', substr($dat, ($count << 1) + ($i << 2), 4))]); }
+ $lookup->{'RULES'} = [[{'ACTION' => [@srec], 'MATCH' => [@subst]}]];
+ $lookup->{'ACTION_TYPE'} = 'l';
+ $lookup->{'MATCH_TYPE'} = 'o';
+ } elsif ($type == 6 && $fmt < 3)
+ {
+ if ($fmt == 2)
+ {
+ $fh->read($dat, 6);
+ $lookup->{'PRE_CLASS'} = $self->read_cover($count, $loc, $lookup, $fh, 0) if $count;
+ ($i, $mcount, $count) = TTF_Unpack('S3', $dat); # messy: 2 classes & count
+ $lookup->{'CLASS'} = $self->read_cover($i, $loc, $lookup, $fh, 0) if $i;
+ $lookup->{'POST_CLASS'} = $self->read_cover($mcount, $loc, $lookup, $fh, 0) if $mcount;
+ }
+ $fh->read($dat, $count << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ {
+ if ($s == 0)
+ {
+ push (@{$lookup->{'RULES'}}, []);
+ next;
+ }
+ @subst = ();
+ $fh->seek($loc + $s, 0);
+ $fh->read($dat, 2);
+ $t = TTF_Unpack('S', $dat);
+ $fh->read($dat, $t << 1);
+ foreach $i (TTF_Unpack('S*', $dat))
+ {
+ $fh->seek($loc + $s + $i, 0);
+ @srec = ();
+ $t = {};
+ $fh->read($dat, 2);
+ $mcount = TTF_Unpack('S', $dat);
+ if ($mcount > 0)
+ {
+ $fh->read($dat, $mcount << 1);
+ $t->{'PRE'} = [TTF_Unpack('S*', $dat)];
+ }
+ $fh->read($dat, 2);
+ $mcount = TTF_Unpack('S', $dat);
+ if ($mcount > 1)
+ {
+ $fh->read($dat, ($mcount - 1) << 1);
+ $t->{'MATCH'} = [TTF_Unpack('S*', $dat)];
+ }
+ $fh->read($dat, 2);
+ $mcount = TTF_Unpack('S', $dat);
+ if ($mcount > 0)
+ {
+ $fh->read($dat, $mcount << 1);
+ $t->{'POST'} = [TTF_Unpack('S*', $dat)];
+ }
+ $fh->read($dat, 2);
+ $scount = TTF_Unpack('S', $dat);
+ $fh->read($dat, $scount << 2);
+ for ($i = 0; $i < $scount; $i++)
+ { push (@srec, [TTF_Unpack('S2', substr($dat, $i << 2))]); }
+ $t->{'ACTION'} = [@srec];
+ push (@subst, $t);
+ }
+ push (@{$lookup->{'RULES'}}, [@subst]);
+ }
+ $lookup->{'ACTION_TYPE'} = 'l';
+ $lookup->{'MATCH_TYPE'} = ($fmt == 2 ? 'c' : 'g');
+ } elsif ($type == 6 && $fmt == 3)
+ {
+ $t = {};
+ unless ($cover == 0)
+ {
+ @subst = ();
+ $fh->read($dat, $cover << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
+ $t->{'PRE'} = [@subst];
+ }
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ unless ($count == 0)
+ {
+ @subst = ();
+ $fh->read($dat, $count << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
+ $t->{'MATCH'} = [@subst];
+ }
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ unless ($count == 0)
+ {
+ @subst = ();
+ $fh->read($dat, $count << 1);
+ foreach $s (TTF_Unpack('S*', $dat))
+ { push(@subst, $self->read_cover($s, $loc, $lookup, $fh, 1)); }
+ $t->{'POST'} = [@subst];
+ }
+ $fh->read($dat, 2);
+ $count = TTF_Unpack('S', $dat);
+ @subst = ();
+ $fh->read($dat, $count << 2);
+ for ($i = 0; $i < $count; $i++)
+ { push (@subst, [TTF_Unpack('S2', substr($dat, $i << 2, 4))]); }
+ $t->{'ACTION'} = [@subst];
+ $lookup->{'RULES'} = [[$t]];
+ $lookup->{'ACTION_TYPE'} = 'l';
+ $lookup->{'MATCH_TYPE'} = 'o';
+ }
+ $lookup;
+}
+
+
+=head2 $self->out_context($lookup, $fh, $type, $fmt, $ctables, $out, $num)
+
+Provides shared behaviour between GSUB and GPOS tables during output for context
+(chained and simple) rules. In addition, support is provided here for type 4 GSUB
+tables, which are not used in GPOS. The value for $type corresponds to the type
+in a GSUB table so calling from GPOS should adjust the value accordingly.
+
+=cut
+
+sub out_context
+{
+ my ($self, $lookup, $fh, $type, $fmt, $ctables, $out, $num) = @_;
+ my ($offc, $offd, $i, $j, $r, $t, $numd);
+
+ if (($type == 4 || $type == 5 || $type == 6) && ($fmt == 1 || $fmt == 2))
+ {
+ my ($base_off);
+
+ if ($fmt == 1)
+ {
+ $out = pack("nnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ $num);
+ $base_off = 6;
+ } elsif ($type == 5)
+ {
+ $out = pack("nnnn", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 4), $num);
+ $base_off = 8;
+ } elsif ($type == 6)
+ {
+ $out = pack("n6", $fmt, Font::TTF::Ttopen::ref_cache($lookup->{'COVERAGE'}, $ctables, 2),
+ Font::TTF::Ttopen::ref_cache($lookup->{'PRE_CLASS'}, $ctables, 4),
+ Font::TTF::Ttopen::ref_cache($lookup->{'CLASS'}, $ctables, 6),
+ Font::TTF::Ttopen::ref_cache($lookup->{'POST_CLASS'}, $ctables, 8),
+ $num);
+ $base_off = 12;
+ }
+
+ $out .= pack('n*', (0) x $num);
+ $offc = length($out);
+ for ($i = 0; $i < $num; $i++)
+ {
+ $r = $lookup->{'RULES'}[$i];
+ next unless exists $r->[0]{'ACTION'};
+ $numd = $#{$r} + 1;
+ substr($out, ($i << 1) + $base_off, 2) = pack('n', $offc);
+ $out .= pack('n*', $numd, (0) x $numd);
+ $offd = length($out) - $offc;
+ for ($j = 0; $j < $numd; $j++)
+ {
+ substr($out, $offc + 2 + ($j << 1), 2) = pack('n', $offd);
+ if ($type == 4)
+ {
+ $out .= pack('n*', $r->[$j]{'ACTION'}[0], $#{$r->[$j]{'MATCH'}} + 2,
+ @{$r->[$j]{'MATCH'}});
+ } elsif ($type == 5)
+ {
+ $out .= pack('n*', $#{$r->[$j]{'MATCH'}} + 2,
+ $#{$r->[$j]{'ACTION'}} + 1,
+ @{$r->[$j]{'MATCH'}});
+ foreach $t (@{$r->[$j]{'ACTION'}})
+ { $out .= pack('n2', @$t); }
+ } elsif ($type == 6)
+ {
+ $out .= pack('n*', $#{$r->[$j]{'PRE'}} + 1, @{$r->[$j]{'PRE'}},
+ $#{$r->[$j]{'MATCH'}} + 2, @{$r->[$j]{'MATCH'}},
+ $#{$r->[$j]{'POST'}} + 1, @{$r->[$j]{'POST'}},
+ $#{$r->[$j]{'ACTION'}} + 1);
+ foreach $t (@{$r->[$j]{'ACTION'}})
+ { $out .= pack('n2', @$t); }
+ }
+ $offd = length($out) - $offc;
+ }
+ $offc = length($out);
+ }
+ } elsif ($type == 5 && $fmt == 3)
+ {
+ $out .= pack('n3', $fmt, $#{$lookup->{'RULES'}[0][0]{'MATCH'}} + 1,
+ $#{$lookup->{'RULES'}[0][0]{'ACTION'}} + 1);
+ foreach $t (@{$lookup->{'RULES'}[0][0]{'MATCH'}})
+ { $out .= pack('n', Font::TTF::Ttopen::ref_cache($t, $ctables, length($out))); }
+ foreach $t (@{$lookup->{'RULES'}[0][0]{'ACTION'}})
+ { $out .= pack('n2', @$t); }
+ } elsif ($type == 6 && $fmt == 3)
+ {
+ $r = $lookup->{'RULES'}[0][0];
+ $out .= pack('n2', $fmt, $#{$r->{'PRE'}} + 1);
+ foreach $t (@{$r->{'PRE'}})
+ { $out .= Font::TTF::Ttopen::ref_cache($t, $ctables, length($out)); }
+ $out .= pack('n', $#{$r->{'MATCH'}} + 1);
+ foreach $t (@{$r->{'MATCH'}})
+ { $out .= Font::TTF::Ttopen::ref_cache($t, $ctables, length($out)); }
+ $out .= pack('n', $#{$r->{'POST'}} + 1);
+ foreach $t (@{$r->{'POST'}})
+ { $out .= Font::TTF::Ttopen::ref_cache($t, $ctables, length($out)); }
+ $out .= pack('n', $#{$r->{'ACTION'}} + 1);
+ foreach $t (@{$r->{'ACTION'}})
+ { $out .= pack('n2', @$t); }
+ }
+ $out;
+}
+
+=head1 BUGS
+
+=over 4
+
+=item *
+
+No way to share cachable items (coverage tables, classes, anchors, device tables)
+across different lookups. The items are always output after the lookup and
+repeated if necessary. Within lookup sharing is possible.
+
+=back
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
+1;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Useall.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Useall.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Useall.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,52 @@
+use Font::TTF::Cvt_;
+use Font::TTF::Fpgm;
+use Font::TTF::Glyf;
+use Font::TTF::Hdmx;
+use Font::TTF::Kern;
+use Font::TTF::Loca;
+use Font::TTF::LTSH;
+use Font::TTF::Name;
+use Font::TTF::OS_2;
+use Font::TTF::PCLT;
+use Font::TTF::Post;
+use Font::TTF::Prep;
+use Font::TTF::Vmtx;
+use Font::TTF::AATKern;
+use Font::TTF::AATutils;
+use Font::TTF::Anchor;
+use Font::TTF::Bsln;
+use Font::TTF::Delta;
+use Font::TTF::Fdsc;
+use Font::TTF::Feat;
+use Font::TTF::Fmtx;
+use Font::TTF::GPOS;
+use Font::TTF::Mort;
+use Font::TTF::Prop;
+use Font::TTF::GDEF;
+use Font::TTF::Coverage;
+use Font::TTF::GSUB;
+use Font::TTF::Hhea;
+use Font::TTF::Table;
+use Font::TTF::Ttopen;
+use Font::TTF::Glyph;
+use Font::TTF::Head;
+use Font::TTF::Hmtx;
+use Font::TTF::Vhea;
+use Font::TTF::Cmap;
+use Font::TTF::Utils;
+use Font::TTF::Maxp;
+use Font::TTF::Font;
+use Font::TTF::Kern::ClassArray;
+use Font::TTF::Kern::CompactClassArray;
+use Font::TTF::Kern::OrderedList;
+use Font::TTF::Kern::StateTable;
+use Font::TTF::Kern::Subtable;
+use Font::TTF::Mort::Chain;
+use Font::TTF::Mort::Contextual;
+use Font::TTF::Mort::Insertion;
+use Font::TTF::Mort::Ligature;
+use Font::TTF::Mort::Noncontextual;
+use Font::TTF::Mort::Rearrangement;
+use Font::TTF::Mort::Subtable;
+
+1;
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Utils.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Utils.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Utils.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,610 @@
+package Font::TTF::Utils;
+
+=head1 NAME
+
+Font::TTF::Utils - Utility functions to save fingers
+
+=head1 DESCRIPTION
+
+Lots of useful functions to save my fingers, especially for trivial tables
+
+=head1 FUNCTIONS
+
+The following functions are exported
+
+=cut
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION @EXPORT_OK);
+require Exporter;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(TTF_Init_Fields TTF_Read_Fields TTF_Out_Fields TTF_Pack
+ TTF_Unpack TTF_word_utf8 TTF_utf8_word TTF_bininfo);
+ at EXPORT_OK = (@EXPORT, qw(XML_hexdump));
+$VERSION = 0.0001;
+
+=head2 ($val, $pos) = TTF_Init_Fields ($str, $pos)
+
+Given a field description from the C<DATA> section, creates an absolute entry
+in the fields associative array for the class
+
+=cut
+
+sub TTF_Init_Fields
+{
+ my ($str, $pos, $inval) = @_;
+ my ($key, $val, $res, $len, $rel);
+
+ $str =~ s/\r?\n$//o;
+ if ($inval)
+ { ($key, $val) = ($str, $inval); }
+ else
+ { ($key, $val) = split(',\s*', $str); }
+ return (undef, undef, 0) unless (defined $key && $key ne "");
+ if ($val =~ m/^(\+?)(\d*)(\D+)(\d*)/oi)
+ {
+ $rel = $1;
+ if ($rel eq "+")
+ { $pos += $2; }
+ elsif ($2 ne "")
+ { $pos = $2; }
+ $val = $3;
+ $len = $4;
+ }
+ $len = "" unless defined $len;
+ $pos = 0 if !defined $pos || $pos eq "";
+ $res = "$pos:$val:$len";
+ if ($val eq "f" || $val =~ m/^[l]/oi)
+ { $pos += 4 * ($len ne "" ? $len : 1); }
+ elsif ($val eq "F" || $val =~ m/^[s]/oi)
+ { $pos += 2 * ($len ne "" ? $len : 1); }
+ else
+ { $pos += 1 * ($len ne "" ? $len : 1); }
+
+ ($key, $res, $pos);
+}
+
+
+=head2 TTF_Read_Fields($obj, $dat, $fields)
+
+Given a block of data large enough to account for all the fields in a table,
+processes the data block to convert to the values in the objects instance
+variables by name based on the list in the C<DATA> block which has been run
+through C<TTF_Init_Fields>
+
+=cut
+
+sub TTF_Read_Fields
+{
+ my ($self, $dat, $fields) = @_;
+ my ($pos, $type, $res, $f, $arrlen, $arr, $frac);
+
+ foreach $f (keys %{$fields})
+ {
+ ($pos, $type, $arrlen) = split(':', $fields->{$f});
+ $pos = 0 if $pos eq "";
+ if ($arrlen ne "")
+ { $self->{$f} = [TTF_Unpack("$type$arrlen", substr($dat, $pos))]; }
+ else
+ { $self->{$f} = TTF_Unpack("$type", substr($dat, $pos)); }
+ }
+ $self;
+}
+
+
+=head2 TTF_Unpack($fmt, $dat)
+
+A TrueType types equivalent of Perls C<unpack> function. Thus $fmt consists of
+type followed by an optional number of elements to read including *. The type
+may be one of:
+
+ c BYTE
+ C CHAR
+ f FIXED
+ F F2DOT14
+ l LONG
+ L ULONG
+ s SHORT
+ S USHORT
+
+Note that C<FUNIT>, C<FWORD> and C<UFWORD> are not data types but units.
+
+Returns array of scalar (first element) depending on context
+
+=cut
+
+sub TTF_Unpack
+{
+ my ($fmt, $dat) = @_;
+ my ($res, $frac, $i, $arrlen, $type, @res);
+
+ while ($fmt =~ s/^([cfls])(\d+|\*)?//oi)
+ {
+ $type = $1;
+ $arrlen = $2;
+ $arrlen = 1 if !defined $arrlen || $arrlen eq "";
+ $arrlen = -1 if $arrlen eq "*";
+
+ for ($i = 0; ($arrlen == -1 && $dat ne "") || $i < $arrlen; $i++)
+ {
+ if ($type eq "f")
+ {
+ ($res, $frac) = unpack("nn", $dat);
+ substr($dat, 0, 4) = "";
+ $res -= 65536 if $res > 32767;
+ $res += $frac / 65536.;
+ }
+ elsif ($type eq "F")
+ {
+ $res = unpack("n", $dat);
+ substr($dat, 0, 2) = "";
+# $res -= 65536 if $res >= 32768;
+ $frac = $res & 0x3fff;
+ $res >>= 14;
+ $res -= 4 if $res > 1;
+# $frac -= 16384 if $frac > 8191;
+ $res += $frac / 16384.;
+ }
+ elsif ($type =~ m/^[l]/oi)
+ {
+ $res = unpack("N", $dat);
+ substr($dat, 0, 4) = "";
+ $res -= (1 << 32) if ($type eq "l" && $res >= 1 << 31);
+ }
+ elsif ($type =~ m/^[s]/oi)
+ {
+ $res = unpack("n", $dat);
+ substr($dat, 0, 2) = "";
+ $res -= 65536 if ($type eq "s" && $res >= 32768);
+ }
+ elsif ($type eq "c")
+ {
+ $res = unpack("c", $dat);
+ substr($dat, 0, 1) = "";
+ }
+ else
+ {
+ $res = unpack("C", $dat);
+ substr($dat, 0, 1) = "";
+ }
+ push (@res, $res);
+ }
+ }
+ return wantarray ? @res : $res[0];
+}
+
+
+=head2 $dat = TTF_Out_Fields($obj, $fields, $len)
+
+Given the fields table from C<TTF_Init_Fields> writes out the instance variables from
+the object to the filehandle in TTF binary form.
+
+=cut
+
+sub TTF_Out_Fields
+{
+ my ($obj, $fields, $len) = @_;
+ my ($dat) = "\000" x $len;
+ my ($f, $pos, $type, $res, $arr, $arrlen, $frac);
+
+ foreach $f (keys %{$fields})
+ {
+ ($pos, $type, $arrlen) = split(':', $fields->{$f});
+ if ($arrlen ne "")
+ { $res = TTF_Pack("$type$arrlen", @{$obj->{$f}}); }
+ else
+ { $res = TTF_Pack("$type", $obj->{$f}); }
+ substr($dat, $pos, length($res)) = $res;
+ }
+ $dat;
+}
+
+
+=head2 $dat = TTF_Pack($fmt, @data)
+
+The TrueType equivalent to Perl's C<pack> function. See details of C<TTF_Unpack>
+for how to work the $fmt string.
+
+=cut
+
+sub TTF_Pack
+{
+ my ($fmt, @obj) = @_;
+ my ($type, $i, $arrlen, $dat, $res, $frac);
+
+ while ($fmt =~ s/^([flsc])(\d+|\*)?//oi)
+ {
+ $type = $1;
+ $arrlen = $2 || "";
+ $arrlen = $#obj + 1 if $arrlen eq "*";
+ $arrlen = 1 if $arrlen eq "";
+
+ for ($i = 0; $i < $arrlen; $i++)
+ {
+ $res = shift(@obj);
+ if ($type eq "f")
+ {
+ $frac = int(($res - int($res)) * 65536);
+ $res = (int($res) << 16) + $frac;
+ $dat .= pack("N", $res);
+ }
+ elsif ($type eq "F")
+ {
+ $frac = int(($res - int($res)) * 16384);
+ $res = (int($res) << 14) + $frac;
+ $dat .= pack("n", $res);
+ }
+ elsif ($type =~ m/^[l]/oi)
+ {
+ $res += 1 << 32 if ($type eq 'L' && $res < 0);
+ $dat .= pack("N", $res);
+ }
+ elsif ($type =~ m/^[s]/oi)
+ {
+ $res += 1 << 16 if ($type eq 'S' && $res < 0);
+ $dat .= pack("n", $res);
+ }
+ elsif ($type eq "c")
+ { $dat .= pack("c", $res); }
+ else
+ { $dat .= pack("C", $res); }
+ }
+ }
+ $dat;
+}
+
+
+=head2 ($num, $range, $select, $shift) = TTF_bininfo($num)
+
+Calculates binary search information from a number of elements
+
+=cut
+
+sub TTF_bininfo
+{
+ my ($num, $block) = @_;
+ my ($range, $select, $shift);
+
+ $range = 1;
+ for ($select = 0; $range <= $num; $select++)
+ { $range *= 2; }
+ $select--; $range /= 2;
+ $range *= $block;
+
+ $shift = $num * $block - $range;
+ ($num, $range, $select, $shift);
+}
+
+
+=head2 TTF_word_utf8($str)
+
+Returns the UTF8 form of the 16 bit string, assumed to be in big endian order,
+including surrogate handling
+
+=cut
+
+sub TTF_word_utf8
+{
+ my ($str) = @_;
+ my ($res, $i);
+ my (@dat) = unpack("n*", $str);
+
+ return pack("U*", @dat) if ($^V && $^V ge v5.6.0);
+ for ($i = 0; $i <= $#dat; $i++)
+ {
+ my ($dat) = $dat[$i];
+ if ($dat < 0x80) # Thanks to Gisle Aas for some of his old code
+ { $res .= chr($dat); }
+ elsif ($dat < 0x800)
+ { $res .= chr(0xC0 | ($dat >> 6)) . chr(0x80 | ($dat & 0x3F)); }
+ elsif ($dat >= 0xD800 && $dat < 0xDC00)
+ {
+ my ($dat1) = $dat[++$i];
+ my ($top) = (($dat & 0x3C0) >> 6) + 1;
+ $res .= chr(0xF0 | ($top >> 2))
+ . chr(0x80 | (($top & 1) << 4) | (($dat & 0x3C) >> 2))
+ . chr(0x80 | (($dat & 0x3) << 4) | (($dat1 & 0x3C0) >> 6))
+ . chr(0x80 | ($dat1 & 0x3F));
+ } else
+ { $res .= chr(0xE0 | ($dat >> 12)) . chr(0x80 | (($dat >> 6) & 0x3F))
+ . chr(0x80 | ($dat & 0x3F)); }
+ }
+ $res;
+}
+
+
+=head2 TTF_utf8_word($str)
+
+Returns the 16-bit form in big endian order of the UTF 8 string, including
+surrogate handling to Unicode.
+
+=cut
+
+sub TTF_utf8_word
+{
+ my ($str) = @_;
+ my ($res);
+
+ return pack("n*", unpack("U*", $str)) if ($^V ge v5.6.0);
+ $str = "$str"; # copy $str
+ while (length($str)) # Thanks to Gisle Aas for some of his old code
+ {
+ $str =~ s/^[\x80-\xBF]+//o;
+ if ($str =~ s/^([\x00-\x7F]+)//o)
+ { $res .= pack("n*", unpack("C*", $1)); }
+ elsif ($str =~ s/^([\xC0-\xDF])([\x80-\xBF])//o)
+ { $res .= pack("n", ((ord($1) & 0x1F) << 6) | (ord($2) & 0x3F)); }
+ elsif ($str =~ s/^([\0xE0-\xEF])([\x80-\xBF])([\x80-\xBF])//o)
+ { $res .= pack("n", ((ord($1) & 0x0F) << 12)
+ | ((ord($2) & 0x3F) << 6)
+ | (ord($3) & 0x3F)); }
+ elsif ($str =~ s/^([\xF0-\xF7])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])//o)
+ {
+ my ($b1, $b2, $b3, $b4) = (ord($1), ord($2), ord($3), ord($4));
+ $res .= pack("n", ((($b1 & 0x07) << 8) | (($b2 & 0x3F) << 2)
+ | (($b3 & 0x30) >> 4)) + 0xD600); # account for offset
+ $res .= pack("n", ((($b3 & 0x0F) << 6) | ($b4 & 0x3F)) + 0xDC00);
+ }
+ elsif ($str =~ s/^[\xF8-\xFF][\x80-\xBF]*//o)
+ { }
+ }
+ $res;
+}
+
+
+=head2 XML_hexdump($context, $dat)
+
+Dumps out the given data as a sequence of <data> blocks each 16 bytes wide
+
+=cut
+
+sub XML_hexdump
+{
+ my ($context, $depth, $dat) = @_;
+ my ($fh) = $context->{'fh'};
+ my ($i, $len, $out);
+
+ $len = length($dat);
+ for ($i = 0; $i < $len; $i += 16)
+ {
+ $out = join(' ', map {sprintf("%02X", ord($_))} (split('', substr($dat, $i, 16))));
+ $fh->printf("%s<data addr='%04X'>%s</data>\n", $depth, $i, $out);
+ }
+}
+
+
+=head2 XML_outhints
+
+Converts a binary string of hinting code into a textual representation
+
+=cut
+
+{
+ my (@hints) = (
+ ['SVTCA[0]'], ['SVTCA[1]'], ['SPVTCA[0]'], ['SPVTCA[1]'], ['SFVTCA[0]'], ['SFVTCA[1]'], ['SPVTL[0]'], ['SPVTL[1]'],
+ ['SFVTL[0]'], ['SFVTL[1]'], ['SPVFS'], ['SFVFS'], ['GPV'], ['GFV'], ['SVFTPV'], ['ISECT'],
+# 10
+ ['SRP0'], ['SRP1'], ['SRP2'], ['SZP0'], ['SZP1'], ['SZP2'], ['SZPS'], ['SLOOP'],
+ ['RTG'], ['RTHG'], ['SMD'], ['ELSE'], ['JMPR'], ['SCVTCI'], ['SSWCI'], ['SSW'],
+# 20
+ ['DUP'], ['POP'], ['CLEAR'], ['SWAP'], ['DEPTH'], ['CINDEX'], ['MINDEX'], ['ALIGNPTS'],
+ [], ['UTP'], ['LOOPCALL'], ['CALL'], ['FDEF'], ['ENDF'], ['MDAP[0]'], ['MDAP[1]'],
+# 30
+ ['IUP[0]'], ['IUP[1]'], ['SHP[0]'], ['SHP[1]'], ['SHC[0]'], ['SHC[1]'], ['SHZ[0]'], ['SHZ[1]'],
+ ['SHPIX'], ['IP'], ['MSIRP[0]'], ['MSIRP[1]'], ['ALIGNRP'], ['RTDG'], ['MIAP[0]'], ['MIAP[1]'],
+# 40
+ ['NPUSHB', -1, 1], ['NPUSHW', -1, 2], ['WS', 0, 0], ['RS', 0, 0], ['WCVTP', 0, 0], ['RCVT', 0, 0], ['GC[0]'], ['GC[1]'],
+ ['SCFS'], ['MD[0]'], ['MD[1]'], ['MPPEM'], ['MPS'], ['FLIPON'], ['FLIPOFF'], ['DEBUG'],
+# 50
+ ['LT'], ['LTEQ'], ['GT'], ['GTEQ'], ['EQ'], ['NEQ'], ['ODD'], ['EVEN'],
+ ['IF'], ['EIF'], ['AND'], ['OR'], ['NOT'], ['DELTAP1'], ['SDB'], ['SDS'],
+# 60
+ ['ADD'], ['SUB'], ['DIV'], ['MULT'], ['ABS'], ['NEG'], ['FLOOR'], ['CEILING'],
+ ['ROUND[0]'], ['ROUND[1]'], ['ROUND[2]'], ['ROUND[3]'], ['NROUND[0]'], ['NROUND[1]'], ['NROUND[2]'], ['NROUND[3]'],
+# 70
+ ['WCVTF'], ['DELTAP2'], ['DELTAP3'], ['DELTAC1'], ['DELTAC2'], ['DELTAC3'], ['SROUND'], ['S45ROUND'],
+ ['JROT'], ['JROF'], ['ROFF'], [], ['RUTG'], ['RDTG'], ['SANGW'], [],
+# 80
+ ['FLIPPT'], ['FLIPRGON'], ['FLIPRGOFF'], [], [], ['SCANCTRL'], ['SDPVTL[0]'], ['SDPVTL[1]'],
+ ['GETINFO'], ['IDEF'], ['ROLL'], ['MAX'], ['MIN'], ['SCANTYPE'], ['INSTCTRL'], [],
+# 90
+ [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [],
+# A0
+ [], [], [], [], [], [], [], [], [], [], [], [], [], [], [], [],
+# B0
+ ['PUSHB1', 1, 1], ['PUSHB2', 2, 1], ['PUSHB3', 3, 1], ['PUSHB4', 4, 1], ['PUSHB5', 5, 1], ['PUSHB6', 6, 1], ['PUSHB7', 7, 1], ['PUSHB8', 8, 1],
+ ['PUSHW1', 1, 2], ['PUSHW2', 2, 2], ['PUSHW3', 3, 2], ['PUSHW4', 4, 2], ['PUSHW5', 5, 2], ['PUSHW6', 6, 2], ['PUSHW7', 7, 2], ['PUSHW8', 8, 2],
+# C0
+ ['MDRP[0]'], ['MDRP[1]'], ['MDRP[2]'], ['MDRP[3]'], ['MDRP[4]'], ['MDRP[5]'], ['MDRP[6]'], ['MDRP[7]'],
+ ['MDRP[8]'], ['MDRP[9]'], ['MDRP[A]'], ['MDRP[B]'], ['MDRP[C]'], ['MDRP[D]'], ['MDRP[E]'], ['MDRP[F]'],
+# D0
+ ['MDRP[10]'], ['MDRP[11]'], ['MDRP[12]'], ['MDRP[13]'], ['MDRP[14]'], ['MDRP[15]'], ['MDRP[16]'], ['MDRP[17]'],
+ ['MDRP[18]'], ['MDRP[19]'], ['MDRP[1A]'], ['MDRP[1B]'], ['MDRP[1C]'], ['MDRP[1D]'], ['MDRP[1E]'], ['MDRP[1F]'],
+# E0
+ ['MIRP[0]'], ['MIRP[1]'], ['MIRP[2]'], ['MIRP[3]'], ['MIRP[4]'], ['MIRP[5]'], ['MIRP[6]'], ['MIRP[7]'],
+ ['MIRP[8]'], ['MIRP[9]'], ['MIRP[A]'], ['MIRP[B]'], ['MIRP[C]'], ['MIRP[D]'], ['MIRP[E]'], ['MIRP[F]'],
+# F0
+ ['MIRP[10]'], ['MIRP[11]'], ['MIRP[12]'], ['MIRP[13]'], ['MIRP[14]'], ['MIRP[15]'], ['MIRP[16]'], ['MIRP[17]'],
+ ['MIRP[18]'], ['MIRP[19]'], ['MIRP[1A]'], ['MIRP[1B]'], ['MIRP[1C]'], ['MIRP[1D]'], ['MIRP[1E]'], ['MIRP[1F]']);
+
+ my ($i);
+ my (%hints) = map { $_->[0] => $i++ if (defined $_->[0]); } @hints;
+
+ sub XML_binhint
+ {
+ my ($dat) = @_;
+ my ($len) = length($dat);
+ my ($res, $i);
+ my ($text, $num, $size);
+
+ for ($i = 0; $i < $len; $i++)
+ {
+ ($text, $num, $size) = @{$hints[ord(substr($dat, $i, 1))]};
+ $text = sprintf("UNK[%02X]", ord(substr($dat, $i, 1))) unless defined $text;
+ $res .= $text;
+ if ($num != 0)
+ {
+ if ($num < 0)
+ {
+ $i++;
+ my ($nnum) = unpack($num == -1 ? 'C' : 'n', substr($dat, $i, -$num));
+ $i += -$num - 1;
+ $num = $nnum;
+ }
+ $res .= "\t" . join(' ', unpack($size == 1 ? 'C*' : 'n*', substr($dat, $i + 1, $num * $size)));
+ $i += $num * $size;
+ }
+ $res .= "\n";
+ }
+ $res;
+ }
+
+ sub XML_hintbin
+ {
+ my ($dat) = @_;
+ my ($l, $res, @words, $num);
+
+ foreach $l (split(/\s*\n\s*/, $dat))
+ {
+ @words = split(/\s*/, $l);
+ next unless (defined $hints{$words[0]});
+ $num = $hints{$words[0]};
+ $res .= pack('C', $num);
+ if ($hints[$num][1] < 0)
+ {
+ $res .= pack($hints[$num][1] == -1 ? 'C' : 'n', $#words);
+ $res .= pack($hints[$num][2] == 1 ? 'C*' : 'n*', @words[1 .. $#words]);
+ }
+ elsif ($hints[$num][1] > 0)
+ {
+ $res .= pack($hints[$num][2] == 1 ? 'C*' : 'n*', @words[1 .. $hints[$num][1]]);
+ }
+ }
+ $res;
+ }
+}
+
+
+=head2 make_circle($f, $cmap, [$dia, $sb, $opts])
+
+Adds a dotted circle to a font. This function is very configurable. The
+parameters passed in are:
+
+=over 4
+
+=item $f
+
+Font to work with. This is required.
+
+=item $cmap
+
+A cmap table (not the 'val' sub-element of a cmap) to add the glyph too. Optional.
+
+=item $dia
+
+Optional diameter for the main circle. Defaults to 80% em
+
+=item $sb
+
+Side bearing. The left and right side-bearings are always the same. This value
+defaults to 10% em.
+
+=back
+
+There are various options to control all sorts of interesting aspects of the circle
+
+=over 4
+
+=item numDots
+
+Number of dots in the circle
+
+=item numPoints
+
+Number of curve points to use to create each dot
+
+=item uid
+
+Unicode reference to store this glyph under in the cmap. Defaults to 0x25CC
+
+=item pname
+
+Postscript name to give the glyph. Defaults to uni25CC.
+
+=item -dRadius
+
+Radius of each dot.
+
+=back
+
+=cut
+
+sub make_circle
+{
+ my ($font, $cmap, $dia, $sb, %opts) = @_;
+ my ($upem) = $font->{'head'}{'unitsPerEm'};
+ my ($glyph) = Font::TTF::Glyph->new('PARENT' => $font, 'read' => 2);
+ my ($PI) = 3.1415926535;
+ my ($R, $r, $xorg, $yorg);
+ my ($i, $j, $numg, $maxp);
+ my ($numc) = $opts{'-numDots'} || 16;
+ my ($nump) = ($opts{'-numPoints'} * 2) || 8;
+ my ($uid) = $opts{'-uid'} || 0x25CC;
+ my ($pname) = $opts{'-pname'} || 'uni25CC';
+
+ $dia ||= $upem * .8; # .95 to fit exactly
+ $sb ||= $upem * .1;
+ $R = $dia / 2;
+ $r = $opts{'-dRadius'} || ($R * .1);
+ ($xorg, $yorg) = ($R + $r, $R);
+
+ $xorg += $sb;
+ $font->{'post'}->read;
+ $font->{'glyf'}->read;
+ for ($i = 0; $i < $numc; $i++)
+ {
+ my ($pxorg, $pyorg) = ($xorg + $R * cos(2 * $PI * $i / $numc),
+ $yorg + $R * sin(2 * $PI * $i / $numc));
+ for ($j = 0; $j < $nump; $j++)
+ {
+ push (@{$glyph->{'x'}}, int ($pxorg + ($j & 1 ? 1/cos(2*$PI/$nump) : 1) * $r * cos(2 * $PI * $j / $nump)));
+ push (@{$glyph->{'y'}}, int ($pyorg + ($j & 1 ? 1/cos(2*$PI/$nump) : 1) * $r * sin(2 * $PI * $j / $nump)));
+ push (@{$glyph->{'flags'}}, $j & 1 ? 0 : 1);
+ }
+ push (@{$glyph->{'endPoints'}}, $#{$glyph->{'x'}});
+ }
+ $glyph->{'numberOfContours'} = $#{$glyph->{'endPoints'}} + 1;
+ $glyph->{'numPoints'} = $#{$glyph->{'x'}} + 1;
+ $glyph->update;
+ $numg = $font->{'maxp'}{'numGlyphs'};
+ $font->{'maxp'}->read->{'numGlyphs'}++;
+
+ $font->{'hmtx'}{'advance'}[$numg] = int($xorg + $R + $r + $sb + .5);
+ $font->{'hmtx'}{'lsb'}[$numg] = int($xorg - $R - $r + .5);
+ $font->{'loca'}{'glyphs'}[$numg] = $glyph;
+ $cmap->{'val'}{$uid} = $numg if ($cmap);
+ $font->{'post'}{'VAL'}[$numg] = $pname;
+ delete $font->{'hdmx'};
+ delete $font->{'VDMX'};
+ delete $font->{'LTSH'};
+
+ $font->tables_do(sub {$_[0]->dirty;});
+ $font->update;
+ return ($numg - 1);
+}
+
+
+1;
+
+=head1 BUGS
+
+No known bugs
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vhea.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vhea.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vhea.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,159 @@
+package Font::TTF::Vhea;
+
+=head1 NAME
+
+TTF:Vhea - Vertical Header table
+
+=head1 DESCRIPTION
+
+This is a simple table with just standards specified instance variables
+
+=head1 INSTANCE VARIABLES
+
+ version
+ Ascender
+ Descender
+ LineGap
+ advanceHeightMax
+ minTopSideBearing
+ minBottomSideBearing
+ yMaxExtent
+ caretSlopeRise
+ caretSlopeRun
+ metricDataFormat
+ numberOfVMetrics
+
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA %fields @field_info);
+
+require Font::TTF::Table;
+use Font::TTF::Utils;
+
+ at ISA = qw(Font::TTF::Table);
+ at field_info = (
+ 'version' => 'f',
+ 'Ascender' => 's',
+ 'Descender' => 's',
+ 'LineGap' => 's',
+ 'advanceHeightMax' => 'S',
+ 'minTopSideBearing' => 's',
+ 'minBottomSideBearing' => 's',
+ 'yMaxExtent' => 's',
+ 'caretSlopeRise' => 's',
+ 'caretSlopeRun' => 's',
+ 'metricDataFormat' => '+10s',
+ 'numberOfVMetrics' => 's');
+
+sub init
+{
+ my ($k, $v, $c, $i);
+ for ($i = 0; $i < $#field_info; $i += 2)
+ {
+ ($k, $v, $c) = TTF_Init_Fields($field_info[$i], $c, $field_info[$i + 1]);
+ next unless defined $k && $k ne "";
+ $fields{$k} = $v;
+ }
+}
+
+
+=head2 $t->read
+
+Reads the table into memory as instance variables
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($dat);
+
+ $self->SUPER::read or return $self;
+ init unless defined $fields{'Ascender'};
+ $self->{' INFILE'}->read($dat, 36);
+
+ TTF_Read_Fields($self, $dat, \%fields);
+ $self;
+}
+
+
+=head2 $t->out($fh)
+
+Writes the table to a file either from memory or by copying.
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+
+ return $self->SUPER::out($fh) unless $self->{' read'};
+
+ $self->{'numberOfVMetrics'} = $self->{' PARENT'}{'vmtx'}->numMetrics || $self->{'numberOfVMetrics'};
+ $fh->print(TTF_Out_Fields($self, \%fields, 36));
+ $self;
+}
+
+
+=head2 $t->update
+
+Updates various parameters in the hhea table from the hmtx table, assuming
+the C<hmtx> table is dirty.
+
+=cut
+
+sub update
+{
+ my ($self) = @_;
+ my ($vmtx) = $self->{' PARENT'}{'vmtx'};
+ my ($glyphs);
+ my ($num);
+ my ($i, $maw, $mlsb, $mrsb, $mext, $aw, $lsb, $ext);
+
+ return undef unless ($self->SUPER::update);
+ return undef unless (defined $vmtx && defined $self->{' PARENT'}{'loca'});
+ $vmtx->read->update;
+ $self->{' PARENT'}{'loca'}->read->update;
+ $glyphs = $self->{' PARENT'}{'loca'}{'glyphs'};
+ $num = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+
+ for ($i = 0; $i < $num; $i++)
+ {
+ $aw = $vmtx->{'advance'}[$i];
+ $lsb = $vmtx->{'top'}[$i];
+ if (defined $glyphs->[$i])
+ { $ext = $lsb + $glyphs->[$i]->read->{'yMax'} - $glyphs->[$i]{'yMin'}; }
+ else
+ { $ext = $aw; }
+ $maw = $aw if ($aw > $maw);
+ $mlsb = $lsb if ($lsb < $mlsb or $i == 0);
+ $mrsb = $aw - $ext if ($aw - $ext < $mrsb or $i == 0);
+ $mext = $ext if ($ext > $mext);
+ }
+ $self->{'advanceHeightMax'} = $maw;
+ $self->{'minTopSideBearing'} = $mlsb;
+ $self->{'minBottomSideBearing'} = $mrsb;
+ $self->{'yMaxExtent'} = $mext;
+ $self->{'numberOfVMetrics'} = $vmtx->numMetrics;
+ $self;
+}
+
+
+1;
+
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vmtx.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vmtx.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Vmtx.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,86 @@
+package Font::TTF::Vmtx;
+
+=head1 NAME
+
+Font::TTF::Vmtx - Vertical Metrics
+
+=head1 DESCRIPTION
+
+Contains the advance height and top side bearing for each glyph. Given the
+compressability of the data onto disk, this table uses information from
+other tables, and thus must do part of its output during the output of
+other tables
+
+=head1 INSTANCE VARIABLES
+
+The vertical metrics are kept in two arrays by glyph id. The variable names
+do not start with a space
+
+=over 4
+
+=item advance
+
+An array containing the advance height for each glyph
+
+=item top
+
+An array containing the top side bearing for each glyph
+
+=back
+
+=head1 METHODS
+
+=cut
+
+use strict;
+use vars qw(@ISA);
+require Font::TTF::Hmtx;
+
+ at ISA = qw(Font::TTF::Hmtx);
+
+
+=head2 $t->read
+
+Reads the vertical metrics from the TTF file into memory
+
+=cut
+
+sub read
+{
+ my ($self) = @_;
+ my ($numh, $numg);
+
+ $numh = $self->{' PARENT'}{'vhea'}->read->{'numberOfVMetrics'};
+ $numg = $self->{' PARENT'}{'maxp'}->read->{'numGlyphs'};
+ $self->_read($numg, $numh, "advance", "top");
+}
+
+
+=head2 $t->out($fh)
+
+Writes the metrics to a TTF file. Assumes that the C<vhea> has updated the
+numVMetrics from here
+
+=cut
+
+sub out
+{
+ my ($self, $fh) = @_;
+ my ($numg) = $self->{' PARENT'}{'maxp'}{'numGlyphs'};
+ my ($numh) = $self->{' PARENT'}{'vhea'}{'numberOfVMetrics'};
+ $self->_out($fh, $numg, $numh, "advance", "top");
+}
+
+1;
+
+=head1 BUGS
+
+None known
+
+=head1 AUTHOR
+
+Martin Hosken Martin_Hosken at sil.org. See L<Font::TTF::Font> for copyright and
+licensing.
+
+=cut
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Win32.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Win32.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/Win32.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,33 @@
+package Font::TTF::Win32;
+
+# use strict;
+# use vars qw($HKEY_LOCAL_MACHINE);
+
+use Win32::Registry;
+use Win32;
+use File::Spec;
+use Font::TTF::Font;
+
+
+sub findfonts
+{
+ my ($sub) = @_;
+ my ($font_key) = 'SOFTWARE\Microsoft\Windows' . (Win32::IsWinNT() ? ' NT' : '') . '\CurrentVersion\Fonts';
+ my ($regFont, $list, $l, $font, $file);
+
+# get entry from registry for a font of this name
+ $::HKEY_LOCAL_MACHINE->Open($font_key, $regFont);
+ $regFont->GetValues($list);
+
+ foreach $l (sort keys %{$list})
+ {
+ my ($fname) = $list->{$l}[0];
+ next unless ($fname =~ s/\(TrueType\)$//o);
+ $file = File::Spec->rel2abs($list->{$l}[2], "$ENV{'windir'}/fonts");
+ $font = Font::TTF::Font->open($file) || next;
+ &{$sub}($font, $fname);
+ $font->release;
+ }
+}
+
+1;
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/XMLparse.pm
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/XMLparse.pm 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/Font/TTF/XMLparse.pm 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,176 @@
+package Font::TTF::XMLparse;
+
+=head1 NAME
+
+Font::TTF::XMLparse - provides support for XML parsing. Requires Expat module XML::Parser::Expat
+
+=head1 SYNOPSIS
+
+ use Font::TTF::Font;
+ use Font::TTF::XMLparse;
+
+ $f = Font::TTF::Font->new;
+ read_xml($f, $ARGV[0]);
+ $f->out($ARGV[1]);
+
+=head1 DESCRIPTION
+
+This module contains the support routines for parsing XML and generating the
+Truetype font structures as a result. The module has been separated from the rest
+of the package in order to reduce the dependency that this would bring, of the
+whole package on XML::Parser. This way, people without the XML::Parser can still
+use the rest of the package.
+
+The package interacts with another package through the use of a context containing
+and element 'receiver' which is an object which can possibly receive one of the
+following messages:
+
+=over 4
+
+=item XML_start
+
+This message is called when an open tag occurs. It is called with the context,
+tag name and the attributes. The return value has no meaning.
+
+=item XML_end
+
+This messages is called when a close tag occurs. It is called with the context,
+tag name and attributes (held over from when the tag was opened). There are 3
+possible return values from such a message:
+
+=over 8
+
+=item undef
+
+This is the default return value indicating that default processing should
+occur in which either the current element on the tree, or the text of this element
+should be stored in the parent object.
+
+=item $context
+
+This magic value marks that the element should be deleted from the parent.
+Nothing is stored in the parent. (This rather than '' is used to allow 0 returns.)
+
+=item anything
+
+Anything else is taken as the element content to be stored in the parent.
+
+=back 4
+
+=back 4
+
+In addition, the context hash passed to these messages contains the following
+keys:
+
+=over 4
+
+=item xml
+
+This is the expat xml object. The context is also available as
+$context->{'xml'}{' mycontext'}. But that is a long winded way of not saying much!
+
+=item font
+
+This is the base object that was passed in for XML parsing.
+
+=item receiver
+
+This holds the current receiver of parsing events. It may be set in associated
+application to adjust which objects should receive messages when. It is also stored
+in the parsing stack to ensure that where an object changes it during XML_start, that
+that same object that received XML_start will receive the corresponding XML_end
+
+=item stack
+
+This is the parsing stack, used internally to hold the current receiver and attributes
+for each element open, as a complete hierarchy back to the root element.
+
+=item tree
+
+This element contains the storage tree corresponding to the parent of each element
+in the stack. The default action is to push undef onto this stack during XML_start
+and then to resolve this, either in the associated application (by changing
+$context->{'tree'}[-1]) or during XML_end of a child element, by which time we know
+whether we are dealing with an array or a hash or what.
+
+=item text
+
+Character processing is to insert all the characters into the text element of the
+context for available use later.
+
+=back 4
+
+=head1 METHODS
+
+=cut
+
+use XML::Parser::Expat;
+use Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT);
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(read_xml);
+
+sub read_xml
+{
+ my ($font, $fname) = @_;
+
+ my ($xml) = XML::Parser::Expat->new;
+ my ($context) = {'xml' => $xml, 'font' => $font};
+
+ $xml->setHandlers('Start' => sub {
+ my ($x, $tag, %attrs) = @_;
+ my ($context) = $x->{' mycontext'};
+ my ($fn) = $context->{'receiver'}->can('XML_start');
+
+ push(@{$context->{'tree'}}, undef);
+ push(@{$context->{'stack'}}, [$context->{'receiver'}, {%attrs}]);
+ &{$fn}($context->{'receiver'}, $context, $tag, %attrs) if defined $fn;
+ },
+ 'End' => sub {
+ my ($x, $tag) = @_;
+ my ($context) = $x->{' mycontext'};
+ my ($fn) = $context->{'receiver'}->can('XML_end');
+ my ($stackinfo) = pop(@{$context->{'stack'}});
+ my ($current, $res);
+
+ $context->{'receiver'} = $stackinfo->[0];
+ $context->{'text'} =~ s/^\s*(.*?)\s*$/$1/o;
+ $res = &{$fn}($context->{'receiver'}, $context, $tag, %{$stackinfo->[1]}) if defined $fn;
+ $current = pop(@{$context->{'tree'}});
+ $current = $context->{'text'} unless (defined $current);
+ $context->{'text'} = '';
+
+ if (defined $res)
+ {
+ return if ($res eq $context);
+ $current = $res;
+ }
+ return unless $#{$context->{'tree'}} >= 0;
+ if ($tag eq 'elem')
+ {
+ $context->{'tree'}[-1] = [] unless defined $context->{'tree'}[-1];
+ push (@{$context->{'tree'}[-1]}, $current);
+ } else
+ {
+ $context->{'tree'}[-1] = {} unless defined $context->{'tree'}[-1];
+ $context->{'tree'}[-1]{$tag} = $current;
+ }
+ },
+ 'Char' => sub {
+ my ($x, $str) = @_;
+ $x->{' mycontext'}{'text'} .= $str;
+ });
+
+ $xml->{' mycontext'} = $context;
+
+ $context->{'receiver'} = $font;
+ if (ref $fname)
+ { return $xml->parse($fname); }
+ else
+ { return $xml->parsefile($fname); }
+}
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/lib/ttfmod.pl
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/lib/ttfmod.pl 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/lib/ttfmod.pl 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,174 @@
+# Title: TTFMOD.PL
+# Author: M. Hosken
+# Description: Read TTF file calling user functions for each table
+# and output transformed tables to new TTF file.
+# Useage: TTFMOD provides the complete control loop for processing
+# the TTF files. All that the caller need supply is an
+# associative array of functions to call keyed by the TTF
+# table name and the two filenames.
+#
+# &ttfmod($infile, $outfile, *fns [, @must]);
+#
+# *fns is an associative array keyed by table name with
+# values of the name of the subroutine in package main to
+# be called to transfer the table from INFILE to OUTFILE.
+# The subroutine is called with the following parameters and
+# expected return values:
+#
+# ($len, $csum) = &sub(*INFILE, *OUTFILE, $len);
+#
+# INFILE and OUTFILE are the input and output streams, $len
+# is the length of the table according to the directory.
+# The return values are $len = new length of table to be
+# given in the table directory. $csum = new value of table
+# checksum. A way to test that this is correct is to
+# checksum the whole file (e.g. using CSUM.BAT) and to
+# ensure that the value is 0xB1B0AFBA according to a 32 bit
+# checksum calculated bigendien.
+#
+# @must consists of a list of tables which must exist in the
+# final output file, either by being there alread or by being
+# inserted.
+#
+# Modifications:
+# MJPH 1.00 22-SEP-1994 Original
+# MJPH 1.1 18-MAR-1998 Added @must to ttfmod()
+# MJPH 1.1.1 25-MAR-1998 Added $csum to copytab (to make reusable)
+
+package ttfmod;
+
+sub main'ttfmod {
+ local($infile, $outfile, *fns, @must) = @_;
+
+ # open files as binary. Notice OUTFILE is opened for update not just write
+ open(INFILE, "$infile") || die "Unable top open \"$infile\" for reading";
+ binmode INFILE;
+ open(OUTFILE, "+>$outfile") || die "Unable to open \"$outfile\" for writing";
+ binmode OUTFILE;
+
+ seek(INFILE, 0, 0);
+ read(INFILE, $dir_head, 12) || die "Reading table header";
+ ($dir_num) = unpack("x4n", $dir_head);
+ print OUTFILE $dir_head;
+ # read and unpack table directory
+ for ($i = 0; $i < $dir_num; $i++)
+ {
+ read(INFILE, $dir_val, 16) || die "Reading table entry";
+ $dir{unpack("a4", $dir_val)} = join(":", $i, unpack("x4NNN", $dir_val));
+ print OUTFILE $dir_val;
+ printf STDERR "%s %08x\n", unpack("a4", $dir_val), unpack("x8N", $dir_val)
+ if (defined $main'opt_z);
+ }
+ foreach $n (@must)
+ {
+ next if defined $dir{$n};
+ $dir{$n} = "$i:0:-1:0";
+ $i++; $dir_num++;
+ print OUTFILE pack("a4NNN", $n, 0, -1, 0);
+ }
+ substr($dir_head, 4, 2) = pack("n", $dir_num);
+ $csum = unpack("%32N*", $dir_head);
+ $off = tell(OUTFILE);
+ seek(OUTFILE, 0, 0);
+ print OUTFILE $dir_head;
+ seek (OUTFILE, $off, 0);
+ # process tables in order they occur in the file
+ @dirlist = sort byoffset keys(%dir);
+ foreach $tab (@dirlist)
+ {
+ @tab_split = split(':', $dir{$tab});
+ seek(INFILE, $tab_split[2], 0); # offset
+ $tab_split[2] = tell(OUTFILE);
+ if (defined $fns{$tab})
+ {
+ $temp = "main'$fns{$tab}";
+ ($dir_len, $sum) = &$temp(*INFILE, *OUTFILE, $tab_split[3]);
+ }
+ else
+ {
+ ($dir_len, $sum) = ©tab(*INFILE, *OUTFILE, $tab_split[3]);
+ }
+ $tab_split[3] = $dir_len; # len
+ $tab_split[1] = $sum; # checksum
+ $out_dir{$tab} = join(":", @tab_split);
+ }
+ # now output directory in same order as original directory
+ @dirlist = sort byindex keys(%out_dir);
+ foreach $tab (@dirlist)
+ {
+ @tab_split = split(':', $out_dir{$tab});
+ seek (OUTFILE, 12 + $tab_split[0] * 16, 0); # directory index
+ print OUTFILE pack("A4N3", $tab, @tab_split[1..3]);
+ foreach $i (1..3, 1) # checksum directory values with csum twice
+ {
+ $csum += $tab_split[$i];
+ # this line ensures $csum stays within 32 bit bounds, clipping as necessary
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
+ }
+ # checksum the tag
+ $csum += unpack("N", $tab);
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
+ }
+ # handle main checksum
+ @tab_split = split(':', $out_dir{"head"});
+ seek(OUTFILE, $tab_split[2], 0);
+ read(OUTFILE, $head_head, 12); # read first bit of "head" table
+ @head_split = unpack("N3", $head_head);
+ $tab_split[1] -= $head_split[2]; # subtract old checksum
+ $csum -= $head_split[2] * 2; # twice because had double effect
+ # already
+ if ($csum < 0 ) { $csum += 0xffffffff; $csum++; }
+ $head_split[2] = 0xB1B0AFBA - $csum; # calculate new checksum
+ seek (OUTFILE, 12 + $tab_split[0] * 16, 0);
+ print OUTFILE pack("A4N3", "head", @tab_split[1..3]);
+ seek (OUTFILE, $tab_split[2], 0); # rewrite first bit of "head" table
+ print OUTFILE pack("N3", @head_split);
+
+ # finish up
+ close(OUTFILE);
+ close(INFILE);
+ }
+
+# support function for sorting by table offset
+sub byoffset {
+ @t1 = split(':', $dir{$a});
+ @t2 = split(':', $dir{$b});
+ return 1 if ($t1[2] == -1); # put inserted tables at the end
+ return -1 if ($t2[2] == -1);
+ return $t1[2] <=> $t2[2];
+ }
+
+# support function for sorting by directory entry order
+sub byindex {
+ $t1 = split(':', $dir{$a}, 1);
+ $t2 = split(':', $dir{$b}, 1);
+ return $t1 <=> $t2;
+ }
+
+# default table action: copies a table from input to output, recalculating
+# the checksum (just to be absolutely sure).
+sub copytab {
+ local(*INFILE, *OUTFILE, $len, $csum) = @_;
+
+ while ($len > 0)
+ {
+ $count = ($len > 8192) ? 8192 : $len; # 8K buffering
+ read(INFILE, $buf, $count) == $count || die "Copying";
+ $buf .= "\0" x (4 - ($count & 3)) if ($count & 3); # pad to long
+ print OUTFILE $buf;
+ $csum += unpack("%32N*", $buf);
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum--; }
+ $len -= $count;
+ }
+ ($_[2], $csum);
+ }
+
+# test routine to copy file from input to output, no changes
+package main;
+
+if ($test_package)
+ {
+ &ttfmod($ARGV[0], $ARGV[1], *dummy);
+ }
+else
+ { 1; }
Added: packages/libfont-ttf-perl/branches/upstream/current/pmake.bat
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/pmake.bat 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/pmake.bat 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,85 @@
+ at rem = '--*-Perl-*--
+ at echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S "%0" %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+ at rem ';
+#!/usr/local/bin/perl -w
+#line 15
+use 5.005; # Need look-behind assertions
+
+use Getopt::Std;
+use Make;
+
+my %opt;
+
+getopts('Dgnpf:j:C:',\%opt);
+
+my $info = Make->new(GNU => $opt{'g'},
+ Override => { MAKE => "$^X $0" },
+ Makefile => $opt{'f'},
+ Jobs => $opt{'j'},
+ Dir => $opt{'C'});
+
+if ($opt{'D'})
+ {
+ require Data::Dumper;
+ print Data::Dumper::DumperX($info);
+ exit;
+ }
+
+if ($opt{'p'})
+ {
+ $info->Print(@ARGV);
+ exit;
+ }
+if ($opt{'n'})
+ {
+ $info->Script(@ARGV);
+ }
+else
+ {
+ $info->Make(@ARGV);
+ }
+
+=head1 NAME
+
+pmake - a perl 'make' replacement
+
+=head1 SYNOPSIS
+
+ pmake [-n] [-g] [-p] [-C directory] targets
+
+=head1 DESCRIPTION
+
+Performs the same function as make(1) but is written entirely in perl.
+A subset of GNU make extensions is supported.
+For details see L<Make> for the underlying perl module.
+
+=head1 BUGS
+
+=item *
+
+No B<-k> flag
+
+I strongly suspect there are lots more.
+
+=head1 SEE ALSO
+
+L<Make>, make(1)
+
+=head1 AUTHOR
+
+Nick Ing-Simmons
+
+=cut
+
+
+__END__
+:endofperl
Property changes on: packages/libfont-ttf-perl/branches/upstream/current/pmake.bat
___________________________________________________________________
Name: svn:executable
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/check_attach.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/check_attach.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/check_attach.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,172 @@
+#! perl
+use Font::TTF::Font;
+use XML::Parser::Expat;
+use Getopt::Std;
+
+getopts('z:');
+
+$VERSION = 0.01; # MJPH 30-JUL-2001 Original
+
+unless (defined $ARGV[1])
+{
+ die <<'EOT';
+ check_attach [-z outfile.xml] infile.xml infile.ttf
+Checks an attachment point database against a font, checking that any
+contours are single point and any locations tie up with their corresponding
+contour, or that there exists a single point contour at a given location.
+This program can also generate missing information and write it to a new
+attachment point database.
+
+ -z file Output file to generate
+EOT
+}
+
+if (defined $opt_z)
+{
+ open('OUT', "> $opt_z") || die "Can't write $opt_z";
+}
+
+$f = Font::TTF::Font->open($ARGV[1]) || die "Can't open font $ARGV[1]";
+foreach $t (qw(post cmap loca))
+{ $f->{$t}->read; }
+
+$c = $f->{'cmap'}->find_ms->{'val'} || die "Can't find Unicode table in font $ARGV[1]";
+
+$xml = XML::Parser::Expat->new();
+$xml->setHandlers('Start' => sub {
+ my ($xml, $tag, %attrs) = @_;
+
+ if ($tag eq 'glyph')
+ {
+ my ($ug, $pg, $ig, $glyph);
+ $cur_glyph = {%attrs};
+ undef $cur_pt;
+
+ if (defined $opt_z)
+ { print OUT "<glyph"; }
+
+ if (defined $attrs{'UID'})
+ {
+ $ug = $c->{hex($attrs{'UID'})};
+ error($xml, "No glyph associated with UID $attrs{'UID'}") unless $ug;
+ $cur_glyph->{'gnum'} = $ug;
+ print OUT " UID=\"$attrs{'UID'}\"" if (defined $opt_z);
+ }
+ if (defined $attrs{'PSName'})
+ {
+ $pg = $f->{'post'}{'STRINGS'}{$attrs{'PSName'}};
+ error($xml, "No glyph associated with postscript name $attrs{'PSName'}") unless $pg;
+ error($xml, "Postscript name: $attrs{'PSName'} resolves to different glyph to Unicode ID: $attrs{'UID'}")
+ if (defined $attrs{'UID'} && $pg != $ug);
+ $cur_glyph->{'gnum'} ||= $pg;
+ print OUT " PSName=\"$attrs{'PSName'}\"" if (defined $opt_z);
+ }
+ if (defined $attrs{'GID'})
+ {
+ $ig = $attrs{'GID'};
+ error($xml, "Specified glyph id $attrs{'GID'} different to glyph of Unicode ID: $attrs{'UID'}")
+ if (defined $attrs{'UID'} && $ug != $ig);
+ error($xml, "Specified glyph id $attrs{'GID'} different to glyph of postscript name $attrs{'PSName'}")
+ if (defined $attrs{'PSName'} && $pg != $ig);
+ $cur_glyph->{'gnum'} ||= $ig;
+ print OUT " GID=\"$attrs{'GID'}\"" if (defined $opt_z);
+ }
+
+ unless ($glyph = $f->{'loca'}{'glyphs'}[$cur_glyph->{'gnum'}])
+ {
+ error ($xml, "No glyph outline in font");
+ return;
+ }
+ $cur_glyph->{'glyph'} = $glyph;
+ $cur_glyph->{'glyph'}->read_dat;
+ $cur_glyph->{'glyph'}->get_points;
+ print OUT ">\n" if (defined $opt_z);
+ } elsif ($tag eq 'point')
+ {
+ $cur_pt = {'name' => $attrs{'type'}};
+ } elsif ($tag eq 'contour')
+ {
+ my ($cont) = $attrs{'num'};
+ my ($g) = $cur_glyph->{'glyph'} || return;
+
+ error($xml, "Specified contour of $cont different from calculated contour of $cur_pt->{'cont'}")
+ if (defined $cur_pt->{'cont'} && $cur_pt->{'cont'} != $attrs{'num'});
+
+ if (($cont == 0 && $g->{'endPoints'}[0] != 0)
+ || ($cont > 0 && $g->{'endPoints'}[$cont-1] + 1 != $g->{'endPoints'}[$cont]))
+ { error($xml, "Contour $cont not a single point path"); }
+ else
+ { $cur_pt->{'cont'} = $cont; }
+
+ $cur_pt->{'x'} = $g->{'x'}[$g->{'endPoints'}[$cont]];
+ $cur_pt->{'y'} = $g->{'y'}[$g->{'endPoints'}[$cont]];
+ } elsif ($tag eq 'location')
+ {
+ my ($x) = $attrs{'x'};
+ my ($y) = $attrs{'y'};
+ my ($g) = $cur_glyph->{'glyph'} || return;
+ my ($cont, $i);
+
+ error($xml, "Specified location of ($x, $y) different from calculated location ($cur_pt->{'x'}, $cur_pt->{'y'})")
+ if (defined $cur_pt->{'x'} && ($cur_pt->{'x'} != $x || $cur_pt->{'y'} != $y));
+ for ($i = 0; $i < $g->{'numPoints'}; $i++)
+ {
+ if ($g->{'x'}[$i] == $x && $g->{'y'}[$i] == $y)
+ {
+ for ($cont = 0; $cont <= $#{$g->{'endPoints'}}; $cont++)
+ {
+ last if ($g->{'endPoints'}[$cont] > $i);
+ }
+ }
+ }
+ if ($g->{'x'}[$i] != $x || $g->{'y'}[$i] != $y)
+ { error($xml, "No glyph point at specified location ($x, $y)"); }
+ if (($cont == 0 && $g->{'endPoints'}[0] != 0)
+ || $g->{'endPoints'}[$cont-1] + 1 != $g->{'endPoints'}[$cont])
+ { error($xml, "Calculated contour $cont not a single point path"); }
+ else
+ { $cur_pt->{'cont'} = $cont; }
+
+ $cur_pt->{'x'} = $x unless defined $cur_pt->{'x'};
+ $cur_pt->{'y'} = $y unless defined $cur_pt->{'y'};
+ }
+}, 'End' => sub {
+ my ($xml, $tag) = @_;
+
+ return unless (defined $opt_z);
+
+ if ($tag eq 'point')
+ {
+ print OUT " <point type=\"$cur_pt->{'name'}\">\n";
+ print OUT " <contour num=\"$cur_pt->{'cont'}\"/>\n" if defined $cur_pt->{'cont'};
+ print OUT " <location x=\"$cur_pt->{'x'}\" y=\"$cur_pt->{'y'}\"/>\n" if defined $cur_pt->{'x'};
+ print OUT " </point>\n";
+ undef $cur_pt;
+ } elsif ($tag eq 'glyph')
+ { print OUT "</glyph>\n"; }
+});
+
+$xml->parsefile($ARGV[0]) || die "Failed to parse file $ARGV[0]";
+close(OUT) if defined $opt_z;
+
+sub error
+{
+ my ($xml, $str) = @_;
+
+ if (defined $cur_glyph->{'UID'})
+ { print "U+$cur_glyph->{'UID'}: "; }
+ elsif (defined $cur_glyph->{'PSName'})
+ { print "$cur_glyph->{'PSName'}: "; }
+ elsif (defined $cur_glyph->{'GID'})
+ { print "$cur_glyph->{'GID'}: "; }
+ else
+ { print "Undefined: "; }
+
+ print $str;
+
+ if (defined $cur_pt)
+ { print " in point $cur_pt->{'name'}"; }
+
+ print " at line " . $xml->current_line . ".\n";
+}
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/eurofix.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/eurofix.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/eurofix.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,74 @@
+#! perl
+# 1.1 MJPH 13-AUG-1999 Add U+00B7 and reverse mappings as well
+
+use Font::TTF::Font;
+require 'getopts.pl';
+Getopts('m:');
+
+unless (defined $ARGV[1])
+{
+ die <<'EOT';
+ EUROFIX [-m num] infile outfile
+Edits a font to account for the change in codepage 1252 definition in Win98,
+NT5 and all things new then. -m specifies that the Mac hack should also be
+done.
+
+The following changes are made to ensure that the glyphs at the two positions
+are the same, if possible:
+ U+0080 and U+20AC Euro sign
+ U+008E and U+017D Z caron
+ U+009E and U+017E z caron
+ U+00B7 and U+2219 Middle dot
+For more details of which glyph is used where in Windows, see the POD which
+accompanies this program.
+
+For the Mac table
+ glyph at U+0080 (in MS table) copied to num Euro sign
+ (-m may be for 240 or 211 depending on Apple or MS)
+
+Copies are only made if there is no glyph there already.
+EOT
+}
+
+$f = Font::TTF::Font->open($ARGV[0]);
+$f->{'cmap'}->read->{' isDirty'} = 1;
+
+copy_cmap($f, $opt_m, 0x0080, 0x20AC);
+copy_cmap($f, 0, 0x008E, 0x017D);
+copy_cmap($f, 0, 0x009E, 0x017E);
+copy_cmap($f, 0, 0x00B7, 0x2219);
+
+$f->{'OS/2'}->read->update;
+
+$f->out($ARGV[1]);
+
+
+
+sub copy_cmap
+{
+ my ($f, $mac, @equates) = @_;
+ my ($gnum, $i, $t, $u);
+
+ foreach $u (@equates)
+ { last if ($gnum = $f->{'cmap'}->ms_lookup($u)); }
+
+ return undef unless $gnum;
+
+ # Work through the tables hacking:
+ for ($i = 0; $i < $f->{'cmap'}{'Num'}; $i++)
+ {
+ $t = $f->{'cmap'}{'Tables'}[$i];
+ if ($mac && $t->{'Platform'} == 1 && $t->{'Encoding'} == 0)
+ { $t->{'val'}{$mac} = $gnum if ($mac && !$t->{'val'}{$mac}); } # Mac
+ elsif (($t->{'Platform'} == 0 && $t->{'Encoding'} == 0)
+ || ($t->{'Platform'} == 3 && $t->{'Encoding'} == 1))
+ {
+ foreach $u (@equates)
+ { $t->{'val'}{$u} = $gnum unless $t->{'val'}{$u}; }
+ } # ISO or MS
+ }
+ $f;
+}
+
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/hackos2.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/hackos2.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/hackos2.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,166 @@
+#! perl
+# Title: HACKOS2.BAT
+# Author: M. Hosken
+# Description:
+# 1.001 MJPH 05-AUG-1997 Fix &makestr() to work properly
+# 1.002 MJPH 06-AUG-1997 Add -d & -q support
+# 1.1 MJPH 22-MAR-1998 Add -f support
+# 1.2 MJPH 11-JUN-1999 Add -t support
+# 1.3 MJPH 9-AUG-1999 Fix -d glob
+# 1.4 MJPH 17-FEB-2000 Fix typo for type 1 tables
+# 1.5 MJPH 19-SEP-2000 Add -n, -x
+# 1.6 MJPH 10-NOV-2000 Add -v
+
+require 'ttfmod.pl';
+require 'getopts.pl';
+do Getopts("c:d:f:n:p:qt:u:v:x:");
+
+$[ = 0;
+if ((defined $opt_d && !defined $ARGV[0]) || (!defined $opt_d && !defined $ARGV[1]))
+ {
+ die 'HACKOS2 [-c hex] [-d directory] [-f fsSelection] [-p hex] [-q]
+ [-t num] [-u hex] <infile> <outfile>
+
+v1.6.0, 10-NOV-2000 (c) martin_hosken at sil.org
+
+Hacks the OS/2 table of a ttf file copying from infile to outfile.
+ -c change codepage information (a 64 bit hex number)
+ -d specifies output directory for processing multiple files. In which
+ case <outfile> is not used and <infile> may be a list including
+ wildcards.
+ -f fsSelection value (16 bit hex) (e.g. 4240 for Thai fonts)
+ -n sets usFirstCharIndex given a hex value
+ -p change panose info
+ (10 bytes of hex in reverse order: 0A090807060504030201)
+ -q Quiet mode (do not list names as they are processed)
+ -t Sets fsType (embedding) information (decimal)
+ -u change unicode info (a 128 bit hex number)
+ -v sets vendor tag to the first 4 chars of the string
+ -x sets usLastCharIndex given a hex value
+
+For example, to convert a Win3.1 ANSI font to Win95 use the following:
+ hackos2 -c01 -u03 old.ttf new.ttf
+or for a Symbol font use:
+ hackos2 -c80000000 -u0 old.ttf new.ttf
+Or to revert:
+ hackos2 -cnone other.ttf new.ttf
+';
+ }
+
+$old = select(STDERR); $| = 1; select($old);
+
+if ($opt_c =~ m/^none/oi)
+ {
+ undef $opt_c;
+ $revert = 1;
+ }
+else
+ { $revert = 0; }
+
+$fns{"OS/2"} = "hackos2";
+
+if (defined $opt_d)
+ {
+ foreach $a (@ARGV)
+ {
+ foreach $f (glob($a))
+ {
+ print STDERR "$f -> $opt_d/$f\n" unless (defined $opt_q);
+ &ttfmod($f, "$opt_d/$f", *fns);
+ }
+ }
+ }
+else
+ {
+ &ttfmod($ARGV[0], $ARGV[1], *fns);
+ }
+
+sub hackos2
+ {
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ read(INFILE, $dat, 78);
+ $ver = unpack("n", substr($dat, 0, 2));
+ if ($revert)
+ {
+ if ($ver == 1)
+ {
+ substr($dat, 0, 2) = pack("n", 0);
+ $len = 78;
+ }
+ }
+ else
+ {
+ if ($ver == 1)
+ {
+ read(INFILE, $dat1, 8);
+ $dat .= $dat1;
+ }
+ elsif (defined $opt_c)
+ {
+ substr($dat, 0, 2) = pack("n", 1);
+ $dat .= pack("x8", 0);
+ $len = 86;
+ }
+ }
+ if (defined $opt_c)
+ { substr($dat, 78, 8) = &makestr($opt_c, 8, 4); }
+# pack("NN", unpack("LL", &makestr($opt_c, 8))); }
+ if (defined $opt_p)
+ { substr($dat, 32, 10) = &makestr($opt_p, 10, 1); }
+ if (defined $opt_u)
+ { substr($dat, 42, 16) = &makestr($opt_u, 16, 4); }
+# pack("NNNN", unpack("LLLL", &makestr($opt_u, 16))); }
+ if (defined $opt_f)
+ { substr($dat, 62, 2) = &makestr($opt_f, 2, 2); }
+ if (defined $opt_t)
+ { substr($dat, 8, 2) = pack("n", $opt_t); }
+ if (defined $opt_n)
+ { substr($dat, 64, 2) = &makestr($opt_n, 2, 2); }
+ if (defined $opt_x)
+ { substr($dat, 66, 2) = &makestr($opt_x, 2, 2); }
+ if (defined $opt_v)
+ { substr($dat, 58, 4) = pack("A4", $opt_v); }
+ $csum = unpack("%32N", $dat);
+ print OUTFILE $dat;
+ ($len, $csum);
+ }
+
+# &makestr($string, $number_of_bytes, $granule)
+# converts $string as a big hex number into a packed string no longer than
+# $number_of_bytes long. The string is then swapped on the $granule byte
+# boundary so that the least significant bundle comes first. This is unless
+# $granule is 0 or -ve.
+#
+# returns its string in Network order.
+
+sub makestr
+ {
+ local($str, $len, $group) = @_;
+ local($res, $have, $temp);
+
+ $have = length($str);
+ if ($have % 2)
+ {
+ $str = "0" . $str;
+ $have++;
+ }
+ $have >>= 1;
+ $have = $len if ($have > $len);
+ $res = "\000" x ($len - $have);
+ for ($i = 0; $i < $have; $i++)
+ { $res .= pack("C", hex(substr($str, $i << 1, 2))); }
+ if ($group > 0)
+ {
+ $temp = "";
+ for ($i = 0; $i < $len / $group; $i++)
+ {
+ $temp = substr($res, $i * $group, $group) . $temp;
+ }
+ $res = $temp;
+ }
+ ($res);
+ }
+
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/psfix.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/psfix.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/psfix.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,934 @@
+#! perl
+use Font::TTF::Font;
+
+unless (defined $ARGV[1])
+{
+ die <<'EOT';
+ PSFIX infile outfile
+Updates Postscript table to account for Postscript Unicode conventions
+EOT
+}
+
+while(<DATA>)
+{
+ s/\015?\012$//oi;
+ ($i, $name) = split ';';
+ $names{hex($i)} = $name;
+}
+
+$f = Font::TTF::Font->open($ARGV[0]);
+$f->{'post'}->read if defined $f->{'post'};
+$c = $f->{'cmap'}->read->find_ms;
+$num = $f->{'maxp'}{'numGlyphs'};
+
+foreach $s (keys %{$c->{'val'}})
+{
+ push(@{$res[$c->{'val'}{$s}]}, $s);
+}
+
+outer:
+for ($i = 1; $i < $num; $i++) # skip .notdef for 0
+{
+ @u = sort {$a <=> $b} @{$res[$i]};
+ if ($u[0] == 0) # if no Unicode value, use some other scheme
+ {
+ $f->{'post'}{'VAL'}[$i] =~ s/^([0-9]+)/sil$1/oi
+ || $f->{'post'}{'VAL'}[$i] =~ s/[:+-]/sil/oig;
+ next;
+ }
+ foreach (@u)
+ {
+ if ($names{$_})
+ {
+ $f->{'post'}{'VAL'}[$i] = $names{$_};
+ next outer;
+ }
+ }
+ $f->{'post'}{'VAL'}[$i] = sprintf("uni%04X", $u[0]);
+}
+
+$f->out($ARGV[1]);
+
+
+__DATA__
+0020;space
+0021;exclam
+0022;quotedbl
+0023;numbersign
+0024;dollar
+0025;percent
+0026;ampersand
+0027;quotesingle
+0028;parenleft
+0029;parenright
+002A;asterisk
+002B;plus
+002C;comma
+002D;hyphen
+002E;period
+002F;slash
+0030;zero
+0031;one
+0032;two
+0033;three
+0034;four
+0035;five
+0036;six
+0037;seven
+0038;eight
+0039;nine
+003A;colon
+003B;semicolon
+003C;less
+003D;equal
+003E;greater
+003F;question
+0040;at
+0041;A
+0042;B
+0043;C
+0044;D
+0045;E
+0046;F
+0047;G
+0048;H
+0049;I
+004A;J
+004B;K
+004C;L
+004D;M
+004E;N
+004F;O
+0050;P
+0051;Q
+0052;R
+0053;S
+0054;T
+0055;U
+0056;V
+0057;W
+0058;X
+0059;Y
+005A;Z
+005B;bracketleft
+005C;backslash
+005D;bracketright
+005E;asciicircum
+005F;underscore
+0060;grave
+0061;a
+0062;b
+0063;c
+0064;d
+0065;e
+0066;f
+0067;g
+0068;h
+0069;i
+006A;j
+006B;k
+006C;l
+006D;m
+006E;n
+006F;o
+0070;p
+0071;q
+0072;r
+0073;s
+0074;t
+0075;u
+0076;v
+0077;w
+0078;x
+0079;y
+007A;z
+007B;braceleft
+007C;bar
+007D;braceright
+007E;asciitilde
+00A0;space
+00A1;exclamdown
+00A2;cent
+00A3;sterling
+00A4;currency
+00A5;yen
+00A6;brokenbar
+00A7;section
+00A8;dieresis
+00A9;copyright
+00AA;ordfeminine
+00AB;guillemotleft
+00AC;logicalnot
+00AD;hyphen
+00AE;registered
+00AF;macron
+00B0;degree
+00B1;plusminus
+00B2;twosuperior
+00B3;threesuperior
+00B4;acute
+00B5;mu
+00B6;paragraph
+00B7;periodcentered
+00B8;cedilla
+00B9;onesuperior
+00BA;ordmasculine
+00BB;guillemotright
+00BC;onequarter
+00BD;onehalf
+00BE;threequarters
+00BF;questiondown
+00C0;Agrave
+00C1;Aacute
+00C2;Acircumflex
+00C3;Atilde
+00C4;Adieresis
+00C5;Aring
+00C6;AE
+00C7;Ccedilla
+00C8;Egrave
+00C9;Eacute
+00CA;Ecircumflex
+00CB;Edieresis
+00CC;Igrave
+00CD;Iacute
+00CE;Icircumflex
+00CF;Idieresis
+00D0;Eth
+00D1;Ntilde
+00D2;Ograve
+00D3;Oacute
+00D4;Ocircumflex
+00D5;Otilde
+00D6;Odieresis
+00D7;multiply
+00D8;Oslash
+00D9;Ugrave
+00DA;Uacute
+00DB;Ucircumflex
+00DC;Udieresis
+00DD;Yacute
+00DE;Thorn
+00DF;germandbls
+00E0;agrave
+00E1;aacute
+00E2;acircumflex
+00E3;atilde
+00E4;adieresis
+00E5;aring
+00E6;ae
+00E7;ccedilla
+00E8;egrave
+00E9;eacute
+00EA;ecircumflex
+00EB;edieresis
+00EC;igrave
+00ED;iacute
+00EE;icircumflex
+00EF;idieresis
+00F0;eth
+00F1;ntilde
+00F2;ograve
+00F3;oacute
+00F4;ocircumflex
+00F5;otilde
+00F6;odieresis
+00F7;divide
+00F8;oslash
+00F9;ugrave
+00FA;uacute
+00FB;ucircumflex
+00FC;udieresis
+00FD;yacute
+00FE;thorn
+00FF;ydieresis
+0100;Amacron
+0101;amacron
+0102;Abreve
+0103;abreve
+0104;Aogonek
+0105;aogonek
+0106;Cacute
+0107;cacute
+0108;Ccircumflex
+0109;ccircumflex
+010A;Cdotaccent
+010B;cdotaccent
+010C;Ccaron
+010D;ccaron
+010E;Dcaron
+010F;dcaron
+0110;Dcroat
+0111;dcroat
+0112;Emacron
+0113;emacron
+0114;Ebreve
+0115;ebreve
+0116;Edotaccent
+0117;edotaccent
+0118;Eogonek
+0119;eogonek
+011A;Ecaron
+011B;ecaron
+011C;Gcircumflex
+011D;gcircumflex
+011E;Gbreve
+011F;gbreve
+0120;Gdotaccent
+0121;gdotaccent
+0122;Gcommaaccent
+0123;gcommaaccent
+0124;Hcircumflex
+0125;hcircumflex
+0126;Hbar
+0127;hbar
+0128;Itilde
+0129;itilde
+012A;Imacron
+012B;imacron
+012C;Ibreve
+012D;ibreve
+012E;Iogonek
+012F;iogonek
+0130;Idotaccent
+0131;dotlessi
+0132;IJ
+0133;ij
+0134;Jcircumflex
+0135;jcircumflex
+0136;Kcommaaccent
+0137;kcommaaccent
+0138;kgreenlandic
+0139;Lacute
+013A;lacute
+013B;Lcommaaccent
+013C;lcommaaccent
+013D;Lcaron
+013E;lcaron
+013F;Ldot
+0140;ldot
+0141;Lslash
+0142;lslash
+0143;Nacute
+0144;nacute
+0145;Ncommaaccent
+0146;ncommaaccent
+0147;Ncaron
+0148;ncaron
+0149;napostrophe
+014A;Eng
+014B;eng
+014C;Omacron
+014D;omacron
+014E;Obreve
+014F;obreve
+0150;Ohungarumlaut
+0151;ohungarumlaut
+0152;OE
+0153;oe
+0154;Racute
+0155;racute
+0156;Rcommaaccent
+0157;rcommaaccent
+0158;Rcaron
+0159;rcaron
+015A;Sacute
+015B;sacute
+015C;Scircumflex
+015D;scircumflex
+015E;Scedilla
+015F;scedilla
+0160;Scaron
+0161;scaron
+0162;Tcommaaccent
+0163;tcommaaccent
+0164;Tcaron
+0165;tcaron
+0166;Tbar
+0167;tbar
+0168;Utilde
+0169;utilde
+016A;Umacron
+016B;umacron
+016C;Ubreve
+016D;ubreve
+016E;Uring
+016F;uring
+0170;Uhungarumlaut
+0171;uhungarumlaut
+0172;Uogonek
+0173;uogonek
+0174;Wcircumflex
+0175;wcircumflex
+0176;Ycircumflex
+0177;ycircumflex
+0178;Ydieresis
+0179;Zacute
+017A;zacute
+017B;Zdotaccent
+017C;zdotaccent
+017D;Zcaron
+017E;zcaron
+017F;longs
+0192;florin
+01A0;Ohorn
+01A1;ohorn
+01AF;Uhorn
+01B0;uhorn
+01E6;Gcaron
+01E7;gcaron
+01FA;Aringacute
+01FB;aringacute
+01FC;AEacute
+01FD;aeacute
+01FE;Oslashacute
+01FF;oslashacute
+0218;Scommaaccent
+0219;scommaaccent
+021A;Tcommaaccent
+021B;tcommaaccent
+02BC;afii57929
+02BD;afii64937
+02C6;circumflex
+02C7;caron
+02C9;macron
+02D8;breve
+02D9;dotaccent
+02DA;ring
+02DB;ogonek
+02DC;tilde
+02DD;hungarumlaut
+0300;gravecomb
+0301;acutecomb
+0303;tildecomb
+0309;hookabovecomb
+0323;dotbelowcomb
+0384;tonos
+0385;dieresistonos
+0386;Alphatonos
+0387;anoteleia
+0388;Epsilontonos
+0389;Etatonos
+038A;Iotatonos
+038C;Omicrontonos
+038E;Upsilontonos
+038F;Omegatonos
+0390;iotadieresistonos
+0391;Alpha
+0392;Beta
+0393;Gamma
+0394;Delta
+0395;Epsilon
+0396;Zeta
+0397;Eta
+0398;Theta
+0399;Iota
+039A;Kappa
+039B;Lambda
+039C;Mu
+039D;Nu
+039E;Xi
+039F;Omicron
+03A0;Pi
+03A1;Rho
+03A3;Sigma
+03A4;Tau
+03A5;Upsilon
+03A6;Phi
+03A7;Chi
+03A8;Psi
+03A9;Omega
+03AA;Iotadieresis
+03AB;Upsilondieresis
+03AC;alphatonos
+03AD;epsilontonos
+03AE;etatonos
+03AF;iotatonos
+03B0;upsilondieresistonos
+03B1;alpha
+03B2;beta
+03B3;gamma
+03B4;delta
+03B5;epsilon
+03B6;zeta
+03B7;eta
+03B8;theta
+03B9;iota
+03BA;kappa
+03BB;lambda
+03BC;mu
+03BD;nu
+03BE;xi
+03BF;omicron
+03C0;pi
+03C1;rho
+03C2;sigma1
+03C3;sigma
+03C4;tau
+03C5;upsilon
+03C6;phi
+03C7;chi
+03C8;psi
+03C9;omega
+03CA;iotadieresis
+03CB;upsilondieresis
+03CC;omicrontonos
+03CD;upsilontonos
+03CE;omegatonos
+03D1;theta1
+03D2;Upsilon1
+03D5;phi1
+03D6;omega1
+0401;afii10023
+0402;afii10051
+0403;afii10052
+0404;afii10053
+0405;afii10054
+0406;afii10055
+0407;afii10056
+0408;afii10057
+0409;afii10058
+040A;afii10059
+040B;afii10060
+040C;afii10061
+040E;afii10062
+040F;afii10145
+0410;afii10017
+0411;afii10018
+0412;afii10019
+0413;afii10020
+0414;afii10021
+0415;afii10022
+0416;afii10024
+0417;afii10025
+0418;afii10026
+0419;afii10027
+041A;afii10028
+041B;afii10029
+041C;afii10030
+041D;afii10031
+041E;afii10032
+041F;afii10033
+0420;afii10034
+0421;afii10035
+0422;afii10036
+0423;afii10037
+0424;afii10038
+0425;afii10039
+0426;afii10040
+0427;afii10041
+0428;afii10042
+0429;afii10043
+042A;afii10044
+042B;afii10045
+042C;afii10046
+042D;afii10047
+042E;afii10048
+042F;afii10049
+0430;afii10065
+0431;afii10066
+0432;afii10067
+0433;afii10068
+0434;afii10069
+0435;afii10070
+0436;afii10072
+0437;afii10073
+0438;afii10074
+0439;afii10075
+043A;afii10076
+043B;afii10077
+043C;afii10078
+043D;afii10079
+043E;afii10080
+043F;afii10081
+0440;afii10082
+0441;afii10083
+0442;afii10084
+0443;afii10085
+0444;afii10086
+0445;afii10087
+0446;afii10088
+0447;afii10089
+0448;afii10090
+0449;afii10091
+044A;afii10092
+044B;afii10093
+044C;afii10094
+044D;afii10095
+044E;afii10096
+044F;afii10097
+0451;afii10071
+0452;afii10099
+0453;afii10100
+0454;afii10101
+0455;afii10102
+0456;afii10103
+0457;afii10104
+0458;afii10105
+0459;afii10106
+045A;afii10107
+045B;afii10108
+045C;afii10109
+045E;afii10110
+045F;afii10193
+0462;afii10146
+0463;afii10194
+0472;afii10147
+0473;afii10195
+0474;afii10148
+0475;afii10196
+0490;afii10050
+0491;afii10098
+04D9;afii10846
+05B0;afii57799
+05B1;afii57801
+05B2;afii57800
+05B3;afii57802
+05B4;afii57793
+05B5;afii57794
+05B6;afii57795
+05B7;afii57798
+05B8;afii57797
+05B9;afii57806
+05BB;afii57796
+05BC;afii57807
+05BD;afii57839
+05BE;afii57645
+05BF;afii57841
+05C0;afii57842
+05C1;afii57804
+05C2;afii57803
+05C3;afii57658
+05D0;afii57664
+05D1;afii57665
+05D2;afii57666
+05D3;afii57667
+05D4;afii57668
+05D5;afii57669
+05D6;afii57670
+05D7;afii57671
+05D8;afii57672
+05D9;afii57673
+05DA;afii57674
+05DB;afii57675
+05DC;afii57676
+05DD;afii57677
+05DE;afii57678
+05DF;afii57679
+05E0;afii57680
+05E1;afii57681
+05E2;afii57682
+05E3;afii57683
+05E4;afii57684
+05E5;afii57685
+05E6;afii57686
+05E7;afii57687
+05E8;afii57688
+05E9;afii57689
+05EA;afii57690
+05F0;afii57716
+05F1;afii57717
+05F2;afii57718
+060C;afii57388
+061B;afii57403
+061F;afii57407
+0621;afii57409
+0622;afii57410
+0623;afii57411
+0624;afii57412
+0625;afii57413
+0626;afii57414
+0627;afii57415
+0628;afii57416
+0629;afii57417
+062A;afii57418
+062B;afii57419
+062C;afii57420
+062D;afii57421
+062E;afii57422
+062F;afii57423
+0630;afii57424
+0631;afii57425
+0632;afii57426
+0633;afii57427
+0634;afii57428
+0635;afii57429
+0636;afii57430
+0637;afii57431
+0638;afii57432
+0639;afii57433
+063A;afii57434
+0640;afii57440
+0641;afii57441
+0642;afii57442
+0643;afii57443
+0644;afii57444
+0645;afii57445
+0646;afii57446
+0647;afii57470
+0648;afii57448
+0649;afii57449
+064A;afii57450
+064B;afii57451
+064C;afii57452
+064D;afii57453
+064E;afii57454
+064F;afii57455
+0650;afii57456
+0651;afii57457
+0652;afii57458
+0660;afii57392
+0661;afii57393
+0662;afii57394
+0663;afii57395
+0664;afii57396
+0665;afii57397
+0666;afii57398
+0667;afii57399
+0668;afii57400
+0669;afii57401
+066A;afii57381
+066D;afii63167
+0679;afii57511
+067E;afii57506
+0686;afii57507
+0688;afii57512
+0691;afii57513
+0698;afii57508
+06A4;afii57505
+06AF;afii57509
+06BA;afii57514
+06D2;afii57519
+06D5;afii57534
+1E80;Wgrave
+1E81;wgrave
+1E82;Wacute
+1E83;wacute
+1E84;Wdieresis
+1E85;wdieresis
+1EF2;Ygrave
+1EF3;ygrave
+200C;afii61664
+200D;afii301
+200E;afii299
+200F;afii300
+2012;figuredash
+2013;endash
+2014;emdash
+2015;afii00208
+2017;underscoredbl
+2018;quoteleft
+2019;quoteright
+201A;quotesinglbase
+201B;quotereversed
+201C;quotedblleft
+201D;quotedblright
+201E;quotedblbase
+2020;dagger
+2021;daggerdbl
+2022;bullet
+2024;onedotenleader
+2025;twodotenleader
+2026;ellipsis
+202C;afii61573
+202D;afii61574
+202E;afii61575
+2030;perthousand
+2032;minute
+2033;second
+2039;guilsinglleft
+203A;guilsinglright
+203C;exclamdbl
+2044;fraction
+2070;zerosuperior
+2074;foursuperior
+2075;fivesuperior
+2076;sixsuperior
+2077;sevensuperior
+2078;eightsuperior
+2079;ninesuperior
+207D;parenleftsuperior
+207E;parenrightsuperior
+207F;nsuperior
+2080;zeroinferior
+2081;oneinferior
+2082;twoinferior
+2083;threeinferior
+2084;fourinferior
+2085;fiveinferior
+2086;sixinferior
+2087;seveninferior
+2088;eightinferior
+2089;nineinferior
+208D;parenleftinferior
+208E;parenrightinferior
+20A1;colonmonetary
+20A3;franc
+20A4;lira
+20A7;peseta
+20AA;afii57636
+20AB;dong
+20AC;Euro
+2105;afii61248
+2111;Ifraktur
+2113;afii61289
+2116;afii61352
+2118;weierstrass
+211C;Rfraktur
+211E;prescription
+2122;trademark
+2126;Omega
+212E;estimated
+2135;aleph
+2153;onethird
+2154;twothirds
+215B;oneeighth
+215C;threeeighths
+215D;fiveeighths
+215E;seveneighths
+2190;arrowleft
+2191;arrowup
+2192;arrowright
+2193;arrowdown
+2194;arrowboth
+2195;arrowupdn
+21A8;arrowupdnbse
+21B5;carriagereturn
+21D0;arrowdblleft
+21D1;arrowdblup
+21D2;arrowdblright
+21D3;arrowdbldown
+21D4;arrowdblboth
+2200;universal
+2202;partialdiff
+2203;existential
+2205;emptyset
+2206;Delta
+2207;gradient
+2208;element
+2209;notelement
+220B;suchthat
+220F;product
+2211;summation
+2212;minus
+2215;fraction
+2217;asteriskmath
+2219;periodcentered
+221A;radical
+221D;proportional
+221E;infinity
+221F;orthogonal
+2220;angle
+2227;logicaland
+2228;logicalor
+2229;intersection
+222A;union
+222B;integral
+2234;therefore
+223C;similar
+2245;congruent
+2248;approxequal
+2260;notequal
+2261;equivalence
+2264;lessequal
+2265;greaterequal
+2282;propersubset
+2283;propersuperset
+2284;notsubset
+2286;reflexsubset
+2287;reflexsuperset
+2295;circleplus
+2297;circlemultiply
+22A5;perpendicular
+22C5;dotmath
+2302;house
+2310;revlogicalnot
+2320;integraltp
+2321;integralbt
+2329;angleleft
+232A;angleright
+2500;SF100000
+2502;SF110000
+250C;SF010000
+2510;SF030000
+2514;SF020000
+2518;SF040000
+251C;SF080000
+2524;SF090000
+252C;SF060000
+2534;SF070000
+253C;SF050000
+2550;SF430000
+2551;SF240000
+2552;SF510000
+2553;SF520000
+2554;SF390000
+2555;SF220000
+2556;SF210000
+2557;SF250000
+2558;SF500000
+2559;SF490000
+255A;SF380000
+255B;SF280000
+255C;SF270000
+255D;SF260000
+255E;SF360000
+255F;SF370000
+2560;SF420000
+2561;SF190000
+2562;SF200000
+2563;SF230000
+2564;SF470000
+2565;SF480000
+2566;SF410000
+2567;SF450000
+2568;SF460000
+2569;SF400000
+256A;SF540000
+256B;SF530000
+256C;SF440000
+2580;upblock
+2584;dnblock
+2588;block
+258C;lfblock
+2590;rtblock
+2591;ltshade
+2592;shade
+2593;dkshade
+25A0;filledbox
+25A1;H22073
+25AA;H18543
+25AB;H18551
+25AC;filledrect
+25B2;triagup
+25BA;triagrt
+25BC;triagdn
+25C4;triaglf
+25CA;lozenge
+25CB;circle
+25CF;H18533
+25D8;invbullet
+25D9;invcircle
+25E6;openbullet
+263A;smileface
+263B;invsmileface
+263C;sun
+2640;female
+2642;male
+2660;spade
+2663;club
+2665;heart
+2666;diamond
+266A;musicalnote
+266B;musicalnotedbl
+FB00;ff
+FB01;fi
+FB02;fl
+FB03;ffi
+FB04;ffl
+FB1F;afii57705
+FB2A;afii57694
+FB2B;afii57695
+FB35;afii57723
+FB4B;afii57700
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfbuilder.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfbuilder.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfbuilder.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,1189 @@
+use Font::TTF::Font;
+use Font::TTF::Glyf;
+use Font::TTF::Glyph;
+use Font::TTF::Hmtx;
+use Font::TTF::Loca;
+use Font::TTF::PSNames;
+use XML::Parser::Expat;
+use Pod::Usage;
+use Getopt::Std;
+
+$VERSION = 0.17; # MJPH 28-MAR-2003 Fix property copying
+# $VERSION = 0.16; # MJPH 1-FEB-2003 Fix surrogates
+# $VERSION = 0.15; # MJPH 3-OCT-2002 Allow overstrike="right" etc.
+# $VERSION = 0.14; # MJPH 2-OCT-2002 Fix scaling and component references
+# $VERSION = 0.13; # MJPH 17-AUG-2002 Add noaps attribute, points on attachments now work
+# $VERSION = 0.12; # MJPH 22-JUL-2002 Fix overstrike
+# $VERSION = 0.11; # MJPH 11-JUL-2002 Error message refining
+# $VERSION = 0.10; # MJPH 24-JUN-2002 add rsb & lsb tags and -d 16 (overstriking disabling)
+# $VERSION = 0.09; # MJPH 14-JUN-2002 Fix property output and bad sync in attach.xml
+# $VERSION = 0.08; # MJPH 16-APR-2002 Change default PS names for .notdef null & CR
+# $VERSION = 0.07; # MJPH 18-MAR-2002 Support .notdef
+# $VERSION = 0.06; # MJPH 7-MAR-2002 errors, base glyphs with no outlines,
+# properties & notes, symbol fonts, surrogates
+# $VERSION = 0.05; # MJPH 10-DEC-2001 improve error messages
+# $VERSION = 0.04; # MJPH 19-SEP-2001 documentation improvements add Pod::Usage
+# $VERSION = 0.03; # MJPH 18-SEP-2001 add ascent, descent, linegap attributes
+# $VERSION = 0.02; # MJPH 12-SEP-2001 -x now optional, -a bug fixes
+# $VERSION = 0.01; # MJPH 31-JUL-2001 Original
+
+getopts('ac:d:hx:z:');
+
+unless ((defined $ARGV[1] && defined $opt_c) || defined $opt_h)
+{
+ die <<"EOT";
+ TTFBUILDER version $VERSION
+
+ ttfbuilder [-a] [-h] -c config.xml [-x attach.xml] [-z out.xml] \\
+ infile.ttf outfile.ttf
+Builds outfile.ttf from infile.ttf according to config.xml. Also requires an
+attachment point database (attach.xml) and can generate out.xml.
+
+ -a initialise output font with all the glyphs of the input font
+ and append new glyphs to that
+ -c file Configuration file to use
+ -d bits Flag bits
+ 0: Don't Set dates in the font to now
+ 1: Don't Auto-create postscript names for component glyphs
+ 2: Don't Hack the copyright message (if none set)
+ 3: Mark target font as symbol font
+ 4: Default to not allowing overstrikes (ensures guard space) on lhs
+ 5: Default to not allowing overstriking on rhs
+ -h Help
+ -x file Attachment database to read
+ -z file Attachment database to output
+EOT
+}
+
+if ($opt_h)
+{
+ pod2usage( -verbose => 2);
+ exit;
+}
+
+$if = Font::TTF::Font->open($ARGV[0]) || die "Can't read font $ARGV[0]";
+$of = Font::TTF::Font->new();
+foreach $t ('OS/2', 'cvt ', 'fpgm', 'gasp', 'head', 'hhea', 'maxp', 'name', 'prep', 'post')
+{
+ next unless defined $if->{$t};
+ $if->{$t}->read;
+ $of->{$t} = bless {%{$if->{$t}}}, ref $if->{$t};
+ $of->{$t}{' PARENT'} = $of;
+}
+
+$c = $if->{'cmap'}->read->find_ms;
+$ifissymbol = $if->{'cmap'}->ms_enc;
+$ifissymbol = 1 if (defined $ifissymbol && $ifissymbol == 0);
+
+$if->{'hmtx'}->read;
+$fname = $if->{'name'}->find_name(4);
+
+if (defined $opt_x)
+{
+ $xml = XML::Parser::Expat->new();
+ $xml->setHandlers('Start' => sub {
+ my ($xml, $tag, %attrs) = @_;
+
+ if ($tag eq 'glyph')
+ {
+ $gid = $c->{'val'}{hex($attrs{'UID'})}
+ || $if->{'post'}{'STRINGS'}{$attrs{'PSName'}}
+ || $attrs{'GID'};
+ if (!defined $gid && ($attrs{'PSName'} || $attrs{'UID'}))
+ { return $xml->xpcarp("No glyph called: $attrs{'PSName'}, Unicode: $attrs{'UID'} in $opt_x"); }
+ $xml_dat[$gid]{'ps'} = $attrs{'PSName'};
+ $xml_dat[$gid]{'UID'} = $attrs{'UID'};
+ } elsif ($tag eq 'point')
+ {
+ $pname = $attrs{'type'};
+ } elsif ($tag eq 'contour')
+ {
+ $xml_dat[$gid]{'points'}{$pname}{'cont'} = $attrs{'num'};
+ } elsif ($tag eq 'location')
+ {
+ $xml_dat[$gid]{'points'}{$pname}{'loc'} = [$attrs{'x'}, $attrs{'y'}];
+ } elsif ($tag eq 'font')
+ {
+ $fontname = $attrs{'name'};
+ $fontupem = $attrs{'upem'};
+ } elsif ($tag eq 'property')
+ {
+ $xml_dat[$gid]{'properties'}{$attrs{'name'}} = $attrs{'value'};
+ } elsif ($tag eq 'note')
+ {
+ $currtext = '';
+ }
+ }, 'End' => sub {
+ my ($xml, $tag) = @_;
+
+ if ($tag eq 'point')
+ { $xml->xpcarp("Attachment point must have location or contour in $opt_x")
+ unless (defined $xml_dat[$gid]{'points'}{$pname}{'cont'}
+ || defined $xml_dat[$gid]{'points'}{$pname}{'loc'}); }
+ elsif ($tag eq 'note')
+ {
+ $currtext =~ s/\s*(.*?)\s*$//o;
+ $xml_dat[$gid]{'notes'} = $currtext;
+ $currtext = '';
+ }
+ }, 'Char' => sub {
+ my ($xml, $str) = @_;
+
+ $currtext .= $str;
+ });
+
+ $xml->parsefile($opt_x) || die "Can't read $opt_x";
+}
+
+$if->{'loca'}->read;
+$of->{'hmtx'} = Font::TTF::Hmtx->new(PARENT => $of, read => 1);
+
+if ($opt_a)
+{
+ my ($p, $aglyph);
+
+ $oc = {%{$if->{'cmap'}->find_ms->{'val'}}};
+ for ($i = 0; $i < $if->{'maxp'}{'numGlyphs'}; $i++)
+ {
+ my ($g) = $if->{'loca'}{'glyphs'}[$i];
+ my ($bbox);
+
+ $aglyph = {
+ 'GID' => $i,
+ 'PSName' => $if->{'post'}{'VAL'}[$i]};
+
+ if ($g)
+ {
+ $g->read;
+ $bbox =
+ $aglyph->{'glyph_list'} = [{
+ 'glyph' => $g,
+ 'GID' => $i,
+ 'offset' => [0, 0]}];
+ $aglyph->{'bbox'} = [$g->{'xMin'}, $g->{'yMin'}, $g->{'xMax'}, $g->{'yMax'}];
+ }
+
+ foreach $p (keys %{$xml_dat[$i]{'points'}})
+ {
+ my ($p1) = $xml_dat[$i]{'points'}{$p};
+ $aglyph->{'points'}{$p}{'base'} = $aglyph;
+ $aglyph->{'points'}{$p}{'loc'} = [@{$p1->{'loc'}}] if (defined $p1->{'loc'});
+ $aglyph->{'points'}{$p}{'cont'} = $p1->{'cont'} if (defined $p1->{'cont'}); # deep copy - klunky
+ }
+ $aglyph->{'properties'} = {%{$xml_dat[$i]{'properties'}}} if defined $xml_dat[$i]{'properties'};
+ $aglyph->{'notes'} = $xml_dat[$i]{'notes'} if defined $xml_dat[$i]{'notes'};
+ $g->{'required'} = $i;
+ push (@glyphs, $aglyph);
+ $of->{'hmtx'}{'advance'}[$i] = $if->{'hmtx'}{'advance'}[$i];
+ }
+ $gcount = $i - 1;
+} else {
+ $oc = {};
+ $gcount = 2;
+}
+
+$xml = XML::Parser::Expat->new();
+$xml->setHandlers('Start' => sub {
+ my ($xml, $tag, %attrs) = @_;
+ my ($curbase) = $xml->{' curbase'};
+
+ if ($tag eq 'glyph')
+ {
+ $curbase = {%attrs};
+ $xml->{' curbase'} = $curbase;
+ $curbase->{'GID'} = ++$gcount unless (defined $curbase->{'GID'});
+ $gcount = $curbase->{'GID'} if ($gcount < $curbase->{'GID'});
+ $glyphs[$curbase->{'GID'}] = $curbase;
+ }
+ elsif ($tag eq 'base' || $tag eq 'attach')
+ {
+ my ($gid, $aglyph, $p);
+
+ unless (($attrs{'PSName'} && ($gid = $if->{'post'}{'STRINGS'}{$attrs{'PSName'}}))
+ || ($attrs{'UID'} && ($gid = $c->{'val'}{hex($attrs{'UID'})}))
+ || ($gid = $attrs{'GID'}) || defined $attrs{'GID'})
+ { $xml->xpcarp("Can't find glyph $attrs{PSName}/U+" . ($attrs{UID} ? $attrs{UID} : "0000") . " for $tag in $opt_c"); }
+
+ $aglyph = {
+ 'gid' => $gid,
+ 'glyph' => $if->{'loca'}{'glyphs'}[$gid],
+ 'parent' => $curbase,
+ 'PSName' => $attrs{'PSName'},
+ 'UID' => $attrs{'UID'}
+ };
+ push (@{$curbase->{'glyphs'}}, $aglyph); # build components tree
+
+ unless (defined $attrs{'noaps'})
+ {
+ foreach $p (keys %{$xml_dat[$gid]{'points'}})
+ {
+ my ($p1) = $xml_dat[$gid]{'points'}{$p};
+ $aglyph->{'points'}{$p}{'base'} = $aglyph;
+ $aglyph->{'points'}{$p}{'loc'} = [@{$p1->{'loc'}}] if (defined $p1->{'loc'});
+ $aglyph->{'points'}{$p}{'cont'} = $p1->{'cont'} if (defined $p1->{'cont'}); # deep copy - klunky
+ }
+ }
+ $aglyph->{'properties'} = {%{$xml_dat[$gid]{'properties'}}} if defined $xml_dat[$gid]{'properties'};
+ $aglyph->{'notes'} = $xml_dat[$gid]{'notes'} if defined $xml_dat[$gid]{'notes'};
+
+ if ($tag eq 'attach') # position attachment
+ {
+ my ($atx, $aty, $withx, $withy, $pt);
+ if (defined $attrs{'at'})
+ {
+ $pt = $xml_dat[$curbase->{'gid'}]{'points'}{$attrs{'at'}};
+ if (!defined $pt)
+ { $xml->xpcarp("Undefined attachment point $attrs{'at'} on glyph $xml_dat[$curbase->{'gid'}]{'ps'} in $opt_c"); }
+ elsif (!defined $pt->{'loc'})
+ {
+ if (defined $pt->{'cont'})
+ {
+ $xml->xpcarp("glyph $xml_dat[$curbase->{'gid'}]{'ps'} has no outline in $opt_c")
+ unless ($curbase->{'glyph'});
+ $pt->{'loc'} = lookup_pt($curbase->{'glyph'}, $pt->{'cont'});
+ }
+ else
+ { $xml->xpcarp("Unlocatable attachment point $attrs{'at'} on glyph $xml_dat[$curbase->{'gid'}]{'ps'} in $opt_c"); }
+ }
+ ($atx, $aty) = @{$pt->{'loc'}};
+ delete $curbase->{'points'}{$attrs{'at'}}; # used it so delete it
+ } else # no attachment point, default centre the glyphs in x
+ {
+ $atx = $if->{'hmtx'}{'advance'}[$curbase->{'gid'}] / 2;
+ $aty = 0;
+ }
+
+ if (defined $attrs{'with'})
+ {
+ $pt = $xml_dat[$aglyph->{'gid'}]{'points'}{$attrs{'with'}};
+ if (!defined $pt)
+ { $xml->xpcarp("Undefined attachment point $attrs{'with'} on glyph $xml_dat[$aglyph->{'gid'}]{'ps'} in $opt_c"); }
+ elsif (!defined $pt->{'loc'})
+ {
+ if (defined $pt->{'cont'})
+ { $pt->{'loc'} = lookup_pt($aglyph->{'glyph'}, $pt->{'cont'}); }
+ else
+ { $xml->xpcarp("Unlocatable attachment point $attrs{'at'} on glyph $xml_dat[$aglyph->{'gid'}]{'ps'} in $opt_c"); }
+ }
+ ($withx, $withy) = @{$pt->{'loc'}};
+ delete $aglyph->{'points'}{$attrs{'with'}} # delete if attaching to a real glyph
+ if (defined $curbase->{'glyph'} && $curbase->{'glyph'}{'numPoints'} != scalar @{$curbase->{'glyph'}{'endPoints'}});
+ } else
+ {
+ $withx = $if->{'hmtx'}{'advance'}[$aglyph->{'gid'}] / 2;
+ $withy = 0;
+ }
+
+ $aglyph->{'roffset'} = [$atx - $withx, $aty - $withy];
+ }
+ $xml->{' curbase'} = $aglyph;
+ }
+ elsif ($tag eq 'advance')
+ {
+ $curbase->{'adv'} = $attrs{'width'};
+ }
+ elsif ($tag eq 'rsb')
+ {
+ $curbase->{'adv'} = $curbase->{'glyph'}->read->{'xMax'} + $attrs{'width'};
+ }
+ elsif ($tag eq 'lsb')
+ {
+ $curbase->{'lsb'} = $attrs{'width'};
+ }
+ elsif ($tag eq 'shift')
+ {
+ $curbase->{'roffset'}[0] += $attrs{'x'};
+ $curbase->{'roffset'}[1] += $attrs{'y'};
+ }
+ elsif ($tag eq 'string')
+ {
+ $cur_str = {%attrs};
+ $currtext = '';
+ }
+ elsif ($tag eq 'font')
+ {
+ my ($s);
+
+ $of->{'hhea'}{'Ascender'} = $attrs{'ascent'} if defined $attrs{'ascent'};
+ $of->{'hhea'}{'Descender'} = $attrs{'descent'} if defined $attrs{'descent'};
+ $of->{'hhea'}{'LineGap'} = $attrs{'linegap'} if defined $attrs{'linegap'};
+ if ($s = $attrs{'cp'})
+ {
+ $s = '0' x (16 - length($s)) . $s;
+ $of->{'OS/2'}{'ulCodePageRange1'} = hex(substr($s, 8));
+ $of->{'OS/2'}{'ulCodePageRange2'} = hex(substr($s, 0, 8));
+ }
+ if ($s = $attrs{'coverage'})
+ {
+ $s = '0' x (32 - length($s)) . $s;
+ $of->{'OS/2'}{'ulUnicodeRange1'} = hex(substr($s, 24));
+ $of->{'OS/2'}{'ulUnicodeRange2'} = hex(substr($s, 16, 8));
+ $of->{'OS/2'}{'ulUnicodeRange3'} = hex(substr($s, 8, 8));
+ $of->{'OS/2'}{'ulUnicodeRange4'} = hex(substr($s, 0, 8));
+ }
+ }
+ elsif ($tag eq 'property')
+ {
+ $curbase->{'properties'}{$attrs{'name'}} = $attrs{'value'};
+ }
+ elsif ($tag eq 'note')
+ {
+ $currtext = '';
+ }
+}, 'End' => sub {
+ my ($xml, $tag) = @_;
+ my ($curbase) = $xml->{' curbase'};
+
+ if ($tag eq 'base' || $tag eq 'attach')
+ {
+ $curbase->{'adv'} = $if->{'hmtx'}{'advance'}[$curbase->{'gid'}]
+ unless (defined $curbase->{'adv'});
+ $xml->{' curbase'} = $curbase->{'parent'};
+ $curbase = $xml->{' curbase'};
+ if ($tag eq 'base' && scalar @{$curbase->{'glyphs'}} == 1)
+ {
+ my ($k);
+ foreach $k (keys %{$curbase->{'glyphs'}[0]{'properties'}})
+ {
+ $curbase->{'properties'}{$k} = $curbase->{'glyphs'}[0]{'properties'}{$k}
+ unless defined $curbase->{'properties'}{$k};
+ }
+ $curbase->{'notes'} = $curbase->{'glyphs'}[0]{'notes'}
+ if (defined $curbase->{'glyphs'}[0]{'notes'} && !defined $curbase->{'notes'});
+ }
+ }
+ elsif ($tag eq 'glyph')
+ {
+ my ($adv, $g, $xMin, $yMin, $xMax, $yMax, $p, $lorg, $pcount);
+
+ foreach $g (@{$curbase->{'glyphs'}})
+ {
+ $pcount = resolve_glyph($g, $adv, 0, $pcount, !(over_asnum($curbase->{'overstrike'}, ($opt_d & 32) >> 4) & 2)); # get absolute position of glyph
+ $adv = $g->{'offset'}[0] + $g->{'adv'};
+ $lorg = $g->{'lorg'} if ($g->{'lorg'} < $lorg);
+ push (@{$curbase->{'glyph_list'}}, @{$g->{'glyph_list'}}); # compile full glyph list
+ if (defined $g->{'bbox'})
+ { ($xMin, $yMin, $xMax, $yMax) =
+ findbox($xMin, $yMin, $xMax, $yMax, $g->{'bbox'}, $g->{'offset'}); }
+ foreach $p (keys %{$g->{'points'}})
+ { $curbase->{'points'}{$p} = $g->{'points'}{$p}; }
+ }
+
+ if ((over_asnum($curbase->{'overstrike'}, ($opt_d & 16) >> 4) & 1) && $lorg < 0)
+ {
+ foreach $g (@{$curbase->{'glyph_list'}})
+ { $g->{'offset'}[0] -= $lorg; }
+ foreach $g (@{$curbase->{'glyphs'}})
+ { $g->{'offset'}[0] -= $lorg; }
+ $adv -= $lorg;
+ $xMax -= $lorg;
+ $xMin -= $lorg;
+ }
+
+ if (scalar @{$curbase->{'glyph_list'}} == 1) # only one glyph?
+ {
+ my ($cg) = $curbase->{'glyph_list'}[0];
+
+ if ($cg->{'offset'}[0] == 0 && $cg->{'offset'}[1] == 0 && !defined $cg->{'scale'}) # no move - then basis for other references
+ { $cg->{'glyph'}{'required'} = $curbase->{'GID'}; }
+ else
+ { $cg->{'glyph'}{'required1'} = $curbase->{'GID'}; } # moved - perhaps a basis
+ }
+
+ $curbase->{'bbox'} = [$xMin, $yMin, $xMax, $yMax];
+ $of->{'hmtx'}{'advance'}[$curbase->{'GID'}] = # font update handles lsb
+ defined ($curbase->{'adv'}) ? $curbase->{'adv'} : $adv; # resolve advance width here
+ undef $xml->{' curbase'};
+ }
+ elsif ($tag eq 'string')
+ {
+ $currtext =~ s/^\s*(.*?)\s*$/$1/o;
+ $currtext =~ s/\s(?=\s)//og;
+ $cur_str->{'text'} = $currtext;
+ if ($cur_str->{'num'} eq 'name')
+ {
+ my ($style);
+
+ $cur_str->{'num'} = 1;
+ do_name($of, $cur_str);
+ $style = $of->{'name'}->find_name(2);
+ if ($style && $style ne 'Regular')
+ { $cur_str->{'text'} .= " $style"; }
+ $cur_str->{'num'} = 4;
+ do_name($of, $cur_str);
+ } else
+ { do_name($of, $cur_str); }
+ if ($cur_str->{'num'} == 0)
+ { $done_cpyrt = 1; }
+ undef $cur_str;
+ }
+ elsif ($tag eq 'note')
+ {
+ $currtext =~s/^\s*(.*?)\s*$/$1/o;
+ $curbase->{'notes'} = $currtext;
+ }
+}, 'Char' => sub {
+ my ($xml, $text) = @_;
+
+ $currtext .= $text;
+});
+
+$xml->parsefile($opt_c) || die "Can't read $opt_c";
+
+unless ($opt_a) # only need this if not copying old font anyway.
+{
+ my (@names) = qw(.notdef .null nonmarkingreturn);
+ # fill in first 3 special glyphs: .notdef .null nonmarkingreturn
+ for ($i = 0; $i < 3; $i++)
+ {
+ my ($g, $bbox);
+
+ next if defined $glyphs[$i];
+
+ $g = $if->{'loca'}{'glyphs'}[$i];
+ if ($g)
+ {
+ $g->read;
+ $bbox = [$g->{'xMin'}, $g->{'yMin'}, $g->{'xMax'}, $g->{'yMax'}];
+
+ $glyphs[$i] = {
+ 'GID' => $i,
+ 'glyph_list' => [{
+ 'glyph' => $g,
+ 'GID' => $i}],
+ 'bbox' => $bbox,
+ 'PSName' => $names[$i]};
+ } else
+ {
+ $glyphs[$i] = {
+ 'GID' => $i,
+ 'PSName' => $names[$i]};
+ }
+ $of->{'hmtx'}{'advance'}[$i] = $if->{'hmtx'}{'advance'}[$i];
+ }
+
+ # resolve reference bases - use possible bases here
+ for ($i = 0; $i < $if->{'maxp'}{'numGlyphs'}; $i++)
+ {
+ my ($g) = $if->{'loca'}{'glyphs'}[$i];
+ my ($bbox);
+
+ next unless ($g && $g->{'required'} == -1);
+ $g->read;
+ if (defined $g->{'required1'})
+ {
+ $g->{'required'} = $g->{'required1'};
+ next;
+ }
+ $bbox = [$g->{'xMin'}, $g->{'yMin'}, $g->{'xMax'}, $g->{'yMax'}];
+
+ push (@glyphs, {
+ 'GID' => ++$gcount,
+ 'glyph_list' => [{
+ 'glyph' => $g,
+ 'GID' => $i,
+ 'offset' => [0, 0]}],
+ 'bbox' => $bbox,
+ ($opt_d & 2 ? () : ('PSName' => $if->{'post'}{'VAL'}[$i]))});
+ $g->{'required'} = $gcount;
+ $of->{'hmtx'}{'advance'}[$gcount] = $if->{'hmtx'}{'advance'}[$i];
+ }
+}
+
+
+$of->{'maxp'}{'numGlyphs'} = scalar @glyphs;
+$of->{'post'}{'VAL'} = [];
+$of->{'loca'} = Font::TTF::Loca->new(PARENT => $of, read => 1);
+$of->{'glyf'} = Font::TTF::Glyf->new(PARENT => $of, read => 1);
+
+if ($opt_z)
+{
+ my ($fname) = $of->{'name'}->find_name(4);
+ open (OX, "> $opt_z") || die "Can't open $opt_z for writing";
+ print OX "<?xml version='1.0' encoding='UTF-8'?>\n";
+ print OX "<font name=\"$fname\" upem=\"$of->{'head'}{'unitsPerEm'}\">\n";
+}
+
+for ($i = 0; $i < $of->{'maxp'}{'numGlyphs'}; $i++)
+{
+ my ($g) = $glyphs[$i];
+ my ($glyph, $uid, $pname);
+
+ unless (defined $g)
+ {
+ $of->{'post'}{'VAL'}[$i] = '.notdef';
+ next;
+ }
+
+ if ($g->{'UID'})
+ {
+ $uid = hex($g->{'UID'});
+ $uidmax = $uid if ($uid > $uidmax);
+ $oc->{$uid} = $i;
+ } else
+ { $uid = 0; }
+ if ($g->{'BID'})
+ { $bc->{hex($g->{'BID'})} = $i; }
+
+ if ($g->{'PSName'})
+ { $pname = $g->{'PSName'}; }
+ else
+ { $pname = Font::TTF::PSNames::lookup($uid); }
+ $of->{'post'}{'VAL'}[$i] = $pname;
+
+ if (scalar @{$g->{'glyph_list'}})
+ {
+
+ $glyph = Font::TTF::Glyph->new(PARENT => $of, read => 2);
+ $glyph->{'xMin'} = $g->{'bbox'}[0];
+ $glyph->{'yMin'} = $g->{'bbox'}[1];
+ $glyph->{'xMax'} = $g->{'bbox'}[2];
+ $glyph->{'yMax'} = $g->{'bbox'}[3];
+ if (scalar @{$g->{'glyph_list'}} == 1)
+ {
+ my ($cg) = $g->{'glyph_list'}[0];
+ my ($gb) = $cg->{'glyph'};
+ foreach (qw(numberOfContours xMin yMin xMax yMax), ' DAT')
+ { $glyph->{$_} = $gb->{$_}; }
+ $glyph->{' read'} = 1;
+ if ($glyph->{'numberOfContours'} < 0)
+ {
+ my ($comp);
+ $glyph->read_dat;
+ foreach $comp (@{$glyph->{'comps'}})
+ { $comp->{'glyph'} = $if->{'loca'}{'glyphs'}[$comp->{'glyph'}]{'required'}; }
+ }
+ if ($cg->{'offset'}[0] != 0 || $cg->{'offset'}[1] != 0 || defined $cg->{'scale'})
+ {
+ $glyph->read_dat;
+ if ($glyph->{'numberOfContours'} < 0)
+ {
+ my ($comp);
+
+ foreach $comp (@{$glyph->{'comps'}})
+ {
+ $comp->{'args'}[0] += $cg->{'offset'}[0];
+ $comp->{'args'}[1] += $cg->{'offset'}[1];
+ $comp->{'scale'} = mat_mult($cg->{'scale'}, $comp->{'scale'});
+ }
+ } else
+ {
+ for ($j = 0; $j < scalar @{$glyph->{'x'}}; $j++)
+ {
+ my ($x, $y) = ($glyph->{'x'}[$j], $glyph->{'y'}[$j]);
+
+ if ($cg->{'scale'})
+ {
+ my (@m) = @{$cg->{'scale'}};
+ if ($m[0] != 0 || $m[1] != 0 || $m[2] != 0 || $m[3] != 0)
+ {
+ $x = $x * $m[0] + $y * $m[1];
+ $y = $x * $m[2] + $y * $m[3];
+ }
+ }
+
+ $x += $cg->{'offset'}[0];
+ $y += $cg->{'offset'}[1];
+ ($glyph->{'x'}[$j], $glyph->{'y'}[$j]) = ($x, $y);
+ }
+ }
+ }
+ $of->{'hmtx'}{'lsb'}[$i] -= $cg->{'offset'}[0];
+ } else
+ {
+ my ($gb);
+
+ $glyph->{'numberOfContours'} = -1;
+ foreach $gb (@{$g->{'glyph_list'}})
+ {
+ my ($co) = $glyphs[$gb->{'glyph'}{'required'}]{'glyph_list'}[0];
+
+ push (@{$glyph->{'comps'}}, {
+ 'glyph' => $gb->{'glyph'}{'required'},
+ 'flag' => 2,
+ # 'scale' => mat_mult($gb->{'scale'}, $co->{'scale'}),
+ 'scale' => $gb->{'scale'},
+ 'args' => [$gb->{'offset'}[0] - $co->{'offset'}[0], $gb->{'offset'}[1] - $co->{'offset'}[1]]});
+ }
+ }
+ $of->{'loca'}{'glyphs'}[$i] = $glyph;
+ }
+
+ next unless defined $opt_z;
+ print OX "\n<glyph GID=\"$i\"";
+ print OX " PSName=\"$pname\"" if ($pname ne '.notdef');
+ printf OX " UID=\"%04X\"", $uid if ($uid != 0);
+ print OX ">\n";
+ foreach $glyph (@{$g->{'glyphs'}})
+ {
+ my ($p, $cg);
+
+ if (scalar @{$g->{'glyph_list'}} > 1)
+ {
+ foreach $cg (@{$g->{'glyph_list'}})
+ {
+ my ($ag) = $glyphs[$if->{'loca'}{'glyphs'}[$cg->{'GID'}]{'required'}];
+ my (@bbox) = ($ag->{'bbox'}[0] + $cg->{'offset'}[0],
+ $ag->{'bbox'}[1] + $cg->{'offset'}[1],
+ $ag->{'bbox'}[2] + $cg->{'offset'}[0],
+ $ag->{'bbox'}[3] + $cg->{'offset'}[1]);
+ print OX " <compound bbox=\"" . join(', ', @bbox) . "\"";
+ if ($ag->{'UID'})
+ { print OX " UID=\"$ag->{'UID'}\""; }
+ elsif ($ag->{'PSName'})
+ { print OX " PSName=\"$ag->{'PSName'}\""; }
+ elsif ($ag->{'GID'})
+ { print OX " GID=\"$ag->{'GID'}\""; }
+ print OX "/>\n";
+ }
+ }
+ foreach $p (keys %{$g->{'points'}})
+ {
+ my ($p1) = $g->{'points'}{$p};
+ my ($pb) = $p1->{'base'};
+
+ print OX " <point type=\"$p\">\n";
+ print OX " <contour num=\"" .
+ ($p1->{'cont'} + $pb->{'pathbase'}) .
+ "\"/>\n" if (defined $p1->{'cont'});
+ print OX " <location x=\"" . ($p1->{'loc'}[0] + $pb->{'offset'}[0]) .
+ "\" y=\"" . ($p1->{'loc'}[1] + $pb->{'offset'}[1]) .
+ "\"/>\n" if ($p1->{'loc'});
+ print OX " </point>\n";
+ }
+ }
+ foreach $p (keys %{$g->{'glyphs'}[0]{'properties'}})
+ { print OX " <property name=\"$p\" value=\"$g->{'glyphs'}[0]{'properties'}{$p}\"/>\n"; }
+ print OX "</glyph>\n";
+}
+
+if ($opt_z)
+{
+ print OX "\n</font>\n";
+ close(OX);
+}
+
+$of->{'cmap'} = Font::TTF::Cmap->new(PARENT => $of, read => 1);
+
+$format = $uidmax > 0xFFFF ? 12 : 4;
+push (@{$of->{'cmap'}{'Tables'}}, {
+ 'Platform' => 0,
+ 'Encoding' => 0,
+ 'Format' => $format,
+ 'Ver' => 0,
+ 'val' => $oc});
+if ($bc)
+{
+ push (@{$of->{'cmap'}{'Tables'}}, {
+ 'Platform' => 1,
+ 'Encoding' => 0,
+ 'Format' => 0,
+ 'Ver' => 0,
+ 'val' => $bc});
+}
+
+push (@{$of->{'cmap'}{'Tables'}}, {
+ 'Platform' => 3,
+ 'Encoding' => ($uidmax > 0xFFFF ? 10 : ($opt_d & 8 ? 0 : 1)),
+ 'Format' => $format,
+ 'Ver' => 0,
+ 'val' => $oc});
+
+if ($uidmax > 0xFFFF) # also include a BMP cmap
+{
+ my ($k);
+
+ foreach $k (keys %{$oc})
+ { $bmpc{$k} = $oc->{$k} if ($k <= 0xFFFF); }
+ push (@{$of->{'cmap'}{'Tables'}}, {
+ 'Platform' => 3,
+ 'Encoding' => ($opt_d & 8 ? 0 : 1),
+ 'Format' => 4,
+ 'Ver' => 0,
+ 'val' => \%bmpc});
+}
+
+$of->{'cmap'}{'Num'} = scalar @{$of->{'cmap'}{'Tables'}};
+
+unless ($done_cpyrt || ($opt_d & 4))
+{
+ my ($text) = $of->{'name'}->find_name(0);
+ $text .= " Derived from $fname by ttfbuilder v$VERSION";
+ do_name($of, {'num' => 0, 'text' => $text});
+}
+
+if ($ifissymbol ^ ($opt_d & 8 ? 1 : 0))
+{
+ my ($n, $s);
+
+ foreach $n (@{$of->{'name'}{'strings'}})
+ {
+ if (defined ($s = $n->[3][!$ifissymbol]))
+ {
+ undef $n->[3][!$ifissymbol];
+ $n->[3][$ifissymbol] = $s;
+ }
+ }
+}
+
+unless ($opt_d & 1)
+{
+ $of->{'head'}->setdate(time(), 1); # set creation date
+ $of->{'head'}->setdate(time(), 0); # set modified date
+}
+$of->tables_do(sub {$_[0]->dirty});
+$of->update;
+# $of->{'head'}{'flags'} &= ~2;
+$of->out($ARGV[1]) || die "Can't write to font file $ARGV[1]. Do you have it installed?";
+
+sub resolve_glyph
+{
+ my ($g, $orgx, $orgy, $pathcount, $overstrike) = @_;
+ my ($glyph, $xMin, $yMin, $xMax, $yMax, $c, $p, $adv, $lorg);
+
+ $g->{'pathbase'} = $pathcount;
+ $g->{'offset'} = [$g->{'roffset'}[0] + $orgx,
+ $g->{'roffset'}[1] + $orgy];
+ $adv = (defined $g->{'adv'} ? $g->{'adv'} : $if->{'hmtx'}{'advance'}[$g->{'gid'}])
+ + $g->{'offset'}[0];
+
+ if ($glyph = $g->{'glyph'})
+ {
+ $glyph->read->get_points;
+ $pathcount += scalar @{$glyph->{'endPoints'}};
+
+ push (@{$g->{'glyph_list'}}, pos_glyphs($g->{'gid'}, $glyph, @{$g->{'offset'}}, $g->{'scale'}));
+
+ $xMin = $glyph->{'xMin'};
+ $yMin = $glyph->{'yMin'};
+ $xMax = $glyph->{'xMax'};
+ $yMax = $glyph->{'yMax'};
+ }
+
+ $lorg = $xMin - $g->{'lsb'} + $g->{'offset'}[0];
+
+ foreach $c (@{$g->{'glyphs'}})
+ {
+ my ($lorgt);
+ $pathcount = resolve_glyph($c, @{$g->{'offset'}}, $pathcount);
+ $adv = $c->{'adv'} if (!$overstrike && $c->{'adv'} > $adv);
+ ($xMin, $yMin, $xMax, $yMax) = findbox($xMin, $yMin, $xMax, $yMax, $c->{'bbox'}, $c->{'offset'});
+ $lorgt = $c->{'bbox'}[0] - $c->{'lsb'} + $c->{'offset'}[0];
+ $lorg = $lorgt if ($lorgt < $lorg);
+ push (@{$g->{'glyph_list'}}, @{$c->{'glyph_list'}});
+ foreach $p (keys %{$c->{'points'}})
+ { $g->{'points'}{$p} = $c->{'points'}{$p}; }
+ }
+ $g->{'bbox'} = [$xMin, $yMin, $xMax, $yMax];
+ $g->{'adv'} = $adv;
+ $g->{'lorg'} = $lorg;
+ return $pathcount;
+}
+
+sub pos_glyphs
+{
+ my ($gid, $glyph, $orgx, $orgy, $scale) = @_;
+
+ if ($glyph->{'numberOfContours'} < 0)
+ {
+ my (@res);
+ $glyph->read_dat;
+ foreach $comp (@{$glyph->{'comps'}})
+ {
+ push (@res, pos_glyphs($comp->{'glyph'},
+ $if->{'loca'}{'glyphs'}[$comp->{'glyph'}],
+ $comp->{'args'}[0] + $orgx,
+ $comp->{'args'}[1] + $orgy, mat_mult($scale, $comp->{'scale'})));
+ }
+ return @res;
+ } elsif (scalar @{$glyph->{'endPoints'}} == $glyph->{'numPoints'})
+ {
+ return ();
+ } else
+ {
+ $glyph->{'required'} = -1 if (!defined $glyph->{'required'});
+ return ({
+ 'GID' => $gid,
+ 'offset' => [$orgx, $orgy],
+ 'scale' => $scale,
+ 'glyph' => $glyph});
+ }
+}
+
+
+sub lookup_pt
+{
+ my ($glyph, $cont) = @_;
+ $glyph->get_points;
+ return [$glyph->{'x'}[$glyph->{'endPoints'}[$cont]],
+ $glyph->{'y'}[$glyph->{'endPoints'}[$cont]]];
+}
+
+sub findbox
+{
+ my ($xMin, $yMin, $xMax, $yMax, $others, $org) = @_;
+ my ($o);
+
+ $o = $others->[0] + $org->[0];
+ $xMin = $o if (!defined $xMin || $o < $xMin);
+ $o = $others->[1] + $org->[1];
+ $yMin = $o if (!defined $yMin || $o < $yMin);
+ $o = $others->[2] + $org->[0];
+ $xMax = $o if ($o > $xMax);
+ $o = $others->[3] + $org->[1];
+ $yMax = $o if ($o > $yMax);
+ ($xMin, $yMin, $xMax, $yMax);
+}
+
+sub do_name
+{
+ my ($f, $inf) = @_;
+ my ($base) = $f->{'name'}{'strings'}[$inf->{'num'}];
+ my ($pid, $eid, $lid);
+ my $processed;
+
+ for ($pid = 0; $pid <= $#{$base}; $pid++)
+ {
+ next if (defined $inf->{'pid'} && $pid != $inf->{'pid'});
+ next unless $base->[$pid];
+ for ($eid = 0; $eid <= $#{$base->[$pid]}; $eid++)
+ {
+ next if (defined $inf->{'eid'} && $eid != $inf->{'eid'});
+ next unless $base->[$pid][$eid];
+ next unless $f->{'name'}->is_utf8($pid, $eid);
+ foreach $lid (keys %{$base->[$pid][$eid]})
+ {
+ next if (defined $inf->{'lid'} && $lid != $inf->{'lid'});
+ $base->[$pid][$eid]{$lid} = $inf->{'text'};
+ $processed = 1;
+ }
+ }
+ }
+ # Add this name if we haven't done something with it yet and it is fully specified:
+ if (!$processed)
+ {
+ if (defined $inf->{'pid'} && defined $inf->{'eid'} && defined $inf->{'lid'})
+ { $f->{'name'}{'strings'}[$inf->{'num'}][$inf->{'pid'}][$inf->{'eid'}]{$inf->{'lid'}}
+ = $inf->{'text'}; }
+ else
+ { warn "Incompletely specified string not added to name table."; }
+ }
+}
+
+sub as_bool
+{
+ my ($str, $default) = @_;
+
+ if ($str eq '1' || $str eq 'true')
+ { return 1; }
+ elsif ($str eq '0' || $str eq 'false')
+ { return 0; }
+ else
+ { return $default; }
+}
+
+sub over_asnum
+{
+ my ($str, $default) = @_;
+
+ if ($str eq '1' || $str eq 'true' || $str eq 'both')
+ { return 3; }
+ elsif ($str eq 'left')
+ { return 1; }
+ elsif ($str eq 'right')
+ { return 2; }
+ elsif ($str eq '0' || $str eq 'false' || $str eq 'none')
+ { return 0; }
+ else
+ { return $default; }
+}
+
+sub mat_mult
+{
+ my ($a, $b) = @_;
+
+ if (!defined $a)
+ { return $b; }
+ if (!defined $b)
+ { return $a; }
+
+ return [$a->[0] * $b->[0] + $a->[1] * $b->[2], $a->[0] * $b->[1] + $a->[1] * $b->[3],
+ $a->[2] * $b->[0] + $a->[3] * $b->[2], $a->[2] * $b->[1] + $a->[3] * $b->[3]];
+}
+
+__END__
+
+=head1 TITLE
+
+ttfbuilder - assemble a font from another font
+
+=head1 DESCRIPTION
+
+ttfbuilder is a font subsetting program gone wild. It's aim is to allow a user to
+describe a new font in terms of the glyph pallette of a source font. Thus the new
+font may include ligatures of glyphs in the source font, or positional movements
+or whatever.
+
+The main features of ttfbuilder are
+
+=over 4
+
+=item *
+
+Ability to create glyphs that are not in any cmap and to reference such glyphs via
+postscript name, glyph id or Unicode cmap entry.
+
+=item *
+
+Ability to work with an attachment points database. Thus ligatures are assembled
+by describing which attachment points should coincide, rather than having to give
+absolute locations in terms of shifting.
+
+=item *
+
+Ability to change the name of the font and change strings in the name table.
+
+=back
+
+ttfbuilder is controlled via a description file which describes the glyphs in the
+new font, in terms of glyphs in the source font. This description file is an XML
+file with the following key elements:
+
+=over 4
+
+=item glyph
+
+This describes a glyph and the attributes allow setting of the postscript name and
+Unicode id for the glyph. The glyph element has children which describe what goes
+into the glyph.
+
+The C<overstrike> attribute controls whether an attachment to a base glyph can extend
+beyond origin or the advance width of the base glyph. The default is to allow the
+diacritics to extend and even occur to the left of the origin or to the right of the
+advance. if C<overstrike> is set to C<left> for a glyph, then any diacritics may not
+extend to the left of the origin and the glyph will be shifted right to ensure this,
+if necessary. Likewise if C<overstrike> is set to C<right> then the advance will be
+increased to ensure that a diacritic does not extend beyond the advance width. values
+of C<true> or C<1> or C<both> or C<all> guard both sides of the glyph.
+
+The default action for all glyphs is not to guard. This can be changed using the -d
+option with 16 setting the default C<left> value and 32 setting the default C<right>
+value.
+
+=item base
+
+A base character is a reference to a glyph in the source font (via Unicode id,
+postscript name, glyph id) which is used in building the parent glyph. If there is
+more than one base glyph in a glyph, then the base glyphs are concatenated in
+sequence according to their advance widths, creating a single glyph. If a glyph only
+contains a single base glyph with no attachments, and the base glyph has not been
+shifted in any way, then the resulting font will include the glyph directly rather
+than by reference.
+
+=item attach
+
+A base glyph may have attachments, which may have their own attachments in their
+turn. An attachment is a reference to a glyph in the source font and also the name
+of an attachment point on the attachment and one on its parent which are used to
+position the attachment so that the attachment points coincide.
+
+The C<attach> element takes two parameters describing the attachment point on the base
+(C<at>) and the attachment point on the diacritic (C<with>). If these are missing, then
+the glyphs are aligned centrally in the x direction and with no adjustment vertically.
+
+=item advance
+
+It is possible to override the default value of the advance width for any glyph. Thus
+the advance element may occur is a child of either glyph, base or attach and it sets
+the value of the advance width for its parent to the value given in the width
+attribute. The default value of the advance width for a glyph is the widest advance
+width taken from each of the child glyphs (including attachments) in their position
+within the glyph. Thus if an attachment is positioned far enough to the right, it
+may well cause the advance width of the glyph to increase beyond that of the base
+glyph the attachment is on.
+
+=item rsb
+
+This allows the advance of a glyph to be specified in terms of the right side
+bearing rather than an absolute advance value.
+
+=item lsb
+
+In the case where overstrike is disallowed, sets the guard space to the left of
+the glyph.
+
+=item shift
+
+It is also possible to shift glyphs, at least base and attach glyphs. Shifting
+occurs after attachment (for obvious reasons).
+
+=item string
+
+In the names section of the description file it is possible to specify strings which
+cause changes to the name section of the font. The string element takes a num
+attribute which specifies which string to change. It is also possible to specify
+which platform, encoding and or language id the change should be made to.
+
+There is one special value for the num attribute, which is C<name>. This causes
+the name of the font (string id 1) and also the full font name (string id 4) to be
+assembled from the font name and style (string id 2).
+
+=item font attributes
+
+Various font attributes can be set from a TTFBuilder configuration file:
+
+ ascent amount of space needed above the baseline for a glyph
+ descent space below the baseline needed for a glyph
+ linegap how much space to put between lines
+ cp OS/2 codepages field (in binary)
+ coverage OS/2 Unicode block coverage (in binary)
+
+Binary values are written in hex (as in: 0003)
+
+=back
+
+The DTD for the configuration file is:
+
+ <!ELEMENT font (names?, glyphs)>
+ <!ATTLIST font
+ ascent CDATA #IMPLIED
+ descent CDATA #IMPLIED
+ linegap CDATA #IMPLIED
+ cp CDATA #IMPLIED
+ coverage CDATA #IMPLIED>
+
+ <!ELEMENT names (string)+>
+
+ <!ELEMENT string (#PCDATA)>
+ <!ATTLIST string
+ num CDATA #REQUIRED
+ pid CDATA #IMPLIED
+ eid CDATA #IMPLIED
+ lid CDATA #IMPLIED>
+
+ <!ELEMENT glyphs (glyph)+>
+
+ <!ELEMENT glyph (property* | note? | (advance | rsb | lsb)+ | base)+>
+ <!ATTLIST glyph
+ PSNAme CDATA #IMPLIED
+ UID CDATA #IMPLIED
+ GID CDATA #IMPLIED
+ overstrike (0 | false | none | 1 | true | all | both | left | right) #IMPLIED>
+
+ <!ELEMENT base (advance | rsb | lsb | attach | shift)*>
+ <!ATTLIST base
+ PSName CDATA #IMPLIED
+ UID CDATA #IMPLIED
+ GID CDATA #IMPLIED>
+
+ <!ELEMENT attach (advance | rsb | lsb | shift)*>
+ <!ATTLIST attach
+ PSName CDATA #IMPLIED
+ UID CDATA #IMPLIED
+ GID CDATA #IMPLIED
+ with CDATA #IMPLIED
+ at CDATA #IMPLIED>
+
+ <!ELEMENT advance EMPTY>
+ <!ATTLIST advance
+ width CDATA #REQUIRED>
+
+ <!ELEMENT rsb EMPTY>
+ <!ATTLIST rsb
+ width CDATA #REQUIRED>
+
+ <!ELEMENT lsb EMPTY>
+ <!ATTLIST lsb
+ width CDATA #REQUIRED>
+
+ <!ELEMENT shift EMPTY>
+ <!ATTLIST shift
+ x CDATA #IMPLIED
+ y CDATA #IMPLIED>
+
+ <!ELEMENT property EMPTY>
+ <!ATTLIST property
+ name CDATA #REQUIRED
+ value CDATA #REQUIRED>
+
+ <!ELEMENT note (#PCDATA)>
+
+From this small language, quite a lot can be done.
+
+=head1 Attachment Points
+
+One of the most powerful mechanisms for relating glyphs is that of attachment points.
+This concept is concerned with attaching diacritics to a base character and the
+attachment is achieved by specifying an attachment point on the base character
+and one on the diacritic. The attachment points are usually designed as single point
+paths in the glyph and their location or path number are held in a separate database.
+When the attaching of the diacritic to the base character occurs, then the diacritic
+is positioned so that the two attachment points coincide.
+
+ttfbuilder works with attachment point databases represented in XML.
+
+The DTD for an attachment point database is:
+
+ <!ELEMENT font (glyph)*>
+ <!ATTLIST font
+ name CDATA #IMPLIED
+ upem CDATA #IMPLIED
+
+ <!ELEMENT glyph (property* | (point | compound)* | note)>
+ <!ATTLIST glyph
+ PSName CDATA #IMPLIED
+ UID CDATA #IMPLIED
+ GID CDATA #IMPLIED>
+
+ <!ELEMENT point (location | contour)+>
+ <!ATTLIST point
+ type CDATA #REQUIRED>
+
+ <!ELEMENT location EMPTY>
+ <!ATTLIST location
+ x CDATA #REQUIRED
+ y CDATA #REQUIRED>
+
+ <!ELEMENT contour EMPTY>
+ <!ATTLIST contour
+ num CDATA #REQUIRED>
+
+ <!ELEMENT compound EMPTY>
+ <!ATTLIST compound
+ bbox CDATA #REQUIRED
+ PSName CDATA #IMPLIED
+ UID CDATA #IMPLIED
+ GID CDATA #IMPLIED>
+
+ <!ELEMENT property EMPTY>
+ <!ATTLIST property
+ name CDATA #REQUIRED
+ value CDATA #REQUIRED>
+
+ <!ELEMENT note (#PCDATA)>
+
+A C<font> contains C<glyphs> which have attachment C<points>. Each point has a name
+and either a contour (path number from 0) or a location of an attachment point (real
+or virtual) in terms of C<x> and C<y> co-ordinates in em units.
+
+A C<glyph> may also be a compound glyph in which case the boxes
+representing the location of the components of the C<compound> are
+listed. Each component lists a bounding box describing the location of
+the component in relation to the main glyph. This is a 4 element string,
+separated by comma and optional whitespace. Each element is a co-ordinate in em
+units. The sequence of values is: C<xMin>, C<yMin>, C<xMax>, C<yMax>. The compound
+also indicates which glyph this component refers to.
+
+Each glyph may also contain properties. A property is a name value pair. There may only
+be one property with any particular name attribute.
+
+A glyph may have textual notes associated with it.
+
+=head1 Usage
+
+ttfbuilder needs a configuration file, an attachment point database and a source font.
+It also needs to know where to store the resulting font and can take a further
+file to write a new attachment point database to, which represents the attachment
+point database for the generated font.
+
+=cut
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfname.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfname.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfname.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,177 @@
+#! perl
+# Title: TTFNAME.BAT
+# Author: M. Hosken
+# Description: Change the family name of a font, thus changing full font
+# name.
+# Requirement: PERL 4 or PERL 5. TTFMOD.PL should come with this.
+#
+# 1.1 MJPH 20-MAR-1998 Add -l, -s
+
+require 'ttfmod.pl';
+require 'getopts.pl';
+do Getopts("f:l:n:qs:t:");
+
+
+if (!defined $ARGV[1] || !defined $opt_n)
+ {
+ die 'TTFNAME [-f "new_full_name"] -n "new_name" [-t num] [-q] <infile> <outfile>
+
+v1.1.0, 20-Mar-1998 (c) Martin_Hosken at sil.org
+
+ Renames the TTF with the given name and outputs the newly named font to
+<outfile>.
+ -f "name" specifies new full name (optional) as opposed to the
+ default calculated form.
+ -l lang language number to use (default all langs)
+ -n "name" specifies new font family name (not optional)
+ -q disable signon message
+ -s filename overrides -n and gets string from file. Useful for -t
+ -t num overrides the normal naming areas to change another
+ string -f becomes inactive.
+';
+ }
+
+if (defined $opt_s)
+{
+ open(INFILE, "$opt_s") || die "Unable to open $opt_s";
+ $opt_n = join('', <INFILE>);
+ $opt_n =~ s/\n/ /oig;
+}
+
+print "TTFNAME v1.1: Freeware, (c) M. Hosken\n" if (!defined $opt_q);
+
+$fns{"name"} = "do_name";
+&ttfmod($ARGV[0], $ARGV[1], *fns);
+# that's all folks!!
+
+# called to process "name" table
+sub do_name {
+ local(*INFILE, *OUTFILE, $len) = @_;
+ local($csum);
+
+ # copy and checksum table header
+ read(INFILE, $name_head, 6) || die "Unable to read name table header";
+ ($name_num) = unpack("x2n", $name_head);
+ print OUTFILE $name_head;
+ $csum = unpack("%32N", $name_head);
+ # not 4 byte boundary - grrr!
+ $csum += unpack("%32N", substr($name_head, 4, 2) . "\0\0");
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum -= 1; }
+
+ # read name directory and calculate string space
+ $str_tot = 0;
+ for ($i = 0; $i < $name_num; $i++)
+ {
+ read(INFILE, $name_dir, 12) || die "Unable to read name entry";
+ $names[$i] = $name_dir;
+ ($name_id, $str_len, $str_off) = unpack("x6n3", $name_dir);
+ $str_tot = $str_off + $str_len if ($str_off + $str_len > $str_tot);
+ $ids[$name_id] .= "$i:";
+ }
+ foreach (@ids)
+ { chop; } # chop trailing ':' from index list
+ read(INFILE, $str, $str_tot) || die "Unable to glob all name strings";
+ # copy strings or hijack them to new string space
+ $spos = 0;
+ for ($i = 0; $i < $name_num; $i++)
+ {
+ ($id_p, $id_e, $id_l, $name_id, $str_len, $str_off)
+ = unpack("n6", $names[$i]);
+ if (!defined $opt_t && ($name_id == 1 || $name_id == 4) # family or full name
+ && !(defined $opt_l && $opt_l == $id_l))
+ {
+ if ($name_id == 4 && !defined $opt_f) # calculate full name?
+ {
+ subfamily: # find subfamily name
+ foreach $id (split(':', $ids[2]))
+ {
+ ($iid_p, $iid_e, $iid_l, $iid_n, $ilen, $ioff)
+ = unpack("n6", $names[$id]);
+ if ($id_p == $iid_p && $id_e == $iid_e && $id_l == $iid_l)
+ {
+ $tstr = substr($str, $ioff, $ilen);
+ $temp = $tstr;
+ $temp =~ s/\0//ogi;
+ $tstr = "" if ($temp =~ m/^regular$/oi
+ || $temp =~ m/^normal$/oi
+ || $temp =~ m/^standard$/oi);
+ $tlen = length($tstr);
+ last subfamily;
+ }
+ }
+ }
+ else # nothing to add to family name
+ {
+ $tstr = "";
+ $tlen = 0;
+ }
+ if ($id_p == 0 || $id_p == 3 || ($id_p == 2 && $id_e == 1))
+ { # 16 bit character set
+ if ($name_id == 4 && defined $opt_f) # special full name?
+ {
+ $outstr .= "\0" . join("\0", split('', $opt_f));
+ $str_len = 2 * length($opt_f);
+ }
+ else # make new 16 bit string
+ {
+ $outstr .= "\0" . join("\0",
+ split('', $opt_n . (($tstr eq "") ? "" : " "))) . $tstr;
+ $str_len = 2 * length($opt_n) + $tlen
+ + ($tstr eq "" ? 0 : 2);
+ }
+ } # else 8 bit
+ elsif ($name_id == 4 && defined $opt_f) # special full name?
+ {
+ $outstr .= $opt_f;
+ $str_len = length($opt_f);
+ }
+ else # hijack 8 bit name
+ {
+ $outstr .= $opt_n . ($tstr eq "" ? "" : " ") . $tstr;
+ $str_len = length($opt_n) + $tlen + ($tstr eq "" ? 0 : 1);
+ }
+ }
+ elsif (defined $opt_t && $opt_t == $name_id && !(defined $opt_l && $opt_l == $id_l))
+ {
+ if ($id_p == 0 || $id_p == 3 || ($id_p == 2 && $id_e == 1))
+ {
+ $outstr .= "\0" . join("\0", split('', $opt_n));
+ $str_len = 2 * length($opt_n);
+ }
+ else
+ {
+ $outstr .= $opt_n;
+ $str_len = length($opt_n);
+ }
+ }
+ else # no hijacking, just copy from string space
+ {
+ $tstr = substr($str, $str_off, $str_len);
+ $outstr .= $tstr;
+ $str_len = length($tstr);
+ }
+ $str_off = $spos; # this string offset
+ $spos += $str_len; # next string offset
+ $outpre = pack("n", $id_p); # handle 2 byte offset in checksums
+ $outval = pack("n5", $id_e, $id_l, $name_id, $str_len, $str_off);
+ print OUTFILE $outpre . $outval; # output new directory entry
+ $csum += unpack("%32N", "\0\0" . $outpre); # checksum
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum -= 1; }
+ $csum += unpack("%32N*", $outval . "\0\0");
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum -= 1; }
+ }
+ $outstr .= "\0" x (2, 1, 0, 3)[$spos & 3]; # pad string space
+ $csum += unpack("%32N", "\0\0" . substr($outstr, 0, 2)); # checksum
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum -= 1; }
+ $csum += unpack("%32N*", substr($outstr, 2));
+ if ($csum > 0xffffffff) { $csum -= 0xffffffff; $csum -= 1; }
+ print OUTFILE $outstr; # output string space
+
+ ($spos + $name_num * 12 + 6, $csum); # return length, checksum
+ }
+
+ at REM=('
+:end
+ at echo off
+ at REM ') if 0 ;
+
Added: packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfremap.plx
===================================================================
--- packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfremap.plx 2005-05-25 15:07:07 UTC (rev 1042)
+++ packages/libfont-ttf-perl/branches/upstream/current/scripts/ttfremap.plx 2005-05-25 15:08:14 UTC (rev 1043)
@@ -0,0 +1,162 @@
+use Font::TTF::Font;
+require 'getopts.pl';
+
+Getopts("c:rsu");
+
+unless (defined $opt_c && defined $ARGV[1] && !(defined $opt_s && defined $opt_u) )
+{
+ die <<'EOT';
+ TTFRemap -c file [-r] [-s | -u] <infile> <outfile>
+Remaps the MS cmap of a font without removing any glyphs. Updates the OS/2
+table according to first and last char of new cmap. The changes file consists
+of lines of any of the following forms:
+
+ uni_first, uni_to
+ uni_first, uni_last, uni_to
+ g, gid_first, uni_to
+ g, gid_first, gid_last, uni_to
+
+where uni_first (gid_first) is the first of a range of Unicodes (glyph IDs)
+in the source font, uni_last (gid_last) is the last of that range (if not
+specified, default is same as uni_first (gid_last)), and uni_to
+is the start of the sequential set of Unicodes that will be altered in the
+output cmap so they map to the specified range. NOTE: Unicode values
+should be in hex, glyph IDs are decimal.
+
+ -r Replace (copy the old cmap before mapping)
+ -s Convert to symbol encoding
+ -u Convert to UGL encoding
+EOT
+}
+
+open(INFILE, "$opt_c") || die "Unable to open $opt_c for reading";
+
+$f = Font::TTF::Font->open($ARGV[0]);
+$v = $f->{'OS/2'}->read; # we need to update this
+$o = $f->{'cmap'}->read->find_ms->{'val'} || die "This font has no MS cmap table";
+
+if ($opt_r)
+{
+ $s = {%{$o}};
+ $cmin = $v->{'usFirstCharIndex'};
+ $cmax = $v->{'usLastCharIndex'};
+}
+else
+{
+ $s = {};
+ $cmin = 0x1FFFFFF;
+ $cmax = 0;
+}
+while (<INFILE>)
+{
+ next unless (m/^[0-9A-Z]/oi); # this is klunky and needs to go
+ chomp;
+ s/\s*[#;].*//o;
+ @work = split /,\s*/;
+
+ $UseGID = lc($work[0] eq 'g');
+ shift @work if $UseGID;
+
+ next if $#work < 1 or $#work > 2;
+
+ @work[1,2] = @work[0,1] if $#work < 2; # if uni_last/g_last is missing, make it same as uni_first/g_first
+
+ $first = ($UseGID ? $work[0] : hex($work[0]));
+ $last = ($UseGID ? $work[1] : hex($work[1]));
+ $to = hex($work[2]);
+
+ map {$s->{$to + $_} = ($UseGID ? ($first + $_) : $o->{$first + $_})} (0 .. ($last - $first));
+
+ $cmin = $to if $cmin > $to;
+ $cmax = ($to + $last - $first) if ($cmax < ($to + $last - $first));
+}
+
+close(INFILE);
+
+foreach $c (@{$f->{'cmap'}{'Tables'}})
+{
+ $c->{'val'} = $s if ($c->{'Platform'} == 0 || $c->{'Platform'} == 3
+ || ($c->{'Platform'} == 2 && $c->{'Encoding'} == 1));
+ if ($c->{'Platform'} == 3)
+ {
+ $c->{'Encoding'} = 0 if $opt_s;
+ $c->{'Encoding'} = 1 if $opt_u;
+ $has_surr = 1 if $c->{'Encoding'} == 10;
+ }
+}
+
+if ($opt_s)
+{
+ my ($n, $n1);
+
+ $n = $f->{'name'}->read;
+ foreach $n1 (@{$n->{'strings'}})
+ {
+ if (defined $n1->[3][1])
+ {
+ $n1->[3][0] = $n1->[3][1];
+ undef $n1->[3][1];
+ }
+ }
+ $v->{'ulUnicodeRange1'} = 0;
+ $v->{'ulUnicodeRange2'} = 0;
+ $v->{'ulUnicodeRange3'} = 0;
+ $v->{'ulUnicodeRange4'} = 0;
+ $v->{'ulCodePageRange1'} = 0x80000000;
+ $v->{'ulCodePageRange2'} = 0;
+}
+
+if ($opt_u)
+{
+ my ($n, $n1);
+
+ $n = $f->{'name'}->read;
+ foreach $n1 (@{$n->{'strings'}})
+ {
+ if (defined $n1->[3][0])
+ {
+ $n1->[3][1] = $n1->[3][0];
+ undef $n1->[3][0];
+ }
+ }
+ $v->{'ulUnicodeRange1'} = 0x00000003;
+ $v->{'ulUnicodeRange2'} = 0;
+ $v->{'ulUnicodeRange3'} = 0;
+ $v->{'ulUnicodeRange4'} = 0;
+ $v->{'ulCodePageRange1'} = 0x00000001;
+ $v->{'ulCodePageRange2'} = 0;
+}
+
+if ($cmax > 0xFFFF)
+{
+ push (@{$f->{'cmap'}{'Tables'}}, {
+ 'Platform' => 3,
+ 'Encoding' => 10,
+ 'Ver' => 0,
+ 'Format' => 12,
+ 'val' => $s}) unless ($has_surr);
+
+ my $has_uni_table;
+ foreach $c (@{$f->{'cmap'}{'Tables'}})
+ {
+ if ($c->{'Platform'} == 0 && $c->{'Encoding'} == 0)
+ {
+ $c->{'Format'} = 12;
+ $has_uni_table = 1;
+ }
+ }
+ push (@{$f->{'cmap'}{'Tables'}}, {
+ 'Platform' => 0,
+ 'Encoding' => 0,
+ 'Ver' => 0,
+ 'Format' => 12,
+ 'val' => $s}) unless ($has_uni_table);
+}
+
+
+$v->{'usFirstCharIndex'} = $cmin > 0xFFFF ? 0xFFFF : $cmin;
+$v->{'usLastCharIndex'} = $cmax > 0xFFFF ? 0xFFFF : $cmax;
+
+$f->out($ARGV[1]);
+
+
More information about the Pkg-perl-cvs-commits
mailing list