"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/IO/Compress/Zlib/Extra.pm" (7 Mar 2020, 5711 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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