use
5.010;
our
$VERSION
=
'0.001002'
;
our
$AUTHORITY
=
'cpan:KENTNL'
;
my
$BLOCK_GROUP_START
=
"\x{c0}\x{01}"
;
my
$BLOCK_GROUP_END
=
"\x{c0}\x{02}"
;
my
$BLOCK_COLOR
=
"\x{00}\x{01}"
;
my
$UTF16NULL
=
"\x{00}\x{00}"
;
sub
read_file {
my
(
$class
,
$file
) =
@_
;
return
$class
->read_string( Path::Tiny::path(
$file
)->slurp_raw );
}
sub
read_filehandle {
my
(
$class
,
$filehandle
) =
@_
;
return
$class
->read_string(
scalar
<
$filehandle
> );
}
sub
read_string {
my
(
$class
,
$string
) =
@_
;
my
$clone
=
"$string"
;
my
$signature
=
$class
->_read_signature( \
$clone
);
my
$version
=
$class
->_read_version( \
$clone
);
my
$numblocks
=
$class
->_read_numblocks( \
$clone
);
my
@blocks
;
for
my
$id
( 1 ..
$numblocks
) {
push
@blocks
,
$class
->_read_block( \
$clone
,
$id
, );
}
if
(
length
$clone
) {
warn
+( (
length
$clone
) .
' bytes of unhandled data'
);
}
return
{
signature
=>
$signature
,
version
=>
$version
,
blocks
=> \
@blocks
, };
}
sub
_read_bytes {
my
(
undef
,
$string
,
$num
,
$decode
) =
@_
;
return
if
(
length
${
$string
} ) <
$num
;
my
$chars
=
substr
${
$string
}, 0,
$num
,
q[]
;
return
unpack
$decode
,
$chars
if
$decode
;
return
$chars
;
}
sub
_read_signature {
my
(
$class
,
$string
) =
@_
;
my
$signature
=
$class
->_read_bytes(
$string
, 4 );
die
'No ASEF signature'
if
not
defined
$signature
or
q[ASEF]
ne
$signature
;
return
$signature
;
}
sub
_read_version {
my
(
$class
,
$string
) =
@_
;
my
(
@version
) =
$class
->_read_bytes(
$string
, 4,
q[nn]
);
die
'No VERSION header'
if
@version
!= 2;
return
\
@version
;
}
sub
_read_numblocks {
my
(
$class
,
$string
) =
@_
;
my
$blocks
=
$class
->_read_bytes(
$string
, 4,
q[N]
);
die
'No NUM BLOCKS header'
if
not
defined
$blocks
;
return
$blocks
;
}
sub
_read_block_group {
my
(
$class
,
$string
) =
@_
;
return
$class
->_read_bytes(
$string
, 2,
q[n]
);
}
sub
_read_group_end {
my
(
undef
,
$group
,
$label
) =
@_
;
return
{
type
=>
'group_end'
,
(
$group
? (
group
=>
$group
) : () ),
(
$label
? (
label
=>
$label
) : () ),
};
}
sub
_read_group_start {
my
(
undef
,
$group
,
$label
) =
@_
;
return
{
type
=>
'group_start'
,
(
$group
? (
group
=>
$group
) : () ),
(
$label
? (
label
=>
$label
) : () ),
};
}
sub
_read_rgb {
my
(
$class
,
$block_body
) =
@_
;
return
$class
->_read_bytes(
$block_body
, 12,
'f>f>f>'
);
}
sub
_read_lab {
my
(
$class
,
$block_body
) =
@_
;
return
$class
->_read_bytes(
$block_body
, 12,
'f>f>f>'
);
}
sub
_read_cmyk {
my
(
$class
,
$block_body
) =
@_
;
return
$class
->_read_bytes(
$block_body
, 16,
'f>f>f>f>'
);
}
sub
_read_gray {
my
(
$class
,
$block_body
) =
@_
;
return
$class
->_read_bytes(
$block_body
, 4,
'f>'
);
}
my
$color_table
= {
q[RGB ]
=>
'_read_rgb'
,
q[LAB ]
=>
'_read_lab'
,
q[CMYK]
=>
'_read_cymk'
,
q[Gray]
=>
'_read_gray'
,
};
sub
_read_color_model {
my
(
$class
,
$id
,
$block_body
) =
@_
;
my
$model
=
$class
->_read_bytes(
$block_body
, 4 );
if
( not
defined
$model
) {
die
"No COLOR MODEL for block $id"
;
}
if
( not
exists
$color_table
->{
$model
} ) {
die
"Unsupported model $model"
;
}
return
$model
;
}
sub
_read_color_type {
my
(
$class
,
$block_body
) =
@_
;
my
$type
=
$class
->_read_bytes(
$block_body
, 2,
q[n]
);
return
$type
;
}
sub
_read_color {
my
(
$class
,
$id
,
$group
,
$label
,
$block_body
) =
@_
;
my
$model
=
$class
->_read_color_model(
$id
,
$block_body
);
my
@values
;
my
$method
=
$class
->can(
$color_table
->{
$model
} );
@values
=
$class
->
$method
(
$block_body
);
my
$type
=
$class
->_read_color_type(
$block_body
);
return
{
type
=>
'color'
,
(
$group
? (
group
=>
$group
) : () ),
(
$label
? (
label
=>
$label
) : () ),
(
$model
? (
model
=>
$model
) : () ),
values
=> \
@values
,
color_type
=>
$type
,
};
}
sub
_read_block_label {
my
(
undef
,
$string
) =
@_
;
my
(
$label
,
$rest
) = ( ${
$string
} =~ /\A(.*?)${UTF16NULL}(.*\z)/msx );
if
(
defined
$rest
) {
${
$string
} =
"$rest"
;
}
else
{
${
$string
} =
q[]
;
}
return
decode(
'UTF-16BE'
,
$label
, Encode::FB_CROAK );
}
sub
_read_block_type {
my
(
$class
,
$string
,
$id
) =
@_
;
my
$type
=
$class
->_read_bytes(
$string
, 2 );
die
"No BLOCK TYPE for block $id"
if
not
defined
$type
;
return
$type
;
}
sub
_read_block_length {
my
(
$class
,
$string
,
$id
) =
@_
;
my
$length
=
$class
->_read_bytes(
$string
, 4,
q[N]
);
die
"No BLOCK LENGTH for block $id"
if
not
defined
$length
;
if
( (
length
${
$string
} ) <
$length
) {
warn
"Possibly corrupt file, EOF before length $length in block $id"
;
}
return
$length
;
}
sub
_read_block {
my
(
$class
,
$string
,
$id
, ) =
@_
;
my
$type
=
$class
->_read_block_type(
$string
);
my
$length
=
$class
->_read_block_length(
$string
);
my
$block_body
;
my
$group
;
my
$label
;
if
(
$length
> 0 ) {
$block_body
=
$class
->_read_bytes(
$string
,
$length
);
$group
=
$class
->_read_block_group( \
$block_body
);
$label
=
$class
->_read_block_label( \
$block_body
);
}
if
(
$BLOCK_GROUP_END
eq
$type
) {
return
$class
->_read_group_end(
$group
,
$label
, );
}
if
(
$BLOCK_GROUP_START
eq
$type
) {
return
$class
->_read_group_start(
$group
,
$label
, );
}
if
(
$BLOCK_COLOR
eq
$type
) {
return
$class
->_read_color(
$id
,
$group
,
$label
, \
$block_body
, );
}
die
"Unknown type $type"
;
}
1;