use
vars
qw(%fields @field_info)
;
@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
;
}
}
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
;
}
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
;
}
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'
};
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
;
}
}
}
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
;
}
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
;
}
}
elsif
(
$num
< 0)
{
$flag
= 1 << 5;
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)
{
$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)
{
$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
;
}
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
;
}
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
<= $
{
$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"
);
$dat
= PDF::API2::Basic::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
PDF::API2::Basic::TTF::Table::XML_element(
@_
); }
$self
;
}
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
);
$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
<= $
{
$comp
=
$self
->{
'comps'
}[
$i
];
$flag
=
$comp
->{
'flag'
} & 7158;
$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
== $
{
$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;
$self
;
}
sub
update_bbox
{
my
(
$self
) =
@_
;
my
(
$num
,
$maxx
,
$minx
,
$maxy
,
$miny
,
$i
,
$comp
,
$x
,
$y
,
$compg
);
return
$self
unless
$self
->{
' read'
} > 1;
$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
);
next
unless
(
defined
$self
->{
' PARENT'
}{
'loca'
}{
'glyphs'
}[
$comp
->{
'glyph'
}]);
$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
;
}
sub
maxInfo
{
my
(
$self
) =
@_
;
my
(
@res
,
$i
,
@n
);
$self
->read_dat;
$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
<= $
{
@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
;
}
sub
empty
{
my
(
$self
) =
@_
;
my
(
%keep
) =
map
{(
" $_"
=> 1)} (
'LOC'
,
'OUTLOC'
,
'PARENT'
,
'INFILE'
,
'BASE'
,
'OUTLEN'
,
'LEN'
);
map
{
delete
$self
->{
$_
}
unless
$keep
{
$_
}}
keys
%$self
;
$self
;
}
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
;
}
sub
get_refs
{
my
(
$self
) =
@_
;
my
(
@res
,
$g
);
$self
->read_dat;
return
unless
(
$self
->{
'numberOfContours'
} < 0);
foreach
$g
(@{
$self
->{
'comps'
}})
{
next
unless
(
defined
$self
->{
' PARENT'
}{
'loca'
}{
'glyphs'
}[
$g
->{
'glyph'
}]);
my
(
@list
) =
$self
->{
' PARENT'
}{
'loca'
}{
'glyphs'
}[
$g
->{
'glyph'
}]->get_points;
push
(
@res
,
$g
->{
'glyph'
});
push
(
@res
,
@list
)
if
(
$list
[0]);
}
return
@res
;
}
1;