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


line stmt bran cond sub pod time code
1             package Parse::AFP;
2             $Parse::AFP::VERSION = '0.25';
3              
4 1     1   817 use strict;
  1         2  
  1         33  
5 1     1   665 use Encode::IBM;
  1         23678  
  1         43  
6 1     1   1155 use Encode::EBCDIC;
  1         736  
  1         32  
7 1     1   5 use base 'Parse::AFP::Base';
  1         3  
  1         691  
8 1         57 use constant FORMAT => (
9             Record => ['H2 n/a* XX', '*', '2'],
10 1     1   7 );
  1         2  
11 1     1   5 use constant BASE_CLASS => __PACKAGE__;
  1         3  
  1         790  
12              
13             # Must start with the magic byte 0x90
14 573     573 0 2688 sub valid_memberdata { $_[-1][0] eq '5a' }
15              
16             sub valid_unformat {
17 0     0 0 0 my ($self, $content, $data) = @_;
18 0 0       0 return if $content->[0] ne '5a';
19 0         0 my $members = $self->{callback_members};
20 0         0 my $table = Parse::AFP::Record->dispatch_table;
21 0         0 my $type = $table->{ unpack('H6', $content->[1]) };
22 0 0 0     0 if (!$members->{ $type } and my $fh = $self->output) {
23 0         0 print $fh $$data;
24 0         0 return;
25             }
26 0         0 return 1;
27             }
28              
29             sub callback_members {
30 0     0 0 0 my $self = shift;
31 0         0 $self->{callback_members} = { map { ($_ => 1) } @{$_[0]} };
  0         0  
  0         0  
32              
33 0 0 0     0 if ($self->{callback_members}{'*'} and $self->{output} and $self->{input}) {
      0        
34 0         0 return $self->tight_loop(@_);
35             }
36              
37 0         0 while (my $member = $self->next_member) {
38 0         0 $member->callback(scalar caller, @_);
39             }
40             }
41              
42 0     0   0 sub _noop { return }
43              
44             sub read_file {
45 2     2 0 1032 my ($self, $file) = @_;
46              
47 2 50       124 open my $fh, "< $file" or die "Cannot open $file for reading: $!";
48 2         7 binmode($fh);
49              
50 2 50 66     19 if (ref($self) and $self->{lazy} and $self->{output_file}) {
      33        
51 0         0 $self->{input} = $fh;
52 0         0 $self->set_output_file($self->{output_file});
53 0         0 return '';
54             }
55              
56 2         8 local $/;
57 2         98 return scalar <$fh>;
58             }
59              
60             sub tight_loop {
61 0     0 0   my $self = shift;
62 0           my $callback = caller(1);
63 0           my $ofh = $self->{output};
64 0           my $is_dirty;
65 0           my ($header, $buf);
66              
67 0           local *Parse::AFP::Record::done = \&_noop;
68             local *Parse::AFP::PTX::refresh_parent = sub {
69 0     0     my $self = shift;
70 0           $self->refresh_length;
71 0           print $ofh $self->dump;
72 0           $is_dirty = 1;
73 0           };
74              
75 0           my %xable = Parse::AFP::Record::DISPATCH_TABLE();
76 0           my %table = reverse Parse::AFP::Record::DISPATCH_TABLE();
77 0           my %IgnoreType =
78 0           map { (pack('H6', $table{$_}) => 1) }
79 0           grep { !$self->{callback_members}{$_} }
80             keys %table;
81              
82 0           my $fh = $self->{input};
83 0           seek $fh, 0, 0;
84              
85 0           my $attr = { lazy => 1, output => $ofh };
86              
87 0           while (!eof($fh)) {
88 0           read($fh, $header, 6);
89 0           seek $fh, -6, 1;
90 0           read($fh, $buf, (unpack('n', substr($header, 1, 2)) + 1));
91              
92             # We now cheat and skip unintereting types.
93 0 0         if (exists $IgnoreType{substr($header, -3)}) {
94 0           print $ofh $buf;
95 0           next;
96             }
97              
98             # Do Something Interesting with $header and $buf
99 0           $is_dirty = 0;
100              
101 0           my $rec = Parse::AFP::Record->new( \$buf, $attr );
102 0           $rec->callback($callback, @_, \$buf);
103              
104 0           $ofh = $self->{output};
105 0 0         print $ofh $buf unless $is_dirty;
106 0           next;
107             }
108             }
109              
110             1;
111              
112             __END__