1package IO::Compress::Zlib::Extra;
2
3require 5.006 ;
4
5use strict ;
6use warnings;
7use bytes;
8
9our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
10
11$VERSION = '2.093';
12
13use IO::Compress::Gzip::Constants 2.093 ;
14
15sub ExtraFieldError
16{
17    return $_[0];
18    return "Error with ExtraField Parameter: $_[0]" ;
19}
20
21sub 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
54sub 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
101sub 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
134sub mkSubField
135{
136    my $id = shift ;
137    my $data = shift ;
138
139    return $id . pack("v", length $data) . $data ;
140}
141
142sub 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
2271;
228
229__END__
230