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