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