"Fossies" - the Fresh Open Source Software Archive

Member "perl-5.32.1/cpan/IO-Compress/t/005defhdr.t" (18 Dec 2020, 9794 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     plan tests => 595 + $extra ;
   23 
   24     use_ok('Compress::Raw::Zlib') ;
   25 
   26     use_ok('IO::Compress::Deflate', qw($DeflateError)) ;
   27     use_ok('IO::Uncompress::Inflate', qw($InflateError)) ;
   28 
   29     use_ok('IO::Compress::Zlib::Constants');
   30 
   31 }
   32 
   33 
   34 sub ReadHeaderInfo
   35 {
   36     my $string = shift || '' ;
   37     my %opts = @_ ;
   38 
   39     my $buffer ;
   40     ok my $def = new IO::Compress::Deflate \$buffer, %opts ;
   41     is $def->write($string), length($string), "write" ;
   42     ok $def->close, "closed" ;
   43     #print "ReadHeaderInfo\n"; hexDump(\$buffer);
   44 
   45     ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
   46     my $uncomp = "";
   47     #ok $inf->read($uncomp) ;
   48     my $actual = 0 ;
   49     my $status = 1 ;
   50     while (($status = $inf->read($uncomp)) > 0) {
   51         $actual += $status ;
   52     }
   53 
   54     is $actual, length($string) ;
   55     is $uncomp, $string;
   56     ok ! $inf->error(), "! error" ;
   57     ok $inf->eof(), "eof" ;
   58     ok my $hdr = $inf->getHeaderInfo();
   59     ok $inf->close ;
   60 
   61     return $hdr ;
   62 }
   63 
   64 sub ReadHeaderInfoZlib
   65 {
   66     my $string = shift || '' ;
   67     my %opts = @_ ;
   68 
   69     my $buffer ;
   70     ok my $def = new Compress::Raw::Zlib::Deflate AppendOutput => 1, %opts ;
   71     cmp_ok $def->deflate($string, $buffer), '==',  Z_OK;
   72     cmp_ok $def->flush($buffer), '==', Z_OK;
   73     #print "ReadHeaderInfoZlib\n"; hexDump(\$buffer);
   74     
   75     ok my $inf = new IO::Uncompress::Inflate \$buffer, Append => 1  ;
   76     my $uncomp ;
   77     #ok $inf->read($uncomp) ;
   78     my $actual = 0 ;
   79     my $status = 1 ;
   80     while (($status = $inf->read($uncomp)) > 0) {
   81         $actual += $status ;
   82     }
   83 
   84     is $actual, length($string) ;
   85     is $uncomp, $string;
   86     ok ! $inf->error() ;
   87     ok $inf->eof() ;
   88     ok my $hdr = $inf->getHeaderInfo();
   89     ok $inf->close ;
   90 
   91     return $hdr ;
   92 }
   93 
   94 sub printHeaderInfo
   95 {
   96     my $buffer = shift ;
   97     my $inf = new IO::Uncompress::Inflate \$buffer  ;
   98     my $hdr = $inf->getHeaderInfo();
   99 
  100     no warnings 'uninitialized' ;
  101     while (my ($k, $v) = each %$hdr) {
  102         print "  $k -> $v\n" ;
  103     }
  104 }
  105 
  106 
  107 # Check the Deflate Header Parameters
  108 #========================================
  109 
  110 #my $lex = new LexFile my $name ;
  111 
  112 {
  113     title "Check default header settings" ;
  114 
  115     my $string = <<EOM;
  116 some text
  117 EOM
  118 
  119     my $hdr = ReadHeaderInfo($string);
  120 
  121     is $hdr->{CM}, 8, "  CM is 8";
  122     is $hdr->{FDICT}, 0, "  FDICT is 0";
  123 
  124 }
  125 
  126 {
  127     title "Check user-defined header settings match zlib" ;
  128 
  129     my $string = <<EOM;
  130 some text
  131 EOM
  132 
  133     my @tests = (
  134         [ {-Level => 0}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  135         [ {-Level => 1}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  136         [ {-Level => 2}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
  137         [ {-Level => 3}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
  138         [ {-Level => 4}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
  139         [ {-Level => 5}, { FLEVEL => ZLIB_FLG_LEVEL_FAST   } ],
  140         [ {-Level => 6}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],
  141         [ {-Level => 7}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
  142         [ {-Level => 8}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
  143         [ {-Level => 9}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
  144 
  145         [ {-Level => Z_NO_COMPRESSION  }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  146         [ {-Level => Z_BEST_SPEED      }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  147         [ {-Level => Z_BEST_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_SLOWEST} ],
  148         [ {-Level => Z_DEFAULT_COMPRESSION}, { FLEVEL => ZLIB_FLG_LEVEL_DEFAULT} ],
  149 
  150         [ {-Strategy => Z_HUFFMAN_ONLY}, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  151         [ {-Strategy => Z_HUFFMAN_ONLY,
  152            -Level    => 3             }, { FLEVEL => ZLIB_FLG_LEVEL_FASTEST} ],
  153     );
  154 
  155     foreach my $test (@tests)
  156     {
  157         my $opts = $test->[0] ;
  158         my $expect = $test->[1] ;
  159 
  160         my @title ;
  161         while (my ($k, $v) = each %$opts)
  162         {
  163             push @title, "$k => $v";
  164         }
  165         title " Set @title";
  166 
  167         my $hdr = ReadHeaderInfo($string, %$opts);
  168 
  169         my $hdr1 = ReadHeaderInfoZlib($string, %$opts);
  170 
  171         is $hdr->{CM},     8, "  CM is 8";
  172         is $hdr->{CINFO},  7, "  CINFO is 7";
  173         is $hdr->{FDICT},  0, "  FDICT is 0";
  174 
  175         while (my ($k, $v) = each %$expect)
  176         {
  177             if (ZLIB_VERNUM >= 0x1220)
  178               { is $hdr->{$k}, $v, "  $k is $v" }
  179             else
  180               { ok 1, "  Skip test for $k" }
  181         }
  182 
  183         is $hdr->{CM},     $hdr1->{CM},     "  CM matches";
  184         is $hdr->{CINFO},  $hdr1->{CINFO},  "  CINFO matches";
  185         is $hdr->{FDICT},  $hdr1->{FDICT},  "  FDICT matches";
  186         is $hdr->{FLEVEL}, $hdr1->{FLEVEL}, "  FLEVEL matches";
  187         is $hdr->{FCHECK}, $hdr1->{FCHECK}, "  FCHECK matches";
  188     }
  189 
  190 
  191 }
  192 
  193 {
  194     title "No compressed data at all";
  195 
  196     my $hdr = ReadHeaderInfo("");
  197 
  198     is $hdr->{CM}, 8, "  CM is 8";
  199     is $hdr->{FDICT}, 0, "  FDICT is 0";
  200 
  201     ok defined $hdr->{ADLER32}, "  ADLER32 is defined" ;
  202     is $hdr->{ADLER32}, 1, "  ADLER32 is 1";
  203 }
  204 
  205 {
  206     # Header Corruption Tests
  207 
  208     my $string = <<EOM;
  209 some text
  210 EOM
  211 
  212     my $good ;
  213     ok my $x = new IO::Compress::Deflate \$good ;
  214     ok $x->write($string) ;
  215     ok $x->close ;
  216 
  217     {
  218         title "Header Corruption - FCHECK failure - 1st byte wrong";
  219         my $buffer = $good ;
  220         substr($buffer, 0, 1) = "\x00" ;
  221 
  222         ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
  223         like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
  224             "CRC mismatch";
  225     }
  226 
  227     {
  228         title "Header Corruption - FCHECK failure - 2nd byte wrong";
  229         my $buffer = $good ;
  230         substr($buffer, 1, 1) = "\x00" ;
  231 
  232         ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
  233         like $IO::Uncompress::Inflate::InflateError, '/Header Error: CRC mismatch/',
  234             "CRC mismatch";
  235     }
  236 
  237 
  238     sub mkZlibHdr
  239     {
  240         my $method = shift ;
  241         my $cinfo  = shift ;
  242         my $fdict  = shift ;
  243         my $level  = shift ;
  244 
  245         my $cmf  = ($method & 0x0F) ;
  246            $cmf |= (($cinfo  & 0x0F) << 4) ;
  247         my $flg  = (($level & 0x03) << 6) ;
  248            $flg |= (($fdict & 0x01) << 5) ;
  249         my $fcheck = 31 - ($cmf * 256 + $flg) % 31 ;
  250         $flg |= $fcheck ;
  251         #print "check $fcheck\n";
  252 
  253         return pack("CC", $cmf, $flg) ;
  254     }
  255 
  256     {
  257         title "Header Corruption - CM not 8";
  258         my $buffer = $good ;
  259         my $header = mkZlibHdr(3, 6, 0, 3);
  260 
  261         substr($buffer, 0, 2) = $header;
  262 
  263         my $un = new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
  264         ok ! new IO::Uncompress::Inflate \$buffer, -Transparent => 0  ;
  265         like $IO::Uncompress::Inflate::InflateError, '/Header Error: Not Deflate \(CM is 3\)/',
  266             "  Not Deflate";
  267     }
  268 
  269 }
  270 
  271 {
  272     # Trailer Corruption tests
  273 
  274     my $string = <<EOM;
  275 some text
  276 EOM
  277 
  278     $string = $string x 1000;
  279     my $good ;
  280     ok my $x = new IO::Compress::Deflate \$good ;
  281     ok $x->write($string) ;
  282     ok $x->close ;
  283 
  284     foreach my $trim (-4 .. -1)
  285     {
  286         my $got = $trim + 4 ;
  287         foreach my $s (0, 1)
  288         {
  289             title "Trailer Corruption - Trailer truncated to $got bytes, strict $s" ;
  290 		my $lex = new LexFile my $name ;
  291             my $buffer = $good ;
  292             my $expected_trailing = substr($good, -4, 4) ;
  293             substr($expected_trailing, $trim) = '';
  294 
  295             substr($buffer, $trim) = '';
  296             writeFile($name, $buffer) ;
  297 
  298             ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => $s;
  299             my $uncomp ;
  300             if ($s)
  301             {
  302                 my $status ;
  303                 1 while ($status = $gunz->read($uncomp)) > 0;
  304                 cmp_ok $status, "<", 0 ;
  305                 like $IO::Uncompress::Inflate::InflateError,"/Trailer Error: trailer truncated. Expected 4 bytes, got $got/",
  306                     "Trailer Error";
  307             }
  308             else
  309             {
  310                 1 while $gunz->read($uncomp) > 0;
  311                 is $uncomp, $string ;
  312             }
  313             ok $gunz->eof() ;
  314             ok $uncomp eq $string;
  315             ok $gunz->close ;
  316         }
  317 
  318     }
  319 
  320     {
  321         title "Trailer Corruption - CRC Wrong, strict" ;
  322         my $buffer = $good ;
  323         my $crc = unpack("N", substr($buffer, -4, 4));
  324         substr($buffer, -4, 4) = pack('N', $crc+1);
  325 		my $lex = new LexFile my $name ;
  326         writeFile($name, $buffer) ;
  327 
  328         ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => 1;
  329         my $uncomp ;
  330         my $status ;
  331         1 while ($status = $gunz->read($uncomp)) > 0;
  332         cmp_ok $status, "<", 0 ;
  333         like $IO::Uncompress::Inflate::InflateError,'/Trailer Error: CRC mismatch/',
  334             "Trailer Error: CRC mismatch";
  335         ok $gunz->eof() ;
  336         ok ! $gunz->trailingData() ;
  337         ok $uncomp eq $string;
  338         ok $gunz->close ;
  339     }
  340 
  341     {
  342         title "Trailer Corruption - CRC Wrong, no strict" ;
  343         my $buffer = $good ;
  344         my $crc = unpack("N", substr($buffer, -4, 4));
  345         substr($buffer, -4, 4) = pack('N', $crc+1);
  346 		my $lex = new LexFile my $name ;
  347         writeFile($name, $buffer) ;
  348 
  349         ok my $gunz = new IO::Uncompress::Inflate $name, Append => 1, Strict => 0;
  350         my $uncomp ;
  351         my $status ;
  352         1 while ($status = $gunz->read($uncomp)) > 0;
  353         cmp_ok $status, '>=', 0  ;
  354         ok $gunz->eof() ;
  355         ok ! $gunz->trailingData() ;
  356         ok $uncomp eq $string;
  357         ok $gunz->close ;
  358     }
  359 }
  360