Profile of /project/perl/lib/IO/Compress/Zlib/Extra.pm

File	/project/perl/lib/IO/Compress/Zlib/Extra.pm
Statements Executed	16
Statement Execution Time	2.02ms

Subroutines — ordered by exclusive time
Exclusive Time	Inclusive Time	Subroutine
0s	0s	IO::Compress::Zlib::Extra::::BEGINIO::Compress::Zlib::Extra::BEGIN
0s	0s	IO::Compress::Zlib::Extra::ExtraFieldError
0s	0s	IO::Compress::Zlib::Extra::::mkSubFieldIO::Compress::Zlib::Extra::mkSubField
0s	0s	IO::Compress::Zlib::Extra::parseExtraField
0s	0s	IO::Compress::Zlib::Extra::parseRawExtra
0s	0s	IO::Compress::Zlib::Extra::validateExtraFieldPair

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1					package IO::Compress::Zlib::Extra;
2
3	1	5µs			require 5.004 ;
4
5	3	88µs	1	26µs	use strict ; # spent 26µs making 1 call to strict::import
6	3	79µs	1	114µs	use warnings; # spent 114µs making 1 call to warnings::import
7	3	161µs	1	13µs	use bytes; # spent 13µs making 1 call to bytes::import
8
9	1	6µs			our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
10
11	1	6µs			$VERSION = '2.005';
12
13	3	1.66ms	2	1.93ms	use IO::Compress::Gzip::Constants 2.005 ; # spent 1.71ms making 1 call to Exporter::import # spent 216µs making 1 call to UNIVERSAL::VERSION
14
15					sub ExtraFieldError
16					{
17					return $_[0];
18					return "Error with ExtraField Parameter: $_[0]" ;
19					}
20
21					sub validateExtraFieldPair
22					{
23					my $pair = shift ;
24					my $strict = shift;
25					my $gzipMode = shift ;
26
27					return ExtraFieldError("Not an array ref")
28					unless ref $pair && ref $pair eq 'ARRAY';
29
30					return ExtraFieldError("SubField must have two parts")
31					unless @$pair == 2 ;
32
33					return ExtraFieldError("SubField ID is a reference")
34					if ref $pair->[0] ;
35
36					return ExtraFieldError("SubField Data is a reference")
37					if ref $pair->[1] ;
38
39					# ID is exactly two chars
40					return ExtraFieldError("SubField ID not two chars long")
41					unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ;
42
43					# Check that the 2nd byte of the ID isn't 0
44					return ExtraFieldError("SubField ID 2nd byte is 0x00")
45					if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ;
46
47					return ExtraFieldError("SubField Data too long")
48					if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ;
49
50
51					return undef ;
52					}
53
54					sub parseRawExtra
55					{
56					my $data = shift ;
57					my $extraRef = shift;
58					my $strict = shift;
59					my $gzipMode = shift ;
60
61					#my $lax = shift ;
62
63					#return undef
64					# if $lax ;
65
66					my $XLEN = length $data ;
67
68					return ExtraFieldError("Too Large")
69					if $XLEN > GZIP_FEXTRA_MAX_SIZE;
70
71					my $offset = 0 ;
72					while ($offset < $XLEN) {
73
74					return ExtraFieldError("Truncated in FEXTRA Body Section")
75					if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ;
76
77					my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE);
78					$offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE;
79
80					my $subLen = unpack("v", substr($data, $offset,
81					GZIP_FEXTRA_SUBFIELD_LEN_SIZE));
82					$offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ;
83
84					return ExtraFieldError("Truncated in FEXTRA Body Section")
85					if $offset + $subLen > $XLEN ;
86
87					my $bad = validateExtraFieldPair( [$id,
88					substr($data, $offset, $subLen)],
89					$strict, $gzipMode );
90					return $bad if $bad ;
91					push @$extraRef, [$id => substr($data, $offset, $subLen)]
92					if defined $extraRef;;
93
94					$offset += $subLen ;
95					}
96
97
98					return undef ;
99					}
100
101
102					sub mkSubField
103					{
104					my $id = shift ;
105					my $data = shift ;
106
107					return $id . pack("v", length $data) . $data ;
108					}
109
110					sub parseExtraField
111					{
112					my $dataRef = $_[0];
113					my $strict = $_[1];
114					my $gzipMode = $_[2];
115					#my $lax = @_ == 2 ? $_[1] : 1;
116
117
118					# ExtraField can be any of
119					#
120					# -ExtraField => $data
121					#
122					# -ExtraField => [$id1, $data1,
123					# $id2, $data2]
124					# ...
125					# ]
126					#
127					# -ExtraField => [ [$id1 => $data1],
128					# [$id2 => $data2],
129					# ...
130					# ]
131					#
132					# -ExtraField => { $id1 => $data1,
133					# $id2 => $data2,
134					# ...
135					# }
136
137					if ( ! ref $dataRef ) {
138
139					return undef
140					if ! $strict;
141
142					return parseRawExtra($dataRef, undef, 1, $gzipMode);
143					}
144
145					#my $data = $$dataRef;
146					my $data = $dataRef;
147					my $out = '' ;
148
149					if (ref $data eq 'ARRAY') {
150					if (ref $data->[0]) {
151
152					foreach my $pair (@$data) {
153					return ExtraFieldError("Not list of lists")
154					unless ref $pair eq 'ARRAY' ;
155
156					my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ;
157					return $bad if $bad ;
158
159					$out .= mkSubField(@$pair);
160					}
161					}
162					else {
163					return ExtraFieldError("Not even number of elements")
164					unless @$data % 2 == 0;
165
166					for (my $ix = 0; $ix <= length(@$data) -1 ; $ix += 2) {
167					my $bad = validateExtraFieldPair([$data->[$ix],
168					$data->[$ix+1]],
169					$strict, $gzipMode) ;
170					return $bad if $bad ;
171
172					$out .= mkSubField($data->[$ix], $data->[$ix+1]);
173					}
174					}
175					}
176					elsif (ref $data eq 'HASH') {
177					while (my ($id, $info) = each %$data) {
178					my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode);
179					return $bad if $bad ;
180
181					$out .= mkSubField($id, $info);
182					}
183					}
184					else {
185					return ExtraFieldError("Not a scalar, array ref or hash ref") ;
186					}
187
188					return ExtraFieldError("Too Large")
189					if length $out > GZIP_FEXTRA_MAX_SIZE;
190
191					$_[0] = $out ;
192
193					return undef;
194					}
195
196	1	16µs			1;
197
198					__END__