File Coverage

lib/Parse/AFP.pm

Criterion	Covered	Total	%
statement	25	78	32.0
branch	2	14	14.2
condition	3	15	20.0
subroutine	8	13	61.5
pod	0	5	0.0
total	38	125	30.4

package Parse::AFP;
$Parse::AFP::VERSION = '0.25';

use strict;
use Encode::IBM;
use Encode::EBCDIC;
use base 'Parse::AFP::Base';
use constant FORMAT => (
    Record => ['H2 n/a* XX', '*', '2'],
);
use constant BASE_CLASS => __PACKAGE__;

# Must start with the magic byte 0x90
sub valid_memberdata { $_[-1][0] eq '5a' }

sub valid_unformat {
    my ($self, $content, $data) = @_;
    return if $content->[0] ne '5a';
    my $members = $self->{callback_members};
    my $table = Parse::AFP::Record->dispatch_table;
    my $type = $table->{ unpack('H6', $content->[1]) };
    if (!$members->{ $type } and my $fh = $self->output) {
	print $fh $$data;
	return;
    }
    return 1;
}

sub callback_members {
    my $self = shift;
    $self->{callback_members} = { map { ($_ => 1) } @{$_[0]} };

    if ($self->{callback_members}{'*'} and $self->{output} and $self->{input}) {
        return $self->tight_loop(@_);
    }

    while (my $member = $self->next_member) {
	$member->callback(scalar caller, @_);
    }
}

sub _noop { return }

sub read_file {
    my ($self, $file) = @_;

    open my $fh, "< $file" or die "Cannot open $file for reading: $!";
    binmode($fh);

    if (ref($self) and $self->{lazy} and $self->{output_file}) {
        $self->{input} = $fh;
        $self->set_output_file($self->{output_file});
        return '';
    }

    local $/;
    return scalar <$fh>;
}

sub tight_loop {
    my $self = shift;
    my $callback = caller(1);
    my $ofh = $self->{output};
    my $is_dirty;
    my ($header, $buf);

    local *Parse::AFP::Record::done = \&_noop;
    local *Parse::AFP::PTX::refresh_parent = sub {
        my $self = shift;
        $self->refresh_length;
        print $ofh $self->dump;
        $is_dirty = 1;
    };

    my %xable = Parse::AFP::Record::DISPATCH_TABLE();
    my %table = reverse Parse::AFP::Record::DISPATCH_TABLE();
    my %IgnoreType =
        map { (pack('H6', $table{$_}) => 1) }
        grep { !$self->{callback_members}{$_} }
        keys %table;

    my $fh = $self->{input};
    seek $fh, 0, 0;

    my $attr = { lazy => 1, output => $ofh };

    while (!eof($fh)) {
        read($fh, $header, 6);
        seek $fh, -6, 1;
        read($fh, $buf, (unpack('n', substr($header, 1, 2)) + 1));

        # We now cheat and skip unintereting types.
        if (exists $IgnoreType{substr($header, -3)}) {
            print $ofh $buf;
            next;
        }

        # Do Something Interesting with $header and $buf
        $is_dirty = 0;

        my $rec = Parse::AFP::Record->new( \$buf, $attr );
        $rec->callback($callback, @_, \$buf);

        $ofh = $self->{output};
        print $ofh $buf unless $is_dirty;
        next;
    }
}

1;

__END__