git.maemo.org Git - pkg-perl/blob - deb-src/libio-compress-zlib-perl/libio-compress-zlib-perl-2.012/lib/IO/Compress/Zlib/Extra.pm

   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
  11 $VERSION = '2.012';
  12
  13 use IO::Compress::Gzip::Constants 2.012 ;
  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);
 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
 196 1;
 197
 198 __END__