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__ |