"Fossies" - the Fresh Open Source Software Archive

Member "perl-5.32.1/cpan/IO-Compress/t/004gziphdr.t" (18 Dec 2020, 29366 Bytes) of package /linux/misc/perl-5.32.1.tar.xz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 BEGIN {
    2     if ($ENV{PERL_CORE}) {
    3 	chdir 't' if -d 't';
    4 	@INC = ("../lib", "lib/compress");
    5     }
    6 }
    7 
    8 use lib qw(t t/compress);
    9 use strict;
   10 use warnings;
   11 use bytes;
   12 
   13 use Test::More ;
   14 use CompTestUtils;
   15 
   16 BEGIN {
   17     # use Test::NoWarnings, if available
   18     my $extra = 0 ;
   19     $extra = 1
   20         if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
   21 
   22 
   23     plan tests => 918 + $extra ;
   24 
   25     use_ok('Compress::Raw::Zlib') ;
   26     use_ok('IO::Compress::Gzip::Constants') ;
   27 
   28     use_ok('IO::Compress::Gzip', qw($GzipError)) ;
   29     use_ok('IO::Uncompress::Gunzip', qw($GunzipError)) ;
   30 
   31 }
   32 
   33 
   34 
   35 # Check the Gzip Header Parameters
   36 #========================================
   37 
   38 my $ThisOS_code = $Compress::Raw::Zlib::gzip_os_code;
   39 
   40 my $lex = new LexFile my $name ;
   41 
   42 {
   43     title "Check Defaults";
   44     # Check Name defaults undef, no name, no comment
   45     # and Time can be explicitly set.
   46 
   47     my $hdr = readHeaderInfo($name, -Time => 1234);
   48 
   49     is $hdr->{Time}, 1234;
   50     ok ! defined $hdr->{Name};
   51     is $hdr->{MethodName}, 'Deflated';
   52     is $hdr->{ExtraFlags}, 0;
   53     is $hdr->{MethodID}, Z_DEFLATED;
   54     is $hdr->{OsID}, $ThisOS_code ;
   55     ok ! defined $hdr->{Comment} ;
   56     ok ! defined $hdr->{ExtraFieldRaw} ;
   57     ok ! defined $hdr->{HeaderCRC} ;
   58     ok ! $hdr->{isMinimalHeader} ;
   59 }
   60 
   61 {
   62 
   63     title "Check name can be different from filename" ;
   64     # Check Name can be different from filename
   65     # Comment and Extra can be set
   66     # Can specify a zero Time 
   67 
   68     my $comment = "This is a Comment" ;
   69     my $extra = "A little something extra" ;
   70     my $aname = "a new name" ;
   71     my $hdr = readHeaderInfo $name, 
   72 				      -Strict     => 0,
   73 				      -Name       => $aname,
   74     				  -Comment    => $comment,
   75     				  -ExtraField => $extra,
   76     				  -Time       => 0 ;
   77 
   78     ok $hdr->{Time} == 0;
   79     ok $hdr->{Name} eq $aname;
   80     ok $hdr->{MethodName} eq 'Deflated';
   81     ok $hdr->{MethodID} == 8;
   82     is $hdr->{ExtraFlags}, 0;
   83     ok $hdr->{Comment} eq $comment ;
   84     is $hdr->{OsID}, $ThisOS_code ;
   85     ok ! $hdr->{isMinimalHeader} ;
   86     ok ! defined $hdr->{HeaderCRC} ;
   87 }
   88 
   89 {
   90     title "Check Time defaults to now" ;
   91 
   92     # Check Time defaults to now
   93     # and that can have empty name, comment and extrafield
   94     my $before = time ;
   95     my $hdr = readHeaderInfo $name, 
   96 		          -TextFlag   => 1,
   97 		          -Name       => "",
   98     		      -Comment    => "",
   99     		      -ExtraField => "";
  100     my $after = time ;
  101 
  102     ok $hdr->{Time} >= $before ;
  103     ok $hdr->{Time} <= $after ;
  104 
  105     ok defined $hdr->{Name} ;
  106     ok $hdr->{Name} eq "";
  107     ok defined $hdr->{Comment} ;
  108     ok $hdr->{Comment} eq "";
  109     ok defined $hdr->{ExtraFieldRaw} ;
  110     ok $hdr->{ExtraFieldRaw} eq "";
  111     is $hdr->{ExtraFlags}, 0;
  112 
  113     ok ! $hdr->{isMinimalHeader} ;
  114     ok   $hdr->{TextFlag} ;
  115     ok ! defined $hdr->{HeaderCRC} ;
  116     is $hdr->{OsID}, $ThisOS_code ;
  117 
  118 }
  119 
  120 {
  121     title "can have null extrafield" ;
  122 
  123     my $before = time ;
  124     my $hdr = readHeaderInfo $name, 
  125 				      -strict     => 0,
  126 		              -Name       => "a",
  127     			      -Comment    => "b",
  128     			      -ExtraField => "\x00";
  129     my $after = time ;
  130 
  131     ok $hdr->{Time} >= $before ;
  132     ok $hdr->{Time} <= $after ;
  133     ok $hdr->{Name} eq "a";
  134     ok $hdr->{Comment} eq "b";
  135     is $hdr->{ExtraFlags}, 0;
  136     ok $hdr->{ExtraFieldRaw} eq "\x00";
  137     ok ! $hdr->{isMinimalHeader} ;
  138     ok ! $hdr->{TextFlag} ;
  139     ok ! defined $hdr->{HeaderCRC} ;
  140     is $hdr->{OsID}, $ThisOS_code ;
  141 
  142 }
  143 
  144 {
  145     title "can have undef name, comment, time and extrafield" ;
  146 
  147     my $hdr = readHeaderInfo $name, 
  148 	                  -Name       => undef,
  149     		          -Comment    => undef,
  150     		          -ExtraField => undef,
  151                       -Time       => undef;
  152 
  153     ok $hdr->{Time} == 0;
  154     ok ! defined $hdr->{Name} ;
  155     ok ! defined $hdr->{Comment} ;
  156     ok ! defined $hdr->{ExtraFieldRaw} ;
  157     ok ! $hdr->{isMinimalHeader} ;
  158     ok ! $hdr->{TextFlag} ;
  159     ok ! defined $hdr->{HeaderCRC} ;
  160     is $hdr->{OsID}, $ThisOS_code ;
  161 
  162 }
  163 
  164 for my $value ( "0D", "0A", "0A0D", "0D0A", "0A0A", "0D0D")
  165 {
  166     title "Comment with $value" ;
  167 
  168     my $v = pack "h*", $value;
  169     my $comment = "my${v}comment$v";
  170     my $hdr = readHeaderInfo $name, 
  171                     Time => 0,
  172                   -TextFlag   => 1, 
  173                   -Name       => "",
  174                   -Comment    => $comment,
  175                   -ExtraField => "";
  176     my $after = time ;
  177 
  178     is $hdr->{Time}, 0 ;
  179 
  180     ok defined $hdr->{Name} ;
  181     ok $hdr->{Name} eq "";
  182     ok defined $hdr->{Comment} ;
  183     is $hdr->{Comment}, $comment;
  184     ok defined $hdr->{ExtraFieldRaw} ;
  185     ok $hdr->{ExtraFieldRaw} eq "";
  186     is $hdr->{ExtraFlags}, 0;
  187 
  188     ok ! $hdr->{isMinimalHeader} ;
  189     ok   $hdr->{TextFlag} ;
  190     ok ! defined $hdr->{HeaderCRC} ;
  191     is $hdr->{OsID}, $ThisOS_code ;
  192 }
  193 
  194 {
  195     title "Check crchdr" ;
  196 
  197     my $hdr = readHeaderInfo $name, -HeaderCRC  => 1;
  198 
  199     ok ! defined $hdr->{Name};
  200     is $hdr->{ExtraFlags}, 0;
  201     ok ! defined $hdr->{ExtraFieldRaw} ;
  202     ok ! defined $hdr->{Comment} ;
  203     ok ! $hdr->{isMinimalHeader} ;
  204     ok ! $hdr->{TextFlag} ;
  205     ok   defined $hdr->{HeaderCRC} ;
  206     is $hdr->{OsID}, $ThisOS_code ;
  207 }
  208 
  209 {
  210     title "Check ExtraFlags" ;
  211 
  212     my $hdr = readHeaderInfo $name, -Level  => Z_BEST_SPEED;
  213 
  214     ok ! defined $hdr->{Name};
  215     is $hdr->{ExtraFlags}, 4;
  216     ok ! defined $hdr->{ExtraFieldRaw} ;
  217     ok ! defined $hdr->{Comment} ;
  218     ok ! $hdr->{isMinimalHeader} ;
  219     ok ! $hdr->{TextFlag} ;
  220     ok ! defined $hdr->{HeaderCRC} ;
  221 
  222     $hdr = readHeaderInfo $name, -Level  => Z_BEST_COMPRESSION;
  223 
  224     ok ! defined $hdr->{Name};
  225     is $hdr->{ExtraFlags}, 2;
  226     ok ! defined $hdr->{ExtraFieldRaw} ;
  227     ok ! defined $hdr->{Comment} ;
  228     ok ! $hdr->{isMinimalHeader} ;
  229     ok ! $hdr->{TextFlag} ;
  230     ok ! defined $hdr->{HeaderCRC} ;
  231 
  232     $hdr = readHeaderInfo $name, -Level  => Z_BEST_COMPRESSION,
  233                                  -ExtraFlags => 42;
  234 
  235     ok ! defined $hdr->{Name};
  236     is $hdr->{ExtraFlags}, 42;
  237     ok ! defined $hdr->{ExtraFieldRaw} ;
  238     ok ! defined $hdr->{Comment} ;
  239     ok ! $hdr->{isMinimalHeader} ;
  240     ok ! $hdr->{TextFlag} ;
  241     ok ! defined $hdr->{HeaderCRC} ;
  242 
  243 
  244 }
  245 
  246 {
  247     title "OS Code" ;
  248 
  249     for my $code ( -1, undef, '', 'fred' )
  250     {
  251         my $code_name = defined $code ? "'$code'" : "'undef'";
  252         eval { new IO::Compress::Gzip $name, -OS_Code => $code } ;
  253         like $@, mkErr("^IO::Compress::Gzip: Parameter 'OS_Code' must be an unsigned int, got $code_name"),
  254             " Trap OS Code $code_name";
  255     }
  256 
  257     for my $code ( qw( 256 ) )
  258     {
  259         eval { ok ! new IO::Compress::Gzip($name, OS_Code => $code) };
  260         like $@, mkErr("OS_Code must be between 0 and 255, got '$code'"),
  261             " Trap OS Code $code";
  262         like $GzipError, "/OS_Code must be between 0 and 255, got '$code'/",
  263             " Trap OS Code $code";
  264     }
  265 
  266     for my $code ( qw(0 1 12 254 255) )
  267     {
  268         my $hdr = readHeaderInfo $name, OS_Code => $code;
  269 
  270         is $hdr->{OsID}, $code, "  Code is $code" ;
  271     }
  272 
  273 
  274 
  275 }
  276 
  277 {
  278     title 'Check ExtraField';
  279 
  280     my @tests = (
  281         [1, ['AB' => '']                   => [['AB'=>'']] ],
  282         [1, {'AB' => ''}                   => [['AB'=>'']] ],
  283         [1, ['AB' => 'Fred']               => [['AB'=>'Fred']] ],
  284         [1, {'AB' => 'Fred'}               => [['AB'=>'Fred']] ],
  285         [1, ['Xx' => '','AB' => 'Fred']    => [['Xx' => ''],['AB'=>'Fred']] ],
  286         [1, ['Xx' => '','Xx' => 'Fred']    => [['Xx' => ''],['Xx'=>'Fred']] ],
  287         [1, ['Xx' => '',
  288              'Xx' => 'Fred', 
  289              'Xx' => 'Fred']               => [['Xx' => ''],['Xx'=>'Fred'],
  290                                                ['Xx'=>'Fred']] ],
  291         [1, [ ['Xx' => 'a'],
  292               ['AB' => 'Fred'] ]           => [['Xx' => 'a'],['AB'=>'Fred']] ],
  293         [0, {'AB' => 'Fred', 
  294              'Pq' => 'r', 
  295              "\x01\x02" => "\x03"}         => [['AB'=>'Fred'],
  296                                                ['Pq'=>'r'], 
  297                                                ["\x01\x02"=>"\x03"]] ],
  298         [1, ['AB' => 'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE] => 
  299                             [['AB'=>'z' x GZIP_FEXTRA_SUBFIELD_MAX_SIZE]] ],
  300                 );
  301 
  302     foreach my $test (@tests) {
  303         my ($order, $input, $result) = @$test ;
  304         ok my $x = new IO::Compress::Gzip $name,
  305                                 -ExtraField  => $input,
  306                                 -HeaderCRC   => 1
  307             or diag "GzipError is $GzipError" ;                            ;
  308         my $string = "abcd" ;
  309         ok $x->write($string) ;
  310         ok $x->close ;
  311         #is GZreadFile($name), $string ;
  312 
  313         ok $x = new IO::Uncompress::Gunzip $name,
  314                               #-Strict     => 1,
  315                                -ParseExtra => 1
  316             or diag "GunzipError is $GunzipError" ;                            ;
  317         my $hdr = $x->getHeaderInfo();
  318         ok $hdr;
  319         ok ! defined $hdr->{Name};
  320         ok ! defined $hdr->{Comment} ;
  321         ok ! $hdr->{isMinimalHeader} ;
  322         ok ! $hdr->{TextFlag} ;
  323         ok   defined $hdr->{HeaderCRC} ;
  324 
  325         ok   defined $hdr->{ExtraFieldRaw} ;
  326         ok   defined $hdr->{ExtraField} ;
  327 
  328         my $extra = $hdr->{ExtraField} ;
  329 
  330         if ($order) {
  331             eq_array $extra, $result;
  332         } else {
  333             eq_set $extra, $result;
  334         } 
  335     }
  336 
  337 }
  338 
  339 {
  340     title 'Write Invalid ExtraField';
  341 
  342     my $prefix = 'Error with ExtraField Parameter: ';
  343     my @tests = (
  344             [ sub{ "abc" }        => "Not a scalar, array ref or hash ref"],
  345             [ [ "a" ]             => "Not even number of elements"],
  346             [ [ "a" => "fred" ]   => 'SubField ID not two chars long'],
  347             [ [ "a\x00" => "fred" ]   => 'SubField ID 2nd byte is 0x00'],
  348             [ [ [ {}, "abc" ]]    => "SubField ID is a reference"],
  349             [ [ [ "ab", \1 ]]     => "SubField Data is a reference"],
  350             [ [ {"a" => "fred"} ] => "Not list of lists"],
  351             [ [ ['ab'=>'x'],{"a" => "fred"} ] => "Not list of lists"],
  352             [ [ ["aa"] ]          => "SubField must have two parts"],
  353             [ [ ["aa", "b", "c"] ] => "SubField must have two parts"],
  354             [ [ ["ab" => 'x' x (GZIP_FEXTRA_SUBFIELD_MAX_SIZE + 1) ] ] 
  355                                    => "SubField Data too long"],
  356 
  357             [ { 'abc', 1 }        => "SubField ID not two chars long"],
  358             [ { \1 , "abc" }    => "SubField ID not two chars long"],
  359             [ { "ab", \1 }     => "SubField Data is a reference"],
  360         );
  361 
  362     
  363 
  364     foreach my $test (@tests) {
  365         my ($input, $string) = @$test ;
  366         my $buffer ;
  367         my $x ;
  368         eval { $x = new IO::Compress::Gzip \$buffer, -ExtraField  => $input; };
  369         like $@, mkErr("$prefix$string");  
  370         like $GzipError, "/$prefix$string/";  
  371         ok ! $x ;
  372 
  373     }
  374 
  375 }
  376 
  377 {
  378     # Corrupt ExtraField
  379 
  380     my @tests = (
  381         ["Sub-field truncated",           
  382             "Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
  383             "Header Error: Truncated in FEXTRA Body Section",
  384             ['a', undef, undef]              ],
  385         ["Length of field incorrect",     
  386             "Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
  387             "Header Error: Truncated in FEXTRA Body Section",
  388             ["ab", 255, "abc"]               ],
  389         ["Length of 2nd field incorrect", 
  390             "Error with ExtraField Parameter: Truncated in FEXTRA Body Section",
  391             "Header Error: Truncated in FEXTRA Body Section",
  392             ["ab", 3, "abc"], ["de", 7, "x"] ],
  393         ["Length of 2nd field incorrect", 
  394             "Error with ExtraField Parameter: SubField ID 2nd byte is 0x00",
  395             "Header Error: SubField ID 2nd byte is 0x00",
  396             ["a\x00", 3, "abc"], ["de", 7, "x"] ],
  397         );
  398 
  399     foreach my $test (@tests)
  400     {
  401         my $name = shift @$test;
  402         my $gzip_error = shift @$test;
  403         my $gunzip_error = shift @$test;
  404 
  405         title "Read Corrupt ExtraField - $name" ;
  406 
  407         my $input = '';
  408 
  409         for my $field (@$test)
  410         {
  411             my ($id, $len, $data) = @$field;
  412 
  413             $input .= $id if defined $id ;
  414             $input .= pack("v", $len) if defined $len ;
  415             $input .= $data if defined $data;
  416         }
  417         #hexDump(\$input);
  418 
  419         my $buffer ;
  420         my $x ;
  421         eval {$x = new IO::Compress::Gzip \$buffer, -ExtraField  => $input, Strict => 1; };
  422         like $@, mkErr("$gzip_error"), "  $name";  
  423         like $GzipError, "/$gzip_error/", "  $name";  
  424 
  425         ok ! $x, "  IO::Compress::Gzip fails";
  426         like $GzipError, "/$gzip_error/", "  $name";  
  427 
  428         foreach my $check (0, 1)    
  429         {
  430             ok $x = new IO::Compress::Gzip \$buffer, 
  431                                            ExtraField => $input, 
  432                                            Strict     => 0
  433                 or diag "GzipError is $GzipError" ;
  434             my $string = "abcd" ;
  435             $x->write($string) ;
  436             $x->close ;
  437             is anyUncompress(\$buffer), $string ;
  438 
  439             $x = new IO::Uncompress::Gunzip \$buffer, 
  440                                        Strict      => 0,
  441                                        Transparent => 0,
  442                                        ParseExtra  => $check;
  443             if ($check) {
  444                 ok ! $x ;
  445                 like $GunzipError, "/^$gunzip_error/";  
  446             }
  447             else {
  448                 ok $x ;
  449             }
  450 
  451         }
  452     }
  453 }
  454 
  455 
  456 {
  457     title 'Check Minimal';
  458 
  459     ok my $x = new IO::Compress::Gzip $name, -Minimal => 1;
  460     my $string = "abcd" ;
  461     ok $x->write($string) ;
  462     ok $x->close ;
  463     #is GZreadFile($name), $string ;
  464 
  465     ok $x = new IO::Uncompress::Gunzip $name  ;
  466     my $hdr = $x->getHeaderInfo();
  467     ok $hdr;
  468     ok $hdr->{Time} == 0;
  469     is $hdr->{ExtraFlags}, 0;
  470     ok ! defined $hdr->{Name} ;
  471     ok ! defined $hdr->{ExtraFieldRaw} ;
  472     ok ! defined $hdr->{Comment} ;
  473     is $hdr->{OsName}, 'Unknown' ;
  474     is $hdr->{MethodName}, "Deflated";
  475     is $hdr->{Flags}, 0;
  476     ok $hdr->{isMinimalHeader} ;
  477     ok ! $hdr->{TextFlag} ;
  478     ok $x->close ;
  479 }
  480 
  481 {
  482     title "Check Minimal + no compressed data";
  483     # This is the smallest possible gzip file (20 bytes)
  484 
  485     ok my $x = new IO::Compress::Gzip $name, -Minimal => 1;
  486     isa_ok $x, "IO::Compress::Gzip";
  487     ok $x->close, "closed" ;
  488 
  489     ok $x = new IO::Uncompress::Gunzip $name, -Append => 0 ;
  490     isa_ok $x, "IO::Uncompress::Gunzip";
  491     my $data ;
  492     my $status  = 1;
  493 
  494     ok $x->eof(), "eof" ;
  495     $status = $x->read($data)
  496         while $status >  0;
  497     is $status, 0, "status == 0" ;
  498     is $data, '', "empty string";
  499     ok ! $x->error(), "no error" ;
  500     ok $x->eof(), "eof" ;
  501 
  502     my $hdr = $x->getHeaderInfo();
  503     ok $hdr;
  504 
  505     ok defined $hdr->{ISIZE} ;
  506     is $hdr->{ISIZE}, 0;
  507 
  508     ok defined $hdr->{CRC32} ;
  509     is $hdr->{CRC32}, 0;
  510 
  511     is $hdr->{Time}, 0;
  512     ok ! defined $hdr->{Name} ;
  513     ok ! defined $hdr->{ExtraFieldRaw} ;
  514     ok ! defined $hdr->{Comment} ;
  515     is $hdr->{OsName}, 'Unknown' ;
  516     is $hdr->{MethodName}, "Deflated";
  517     is $hdr->{Flags}, 0;
  518     ok $hdr->{isMinimalHeader} ;
  519     ok ! $hdr->{TextFlag} ;
  520     ok $x->close ;
  521 }
  522 
  523 {
  524     title "Header Corruption Tests";
  525 
  526     my $string = <<EOM;
  527 some text
  528 EOM
  529 
  530     my $good = '';
  531     ok my $x = new IO::Compress::Gzip \$good, -HeaderCRC => 1 ;
  532     ok $x->write($string) ;
  533     ok $x->close ;
  534 
  535     {
  536         title "Header Corruption - Fingerprint wrong 1st byte" ;
  537         my $buffer = $good ;
  538         substr($buffer, 0, 1) = 'x' ;
  539 
  540         ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0  ;
  541         ok $GunzipError =~ /Header Error: Bad Magic/;
  542     }
  543 
  544     {
  545         title "Header Corruption - Fingerprint wrong 2nd byte" ;
  546         my $buffer = $good ;
  547         substr($buffer, 1, 1) = "\xFF" ;
  548 
  549         ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0  ;
  550         ok $GunzipError =~ /Header Error: Bad Magic/;
  551         #print "$GunzipError\n";
  552     }
  553 
  554     {
  555         title "Header Corruption - CM not 8";
  556         my $buffer = $good ;
  557         substr($buffer, 2, 1) = 'x' ;
  558 
  559         ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0  ;
  560         like $GunzipError, '/Header Error: Not Deflate \(CM is \d+\)/';
  561     }
  562 
  563     {
  564         title "Header Corruption - Use of Reserved Flags";
  565         my $buffer = $good ;
  566         substr($buffer, 3, 1) = "\xff";
  567 
  568         ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0  ;
  569         like $GunzipError, '/Header Error: Use of Reserved Bits in FLG field./';
  570     }
  571 
  572     {
  573         title "Header Corruption - Fail HeaderCRC";
  574         my $buffer = $good ;
  575         substr($buffer, 10, 1) = chr((ord(substr($buffer, 10, 1)) + 1) & 0xFF);
  576 
  577         ok ! new IO::Uncompress::Gunzip \$buffer, -Transparent => 0, Strict => 1
  578          or print "# $GunzipError\n";
  579         like $GunzipError, '/Header Error: CRC16 mismatch/'
  580             #or diag "buffer length " . length($buffer);
  581             or hexDump(\$good), hexDump(\$buffer);
  582     }
  583 }
  584 
  585 {
  586     title "ExtraField max raw size";
  587     my $x ;
  588     my $store = "x" x GZIP_FEXTRA_MAX_SIZE ;
  589     {
  590         my $z = new IO::Compress::Gzip(\$x, ExtraField => $store, Strict => 0) ;
  591         ok $z,  "Created IO::Compress::Gzip object" ;
  592     }
  593     my $gunz = new IO::Uncompress::Gunzip \$x, Strict => 0;
  594     ok $gunz, "Created IO::Uncompress::Gunzip object" ;
  595     my $hdr = $gunz->getHeaderInfo();
  596     ok $hdr;
  597 
  598     is $hdr->{ExtraFieldRaw}, $store ;
  599 }
  600 
  601 {
  602     title "Header Corruption - ExtraField too big";
  603     my $x;
  604     eval { new IO::Compress::Gzip(\$x, -ExtraField => "x" x (GZIP_FEXTRA_MAX_SIZE + 1)) ;};
  605     like $@, mkErr('Error with ExtraField Parameter: Too Large');
  606     like $GzipError, '/Error with ExtraField Parameter: Too Large/';
  607 }
  608 
  609 {
  610     title "Header Corruption - Create Name with Illegal Chars";
  611 
  612     my $x;
  613     eval { new IO::Compress::Gzip \$x, -Name => "fred\x02" };
  614     like $@, mkErr('Non ISO 8859-1 Character found in Name');
  615     like $GzipError, '/Non ISO 8859-1 Character found in Name/';
  616 
  617     ok  my $gz = new IO::Compress::Gzip \$x,
  618 		                      -Strict => 0,
  619 		                      -Name => "fred\x02" ;
  620     ok $gz->close();                          
  621 
  622     ok ! new IO::Uncompress::Gunzip \$x,
  623                         -Transparent => 0,
  624                         -Strict => 1;
  625 
  626     like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Name/';                    
  627     ok my $gunzip = new IO::Uncompress::Gunzip \$x,
  628                                    -Strict => 0;
  629 
  630     my $hdr = $gunzip->getHeaderInfo() ;                  
  631 
  632     is $hdr->{Name}, "fred\x02";
  633 
  634 }
  635 
  636 {
  637     title "Header Corruption - Null Chars in Name";
  638     my $x;
  639     eval { new IO::Compress::Gzip \$x, -Name => "\x00" };
  640     like $@, mkErr('Null Character found in Name');
  641     like $GzipError, '/Null Character found in Name/';
  642 
  643     eval { new IO::Compress::Gzip \$x, -Name => "abc\x00" };
  644     like $@, mkErr('Null Character found in Name');
  645     like $GzipError, '/Null Character found in Name/';
  646 
  647     ok my $gz = new IO::Compress::Gzip \$x,
  648 		                     -Strict  => 0,
  649 		                     -Name => "abc\x00de" ;
  650     ok $gz->close() ;                             
  651     ok my $gunzip = new IO::Uncompress::Gunzip \$x,
  652                                    -Strict => 0;
  653 
  654     my $hdr = $gunzip->getHeaderInfo() ;                  
  655 
  656     is $hdr->{Name}, "abc";
  657     
  658 }
  659 
  660 {
  661     title "Header Corruption - Create Comment with Illegal Chars";
  662 
  663     my $x;
  664     eval { new IO::Compress::Gzip \$x, -Comment => "fred\x02" };
  665     like $@, mkErr('Non ISO 8859-1 Character found in Comment');
  666     like $GzipError, '/Non ISO 8859-1 Character found in Comment/';
  667 
  668     ok  my $gz = new IO::Compress::Gzip \$x,
  669 		                      -Strict => 0,
  670 		                      -Comment => "fred\x02" ;
  671     ok $gz->close();                          
  672 
  673     ok ! new IO::Uncompress::Gunzip \$x, Strict => 1,
  674                         -Transparent => 0;
  675 
  676     like $GunzipError, '/Header Error: Non ISO 8859-1 Character found in Comment/';
  677     ok my $gunzip = new IO::Uncompress::Gunzip \$x, Strict => 0;
  678 
  679     my $hdr = $gunzip->getHeaderInfo() ;                  
  680 
  681     is $hdr->{Comment}, "fred\x02";
  682 
  683 }
  684 
  685 {
  686     title "Header Corruption - Null Char in Comment";
  687     my $x;
  688     eval { new IO::Compress::Gzip \$x, -Comment => "\x00" };
  689     like $@, mkErr('Null Character found in Comment');
  690     like $GzipError, '/Null Character found in Comment/';
  691 
  692     eval { new IO::Compress::Gzip \$x, -Comment => "abc\x00" } ;
  693     like $@, mkErr('Null Character found in Comment');
  694     like $GzipError, '/Null Character found in Comment/';
  695 
  696     ok my $gz = new IO::Compress::Gzip \$x,
  697 		                     -Strict  => 0,
  698 		                     -Comment => "abc\x00de" ;
  699     ok $gz->close() ;                             
  700     ok my $gunzip = new IO::Uncompress::Gunzip \$x,
  701                                    -Strict => 0;
  702 
  703     my $hdr = $gunzip->getHeaderInfo() ;                  
  704 
  705     is $hdr->{Comment}, "abc";
  706     
  707 }
  708 
  709 
  710 for my $index ( GZIP_MIN_HEADER_SIZE + 1 ..  GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1)
  711 {
  712     title "Header Corruption - Truncated in Extra";
  713     my $string = <<EOM;
  714 some text
  715 EOM
  716 
  717     my $truncated ;
  718     ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1, Strict => 0,
  719 				-ExtraField => "hello" x 10  ;
  720     ok $x->write($string) ;
  721     ok $x->close ;
  722 
  723     substr($truncated, $index) = '' ;
  724     #my $lex = new LexFile my $name ;
  725     #writeFile($name, $truncated) ;
  726 
  727     #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; 
  728     my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; 
  729     ok ! $g 
  730 	or print "# $g\n" ;
  731 
  732     like($GunzipError, '/^Header Error: Truncated in FEXTRA/');
  733 
  734 
  735 }
  736 
  737 my $Name = "fred" ;
  738     my $truncated ;
  739 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + length($Name) -1)
  740 {
  741     title "Header Corruption - Truncated in Name";
  742     my $string = <<EOM;
  743 some text
  744 EOM
  745 
  746     my $truncated ;
  747     ok my $x = new IO::Compress::Gzip \$truncated, -Name => $Name;
  748     ok $x->write($string) ;
  749     ok $x->close ;
  750 
  751     substr($truncated, $index) = '' ;
  752 
  753     my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; 
  754     ok ! $g 
  755 	or print "# $g\n" ;
  756 
  757     like $GunzipError, '/^Header Error: Truncated in FNAME Section/';
  758 
  759 }
  760 
  761 my $Comment = "comment" ;
  762 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + length($Comment) -1)
  763 {
  764     title "Header Corruption - Truncated in Comment";
  765     my $string = <<EOM;
  766 some text
  767 EOM
  768 
  769     my $truncated ;
  770     ok my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment;
  771     ok $x->write($string) ;
  772     ok $x->close ;
  773 
  774     substr($truncated, $index) = '' ;
  775     #my $lex = new LexFile my $name ;
  776     #writeFile($name, $truncated) ;
  777 
  778     #my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; 
  779     my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; 
  780     ok ! $g 
  781 	or print "# $g\n" ;
  782 
  783     like $GunzipError, '/^Header Error: Truncated in FCOMMENT Section/';
  784 
  785 }
  786 
  787 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1)
  788 {
  789     title "Header Corruption - Truncated in CRC";
  790     my $string = <<EOM;
  791 some text
  792 EOM
  793 
  794     my $truncated ;
  795     ok my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1;
  796     ok $x->write($string) ;
  797     ok $x->close ;
  798 
  799     substr($truncated, $index) = '' ;
  800     my $lex = new LexFile my $name ;
  801     writeFile($name, $truncated) ;
  802 
  803     my $g = new IO::Uncompress::Gunzip $name, -Transparent => 0; 
  804     #my $g = new IO::Uncompress::Gunzip \$truncated, -Transparent => 0; 
  805     ok ! $g 
  806 	or print "# $g\n" ;
  807 
  808     like $GunzipError, '/^Header Error: Truncated in FHCRC Section/';
  809 
  810 }
  811 
  812 
  813 {
  814     # Trailer Corruption tests
  815 
  816     my $string = <<EOM;
  817 some text
  818 EOM
  819     $string = $string x 1000;
  820 
  821     my $good ;
  822     {
  823         ok my $x = new IO::Compress::Gzip \$good ;
  824         ok $x->write($string) ;
  825         ok $x->close ;
  826     }
  827 
  828     writeFile($name, $good) ;
  829     ok my $gunz = new IO::Uncompress::Gunzip $name, 
  830                                        -Append   => 1,
  831                                        -Strict   => 1;
  832     my $uncomp ;
  833     1 while  $gunz->read($uncomp) > 0 ;
  834     ok $gunz->close() ;
  835     ok $uncomp eq $string 
  836 	or print "# got [$uncomp] wanted [$string]\n";;
  837 
  838     foreach my $trim (-8 .. -1)
  839     {
  840         my $got = $trim + 8 ;
  841         title "Trailer Corruption - Trailer truncated to $got bytes" ;
  842         my $buffer = $good ;
  843         my $expected_trailing = substr($good, -8, 8) ;
  844         substr($expected_trailing, $trim) = '';
  845 
  846         substr($buffer, $trim) = '';
  847         writeFile($name, $buffer) ;
  848 
  849         foreach my $strict (0, 1)
  850         {
  851             ok my $gunz = new IO::Uncompress::Gunzip $name, Append => 1, -Strict   => $strict ;
  852             my $uncomp ;
  853             my $status = 1;
  854             $status = $gunz->read($uncomp) while $status > 0;
  855             if ($strict)
  856             {
  857                 cmp_ok $status, '<', 0, "status 0" ;
  858                 like $GunzipError, "/Trailer Error: trailer truncated. Expected 8 bytes, got $got/", "got Trailer Error";
  859             }
  860             else
  861             {
  862                 is $status, 0, "status 0";
  863                 ok ! $GunzipError, "no error" 
  864                     or diag "$GunzipError";
  865                 my $expected = substr($buffer, - $got);
  866                 is  $gunz->trailingData(),  $expected_trailing, "trailing data";
  867             }
  868             ok $gunz->eof() ;
  869             ok $uncomp eq $string;
  870             ok $gunz->close ;
  871         }
  872 
  873     }
  874 
  875     {
  876         title "Trailer Corruption - Length Wrong, CRC Correct" ;
  877         my $buffer = $good ;
  878         my $actual_len = unpack("V", substr($buffer, -4, 4));
  879         substr($buffer, -4, 4) = pack('V', $actual_len + 1);
  880         writeFile($name, $buffer) ;
  881 
  882         foreach my $strict (0, 1)
  883         {
  884             ok my $gunz = new IO::Uncompress::Gunzip $name, 
  885                                                Append   => 1,
  886                                                -Strict   => $strict ;
  887             my $uncomp ;
  888             my $status = 1;
  889             $status = $gunz->read($uncomp) while $status > 0;
  890             if ($strict)
  891             {
  892                 cmp_ok $status, '<', 0 ;
  893                 my $got_len = $actual_len + 1;
  894                 like $GunzipError, "/Trailer Error: ISIZE mismatch. Got $got_len, expected $actual_len/";
  895             }
  896             else
  897             {
  898                 is $status, 0;
  899                 ok ! $GunzipError ;
  900                 #is   $gunz->trailingData(), substr($buffer, - $got) ;
  901             }
  902             ok ! $gunz->trailingData() ;
  903             ok $gunz->eof() ;
  904             ok $uncomp eq $string;
  905             ok $gunz->close ;
  906         }
  907 
  908     }
  909 
  910     {
  911         title "Trailer Corruption - Length Correct, CRC Wrong" ;
  912         my $buffer = $good ;
  913         my $actual_crc = unpack("V", substr($buffer, -8, 4));
  914         substr($buffer, -8, 4) = pack('V', $actual_crc+1);
  915         writeFile($name, $buffer) ;
  916 
  917         foreach my $strict (0, 1)
  918         {
  919             ok my $gunz = new IO::Uncompress::Gunzip $name, 
  920                                                -Append   => 1,
  921                                                -Strict   => $strict ;
  922             my $uncomp ;
  923             my $status = 1;
  924             $status = $gunz->read($uncomp) while $status > 0;
  925             if ($strict)
  926             {
  927                 cmp_ok $status, '<', 0 ;
  928                 like $GunzipError, '/Trailer Error: CRC mismatch/';
  929             }
  930             else
  931             {
  932                 is $status, 0;
  933                 ok ! $GunzipError ;
  934             }
  935             ok ! $gunz->trailingData() ;
  936             ok $gunz->eof() ;
  937             ok $uncomp eq $string;
  938             ok $gunz->close ;
  939         }
  940 
  941     }
  942 
  943     {
  944         title "Trailer Corruption - Length Wrong, CRC Wrong" ;
  945         my $buffer = $good ;
  946         my $actual_len = unpack("V", substr($buffer, -4, 4));
  947         my $actual_crc = unpack("V", substr($buffer, -8, 4));
  948         substr($buffer, -4, 4) = pack('V', $actual_len+1);
  949         substr($buffer, -8, 4) = pack('V', $actual_crc+1);
  950         writeFile($name, $buffer) ;
  951 
  952         foreach my $strict (0, 1)
  953         {
  954             ok my $gunz = new IO::Uncompress::Gunzip $name, 
  955                                                -Append   => 1,
  956                                                -Strict   => $strict ;
  957             my $uncomp ;
  958             my $status = 1;
  959             $status = $gunz->read($uncomp) while $status > 0;
  960             if ($strict)
  961             {
  962                 cmp_ok $status, '<', 0 ;
  963                 like $GunzipError, '/Trailer Error: CRC mismatch/';
  964             }
  965             else
  966             {
  967                 is $status, 0;
  968                 ok ! $GunzipError ;
  969             }
  970             ok $gunz->eof() ;
  971             ok $uncomp eq $string;
  972             ok $gunz->close ;
  973         }
  974 
  975     }
  976 
  977     {
  978         # RT #72329
  979         my $error = 'Error with ExtraField Parameter: ' .
  980                     'SubField ID not two chars long' ;
  981         my $buffer ;
  982         my $x ;
  983         eval { $x = new IO::Compress::Gzip \$buffer, 
  984                 -ExtraField  => [ at => 'mouse', bad => 'dog'] ;
  985              };
  986         like $@, mkErr("$error");  
  987         like $GzipError, "/$error/";  
  988         ok ! $x ;
  989     }
  990 }
  991 
  992 
  993