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