$VERSION
=
do
{
my
@r
=
q$Revision: 1.3 $
=~/\d+/g;
sprintf
'%d.'
.
'%02d'
x
$#r
,
@r
};
my
%Key_Fields
= (
'version'
=> 1,
'kvno'
=> 1,
'type'
=> -1,
'length'
=> -1,
'contents'
=> -1,
);
sub
new {
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
) ||
$proto
;
my
%args
=
@_
;
my
$self
= {};
$self
->{
'_data_cntr'
} = -1;
if
(not
defined
(
$args
{
'version'
})) {
croak
"version for Key data not defined at line $args{'lineno'}"
;
}
if
(not
defined
(
$args
{
'kvno'
})) {
croak
"kvno for Key data not defined at line $args{'lineno'}"
;
}
if
(not
defined
(
$args
{
'data'
}) or @{
$args
{
'data'
}} < 1) {
croak
"data for Key data not defined at line $args{'lineno'}"
;
}
$self
->{
'version'
} =
$args
{
'version'
};
$self
->{
'kvno'
} =
$args
{
'kvno'
};
$self
->{
'data'
} = [];
foreach
my
$tuple
(@{
$args
{
'data'
}}) {
my
$p
= {};
$p
->{
'type'
} =
$tuple
->[0];
$p
->{
'length'
} =
$tuple
->[1];
$p
->{
'contents'
} =
$tuple
->[2];
if
(
$args
{
'checks'
}) {
if
(check_length(
$p
->{
'length'
}*2,
$p
->{
'contents'
})) {
carp
"key contents length field not ok at line $args{'lineno'}"
;
}
}
push
@{
$self
->{
'data'
}},
$p
;
}
if
(
$args
{
'checks'
} == 2) {
_check_level2(
$self
,
$args
{
'lineno'
});
}
bless
(
$self
,
$class
);
return
$self
;
}
sub
_check_level2 ($$) {
my
$self
=
shift
;
my
$lineno
=
shift
;
if
(
$self
->{
'version'
} !~ /^\d+$/) {
carp
"key version is not valid at line $lineno: $self->{'version'}"
;
}
if
(
$self
->{
'kvno'
} !~ /^\d+$/) {
carp
"key kvno is not valid at line $lineno: $self->{'kvno'}"
;
}
foreach
my
$data
(@{
$self
->{
'data'
}}) {
if
(
$data
->{
'type'
} !~ /^\d+$/) {
carp
"key type is not valid at line $lineno: $data->{'type'}"
;
}
if
(
$data
->{
'length'
} !~ /^\d+$/) {
carp
"key length is not valid at line $lineno: $data->{'length'}"
;
}
if
(
$data
->{
'contents'
} ne
'-1'
and
$data
->{
'contents'
} !~ /^[\da-f]+$/) {
carp
"key contents is not valid at line $lineno: $data->{'contents'}"
;
}
}
}
sub
parse_contents {
my
$self
=
shift
;
my
$byte
= 8;
my
$template
=
"A2"
x
$self
->
length
();
my
@modname
;
my
$modname
=
''
;
my
$octet
= 0;
@modname
=
map
hex
,
unpack
(
$template
,
$self
->contents());
$modname
=
join
''
,
map
chr
,
@modname
;
return
$modname
;
}
sub
next_data {
my
$self
=
shift
;
if
(
defined
(
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}+1])) {
$self
->{
'_data_cntr'
}++;
return
1;
}
else
{
$self
->{
'_data_cntr'
} = -1;
return
0;
}
}
sub
type {
my
$self
=
shift
;
carp
"Can't change value via type method"
if
@_
;
carp
"Need to call the next_data method before calling type method"
if
(
$self
->{
'_data_cntr'
} == -1);
return
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'type'
};
}
sub
length
{
my
$self
=
shift
;
carp
"Can't change value via length method"
if
@_
;
carp
"Need to call the next_data method before calling length method"
if
(
$self
->{
'_data_cntr'
} == -1);
return
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'length'
};
}
sub
contents {
my
$self
=
shift
;
carp
"Need to call the next_data method before calling contents method"
if
(
$self
->{
'_data_cntr'
} == -1);
if
(
@_
) {
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'contents'
} =
shift
;
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'length'
} =
CORE::
length
(
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'contents'
})/2;
}
return
$self
->{
'data'
}[
$self
->{
'_data_cntr'
}]->{
'contents'
};
}
foreach
my
$field
(
keys
%Key_Fields
) {
no
strict
"refs"
;
if
(
$Key_Fields
{
$field
} == 1) {
*$field
=
sub
{
my
$self
=
shift
;
$self
->{
$field
} =
shift
if
@_
;
return
$self
->{
$field
};
};
}
elsif
(not
$Key_Fields
{
$field
}) {
*$field
=
sub
{
my
$self
=
shift
;
carp
"Can't change value via $field method"
if
@_
;
return
$self
->{
$field
};
};
}
}
1;