f99b9ed02b9ba29d18a726dde2872e4c05dff2a4
[perl.git] / cpan / IO-Compress / lib / IO / Compress / Zlib / Extra.pm
1 package IO::Compress::Zlib::Extra;
2
3 require 5.006 ;
4
5 use strict ;
6 use warnings;
7 use bytes;
8
9 our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
10
11 $VERSION = '2.068';
12
13 use IO::Compress::Gzip::Constants 2.068 ;
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 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
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
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);
191             }   
192         }   
193         else {
194             return ExtraFieldError("Not even number of elements")
195                 unless @$data % 2  == 0;
196
197             for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) {
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]);
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);
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__