ext/Compress/Zlib/t/03zlib-v1.t

   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 use Symbol;
  16
  17 BEGIN
  18 {
  19     # use Test::NoWarnings, if available
  20     my $extra = 0 ;
  21     $extra = 1
  22         if eval { require Test::NoWarnings ;  import Test::NoWarnings; 1 };
  23
  24     my $count = 0 ;
  25     if ($] < 5.005) {
  26         $count = 383 ;
  27     }
  28     else {
  29         $count = 394 ;
  30     }
  31
  32
  33     plan tests => $count + $extra ;
  34
  35     use_ok('Compress::Zlib', 2) ;
  36     use_ok('IO::Compress::Gzip::Constants') ;
  37
  38     use_ok('IO::Compress::Gzip', qw($GzipError)) ;
  39 }
  40
  41
  42 my $hello = <<EOM ;
  43 hello world
  44 this is a test
  45 EOM
  46
  47 my $len   = length $hello ;
  48
  49 # Check zlib_version and ZLIB_VERSION are the same.
  50 is Compress::Zlib::zlib_version, ZLIB_VERSION,
  51     "ZLIB_VERSION matches Compress::Zlib::zlib_version" ;
  52
  53 # generate a long random string
  54 my $contents = '' ;
  55 foreach (1 .. 5000)
  56   { $contents .= chr int rand 256 }
  57
  58 my $x ;
  59 my $fil;
  60
  61 # compress/uncompress tests
  62 # =========================
  63
  64 eval { compress([1]); };
  65 ok $@ =~ m#not a scalar reference#
  66     or print "# $@\n" ;;
  67
  68 eval { uncompress([1]); };
  69 ok $@ =~ m#not a scalar reference#
  70     or print "# $@\n" ;;
  71
  72 $hello = "hello mum" ;
  73 my $keep_hello = $hello ;
  74
  75 my $compr = compress($hello) ;
  76 ok $compr ne "" ;
  77
  78 my $keep_compr = $compr ;
  79
  80 my $uncompr = uncompress ($compr) ;
  81
  82 ok $hello eq $uncompr ;
  83
  84 ok $hello eq $keep_hello ;
  85 ok $compr eq $keep_compr ;
  86
  87 # compress a number
  88 $hello = 7890 ;
  89 $keep_hello = $hello ;
  90
  91 $compr = compress($hello) ;
  92 ok $compr ne "" ;
  93
  94 $keep_compr = $compr ;
  95
  96 $uncompr = uncompress ($compr) ;
  97
  98 ok $hello eq $uncompr ;
  99
 100 ok $hello eq $keep_hello ;
 101 ok $compr eq $keep_compr ;
 102
 103 # bigger compress
 104
 105 $compr = compress ($contents) ;
 106 ok $compr ne "" ;
 107
 108 $uncompr = uncompress ($compr) ;
 109
 110 ok $contents eq $uncompr ;
 111
 112 # buffer reference
 113
 114 $compr = compress(\$hello) ;
 115 ok $compr ne "" ;
 116
 117
 118 $uncompr = uncompress (\$compr) ;
 119 ok $hello eq $uncompr ;
 120
 121 # bad level
 122 $compr = compress($hello, 1000) ;
 123 ok ! defined $compr;
 124
 125 # change level
 126 $compr = compress($hello, Z_BEST_COMPRESSION) ;
 127 ok defined $compr;
 128 $uncompr = uncompress (\$compr) ;
 129 ok $hello eq $uncompr ;
 130
 131 # corrupt data
 132 $compr = compress(\$hello) ;
 133 ok $compr ne "" ;
 134
 135 substr($compr,0, 1) = "\xFF";
 136 ok !defined uncompress (\$compr) ;
 137
 138 # deflate/inflate - small buffer
 139 # ==============================
 140
 141 $hello = "I am a HAL 9000 computer" ;
 142 my @hello = split('', $hello) ;
 143 my ($err, $X, $status);
 144
 145 ok  (($x, $err) = deflateInit( {-Bufsize => 1} ) ) ;
 146 ok $x ;
 147 ok $err == Z_OK ;
 148
 149 my $Answer = '';
 150 foreach (@hello)
 151 {
 152     ($X, $status) = $x->deflate($_) ;
 153     last unless $status == Z_OK ;
 154
 155     $Answer .= $X ;
 156 }
 157
 158 ok $status == Z_OK ;
 159
 160 ok    ((($X, $status) = $x->flush())[1] == Z_OK ) ;
 161 $Answer .= $X ;
 162
 163
 164 my @Answer = split('', $Answer) ;
 165
 166 my $k;
 167 ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ;
 168 ok $k ;
 169 ok $err == Z_OK ;
 170
 171 my $GOT = '';
 172 my $Z;
 173 foreach (@Answer)
 174 {
 175     ($Z, $status) = $k->inflate($_) ;
 176     $GOT .= $Z ;
 177     last if $status == Z_STREAM_END or $status != Z_OK ;
 178
 179 }
 180
 181 ok $status == Z_STREAM_END ;
 182 ok $GOT eq $hello ;
 183
 184
 185 title 'deflate/inflate - small buffer with a number';
 186 # ==============================
 187
 188 $hello = 6529 ;
 189
 190 ok (($x, $err) = deflateInit( {-Bufsize => 1} ) ) ;
 191 ok $x ;
 192 ok $err == Z_OK ;
 193
 194 ok !defined $x->msg() ;
 195 ok $x->total_in() == 0 ;
 196 ok $x->total_out() == 0 ;
 197 $Answer = '';
 198 {
 199     ($X, $status) = $x->deflate($hello) ;
 200
 201     $Answer .= $X ;
 202 }
 203
 204 ok $status == Z_OK ;
 205
 206 ok   ((($X, $status) = $x->flush())[1] == Z_OK ) ;
 207 $Answer .= $X ;
 208
 209 ok !defined $x->msg() ;
 210 ok $x->total_in() == length $hello ;
 211 ok $x->total_out() == length $Answer ;
 212
 213
 214 @Answer = split('', $Answer) ;
 215
 216 ok (($k, $err) = inflateInit( {-Bufsize => 1}) ) ;
 217 ok $k ;
 218 ok $err == Z_OK ;
 219
 220 ok !defined $k->msg() ;
 221 ok $k->total_in() == 0 ;
 222 ok $k->total_out() == 0 ;
 223
 224 $GOT = '';
 225 foreach (@Answer)
 226 {
 227     ($Z, $status) = $k->inflate($_) ;
 228     $GOT .= $Z ;
 229     last if $status == Z_STREAM_END or $status != Z_OK ;
 230
 231 }
 232
 233 ok $status == Z_STREAM_END ;
 234 ok $GOT eq $hello ;
 235
 236 ok !defined $k->msg() ;
 237 is $k->total_in(), length $Answer ;
 238 ok $k->total_out() == length $hello ;
 239
 240
 241
 242 title 'deflate/inflate - larger buffer';
 243 # ==============================
 244
 245
 246 ok $x = deflateInit() ;
 247
 248 ok ((($X, $status) = $x->deflate($contents))[1] == Z_OK) ;
 249
 250 my $Y = $X ;
 251
 252
 253 ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ;
 254 $Y .= $X ;
 255
 256
 257
 258 ok $k = inflateInit() ;
 259
 260 ($Z, $status) = $k->inflate($Y) ;
 261
 262 ok $status == Z_STREAM_END ;
 263 ok $contents eq $Z ;
 264
 265 title 'deflate/inflate - preset dictionary';
 266 # ===================================
 267
 268 my $dictionary = "hello" ;
 269 ok $x = deflateInit({-Level => Z_BEST_COMPRESSION,
 270                          -Dictionary => $dictionary}) ;
 271
 272 my $dictID = $x->dict_adler() ;
 273
 274 ($X, $status) = $x->deflate($hello) ;
 275 ok $status == Z_OK ;
 276 ($Y, $status) = $x->flush() ;
 277 ok $status == Z_OK ;
 278 $X .= $Y ;
 279 $x = 0 ;
 280
 281 ok $k = inflateInit(-Dictionary => $dictionary) ;
 282
 283 ($Z, $status) = $k->inflate($X);
 284 ok $status == Z_STREAM_END ;
 285 ok $k->dict_adler() == $dictID;
 286 ok $hello eq $Z ;
 287
 288 #$Z='';
 289 #while (1) {
 290 #    ($Z, $status) = $k->inflate($X) ;
 291 #    last if $status == Z_STREAM_END or $status != Z_OK ;
 292 #print "status=[$status] hello=[$hello] Z=[$Z]\n";
 293 #}
 294 #ok $status == Z_STREAM_END ;
 295 #ok $hello eq $Z
 296 # or print "status=[$status] hello=[$hello] Z=[$Z]\n";
 297
 298
 299
 300
 301
 302
 303 title 'inflate - check remaining buffer after Z_STREAM_END';
 304 # ===================================================
 305
 306 {
 307     ok $x = deflateInit(-Level => Z_BEST_COMPRESSION ) ;
 308
 309     ($X, $status) = $x->deflate($hello) ;
 310     ok $status == Z_OK ;
 311     ($Y, $status) = $x->flush() ;
 312     ok $status == Z_OK ;
 313     $X .= $Y ;
 314     $x = 0 ;
 315
 316     ok $k = inflateInit()  ;
 317
 318     my $first = substr($X, 0, 2) ;
 319     my $last  = substr($X, 2) ;
 320     ($Z, $status) = $k->inflate($first);
 321     ok $status == Z_OK ;
 322     ok $first eq "" ;
 323
 324     $last .= "appendage" ;
 325     my $T;
 326     ($T, $status) = $k->inflate($last);
 327     ok $status == Z_STREAM_END ;
 328     ok $hello eq $Z . $T ;
 329     ok $last eq "appendage" ;
 330
 331 }
 332
 333 title 'memGzip & memGunzip';
 334 {
 335     my $name = "test.gz" ;
 336     my $buffer = <<EOM;
 337 some sample
 338 text
 339
 340 EOM
 341
 342     my $len = length $buffer ;
 343     my ($x, $uncomp) ;
 344
 345
 346     # create an in-memory gzip file
 347     my $dest = Compress::Zlib::memGzip($buffer) ;
 348     ok length $dest ;
 349
 350     # write it to disk
 351     ok open(FH, ">$name") ;
 352     binmode(FH);
 353     print FH $dest ;
 354     close FH ;
 355
 356     # uncompress with gzopen
 357     ok my $fil = gzopen($name, "rb") ;
 358
 359     is $fil->gzread($uncomp, 0), 0 ;
 360     ok (($x = $fil->gzread($uncomp)) == $len) ;
 361
 362     ok ! $fil->gzclose ;
 363
 364     ok $uncomp eq $buffer ;
 365
 366     1 while unlink $name ;
 367
 368     # now check that memGunzip can deal with it.
 369     my $ungzip = Compress::Zlib::memGunzip($dest) ;
 370     ok defined $ungzip ;
 371     ok $buffer eq $ungzip ;
 372
 373     # now do the same but use a reference
 374
 375     $dest = Compress::Zlib::memGzip(\$buffer) ;
 376     ok length $dest ;
 377
 378     # write it to disk
 379     ok open(FH, ">$name") ;
 380     binmode(FH);
 381     print FH $dest ;
 382     close FH ;
 383
 384     # uncompress with gzopen
 385     ok $fil = gzopen($name, "rb") ;
 386
 387     ok (($x = $fil->gzread($uncomp)) == $len) ;
 388
 389     ok ! $fil->gzclose ;
 390
 391     ok $uncomp eq $buffer ;
 392
 393     # now check that memGunzip can deal with it.
 394     my $keep = $dest;
 395     $ungzip = Compress::Zlib::memGunzip(\$dest) ;
 396     ok defined $ungzip ;
 397     ok $buffer eq $ungzip ;
 398
 399     # check memGunzip can cope with missing gzip trailer
 400     my $minimal = substr($keep, 0, -1) ;
 401     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 402     ok defined $ungzip ;
 403     ok $buffer eq $ungzip ;
 404
 405     $minimal = substr($keep, 0, -2) ;
 406     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 407     ok defined $ungzip ;
 408     ok $buffer eq $ungzip ;
 409
 410     $minimal = substr($keep, 0, -3) ;
 411     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 412     ok defined $ungzip ;
 413     ok $buffer eq $ungzip ;
 414
 415     $minimal = substr($keep, 0, -4) ;
 416     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 417     ok defined $ungzip ;
 418     ok $buffer eq $ungzip ;
 419
 420     $minimal = substr($keep, 0, -5) ;
 421     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 422     ok defined $ungzip ;
 423     ok $buffer eq $ungzip ;
 424
 425     $minimal = substr($keep, 0, -6) ;
 426     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 427     ok defined $ungzip ;
 428     ok $buffer eq $ungzip ;
 429
 430     $minimal = substr($keep, 0, -7) ;
 431     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 432     ok defined $ungzip ;
 433     ok $buffer eq $ungzip ;
 434
 435     $minimal = substr($keep, 0, -8) ;
 436     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 437     ok defined $ungzip ;
 438     ok $buffer eq $ungzip ;
 439
 440     $minimal = substr($keep, 0, -9) ;
 441     $ungzip = Compress::Zlib::memGunzip(\$minimal) ;
 442     ok ! defined $ungzip ;
 443
 444
 445     1 while unlink $name ;
 446
 447     # check corrupt header -- too short
 448     $dest = "x" ;
 449     my $result = Compress::Zlib::memGunzip($dest) ;
 450     ok !defined $result ;
 451
 452     # check corrupt header -- full of junk
 453     $dest = "x" x 200 ;
 454     $result = Compress::Zlib::memGunzip($dest) ;
 455     ok !defined $result ;
 456
 457     # corrupt header - 1st byte wrong
 458     my $bad = $keep ;
 459     substr($bad, 0, 1) = "\xFF" ;
 460     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 461     ok ! defined $ungzip ;
 462
 463     # corrupt header - 2st byte wrong
 464     $bad = $keep ;
 465     substr($bad, 1, 1) = "\xFF" ;
 466     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 467     ok ! defined $ungzip ;
 468
 469     # corrupt header - method not deflated
 470     $bad = $keep ;
 471     substr($bad, 2, 1) = "\xFF" ;
 472     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 473     ok ! defined $ungzip ;
 474
 475     # corrupt header - reserverd bits used
 476     $bad = $keep ;
 477     substr($bad, 3, 1) = "\xFF" ;
 478     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 479     ok ! defined $ungzip ;
 480
 481     # corrupt trailer - length wrong
 482     $bad = $keep ;
 483     substr($bad, -8, 4) = "\xFF" x 4 ;
 484     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 485     ok ! defined $ungzip ;
 486
 487     # corrupt trailer - CRC wrong
 488     $bad = $keep ;
 489     substr($bad, -4, 4) = "\xFF" x 4 ;
 490     $ungzip = Compress::Zlib::memGunzip(\$bad) ;
 491     ok ! defined $ungzip ;
 492 }
 493
 494 {
 495     title "Check all bytes can be handled";
 496
 497     my $lex = new LexFile my $name ;
 498     my $data = join '', map { chr } 0x00 .. 0xFF;
 499     $data .= "\r\nabd\r\n";
 500
 501     my $fil;
 502     ok $fil = gzopen($name, "wb") ;
 503     is $fil->gzwrite($data), length $data ;
 504     ok ! $fil->gzclose();
 505
 506     my $input;
 507     ok $fil = gzopen($name, "rb") ;
 508     is $fil->gzread($input), length $data ;
 509     ok ! $fil->gzclose();
 510     ok $input eq $data;
 511
 512     title "Check all bytes can be handled - transparent mode";
 513     writeFile($name, $data);
 514     ok $fil = gzopen($name, "rb") ;
 515     is $fil->gzread($input), length $data ;
 516     ok ! $fil->gzclose();
 517     ok $input eq $data;
 518
 519 }
 520
 521 title 'memGunzip with a gzopen created file';
 522 {
 523     my $name = "test.gz" ;
 524     my $buffer = <<EOM;
 525 some sample
 526 text
 527
 528 EOM
 529
 530     ok $fil = gzopen($name, "wb") ;
 531
 532     ok $fil->gzwrite($buffer) == length $buffer ;
 533
 534     ok ! $fil->gzclose ;
 535
 536     my $compr = readFile($name);
 537     ok length $compr ;
 538     my $unc = Compress::Zlib::memGunzip($compr) ;
 539     ok defined $unc ;
 540     ok $buffer eq $unc ;
 541     1 while unlink $name ;
 542 }
 543
 544 {
 545
 546     # Check - MAX_WBITS
 547     # =================
 548
 549     $hello = "Test test test test test";
 550     @hello = split('', $hello) ;
 551
 552     ok (($x, $err) = deflateInit( -Bufsize => 1, -WindowBits => -MAX_WBITS() ) ) ;
 553     ok $x ;
 554     ok $err == Z_OK ;
 555
 556     $Answer = '';
 557     foreach (@hello)
 558     {
 559         ($X, $status) = $x->deflate($_) ;
 560         last unless $status == Z_OK ;
 561
 562         $Answer .= $X ;
 563     }
 564
 565     ok $status == Z_OK ;
 566
 567     ok   ((($X, $status) = $x->flush())[1] == Z_OK ) ;
 568     $Answer .= $X ;
 569
 570
 571     @Answer = split('', $Answer) ;
 572     # Undocumented corner -- extra byte needed to get inflate to return
 573     # Z_STREAM_END when done.
 574     push @Answer, " " ;
 575
 576     ok (($k, $err) = inflateInit(-Bufsize => 1, -WindowBits => -MAX_WBITS()) ) ;
 577     ok $k ;
 578     ok $err == Z_OK ;
 579
 580     $GOT = '';
 581     foreach (@Answer)
 582     {
 583         ($Z, $status) = $k->inflate($_) ;
 584         $GOT .= $Z ;
 585         last if $status == Z_STREAM_END or $status != Z_OK ;
 586
 587     }
 588
 589     ok $status == Z_STREAM_END ;
 590     ok $GOT eq $hello ;
 591
 592 }
 593
 594 {
 595     # inflateSync
 596
 597     # create a deflate stream with flush points
 598
 599     my $hello = "I am a HAL 9000 computer" x 2001 ;
 600     my $goodbye = "Will I dream?" x 2010;
 601     my ($err, $answer, $X, $status, $Answer);
 602
 603     ok (($x, $err) = deflateInit() ) ;
 604     ok $x ;
 605     ok $err == Z_OK ;
 606
 607     ($Answer, $status) = $x->deflate($hello) ;
 608     ok $status == Z_OK ;
 609
 610     # create a flush point
 611     ok ((($X, $status) = $x->flush(Z_FULL_FLUSH))[1] == Z_OK ) ;
 612     $Answer .= $X ;
 613
 614     ($X, $status) = $x->deflate($goodbye) ;
 615     ok $status == Z_OK ;
 616     $Answer .= $X ;
 617
 618     ok ((($X, $status) = $x->flush())[1] == Z_OK ) ;
 619     $Answer .= $X ;
 620
 621     my ($first, @Answer) = split('', $Answer) ;
 622
 623     my $k;
 624     ok (($k, $err) = inflateInit()) ;
 625     ok $k ;
 626     ok $err == Z_OK ;
 627
 628     ($Z, $status) = $k->inflate($first) ;
 629     ok $status == Z_OK ;
 630
 631     # skip to the first flush point.
 632     while (@Answer)
 633     {
 634         my $byte = shift @Answer;
 635         $status = $k->inflateSync($byte) ;
 636         last unless $status == Z_DATA_ERROR;
 637
 638     }
 639
 640     ok $status == Z_OK;
 641
 642     my $GOT = '';
 643     my $Z = '';
 644     foreach (@Answer)
 645     {
 646         my $Z = '';
 647         ($Z, $status) = $k->inflate($_) ;
 648         $GOT .= $Z if defined $Z ;
 649         # print "x $status\n";
 650         last if $status == Z_STREAM_END or $status != Z_OK ;
 651
 652     }
 653
 654     # zlib 1.0.9 returns Z_STREAM_END here, all others return Z_DATA_ERROR
 655     ok $status == Z_DATA_ERROR || $status == Z_STREAM_END ;
 656     ok $GOT eq $goodbye ;
 657
 658
 659     # Check inflateSync leaves good data in buffer
 660     $Answer =~ /^(.)(.*)$/ ;
 661     my ($initial, $rest) = ($1, $2);
 662
 663
 664     ok (($k, $err) = inflateInit()) ;
 665     ok $k ;
 666     ok $err == Z_OK ;
 667
 668     ($Z, $status) = $k->inflate($initial) ;
 669     ok $status == Z_OK ;
 670
 671     $status = $k->inflateSync($rest) ;
 672     ok $status == Z_OK;
 673
 674     ($GOT, $status) = $k->inflate($rest) ;
 675
 676     ok $status == Z_DATA_ERROR ;
 677     ok $Z . $GOT eq $goodbye ;
 678 }
 679
 680 {
 681     # deflateParams
 682
 683     my $hello = "I am a HAL 9000 computer" x 2001 ;
 684     my $goodbye = "Will I dream?" x 2010;
 685     my ($input, $err, $answer, $X, $status, $Answer);
 686
 687     ok (($x, $err) = deflateInit(-Level    => Z_BEST_COMPRESSION,
 688                                      -Strategy => Z_DEFAULT_STRATEGY) ) ;
 689     ok $x ;
 690     ok $err == Z_OK ;
 691
 692     ok $x->get_Level()    == Z_BEST_COMPRESSION;
 693     ok $x->get_Strategy() == Z_DEFAULT_STRATEGY;
 694
 695     ($Answer, $status) = $x->deflate($hello) ;
 696     ok $status == Z_OK ;
 697     $input .= $hello;
 698
 699     # error cases
 700     eval { $x->deflateParams() };
 701     #like $@, mkErr("^Compress::Raw::Zlib::deflateParams needs Level and/or Strategy");
 702     like $@, "/^Compress::Raw::Zlib::deflateParams needs Level and/or Strategy/";
 703
 704     eval { $x->deflateParams(-Joe => 3) };
 705     like $@, "/^Compress::Raw::Zlib::deflateStream::deflateParams: unknown key value/";
 706     #like $@, mkErr("^Compress::Raw::Zlib::deflateStream::deflateParams: unknown key value(s) Joe");
 707     #ok $@ =~ /^Compress::Zlib::deflateStream::deflateParams: unknown key value\(s\) Joe at/
 708     #    or print "# $@\n" ;
 709
 710     ok $x->get_Level()    == Z_BEST_COMPRESSION;
 711     ok $x->get_Strategy() == Z_DEFAULT_STRATEGY;
 712
 713     # change both Level & Strategy
 714     $status = $x->deflateParams(-Level => Z_BEST_SPEED, -Strategy => Z_HUFFMAN_ONLY) ;
 715     ok $status == Z_OK ;
 716
 717     ok $x->get_Level()    == Z_BEST_SPEED;
 718     ok $x->get_Strategy() == Z_HUFFMAN_ONLY;
 719
 720     ($X, $status) = $x->deflate($goodbye) ;
 721     ok $status == Z_OK ;
 722     $Answer .= $X ;
 723     $input .= $goodbye;
 724
 725     # change only Level
 726     $status = $x->deflateParams(-Level => Z_NO_COMPRESSION) ;
 727     ok $status == Z_OK ;
 728
 729     ok $x->get_Level()    == Z_NO_COMPRESSION;
 730     ok $x->get_Strategy() == Z_HUFFMAN_ONLY;
 731
 732     ($X, $status) = $x->deflate($goodbye) ;
 733     ok $status == Z_OK ;
 734     $Answer .= $X ;
 735     $input .= $goodbye;
 736
 737     # change only Strategy
 738     $status = $x->deflateParams(-Strategy => Z_FILTERED) ;
 739     ok $status == Z_OK ;
 740
 741     ok $x->get_Level()    == Z_NO_COMPRESSION;
 742     ok $x->get_Strategy() == Z_FILTERED;
 743
 744     ($X, $status) = $x->deflate($goodbye) ;
 745     ok $status == Z_OK ;
 746     $Answer .= $X ;
 747     $input .= $goodbye;
 748
 749     ok ((($X, $status) = $x->flush())[1] == Z_OK ) ;
 750     $Answer .= $X ;
 751
 752     my ($first, @Answer) = split('', $Answer) ;
 753
 754     my $k;
 755     ok (($k, $err) = inflateInit()) ;
 756     ok $k ;
 757     ok $err == Z_OK ;
 758
 759     ($Z, $status) = $k->inflate($Answer) ;
 760
 761     ok $status == Z_STREAM_END
 762         or print "# status $status\n";
 763     ok $Z  eq $input ;
 764 }
 765
 766 {
 767     # error cases
 768
 769     eval { deflateInit(-Level) };
 770     like $@, '/^Compress::Zlib::deflateInit: Expected even number of parameters, got 1/';
 771
 772     eval { inflateInit(-Level) };
 773     like $@, '/^Compress::Zlib::inflateInit: Expected even number of parameters, got 1/';
 774
 775     eval { deflateInit(-Joe => 1) };
 776     ok $@ =~ /^Compress::Zlib::deflateInit: unknown key value\(s\) Joe at/;
 777
 778     eval { inflateInit(-Joe => 1) };
 779     ok $@ =~ /^Compress::Zlib::inflateInit: unknown key value\(s\) Joe at/;
 780
 781     eval { deflateInit(-Bufsize => 0) };
 782     ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/;
 783
 784     eval { inflateInit(-Bufsize => 0) };
 785     ok $@ =~ /^.*?: Bufsize must be >= 1, you specified 0 at/;
 786
 787     eval { deflateInit(-Bufsize => -1) };
 788     #ok $@ =~ /^.*?: Bufsize must be >= 1, you specified -1 at/;
 789     ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/;
 790
 791     eval { inflateInit(-Bufsize => -1) };
 792     ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got '-1'/;
 793
 794     eval { deflateInit(-Bufsize => "xxx") };
 795     ok $@ =~ /^Compress::Zlib::deflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/;
 796
 797     eval { inflateInit(-Bufsize => "xxx") };
 798     ok $@ =~ /^Compress::Zlib::inflateInit: Parameter 'Bufsize' must be an unsigned int, got 'xxx'/;
 799
 800     eval { gzopen([], 0) ; }  ;
 801     ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/
 802         or print "# $@\n" ;
 803
 804 #    my $x = Symbol::gensym() ;
 805 #    eval { gzopen($x, 0) ; }  ;
 806 #    ok $@ =~ /^gzopen: file parameter is not a filehandle or filename at/
 807 #       or print "# $@\n" ;
 808
 809 }
 810
 811 if ($] >= 5.005)
 812 {
 813     # test inflate with a substr
 814
 815     ok my $x = deflateInit() ;
 816
 817     ok ((my ($X, $status) = $x->deflate($contents))[1] == Z_OK) ;
 818
 819     my $Y = $X ;
 820
 821
 822
 823     ok ((($X, $status) = $x->flush() )[1] == Z_OK ) ;
 824     $Y .= $X ;
 825
 826     my $append = "Appended" ;
 827     $Y .= $append ;
 828
 829     ok $k = inflateInit() ;
 830
 831     #($Z, $status) = $k->inflate(substr($Y, 0, -1)) ;
 832     ($Z, $status) = $k->inflate(substr($Y, 0)) ;
 833
 834     ok $status == Z_STREAM_END ;
 835     ok $contents eq $Z ;
 836     is $Y, $append;
 837
 838 }
 839
 840 if ($] >= 5.005)
 841 {
 842     # deflate/inflate in scalar context
 843
 844     ok my $x = deflateInit() ;
 845
 846     my $X = $x->deflate($contents);
 847
 848     my $Y = $X ;
 849
 850
 851
 852     $X = $x->flush();
 853     $Y .= $X ;
 854
 855     my $append = "Appended" ;
 856     $Y .= $append ;
 857
 858     ok $k = inflateInit() ;
 859
 860     $Z = $k->inflate(substr($Y, 0, -1)) ;
 861     #$Z = $k->inflate(substr($Y, 0)) ;
 862
 863     ok $contents eq $Z ;
 864     is $Y, $append;
 865
 866 }
 867
 868 {
 869     title 'CRC32' ;
 870
 871     # CRC32 of this data should have the high bit set
 872     # value in ascii is ZgRNtjgSUW
 873     my $data = "\x5a\x67\x52\x4e\x74\x6a\x67\x53\x55\x57";
 874     my $expected_crc = 0xCF707A2B ; # 3480255019
 875
 876     my $crc = crc32($data) ;
 877     is $crc, $expected_crc;
 878 }
 879
 880 {
 881     title 'Adler32' ;
 882
 883     # adler of this data should have the high bit set
 884     # value in ascii is lpscOVsAJiUfNComkOfWYBcPhHZ[bT
 885     my $data = "\x6c\x70\x73\x63\x4f\x56\x73\x41\x4a\x69\x55\x66" .
 886                "\x4e\x43\x6f\x6d\x6b\x4f\x66\x57\x59\x42\x63\x50" .
 887                "\x68\x48\x5a\x5b\x62\x54";
 888     my $expected_crc = 0xAAD60AC7 ; # 2866154183
 889     my $crc = adler32($data) ;
 890     is $crc, $expected_crc;
 891 }
 892
 893 {
 894     # memGunzip - input > 4K
 895
 896     my $contents = '' ;
 897     foreach (1 .. 20000)
 898       { $contents .= chr int rand 256 }
 899
 900     ok my $compressed = Compress::Zlib::memGzip(\$contents) ;
 901
 902     ok length $compressed > 4096 ;
 903     ok my $out = Compress::Zlib::memGunzip(\$compressed) ;
 904
 905     ok $contents eq $out ;
 906     is length $out, length $contents ;
 907
 908
 909 }
 910
 911
 912 {
 913     # memGunzip Header Corruption Tests
 914
 915     my $string = <<EOM;
 916 some text
 917 EOM
 918
 919     my $good ;
 920     ok my $x = new IO::Compress::Gzip \$good, Append => 1, -HeaderCRC => 1 ;
 921     ok $x->write($string) ;
 922     ok  $x->close ;
 923
 924     {
 925         title "Header Corruption - Fingerprint wrong 1st byte" ;
 926         my $buffer = $good ;
 927         substr($buffer, 0, 1) = 'x' ;
 928
 929         ok ! Compress::Zlib::memGunzip(\$buffer) ;
 930     }
 931
 932     {
 933         title "Header Corruption - Fingerprint wrong 2nd byte" ;
 934         my $buffer = $good ;
 935         substr($buffer, 1, 1) = "\xFF" ;
 936
 937         ok ! Compress::Zlib::memGunzip(\$buffer) ;
 938     }
 939
 940     {
 941         title "Header Corruption - CM not 8";
 942         my $buffer = $good ;
 943         substr($buffer, 2, 1) = 'x' ;
 944
 945         ok ! Compress::Zlib::memGunzip(\$buffer) ;
 946     }
 947
 948     {
 949         title "Header Corruption - Use of Reserved Flags";
 950         my $buffer = $good ;
 951         substr($buffer, 3, 1) = "\xff";
 952
 953         ok ! Compress::Zlib::memGunzip(\$buffer) ;
 954     }
 955
 956 }
 957
 958 for my $index ( GZIP_MIN_HEADER_SIZE + 1 ..  GZIP_MIN_HEADER_SIZE + GZIP_FEXTRA_HEADER_SIZE + 1)
 959 {
 960     title "Header Corruption - Truncated in Extra";
 961     my $string = <<EOM;
 962 some text
 963 EOM
 964
 965     my $truncated ;
 966     ok  my $x = new IO::Compress::Gzip \$truncated, Append => 1, -HeaderCRC => 1, Strict => 0,
 967                                 -ExtraField => "hello" x 10  ;
 968     ok  $x->write($string) ;
 969     ok  $x->close ;
 970
 971     substr($truncated, $index) = '' ;
 972
 973     ok ! Compress::Zlib::memGunzip(\$truncated) ;
 974
 975
 976 }
 977
 978 my $Name = "fred" ;
 979 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + length($Name) -1)
 980 {
 981     title "Header Corruption - Truncated in Name";
 982     my $string = <<EOM;
 983 some text
 984 EOM
 985
 986     my $truncated ;
 987     ok  my $x = new IO::Compress::Gzip \$truncated, Append => 1, -Name => $Name;
 988     ok  $x->write($string) ;
 989     ok  $x->close ;
 990
 991     substr($truncated, $index) = '' ;
 992
 993     ok ! Compress::Zlib::memGunzip(\$truncated) ;
 994 }
 995
 996 my $Comment = "comment" ;
 997 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + length($Comment) -1)
 998 {
 999     title "Header Corruption - Truncated in Comment";
1000     my $string = <<EOM;
1001 some text
1002 EOM
1003
1004     my $truncated ;
1005     ok  my $x = new IO::Compress::Gzip \$truncated, -Comment => $Comment;
1006     ok  $x->write($string) ;
1007     ok  $x->close ;
1008
1009     substr($truncated, $index) = '' ;
1010     ok ! Compress::Zlib::memGunzip(\$truncated) ;
1011 }
1012
1013 for my $index ( GZIP_MIN_HEADER_SIZE ..  GZIP_MIN_HEADER_SIZE + GZIP_FHCRC_SIZE -1)
1014 {
1015     title "Header Corruption - Truncated in CRC";
1016     my $string = <<EOM;
1017 some text
1018 EOM
1019
1020     my $truncated ;
1021     ok  my $x = new IO::Compress::Gzip \$truncated, -HeaderCRC => 1;
1022     ok  $x->write($string) ;
1023     ok  $x->close ;
1024
1025     substr($truncated, $index) = '' ;
1026
1027     ok ! Compress::Zlib::memGunzip(\$truncated) ;
1028 }
1029
1030 {
1031     title "memGunzip can cope with a gzip header with all possible fields";
1032     my $string = <<EOM;
1033 some text
1034 EOM
1035
1036     my $buffer ;
1037     ok  my $x = new IO::Compress::Gzip \$buffer,
1038                              -Append     => 1,
1039                              -Strict     => 0,
1040                              -HeaderCRC  => 1,
1041                              -Name       => "Fred",
1042                              -ExtraField => "Extra",
1043                              -Comment    => 'Comment';
1044     ok  $x->write($string) ;
1045     ok  $x->close ;
1046
1047     ok defined $buffer ;
1048
1049     ok my $got = Compress::Zlib::memGunzip($buffer)
1050         or diag "gzerrno is $gzerrno" ;
1051     is $got, $string ;
1052 }
1053
1054
1055 {
1056     # Trailer Corruption tests
1057
1058     my $string = <<EOM;
1059 some text
1060 EOM
1061
1062     my $good ;
1063     ok  my $x = new IO::Compress::Gzip \$good, Append => 1 ;
1064     ok  $x->write($string) ;
1065     ok  $x->close ;
1066
1067     foreach my $trim (-8 .. -1)
1068     {
1069         my $got = $trim + 8 ;
1070         title "Trailer Corruption - Trailer truncated to $got bytes" ;
1071         my $buffer = $good ;
1072
1073         substr($buffer, $trim) = '';
1074
1075         ok my $u = Compress::Zlib::memGunzip(\$buffer) ;
1076         ok $u eq $string;
1077
1078     }
1079
1080     {
1081         title "Trailer Corruption - Length Wrong, CRC Correct" ;
1082         my $buffer = $good ;
1083         substr($buffer, -4, 4) = pack('V', 1234);
1084
1085         ok ! Compress::Zlib::memGunzip(\$buffer) ;
1086     }
1087
1088     {
1089         title "Trailer Corruption - Length Wrong, CRC Wrong" ;
1090         my $buffer = $good ;
1091         substr($buffer, -4, 4) = pack('V', 1234);
1092         substr($buffer, -8, 4) = pack('V', 1234);
1093
1094         ok ! Compress::Zlib::memGunzip(\$buffer) ;
1095
1096     }
1097 }
1098
1099
1100 sub slurp
1101 {
1102     my $name = shift ;
1103
1104     my $input;
1105     my $fil = gzopen($name, "rb") ;
1106     ok $fil , "opened $name";
1107     cmp_ok $fil->gzread($input, 50000), ">", 0, "read more than zero bytes";
1108     ok ! $fil->gzclose(), "closed ok";
1109
1110     return $input;
1111 }
1112
1113 sub trickle
1114 {
1115     my $name = shift ;
1116
1117     my $got;
1118     my $input;
1119     $fil = gzopen($name, "rb") ;
1120     ok $fil, "opened ok";
1121     while ($fil->gzread($input, 50000) > 0)
1122     {
1123         $got .= $input;
1124         $input = '';
1125     }
1126     ok ! $fil->gzclose(), "closed ok";
1127
1128     return $got;
1129
1130     return $input;
1131 }
1132
1133 {
1134
1135     title "Append & MultiStream Tests";
1136     # rt.24041
1137
1138     my $lex = new LexFile my $name ;
1139     my $data1 = "the is the first";
1140     my $data2 = "and this is the second";
1141     my $trailing = "some trailing data";
1142
1143     my $fil;
1144
1145     title "One file";
1146     $fil = gzopen($name, "wb") ;
1147     ok $fil, "opened first file";
1148     is $fil->gzwrite($data1), length $data1, "write data1" ;
1149     ok ! $fil->gzclose(), "Closed";
1150
1151     is slurp($name), $data1, "got expected data from slurp";
1152     is trickle($name), $data1, "got expected data from trickle";
1153
1154     title "Two files";
1155     $fil = gzopen($name, "ab") ;
1156     ok $fil, "opened second file";
1157     is $fil->gzwrite($data2), length $data2, "write data2" ;
1158     ok ! $fil->gzclose(), "Closed";
1159
1160     is slurp($name), $data1 . $data2, "got expected data from slurp";
1161     is trickle($name), $data1 . $data2, "got expected data from trickle";
1162
1163     title "Trailing Data";
1164     open F, ">>$name";
1165     print F $trailing;
1166     close F;
1167
1168     is slurp($name), $data1 . $data2 . $trailing, "got expected data from slurp" ;
1169     is trickle($name), $data1 . $data2 . $trailing, "got expected data from trickle" ;
1170 }