package Parse::AFP::Base; use strict; use Parse::Binary; use base 'Parse::Binary'; use constant BASE_CLASS => 'Parse::AFP'; use constant DEFAULT_ARGS => ( Length => 0 ); sub padding { my ($self, $field) = @_; my $padding = $self->PADDING; return $padding if defined($padding); return "\xFF" x $self->member_length_bytes; } sub member_length_bytes { my ($self) = @_; my ($field) = $self->member_fields or return 0; $self->field_format($field) =~ m{(\S+)/} or return 0; return length(pack($1, 0)); } sub refresh_length { my ($self) = @_; if ($self->has_field('Length')) { my $length = length($self->dump); foreach my $field ($self->fields) { last if $field eq 'Length'; $length -= $self->field_length($field); } $self->SetLength($length); } } sub refresh_parent { my ($self) = @_; $self->refresh_length; $self->SUPER::refresh_parent; } sub load_size { my ($self, $data) = @_; $self->SUPER::load_size($data); if ($self->has_field('Length')) { $self->SetLength( $self->Length + $self->field_length('Length') ); } } sub dump { my ($self) = @_; local $SIG{__WARN__} = sub {}; return $self->SUPER::dump unless $self->has_members; my $out = ''; foreach my $field ($self->fields) { my $packer = $self->field_packer($field) or die "No packer for $field\n"; if ($self->member_class($field)) { my $format = $packer->{Format}[0]; my $prefix = ($format =~ m{\((.*?)/}) ? $1 : ''; my $length = $self->member_length_bytes; foreach my $member (@{$self->field($field)}) { my $rv = $packer->format({ $field => $member }); if ($prefix) { my @leading = unpack($prefix, $rv); $leading[-1] += $length; my $leading = pack($prefix, @leading); substr($rv, 0, length($leading), $leading); } $out .= $rv; } } else { $out .= $packer->format($self->struct); } } $self->set_size(length($out)); return $out; } sub set_field_arrayref { my ($self, $field, $data) = @_; @{$self->struct->{$field}||=[]} = @{$data||[]}; } sub validate_memberdata { my ($self, $field) = @_; $field = $self->field($field) or return; @$field = grep { ref($_) eq 'CODE' or $self->valid_memberdata($field, $_) } @$field; } sub spawn_obj { my $self = shift; my $obj = $self->spawn(CC => '5a', @_); @{$obj}{qw( lazy output )} = @{$self}{qw( lazy output )}; $obj->refresh; return $obj; } 1;