Commit | Line | Data |
c70c1701 |
1 | package IO::Compress::Zlib::Extra; |
2 | |
3 | require 5.004 ; |
4 | |
5 | use strict ; |
6 | use warnings; |
7 | use bytes; |
8 | |
9 | our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); |
10 | |
93d092e2 |
11 | $VERSION = '2.005'; |
c70c1701 |
12 | |
93d092e2 |
13 | use IO::Compress::Gzip::Constants 2.005 ; |
c70c1701 |
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); |
c70c1701 |
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]); |
c70c1701 |
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); |
c70c1701 |
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; |
197 | |
198 | __END__ |