@ISA
=
qw(Font::TTF::Ttopen)
;
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
;
}
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
) = $
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
, $
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
, $
}
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),
$
}
foreach
$r
(@{
$lookup
->{
'RULES'
}})
{
$out
.= $
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),
$
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),
$
$
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'
, $
if
(
$type
== 5)
{
$loc1
=
length
(
$out
);
$out
.=
pack
(
'n*'
, (0) x ($
}
$ltables
= {};
for
(
$i
= 0;
$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'
, $
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
;
}
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
;
}
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
;
}
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
;
}
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
;
}
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
;
}
1;