Commit | Line | Data |
---|---|---|
c70c1701 PM |
1 | package IO::Compress::Zlib::Extra; |
2 | ||
422d6414 | 3 | require 5.006 ; |
c70c1701 PM |
4 | |
5 | use strict ; | |
6 | use warnings; | |
7 | use bytes; | |
8 | ||
9 | our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); | |
10 | ||
5173674b | 11 | $VERSION = '2.074'; |
c70c1701 | 12 | |
5173674b | 13 | use IO::Compress::Gzip::Constants 2.074 ; |
c70c1701 PM |
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 | ||
529174d6 CBW |
101 | sub findID |
102 | { | |
103 | my $id_want = shift ; | |
104 | my $data = shift; | |
105 | ||
106 | my $XLEN = length $data ; | |
107 | ||
108 | my $offset = 0 ; | |
109 | while ($offset < $XLEN) { | |
110 | ||
111 | return undef | |
112 | if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; | |
113 | ||
114 | my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); | |
115 | $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; | |
116 | ||
117 | my $subLen = unpack("v", substr($data, $offset, | |
118 | GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); | |
119 | $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; | |
120 | ||
121 | return undef | |
122 | if $offset + $subLen > $XLEN ; | |
123 | ||
124 | return substr($data, $offset, $subLen) | |
125 | if $id eq $id_want ; | |
126 | ||
127 | $offset += $subLen ; | |
128 | } | |
129 | ||
130 | return undef ; | |
131 | } | |
132 | ||
c70c1701 PM |
133 | |
134 | sub mkSubField | |
135 | { | |
136 | my $id = shift ; | |
137 | my $data = shift ; | |
138 | ||
139 | return $id . pack("v", length $data) . $data ; | |
140 | } | |
141 | ||
142 | sub parseExtraField | |
143 | { | |
144 | my $dataRef = $_[0]; | |
145 | my $strict = $_[1]; | |
146 | my $gzipMode = $_[2]; | |
147 | #my $lax = @_ == 2 ? $_[1] : 1; | |
148 | ||
149 | ||
150 | # ExtraField can be any of | |
151 | # | |
152 | # -ExtraField => $data | |
153 | # | |
154 | # -ExtraField => [$id1, $data1, | |
155 | # $id2, $data2] | |
156 | # ... | |
157 | # ] | |
158 | # | |
159 | # -ExtraField => [ [$id1 => $data1], | |
160 | # [$id2 => $data2], | |
161 | # ... | |
162 | # ] | |
163 | # | |
164 | # -ExtraField => { $id1 => $data1, | |
165 | # $id2 => $data2, | |
166 | # ... | |
167 | # } | |
168 | ||
169 | if ( ! ref $dataRef ) { | |
170 | ||
171 | return undef | |
172 | if ! $strict; | |
173 | ||
174 | return parseRawExtra($dataRef, undef, 1, $gzipMode); | |
175 | } | |
176 | ||
c70c1701 PM |
177 | my $data = $dataRef; |
178 | my $out = '' ; | |
179 | ||
180 | if (ref $data eq 'ARRAY') { | |
181 | if (ref $data->[0]) { | |
182 | ||
183 | foreach my $pair (@$data) { | |
184 | return ExtraFieldError("Not list of lists") | |
185 | unless ref $pair eq 'ARRAY' ; | |
186 | ||
187 | my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ; | |
188 | return $bad if $bad ; | |
189 | ||
190 | $out .= mkSubField(@$pair); | |
c70c1701 PM |
191 | } |
192 | } | |
193 | else { | |
194 | return ExtraFieldError("Not even number of elements") | |
195 | unless @$data % 2 == 0; | |
196 | ||
aad9a0d9 | 197 | for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) { |
c70c1701 PM |
198 | my $bad = validateExtraFieldPair([$data->[$ix], |
199 | $data->[$ix+1]], | |
200 | $strict, $gzipMode) ; | |
201 | return $bad if $bad ; | |
202 | ||
203 | $out .= mkSubField($data->[$ix], $data->[$ix+1]); | |
c70c1701 PM |
204 | } |
205 | } | |
206 | } | |
207 | elsif (ref $data eq 'HASH') { | |
208 | while (my ($id, $info) = each %$data) { | |
209 | my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); | |
210 | return $bad if $bad ; | |
211 | ||
212 | $out .= mkSubField($id, $info); | |
c70c1701 PM |
213 | } |
214 | } | |
215 | else { | |
216 | return ExtraFieldError("Not a scalar, array ref or hash ref") ; | |
217 | } | |
218 | ||
219 | return ExtraFieldError("Too Large") | |
220 | if length $out > GZIP_FEXTRA_MAX_SIZE; | |
221 | ||
222 | $_[0] = $out ; | |
223 | ||
224 | return undef; | |
225 | } | |
226 | ||
227 | 1; | |
228 | ||
229 | __END__ |