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