projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Move IO::Compress from ext/ to cpan/
[p5sagit/p5-mst-13.2.git] / cpan / IO-Compress / t / compress / generic.pl
CommitLineData
1a6a8453 1
2use strict;
3use warnings;
4use bytes;
5
6use Test::More ;
25f0751f 7use CompTestUtils;
1a6a8453 8
9use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
10
11our ($UncompressClass);
12BEGIN
13{
14 # use Test::NoWarnings, if available
15 my $extra = 0 ;
16
17 my $st = eval { require Test::NoWarnings ; import Test::NoWarnings; 1; };
18 $extra = 1
19 if $st ;
1a6a8453 20
7efcbeef 21 plan(tests => 666 + $extra) ;
1a6a8453 22}
23
1a6a8453 24sub myGZreadFile
25{
26 my $filename = shift ;
27 my $init = shift ;
28
29
30 my $fil = new $UncompressClass $filename,
31 -Strict => 0,
32 -Append => 1
33 ;
34
35 my $data = '';
36 $data = $init if defined $init ;
37 1 while $fil->read($data) > 0;
38
39 $fil->close ;
40 return $data ;
41}
42
43sub run
44{
1a6a8453 45 my $CompressClass = identify();
46 $UncompressClass = getInverse($CompressClass);
47 my $Error = getErrorRef($CompressClass);
48 my $UnError = getErrorRef($UncompressClass);
49
d54256af 50 if(1)
1a6a8453 51 {
52
53 title "Testing $CompressClass Errors";
54
55 # Buffer not writable
56 eval qq[\$a = new $CompressClass(\\1) ;] ;
57 like $@, mkEvalErr("^$CompressClass: output buffer is read-only") ;
58
59 my($out, $gz);
1a6a8453 60
61 my $x ;
62 $gz = new $CompressClass(\$x);
63
64 foreach my $name (qw(read readline getc))
65 {
66 eval " \$gz->$name() " ;
67 like $@, mkEvalErr("^$name Not Available: File opened only for output");
68 }
69
70 eval ' $gz->write({})' ;
71 like $@, mkEvalErr("^${CompressClass}::write: not a scalar reference");
1a6a8453 72
73 eval ' $gz->syswrite("abc", 1, 5)' ;
74 like $@, mkEvalErr("^${CompressClass}::write: offset outside string");
75
76 eval ' $gz->syswrite("abc", 1, -4)' ;
d54256af 77 like $@, mkEvalErr("^${CompressClass}::write: offset outside string"), "write outside string";
1a6a8453 78 }
79
80
81 {
82 title "Testing $UncompressClass Errors";
83
84 my $out = "" ;
1a6a8453 85
86 my $lex = new LexFile my $name ;
87
88 ok ! -e $name, " $name does not exist";
89
776304fb 90 $a = new $UncompressClass "$name" ;
91 is $a, undef;
1a6a8453 92
93 my $gc ;
94 my $guz = new $CompressClass(\$gc);
95 $guz->write("abc") ;
96 $guz->close();
97
98 my $x ;
99 my $gz = new $UncompressClass(\$gc);
100
101 foreach my $name (qw(print printf write))
102 {
103 eval " \$gz->$name() " ;
104 like $@, mkEvalErr("^$name Not Available: File opened only for intput");
105 }
106
107 }
108
e11a3f9e 109
1a6a8453 110 {
111 title "Testing $CompressClass and $UncompressClass";
112
113 {
114 my ($a, $x, @x) = ("","","") ;
115
116 # Buffer not a scalar reference
117 eval qq[\$a = new $CompressClass \\\@x ;] ;
118 like $@, mkEvalErr("^$CompressClass: output parameter not a filename, filehandle or scalar ref");
119
120 # Buffer not a scalar reference
121 eval qq[\$a = new $UncompressClass \\\@x ;] ;
122 like $@, mkEvalErr("^$UncompressClass: input parameter not a filename, filehandle, array ref or scalar ref");
123 }
124
125 foreach my $Type ( $CompressClass, $UncompressClass)
126 {
127 # Check error handling with IO::Compress::Deflate and IO::Uncompress::Inflate
128
129 my ($a, $x, @x) = ("","","") ;
130
131 # Odd number of parameters
132 eval qq[\$a = new $Type "abc", -Output ] ;
133 like $@, mkEvalErr("^$Type: Expected even number of parameters, got 1");
134
135 # Unknown parameter
136 eval qq[\$a = new $Type "anc", -Fred => 123 ;] ;
137 like $@, mkEvalErr("^$Type: unknown key value\\(s\\) Fred");
138
139 # no in or out param
140 eval qq[\$a = new $Type ;] ;
141 like $@, mkEvalErr("^$Type: Missing (Input|Output) parameter");
142
143 }
144
145
146 {
147 # write a very simple compressed file
148 # and read back
149 #========================================
150
151
152 my $lex = new LexFile my $name ;
153
154 my $hello = <<EOM ;
155hello world
156this is a test
157EOM
158
159 {
160 my $x ;
161 ok $x = new $CompressClass $name ;
25f0751f 162 is $x->autoflush(1), 0, "autoflush";
163 is $x->autoflush(1), 1, "autoflush";
164 ok $x->opened(), "opened";
1a6a8453 165
166 ok $x->write($hello), "write" ;
167 ok $x->flush(), "flush";
168 ok $x->close, "close" ;
25f0751f 169 ok ! $x->opened(), "! opened";
1a6a8453 170 }
171
172 {
173 my $uncomp;
174 ok my $x = new $UncompressClass $name, -Append => 1 ;
25f0751f 175 ok $x->opened(), "opened";
1a6a8453 176
177 my $len ;
178 1 while ($len = $x->read($uncomp)) > 0 ;
179
180 is $len, 0, "read returned 0"
181 or diag $$UnError ;
182
183 ok $x->close ;
184 is $uncomp, $hello ;
25f0751f 185 ok !$x->opened(), "! opened";
1a6a8453 186 }
187 }
188
189 {
190 # write a very simple compressed file
191 # and read back
192 #========================================
193
194
195 my $lex = new LexFile my $name ;
196
197 my $hello = <<EOM ;
198hello world
199this is a test
200EOM
201
202 {
203 my $x ;
204 ok $x = new $CompressClass $name ;
205
206 is $x->write(''), 0, "Write empty string is ok";
207 is $x->write(undef), 0, "Write undef is ok";
208 ok $x->write($hello), "Write ok" ;
209 ok $x->close, "Close ok" ;
210 }
211
212 {
213 my $uncomp;
214 my $x = new $UncompressClass $name ;
215 ok $x, "creates $UncompressClass $name" ;
216
217 my $data = '';
218 $data .= $uncomp while $x->read($uncomp) > 0 ;
219
220 ok $x->close, "close ok" ;
221 is $data, $hello, "expected output" ;
222 }
223 }
224
225
226 {
227 # write a very simple file with using an IO filehandle
228 # and read back
229 #========================================
230
231
232 my $lex = new LexFile my $name ;
233
234 my $hello = <<EOM ;
235hello world
236this is a test
237EOM
238
239 {
240 my $fh = new IO::File ">$name" ;
241 ok $fh, "opened file $name ok";
242 my $x = new $CompressClass $fh ;
243 ok $x, " created $CompressClass $fh" ;
244
245 is $x->fileno(), fileno($fh), "fileno match" ;
246 is $x->write(''), 0, "Write empty string is ok";
247 is $x->write(undef), 0, "Write undef is ok";
248 ok $x->write($hello), "write ok" ;
249 ok $x->flush(), "flush";
250 ok $x->close,"close" ;
251 $fh->close() ;
252 }
253
254 my $uncomp;
255 {
256 my $x ;
257 ok my $fh1 = new IO::File "<$name" ;
258 ok $x = new $UncompressClass $fh1, -Append => 1 ;
259 ok $x->fileno() == fileno $fh1 ;
260
261 1 while $x->read($uncomp) > 0 ;
262
263 ok $x->close ;
264 }
265
266 ok $hello eq $uncomp ;
267 }
268
269 {
270 # write a very simple file with using a glob filehandle
271 # and read back
272 #========================================
273
274
275 my $lex = new LexFile my $name ;
25f0751f 276 #my $name = "/tmp/fred";
1a6a8453 277
278 my $hello = <<EOM ;
279hello world
280this is a test
281EOM
282
283 {
284 title "$CompressClass: Input from typeglob filehandle";
285 ok open FH, ">$name" ;
286
287 my $x = new $CompressClass *FH ;
288 ok $x, " create $CompressClass" ;
289
290 is $x->fileno(), fileno(*FH), " fileno" ;
291 is $x->write(''), 0, " Write empty string is ok";
292 is $x->write(undef), 0, " Write undef is ok";
293 ok $x->write($hello), " Write ok" ;
294 ok $x->flush(), " Flush";
295 ok $x->close, " Close" ;
296 close FH;
297 }
298
299
300 my $uncomp;
301 {
302 title "$UncompressClass: Input from typeglob filehandle, append output";
303 my $x ;
304 ok open FH, "<$name" ;
305 ok $x = new $UncompressClass *FH, -Append => 1, Transparent => 0
306 or diag $$UnError ;
307 is $x->fileno(), fileno FH, " fileno ok" ;
308
309 1 while $x->read($uncomp) > 0 ;
310
311 ok $x->close, " close" ;
312 }
1a6a8453 313
314 is $uncomp, $hello, " expected output" ;
315 }
316
317 {
318 my $lex = new LexFile my $name ;
25f0751f 319 #my $name = "/tmp/fred";
1a6a8453 320
321 my $hello = <<EOM ;
322hello world
323this is a test
324EOM
325
326 {
327 title "Outout to stdout via '-'" ;
328
329 open(SAVEOUT, ">&STDOUT");
330 my $dummy = fileno SAVEOUT;
331 open STDOUT, ">$name" ;
332
333 my $x = new $CompressClass '-' ;
334 $x->write($hello);
335 $x->close;
336
337 open(STDOUT, ">&SAVEOUT");
338
339 ok 1, " wrote to stdout" ;
340 }
25f0751f 341 is myGZreadFile($name), $hello, " wrote OK";
342 #hexDump($name);
1a6a8453 343
344 {
345 title "Input from stdin via filename '-'";
346
347 my $x ;
348 my $uncomp ;
349 my $stdinFileno = fileno(STDIN);
350 # open below doesn't return 1 sometines on XP
351 open(SAVEIN, "<&STDIN");
352 ok open(STDIN, "<$name"), " redirect STDIN";
353 my $dummy = fileno SAVEIN;
25f0751f 354 $x = new $UncompressClass '-', Append => 1, Transparent => 0
355 or diag $$UnError ;
1a6a8453 356 ok $x, " created object" ;
357 is $x->fileno(), $stdinFileno, " fileno ok" ;
358
359 1 while $x->read($uncomp) > 0 ;
360
361 ok $x->close, " close" ;
362 open(STDIN, "<&SAVEIN");
363 is $uncomp, $hello, " expected output" ;
364 }
365 }
366
367 {
368 # write a compressed file to memory
369 # and read back
370 #========================================
371
25f0751f 372 #my $name = "test.gz" ;
373 my $lex = new LexFile my $name ;
1a6a8453 374
375 my $hello = <<EOM ;
376hello world
377this is a test
378EOM
379
380 my $buffer ;
381 {
382 my $x ;
383 ok $x = new $CompressClass(\$buffer) ;
384
25f0751f 385 ok ! defined $x->autoflush(1) ;
386 ok ! defined $x->autoflush(1) ;
1a6a8453 387 ok ! defined $x->fileno() ;
388 is $x->write(''), 0, "Write empty string is ok";
389 is $x->write(undef), 0, "Write undef is ok";
390 ok $x->write($hello) ;
391 ok $x->flush();
392 ok $x->close ;
393
394 writeFile($name, $buffer) ;
395 #is anyUncompress(\$buffer), $hello, " any ok";
396 }
397
398 my $keep = $buffer ;
399 my $uncomp;
400 {
401 my $x ;
402 ok $x = new $UncompressClass(\$buffer, Append => 1) ;
403
25f0751f 404 ok ! defined $x->autoflush(1) ;
405 ok ! defined $x->autoflush(1) ;
1a6a8453 406 ok ! defined $x->fileno() ;
407 1 while $x->read($uncomp) > 0 ;
408
d54256af 409 ok $x->close, "closed" ;
1a6a8453 410 }
411
d54256af 412 is $uncomp, $hello, "got expected uncompressed data" ;
413 ok $buffer eq $keep, "compressed input not changed" ;
1a6a8453 414 }
415
416 if ($CompressClass ne 'RawDeflate')
417 {
418 # write empty file
419 #========================================
420
421 my $buffer = '';
422 {
423 my $x ;
d54256af 424 $x = new $CompressClass(\$buffer);
425 ok $x, "new $CompressClass" ;
426 ok $x->close, "close ok" ;
1a6a8453 427
428 }
429
430 my $keep = $buffer ;
431 my $uncomp= '';
432 {
433 my $x ;
434 ok $x = new $UncompressClass(\$buffer, Append => 1) ;
435
436 1 while $x->read($uncomp) > 0 ;
437
438 ok $x->close ;
439 }
440
441 ok $uncomp eq '' ;
442 ok $buffer eq $keep ;
443
444 }
445
446 {
447 # write a larger file
448 #========================================
449
450
451 my $lex = new LexFile my $name ;
452
453 my $hello = <<EOM ;
454hello world
455this is a test
456EOM
457
458 my $input = '' ;
459 my $contents = '' ;
460
461 {
462 my $x = new $CompressClass $name ;
463 ok $x, " created $CompressClass object";
464
465 ok $x->write($hello), " write ok" ;
466 $input .= $hello ;
467 ok $x->write("another line"), " write ok" ;
468 $input .= "another line" ;
469 # all characters
470 foreach (0 .. 255)
471 { $contents .= chr int $_ }
472 # generate a long random string
473 foreach (1 .. 5000)
474 { $contents .= chr int rand 256 }
475
476 ok $x->write($contents), " write ok" ;
477 $input .= $contents ;
478 ok $x->close, " close ok" ;
479 }
480
481 ok myGZreadFile($name) eq $input ;
482 my $x = readFile($name) ;
483 #print "length " . length($x) . " \n";
484 }
485
486 {
487 # embed a compressed file in another file
488 #================================
489
490
491 my $lex = new LexFile my $name ;
492
493 my $hello = <<EOM ;
494hello world
495this is a test
496EOM
497
498 my $header = "header info\n" ;
499 my $trailer = "trailer data\n" ;
500
501 {
502 my $fh ;
503 ok $fh = new IO::File ">$name" ;
504 print $fh $header ;
505 my $x ;
506 ok $x = new $CompressClass $fh,
507 -AutoClose => 0 ;
508
509 ok $x->binmode();
510 ok $x->write($hello) ;
511 ok $x->close ;
512 print $fh $trailer ;
513 $fh->close() ;
514 }
515
516 my ($fil, $uncomp) ;
517 my $fh1 ;
518 ok $fh1 = new IO::File "<$name" ;
519 # skip leading junk
520 my $line = <$fh1> ;
521 ok $line eq $header ;
522
523 ok my $x = new $UncompressClass $fh1, Append => 1 ;
524 ok $x->binmode();
525 1 while $x->read($uncomp) > 0 ;
526
527 ok $uncomp eq $hello ;
528 my $rest ;
529 read($fh1, $rest, 5000);
530 is $x->trailingData() . $rest, $trailer ;
531 #print "# [".$x->trailingData() . "][$rest]\n" ;
1a6a8453 532
533 }
534
535 {
258133d1 536 # embed a compressed file in another buffer
537 #================================
538
539
540 my $hello = <<EOM ;
541hello world
542this is a test
543EOM
544
545 my $trailer = "trailer data" ;
546
547 my $compressed ;
548
549 {
550 ok my $x = new $CompressClass(\$compressed);
551
552 ok $x->write($hello) ;
553 ok $x->close ;
554 $compressed .= $trailer ;
555 }
556
557 my $uncomp;
558 ok my $x = new $UncompressClass(\$compressed, Append => 1) ;
559 1 while $x->read($uncomp) > 0 ;
560
561 ok $uncomp eq $hello ;
562 is $x->trailingData(), $trailer ;
563
564 }
565
566 {
1a6a8453 567 # Write
568 # these tests come almost 100% from IO::String
569
570 my $lex = new LexFile my $name ;
571
572 my $io = $CompressClass->new($name);
573
574 is $io->tell(), 0, " tell returns 0"; ;
575
576 my $heisan = "Heisan\n";
577 $io->print($heisan) ;
578
579 ok ! $io->eof(), " ! eof";
580
581 is $io->tell(), length($heisan), " tell is " . length($heisan) ;
582
583 $io->print("a", "b", "c");
584
585 {
586 local($\) = "\n";
587 $io->print("d", "e");
588 local($,) = ",";
589 $io->print("f", "g", "h");
590 }
591
592 {
593 local($\) ;
594 $io->print("D", "E");
595 local($,) = ".";
596 $io->print("F", "G", "H");
597 }
598
599 my $foo = "1234567890";
600
601 is $io->syswrite($foo, length($foo)), length($foo), " syswrite ok" ;
d56f7e4c 602 if ( $] < 5.6 )
1a6a8453 603 { is $io->syswrite($foo, length $foo), length $foo, " syswrite ok" }
604 else
605 { is $io->syswrite($foo), length $foo, " syswrite ok" }
606 is $io->syswrite($foo, length($foo)), length $foo, " syswrite ok";
607 is $io->write($foo, length($foo), 5), 5, " write 5";
608 is $io->write("xxx\n", 100, -1), 1, " write 1";
609
610 for (1..3) {
611 $io->printf("i(%d)", $_);
612 $io->printf("[%d]\n", $_);
613 }
614 $io->print("\n");
615
616 $io->close ;
617
618 ok $io->eof(), " eof";
619
620 is myGZreadFile($name), "Heisan\nabcde\nf,g,h\nDEF.G.H" .
621 ("1234567890" x 3) . "67890\n" .
258133d1 622 "i(1)[1]\ni(2)[2]\ni(3)[3]\n\n",
623 "myGZreadFile ok";
1a6a8453 624
625
626 }
627
628 {
629 # Read
630 my $str = <<EOT;
631This is an example
632of a paragraph
633
634
635and a single line.
636
637EOT
638
639 my $lex = new LexFile my $name ;
640
641 my %opts = () ;
642 my $iow = new $CompressClass $name, %opts;
4e7676c7 643 is $iow->input_line_number, undef;
1a6a8453 644 $iow->print($str) ;
4e7676c7 645 is $iow->input_line_number, undef;
1a6a8453 646 $iow->close ;
647
648 my @tmp;
649 my $buf;
650 {
651 my $io = new $UncompressClass $name ;
652
25f0751f 653 is $., 0;
654 is $io->input_line_number, 0;
258133d1 655 ok ! $io->eof, "eof";
656 is $io->tell(), 0, "tell 0" ;
1a6a8453 657 #my @lines = <$io>;
658 my @lines = $io->getlines();
659 is @lines, 6
660 or print "# Got " . scalar(@lines) . " lines, expected 6\n" ;
661 is $lines[1], "of a paragraph\n" ;
662 is join('', @lines), $str ;
663 is $., 6;
25f0751f 664 is $io->input_line_number, 6;
1a6a8453 665 is $io->tell(), length($str) ;
666
667 ok $io->eof;
668
669 ok ! ( defined($io->getline) ||
670 (@tmp = $io->getlines) ||
671 defined($io->getline) ||
672 defined($io->getc) ||
673 $io->read($buf, 100) != 0) ;
674 }
675
676
677 {
678 local $/; # slurp mode
679 my $io = $UncompressClass->new($name);
25f0751f 680 is $., 0;
681 is $io->input_line_number, 0;
1a6a8453 682 ok ! $io->eof;
683 my @lines = $io->getlines;
25f0751f 684 is $., 1;
685 is $io->input_line_number, 1;
1a6a8453 686 ok $io->eof;
687 ok @lines == 1 && $lines[0] eq $str;
688
689 $io = $UncompressClass->new($name);
690 ok ! $io->eof;
691 my $line = $io->getline();
692 ok $line eq $str;
693 ok $io->eof;
694 }
695
696 {
697 local $/ = ""; # paragraph mode
698 my $io = $UncompressClass->new($name);
25f0751f 699 is $., 0;
700 is $io->input_line_number, 0;
1a6a8453 701 ok ! $io->eof;
702 my @lines = $io->getlines();
25f0751f 703 is $., 2;
704 is $io->input_line_number, 2;
1a6a8453 705 ok $io->eof;
706 ok @lines == 2
707 or print "# Got " . scalar(@lines) . " lines, expected 2\n" ;
708 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
709 or print "# $lines[0]\n";
710 ok $lines[1] eq "and a single line.\n\n";
711 }
712
713 {
258133d1 714 # Record mode
715 my $reclen = 7 ;
716 my $expected_records = int(length($str) / $reclen)
717 + (length($str) % $reclen ? 1 : 0);
718 local $/ = \$reclen;
719
720 my $io = $UncompressClass->new($name);
721 is $., 0;
722 is $io->input_line_number, 0;
723
724 ok ! $io->eof;
725 my @lines = $io->getlines();
726 is $., $expected_records;
727 is $io->input_line_number, $expected_records;
728 ok $io->eof;
729 is @lines, $expected_records,
730 "Got $expected_records records\n" ;
731 ok $lines[0] eq substr($str, 0, $reclen)
732 or print "# $lines[0]\n";
733 ok $lines[1] eq substr($str, $reclen, $reclen);
734 }
735
736 {
1a6a8453 737 local $/ = "is";
738 my $io = $UncompressClass->new($name);
739 my @lines = ();
740 my $no = 0;
741 my $err = 0;
742 ok ! $io->eof;
743 while (my $a = $io->getline()) {
744 push(@lines, $a);
745 $err++ if $. != ++$no;
746 }
747
748 ok $err == 0 ;
749 ok $io->eof;
750
25f0751f 751 is $., 3;
752 is $io->input_line_number, 3;
1a6a8453 753 ok @lines == 3
754 or print "# Got " . scalar(@lines) . " lines, expected 3\n" ;
755 ok join("-", @lines) eq
756 "This- is- an example\n" .
757 "of a paragraph\n\n\n" .
758 "and a single line.\n\n";
759 }
760
761
762 # Test read
763
764 {
765 my $io = $UncompressClass->new($name);
766
767
768 eval { $io->read(1) } ;
769 like $@, mkErr("buffer parameter is read-only");
770
93d092e2 771 $buf = "abcd";
1a6a8453 772 is $io->read($buf, 0), 0, "Requested 0 bytes" ;
93d092e2 773 is $buf, "", "Buffer empty";
1a6a8453 774
258133d1 775 is $io->read($buf, 3), 3 ;
776 is $buf, "Thi";
1a6a8453 777
258133d1 778 is $io->sysread($buf, 3, 2), 3 ;
779 is $buf, "Ths i"
1a6a8453 780 or print "# [$buf]\n" ;;
781 ok ! $io->eof;
782
93d092e2 783 $buf = "ab" ;
784 is $io->read($buf, 3, 4), 3 ;
785 is $buf, "ab" . "\x00" x 2 . "s a"
786 or print "# [$buf]\n" ;;
787 ok ! $io->eof;
788
789 # read the rest of the file
790 $buf = '';
791 my $remain = length($str) - 9;
792 is $io->read($buf, $remain+1), $remain ;
793 is $buf, substr($str, 9);
794 ok $io->eof;
795
796 $buf = "hello";
797 is $io->read($buf, 10), 0 ;
798 is $buf, "", "Buffer empty";
799 ok $io->eof;
800
801 ok $io->close();
802 $buf = "hello";
803 is $io->read($buf, 10), 0 ;
804 is $buf, "hello", "Buffer not empty";
805 ok $io->eof;
806
1a6a8453 807 # $io->seek(-4, 2);
808 #
809 # ok ! $io->eof;
810 #
811 # ok read($io, $buf, 20) == 4 ;
812 # ok $buf eq "e.\n\n";
813 #
814 # ok read($io, $buf, 20) == 0 ;
815 # ok $buf eq "";
816 #
817 # ok ! $io->eof;
818 }
819
820 }
821
822 {
823 # Read from non-compressed file
824
825 my $str = <<EOT;
826This is an example
827of a paragraph
828
829
830and a single line.
831
832EOT
833
834 my $lex = new LexFile my $name ;
835
836 writeFile($name, $str);
837 my @tmp;
838 my $buf;
839 {
840 my $io = new $UncompressClass $name, -Transparent => 1 ;
841
842 ok defined $io;
843 ok ! $io->eof;
844 ok $io->tell() == 0 ;
845 my @lines = $io->getlines();
25f0751f 846 is @lines, 6;
1a6a8453 847 ok $lines[1] eq "of a paragraph\n" ;
848 ok join('', @lines) eq $str ;
25f0751f 849 is $., 6;
850 is $io->input_line_number, 6;
1a6a8453 851 ok $io->tell() == length($str) ;
852
853 ok $io->eof;
854
855 ok ! ( defined($io->getline) ||
856 (@tmp = $io->getlines) ||
857 defined($io->getline) ||
858 defined($io->getc) ||
859 $io->read($buf, 100) != 0) ;
860 }
861
862
863 {
864 local $/; # slurp mode
865 my $io = $UncompressClass->new($name);
866 ok ! $io->eof;
867 my @lines = $io->getlines;
25f0751f 868 is $., 1;
869 is $io->input_line_number, 1;
1a6a8453 870 ok $io->eof;
871 ok @lines == 1 && $lines[0] eq $str;
872
873 $io = $UncompressClass->new($name);
874 ok ! $io->eof;
875 my $line = $io->getline;
25f0751f 876 is $., 1;
877 is $io->input_line_number, 1;
1a6a8453 878 ok $line eq $str;
879 ok $io->eof;
880 }
881
882 {
883 local $/ = ""; # paragraph mode
884 my $io = $UncompressClass->new($name);
885 ok ! $io->eof;
886 my @lines = $io->getlines;
25f0751f 887 is $., 2;
888 is $io->input_line_number, 2;
1a6a8453 889 ok $io->eof;
890 ok @lines == 2
891 or print "# exected 2 lines, got " . scalar(@lines) . "\n";
892 ok $lines[0] eq "This is an example\nof a paragraph\n\n\n"
893 or print "# [$lines[0]]\n" ;
894 ok $lines[1] eq "and a single line.\n\n";
895 }
896
897 {
258133d1 898 # Record mode
899 my $reclen = 7 ;
900 my $expected_records = int(length($str) / $reclen)
901 + (length($str) % $reclen ? 1 : 0);
902 local $/ = \$reclen;
903
904 my $io = $UncompressClass->new($name);
905 is $., 0;
906 is $io->input_line_number, 0;
907
908 ok ! $io->eof;
909 my @lines = $io->getlines();
910 is $., $expected_records;
911 is $io->input_line_number, $expected_records;
912 ok $io->eof;
913 is @lines, $expected_records,
914 "Got $expected_records records\n" ;
915 ok $lines[0] eq substr($str, 0, $reclen)
916 or print "# $lines[0]\n";
917 ok $lines[1] eq substr($str, $reclen, $reclen);
918 }
919
920 {
1a6a8453 921 local $/ = "is";
922 my $io = $UncompressClass->new($name);
923 my @lines = ();
924 my $no = 0;
925 my $err = 0;
926 ok ! $io->eof;
927 while (my $a = $io->getline) {
928 push(@lines, $a);
929 $err++ if $. != ++$no;
930 }
931
25f0751f 932 is $., 3;
933 is $io->input_line_number, 3;
1a6a8453 934 ok $err == 0 ;
935 ok $io->eof;
936
25f0751f 937
1a6a8453 938 ok @lines == 3 ;
939 ok join("-", @lines) eq
940 "This- is- an example\n" .
941 "of a paragraph\n\n\n" .
942 "and a single line.\n\n";
943 }
944
945
93d092e2 946 # Test Read
1a6a8453 947
948 {
949 my $io = $UncompressClass->new($name);
950
93d092e2 951 $buf = "abcd";
952 is $io->read($buf, 0), 0, "Requested 0 bytes" ;
953 is $buf, "", "Buffer empty";
954
1a6a8453 955 ok $io->read($buf, 3) == 3 ;
956 ok $buf eq "Thi";
957
958 ok $io->sysread($buf, 3, 2) == 3 ;
959 ok $buf eq "Ths i";
960 ok ! $io->eof;
961
93d092e2 962 $buf = "ab" ;
963 is $io->read($buf, 3, 4), 3 ;
964 is $buf, "ab" . "\x00" x 2 . "s a"
965 or print "# [$buf]\n" ;;
966 ok ! $io->eof;
967
968 # read the rest of the file
969 $buf = '';
970 my $remain = length($str) - 9;
971 is $io->read($buf, $remain), $remain ;
972 is $buf, substr($str, 9);
973 ok $io->eof;
974
975 $buf = "hello";
976 is $io->read($buf, 10), 0 ;
977 is $buf, "", "Buffer empty";
978 ok $io->eof;
979
980 ok $io->close();
981 $buf = "hello";
982 is $io->read($buf, 10), 0 ;
983 is $buf, "hello", "Buffer not empty";
984 ok $io->eof;
985
1a6a8453 986 # $io->seek(-4, 2);
987 #
988 # ok ! $io->eof;
989 #
990 # ok read($io, $buf, 20) == 4 ;
991 # ok $buf eq "e.\n\n";
992 #
993 # ok read($io, $buf, 20) == 0 ;
994 # ok $buf eq "";
995 #
996 # ok ! $io->eof;
997 }
998
999
1000 }
1001
1002 {
1003 # Vary the length parameter in a read
1004
1005 my $str = <<EOT;
1006x
1007x
1008This is an example
1009of a paragraph
1010
1011
1012and a single line.
1013
1014EOT
1015 $str = $str x 100 ;
1016
1017
1018 foreach my $bufsize (1, 3, 512, 4096, length($str)-1, length($str), length($str)+1)
1019 {
1020 foreach my $trans (0, 1)
1021 {
1022 foreach my $append (0, 1)
1023 {
1024 title "Read Tests - buf length $bufsize, Transparent $trans, Append $append" ;
1025
1026 my $lex = new LexFile my $name ;
1027
1028 if ($trans) {
1029 writeFile($name, $str) ;
1030 }
1031 else {
1032 my $iow = new $CompressClass $name;
1033 $iow->print($str) ;
1034 $iow->close ;
1035 }
1036
1037
1038 my $io = $UncompressClass->new($name,
1039 -Append => $append,
1040 -Transparent => $trans);
1041
1042 my $buf;
1043
1044 is $io->tell(), 0;
1045
1046 if ($append) {
1047 1 while $io->read($buf, $bufsize) > 0;
1048 }
1049 else {
1050 my $tmp ;
1051 $buf .= $tmp while $io->read($tmp, $bufsize) > 0 ;
1052 }
1053 is length $buf, length $str;
1054 ok $buf eq $str ;
1055 ok ! $io->error() ;
1056 ok $io->eof;
1057 }
1058 }
1059 }
1060 }
1061
1062 foreach my $file (0, 1)
1063 {
1064 foreach my $trans (0, 1)
1065 {
1066 title "seek tests - file $file trans $trans" ;
1067
1068 my $buffer ;
1069 my $buff ;
1070 my $lex = new LexFile my $name ;
1071
1072 my $first = "beginning" ;
1073 my $last = "the end" ;
1074
1075 if ($trans)
1076 {
1077 $buffer = $first . "\x00" x 10 . $last;
1078 writeFile($name, $buffer);
1079 }
1080 else
1081 {
1082 my $output ;
1083 if ($file)
1084 {
1085 $output = $name ;
1086 }
1087 else
1088 {
1089 $output = \$buffer;
1090 }
1091
1092 my $iow = new $CompressClass $output ;
1093 $iow->print($first) ;
1094 ok $iow->seek(5, SEEK_CUR) ;
1095 ok $iow->tell() == length($first)+5;
1096 ok $iow->seek(0, SEEK_CUR) ;
1097 ok $iow->tell() == length($first)+5;
1098 ok $iow->seek(length($first)+10, SEEK_SET) ;
1099 ok $iow->tell() == length($first)+10;
1100
1101 $iow->print($last) ;
1102 $iow->close ;
1103 }
1104
1105 my $input ;
1106 if ($file)
1107 {
1108 $input = $name ;
1109 }
1110 else
1111 {
1112 $input = \$buffer ;
1113 }
1114
1115 ok myGZreadFile($input) eq $first . "\x00" x 10 . $last ;
1116
1117 my $io = $UncompressClass->new($input, Strict => 1);
25f0751f 1118 ok $io->seek(length($first), SEEK_CUR)
1119 or diag $$UnError ;
1a6a8453 1120 ok ! $io->eof;
1121 is $io->tell(), length($first);
1122
1123 ok $io->read($buff, 5) ;
1124 is $buff, "\x00" x 5 ;
1125 is $io->tell(), length($first) + 5;
1126
1127 ok $io->seek(0, SEEK_CUR) ;
1128 my $here = $io->tell() ;
1129 is $here, length($first)+5;
1130
1131 ok $io->seek($here+5, SEEK_SET) ;
1132 is $io->tell(), $here+5 ;
1133 ok $io->read($buff, 100) ;
1134 ok $buff eq $last ;
1135 ok $io->eof;
1136 }
1137 }
1138
1139 {
1140 title "seek error cases" ;
1141
1142 my $b ;
1143 my $a = new $CompressClass(\$b) ;
1144
1145 ok ! $a->error() ;
1146 eval { $a->seek(-1, 10) ; };
1147 like $@, mkErr("^${CompressClass}::seek: unknown value, 10, for whence parameter");
1148
1149 eval { $a->seek(-1, SEEK_END) ; };
1150 like $@, mkErr("^${CompressClass}::seek: cannot seek backwards");
1151
1152 $a->write("fred");
1153 $a->close ;
1154
1155
1156 my $u = new $UncompressClass(\$b) ;
1157
1158 eval { $u->seek(-1, 10) ; };
1159 like $@, mkErr("^${UncompressClass}::seek: unknown value, 10, for whence parameter");
1160
1161 eval { $u->seek(-1, SEEK_END) ; };
1162 like $@, mkErr("^${UncompressClass}::seek: SEEK_END not allowed");
1163
1164 eval { $u->seek(-1, SEEK_CUR) ; };
1165 like $@, mkErr("^${UncompressClass}::seek: cannot seek backwards");
1166 }
1167
1168 foreach my $fb (qw(filename buffer filehandle))
1169 {
1170 foreach my $append (0, 1)
1171 {
1172 {
1173 title "$CompressClass -- Append $append, Output to $fb" ;
1174
1175 my $lex = new LexFile my $name ;
1176
1177 my $already = 'already';
1178 my $buffer = $already;
1179 my $output;
1180
1181 if ($fb eq 'buffer')
1182 { $output = \$buffer }
1183 elsif ($fb eq 'filename')
1184 {
1185 $output = $name ;
1186 writeFile($name, $buffer);
1187 }
1188 elsif ($fb eq 'filehandle')
1189 {
1190 $output = new IO::File ">$name" ;
1191 print $output $buffer;
1192 }
1193
1194 my $a = new $CompressClass($output, Append => $append) ;
1195 ok $a, " Created $CompressClass";
1196 my $string = "appended";
1197 $a->write($string);
1198 $a->close ;
1199
1200 my $data ;
1201 if ($fb eq 'buffer')
1202 {
1203 $data = $buffer;
1204 }
1205 else
1206 {
1207 $output->close
1208 if $fb eq 'filehandle';
1209 $data = readFile($name);
1210 }
1211
1212 if ($append || $fb eq 'filehandle')
1213 {
1214 is substr($data, 0, length($already)), $already, " got prefix";
1215 substr($data, 0, length($already)) = '';
1216 }
1217
1218
1219 my $uncomp;
1220 my $x = new $UncompressClass(\$data, Append => 1) ;
1221 ok $x, " created $UncompressClass";
1222
1223 my $len ;
1224 1 while ($len = $x->read($uncomp)) > 0 ;
1225
1226 $x->close ;
1227 is $uncomp, $string, ' Got uncompressed data' ;
1228
1229 }
1230 }
1231 }
1232
1233 foreach my $type (qw(buffer filename filehandle))
1234 {
2b4e0969 1235 foreach my $good (0, 1)
1236 {
1237 title "$UncompressClass -- InputLength, read from $type, good data => $good";
1a6a8453 1238
2b4e0969 1239 my $compressed ;
1240 my $string = "some data";
1241 my $appended = "append";
1a6a8453 1242
2b4e0969 1243 if ($good)
1244 {
1245 my $c = new $CompressClass(\$compressed);
1246 $c->write($string);
1247 $c->close();
1248 }
1249 else
1250 {
1251 $compressed = $string ;
1252 }
1a6a8453 1253
2b4e0969 1254 my $comp_len = length $compressed;
1255 $compressed .= $appended;
1a6a8453 1256
2b4e0969 1257 my $lex = new LexFile my $name ;
1258 my $input ;
1259 writeFile ($name, $compressed);
1a6a8453 1260
2b4e0969 1261 if ($type eq 'buffer')
1262 {
1263 $input = \$compressed;
1264 }
1265 if ($type eq 'filename')
1266 {
1267 $input = $name;
1268 }
1269 elsif ($type eq 'filehandle')
1270 {
1271 my $fh = new IO::File "<$name" ;
1272 ok $fh, "opened file $name ok";
1273 $input = $fh ;
1274 }
1a6a8453 1275
2b4e0969 1276 my $x = new $UncompressClass($input,
1277 InputLength => $comp_len,
1278 Transparent => 1) ;
1279 ok $x, " created $UncompressClass";
1a6a8453 1280
2b4e0969 1281 my $len ;
1282 my $output;
1283 $len = $x->read($output, 100);
1284
1285 is $len, length($string);
1286 is $output, $string;
1287
1288 if ($type eq 'filehandle')
1289 {
1290 my $rest ;
1291 $input->read($rest, 1000);
1292 is $rest, $appended;
1293 }
1a6a8453 1294 }
1295
1296
1297 }
1298
1299 foreach my $append (0, 1)
1300 {
1301 title "$UncompressClass -- Append $append" ;
1302
1303 my $lex = new LexFile my $name ;
1304
1305 my $string = "appended";
1306 my $compressed ;
1307 my $c = new $CompressClass(\$compressed);
1308 $c->write($string);
1309 $c->close();
1310
1311 my $x = new $UncompressClass(\$compressed, Append => $append) ;
1312 ok $x, " created $UncompressClass";
1313
1314 my $already = 'already';
1315 my $output = $already;
1316
1317 my $len ;
1318 $len = $x->read($output, 100);
1319 is $len, length($string);
1320
1321 $x->close ;
1322
1323 if ($append)
1324 {
1325 is substr($output, 0, length($already)), $already, " got prefix";
1326 substr($output, 0, length($already)) = '';
1327 }
1328 is $output, $string, ' Got uncompressed data' ;
1329 }
1330
1331
1332 foreach my $file (0, 1)
1333 {
1334 foreach my $trans (0, 1)
1335 {
1336 title "ungetc, File $file, Transparent $trans" ;
1337
1338 my $lex = new LexFile my $name ;
1339
1340 my $string = 'abcdeABCDE';
1341 my $b ;
1342 if ($trans)
1343 {
1344 $b = $string ;
1345 }
1346 else
1347 {
1348 my $a = new $CompressClass(\$b) ;
1349 $a->write($string);
1350 $a->close ;
1351 }
1352
1353 my $from ;
1354 if ($file)
1355 {
1356 writeFile($name, $b);
1357 $from = $name ;
1358 }
1359 else
1360 {
1361 $from = \$b ;
1362 }
1363
1364 my $u = $UncompressClass->new($from, Transparent => 1) ;
1365 my $first;
1366 my $buff ;
1367
1368 # do an ungetc before reading
1369 $u->ungetc("X");
1370 $first = $u->getc();
1371 is $first, 'X';
1372
1373 $first = $u->getc();
1374 is $first, substr($string, 0,1);
1375 $u->ungetc($first);
1376 $first = $u->getc();
1377 is $first, substr($string, 0,1);
1378 $u->ungetc($first);
1379
1380 is $u->read($buff, 5), 5 ;
1381 is $buff, substr($string, 0, 5);
1382
1383 $u->ungetc($buff) ;
1384 is $u->read($buff, length($string)), length($string) ;
1385 is $buff, $string;
1386
1387 is $u->read($buff, 1), 0;
1388 ok $u->eof() ;
1389
1390 my $extra = 'extra';
1391 $u->ungetc($extra);
1392 ok ! $u->eof();
1393 is $u->read($buff), length($extra) ;
1394 is $buff, $extra;
1395
1396 is $u->read($buff, 1), 0;
1397 ok $u->eof() ;
1398
cb7abd7f 1399 # getc returns undef on eof
1400 is $u->getc(), undef;
1a6a8453 1401 $u->close();
1402
1403 }
1404 }
1405
1a6a8453 1406 {
1407 title "write tests - invalid data" ;
1408
1409 #my $lex = new LexFile my $name1 ;
1410 my($Answer);
1411
1412 #ok ! -e $name1, " File $name1 does not exist";
1413
1414 my @data = (
1415 [ '{ }', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1416 [ '[ { } ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1417 [ '[ [ { } ] ]', "${CompressClass}::write: input parameter not a filename, filehandle, array ref or scalar ref" ],
1418 [ '[ "" ]', "${CompressClass}::write: input filename is undef or null string" ],
1419 [ '[ undef ]', "${CompressClass}::write: input filename is undef or null string" ],
1420 [ '[ \$Answer ]',"${CompressClass}::write: input and output buffer are identical" ],
1421 #[ "not readable", 'xx' ],
1422 # same filehandle twice, 'xx'
1423 ) ;
1424
1425 foreach my $data (@data)
1426 {
1427 my ($send, $get) = @$data ;
1428 title "${CompressClass}::write( $send )";
1429 my($copy);
1430 eval "\$copy = $send";
1431 my $x = new $CompressClass(\$Answer);
1432 ok $x, " Created $CompressClass object";
1433 eval { $x->write($copy) } ;
1434 #like $@, "/^$get/", " error - $get";
1435 like $@, "/not a scalar reference /", " error - not a scalar reference";
1436 }
1437
1438 # @data = (
1439 # [ '[ $name1 ]', "input file '$name1' does not exist" ],
1440 # #[ "not readable", 'xx' ],
1441 # # same filehandle twice, 'xx'
1442 # ) ;
1443 #
1444 # foreach my $data (@data)
1445 # {
1446 # my ($send, $get) = @$data ;
1447 # title "${CompressClass}::write( $send )";
1448 # my $copy;
1449 # eval "\$copy = $send";
1450 # my $x = new $CompressClass(\$Answer);
1451 # ok $x, " Created $CompressClass object";
1452 # ok ! $x->write($copy), " write fails" ;
1453 # like $$Error, "/^$get/", " error - $get";
1454 # }
1455
1456 #exit;
1457
1458 }
1459
1460
1461 # sub deepCopy
1462 # {
1463 # if (! ref $_[0] || ref $_[0] eq 'SCALAR')
1464 # {
1465 # return $_[0] ;
1466 # }
1467 #
1468 # if (ref $_[0] eq 'ARRAY')
1469 # {
1470 # my @a ;
1471 # for my $x ( @{ $_[0] })
1472 # {
1473 # push @a, deepCopy($x);
1474 # }
1475 #
1476 # return \@a ;
1477 # }
1478 #
1479 # croak "bad! $_[0]";
1480 #
1481 # }
1482 #
1483 # sub deepSubst
1484 # {
1485 # #my $data = shift ;
1486 # my $from = $_[1] ;
1487 # my $to = $_[2] ;
1488 #
1489 # if (! ref $_[0])
1490 # {
1491 # $_[0] = $to
1492 # if $_[0] eq $from ;
1493 # return ;
1494 #
1495 # }
1496 #
1497 # if (ref $_[0] eq 'SCALAR')
1498 # {
1499 # $_[0] = \$to
1500 # if defined ${ $_[0] } && ${ $_[0] } eq $from ;
1501 # return ;
1502 #
1503 # }
1504 #
1505 # if (ref $_[0] eq 'ARRAY')
1506 # {
1507 # for my $x ( @{ $_[0] })
1508 # {
1509 # deepSubst($x, $from, $to);
1510 # }
1511 # return ;
1512 # }
1513 # #croak "bad! $_[0]";
1514 # }
1515
1516 # {
1517 # title "More write tests" ;
1518 #
1519 # my $file1 = "file1" ;
1520 # my $file2 = "file2" ;
1521 # my $file3 = "file3" ;
1522 # my $lex = new LexFile $file1, $file2, $file3 ;
1523 #
1524 # writeFile($file1, "F1");
1525 # writeFile($file2, "F2");
1526 # writeFile($file3, "F3");
1527 #
1528 # my @data = (
1529 # [ '""', "" ],
1530 # [ 'undef', "" ],
1531 # [ '"abcd"', "abcd" ],
1532 #
1533 # [ '\""', "" ],
1534 # [ '\undef', "" ],
1535 # [ '\"abcd"', "abcd" ],
1536 #
1537 # [ '[]', "" ],
1538 # [ '[[]]', "" ],
1539 # [ '[[[]]]', "" ],
1540 # [ '[\""]', "" ],
1541 # [ '[\undef]', "" ],
1542 # [ '[\"abcd"]', "abcd" ],
1543 # [ '[\"ab", \"cd"]', "abcd" ],
1544 # [ '[[\"ab"], [\"cd"]]', "abcd" ],
1545 #
1546 # [ '$file1', $file1 ],
1547 # [ '$fh2', "F2" ],
1548 # [ '[$file1, \"abc"]', "F1abc"],
1549 # [ '[\"a", $file1, \"bc"]', "aF1bc"],
1550 # [ '[\"a", $fh1, \"bc"]', "aF1bc"],
1551 # [ '[\"a", $fh1, \"bc", $file2]', "aF1bcF2"],
1552 # [ '[\"a", $fh1, \"bc", $file2, $fh3]', "aF1bcF2F3"],
1553 # ) ;
1554 #
1555 #
1556 # foreach my $data (@data)
1557 # {
1558 # my ($send, $get) = @$data ;
1559 #
1560 # my $fh1 = new IO::File "< $file1" ;
1561 # my $fh2 = new IO::File "< $file2" ;
1562 # my $fh3 = new IO::File "< $file3" ;
1563 #
1564 # title "${CompressClass}::write( $send )";
1565 # my $copy;
1566 # eval "\$copy = $send";
1567 # my $Answer ;
1568 # my $x = new $CompressClass(\$Answer);
1569 # ok $x, " Created $CompressClass object";
1570 # my $len = length $get;
1571 # is $x->write($copy), length($get), " write $len bytes";
1572 # ok $x->close(), " close ok" ;
1573 #
1574 # is myGZreadFile(\$Answer), $get, " got expected output" ;
1575 # cmp_ok $$Error, '==', 0, " no error";
1576 #
1577 #
1578 # }
1579 #
1580 # }
1581 }
1582
1583}
1584
15851;
1586
1587
1588
1589
25f0751f 1590
Unnamed repository; edit this file to name it for gitweb.