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