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.074';
  12
  13 use IO::Compress::Gzip::Constants 2.074 ;
  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__