xref: /openbsd-src/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm (revision 4c1e55dc91edd6e69ccc60ce855900fbc12cf34f) 
1package IO::Compress::Zlib::Extra;
2
3require 5.004 ;
4
5use strict ;
6use warnings;
7use bytes;
8
9our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS);
10
11$VERSION = '2.024';
12
13use IO::Compress::Gzip::Constants 2.024 ;
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
101
102sub mkSubField
103{
104    my $id = shift ;
105    my $data = shift ;
106
107    return $id . pack("v", length $data) . $data ;
108}
109
110sub 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
1961;
197
198__END__
199