projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
require should ignore directories found when searching @INC not just
[p5sagit/p5-mst-13.2.git] / ext / Compress / IO / Base / lib / IO / Uncompress / Base.pm
CommitLineData
25f0751f 1
2package IO::Uncompress::Base ;
3
4use strict ;
5use warnings;
6use bytes;
7
8our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS);
9#@ISA = qw(Exporter IO::File);
10@ISA = qw(Exporter );
11
12
13$VERSION = '2.000_08';
14
15use constant G_EOF => 0 ;
16use constant G_ERR => -1 ;
17
18use IO::Compress::Base::Common;
19#use Parse::Parameters ;
20
21use IO::File ;
22use Symbol;
23use Scalar::Util qw(readonly);
24use List::Util qw(min);
25use Carp ;
26
27%EXPORT_TAGS = ( );
28push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
29#Exporter::export_ok_tags('all') ;
30
31
32sub smartRead
33{
34 my $self = $_[0];
35 my $out = $_[1];
36 my $size = $_[2];
37 $$out = "" ;
38
39 my $offset = 0 ;
40
41
42 if ( length *$self->{Prime} ) {
43 #$$out = substr(*$self->{Prime}, 0, $size, '') ;
44 $$out = substr(*$self->{Prime}, 0, $size) ;
45 substr(*$self->{Prime}, 0, $size) = '' ;
46 if (length $$out == $size) {
47 #*$self->{InputLengthRemaining} -= length $$out;
48 return length $$out ;
49 }
50 $offset = length $$out ;
51 }
52
53 my $get_size = $size - $offset ;
54
55 if ( defined *$self->{InputLength} ) {
56 #*$self->{InputLengthRemaining} += length *$self->{Prime} ;
57 #*$self->{InputLengthRemaining} = *$self->{InputLength}
58 # if *$self->{InputLengthRemaining} > *$self->{InputLength};
59 $get_size = min($get_size, *$self->{InputLengthRemaining});
60 }
61
62 if (defined *$self->{FH})
63 { *$self->{FH}->read($$out, $get_size, $offset) }
64 elsif (defined *$self->{InputEvent}) {
65 my $got = 1 ;
66 while (length $$out < $size) {
67 last
68 if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0;
69 }
70
71 if (length $$out > $size ) {
72 #*$self->{Prime} = substr($$out, $size, length($$out), '');
73 *$self->{Prime} = substr($$out, $size, length($$out));
74 substr($$out, $size, length($$out)) = '';
75 }
76
77 *$self->{EventEof} = 1 if $got <= 0 ;
78 }
79 else {
80 no warnings 'uninitialized';
81 my $buf = *$self->{Buffer} ;
82 $$buf = '' unless defined $$buf ;
83 #$$out = '' unless defined $$out ;
84 substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
85 *$self->{BufferOffset} += length($$out) - $offset ;
86 }
87
88 *$self->{InputLengthRemaining} -= length $$out;
89
90 $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ;
91
92 return length $$out;
93}
94
95sub pushBack
96{
97 my $self = shift ;
98
99 return if ! defined $_[0] || length $_[0] == 0 ;
100
101 if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
102 *$self->{Prime} = $_[0] . *$self->{Prime} ;
103 }
104 else {
105 my $len = length $_[0];
106
107 if($len > *$self->{BufferOffset}) {
108 *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ;
109 *$self->{InputLengthRemaining} = *$self->{InputLength};
110 *$self->{BufferOffset} = 0
111 }
112 else {
113 *$self->{InputLengthRemaining} += length($_[0]);
114 *$self->{BufferOffset} -= length($_[0]) ;
115 }
116 }
117}
118
119sub smartSeek
120{
121 my $self = shift ;
122 my $offset = shift ;
123 my $truncate = shift;
124 #print "smartSeek to $offset\n";
125
126 # TODO -- need to take prime into account
127 if (defined *$self->{FH})
128 { *$self->{FH}->seek($offset, SEEK_SET) }
129 else {
130 *$self->{BufferOffset} = $offset ;
131 substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
132 if $truncate;
133 return 1;
134 }
135}
136
137sub smartWrite
138{
139 my $self = shift ;
140 my $out_data = shift ;
141
142 if (defined *$self->{FH}) {
143 # flush needed for 5.8.0
144 defined *$self->{FH}->write($out_data, length $out_data) &&
145 defined *$self->{FH}->flush() ;
146 }
147 else {
148 my $buf = *$self->{Buffer} ;
149 substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ;
150 *$self->{BufferOffset} += length($out_data) ;
151 return 1;
152 }
153}
154
155sub smartReadExact
156{
157 return $_[0]->smartRead($_[1], $_[2]) == $_[2];
158}
159
160sub smartEof
161{
162 my ($self) = $_[0];
163 local $.;
164
165 return 0 if length *$self->{Prime};
166
167 if (defined *$self->{FH})
168 { *$self->{FH}->eof() }
169 elsif (defined *$self->{InputEvent})
170 { *$self->{EventEof} }
171 else
172 { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) }
173}
174
175sub clearError
176{
177 my $self = shift ;
178
179 *$self->{ErrorNo} = 0 ;
180 ${ *$self->{Error} } = '' ;
181}
182
183sub saveStatus
184{
185 my $self = shift ;
186 my $errno = shift() + 0 ;
187 #return $errno unless $errno || ! defined *$self->{ErrorNo};
188 #return $errno unless $errno ;
189
190 *$self->{ErrorNo} = $errno;
191 ${ *$self->{Error} } = '' ;
192
193 return *$self->{ErrorNo} ;
194}
195
196
197sub saveErrorString
198{
199 my $self = shift ;
200 my $retval = shift ;
201
202 #return $retval if ${ *$self->{Error} };
203
204 ${ *$self->{Error} } = shift ;
205 *$self->{ErrorNo} = shift() + 0 if @_ ;
206
207 #warn "saveErrorString: " . ${ *$self->{Error} } . " " . *$self->{Error} . "\n" ;
208 return $retval;
209}
210
211sub croakError
212{
213 my $self = shift ;
214 $self->saveErrorString(0, $_[0]);
215 croak $_[0];
216}
217
218
219sub closeError
220{
221 my $self = shift ;
222 my $retval = shift ;
223
224 my $errno = *$self->{ErrorNo};
225 my $error = ${ *$self->{Error} };
226
227 $self->close();
228
229 *$self->{ErrorNo} = $errno ;
230 ${ *$self->{Error} } = $error ;
231
232 return $retval;
233}
234
235sub error
236{
237 my $self = shift ;
238 return ${ *$self->{Error} } ;
239}
240
241sub errorNo
242{
243 my $self = shift ;
244 return *$self->{ErrorNo};
245}
246
247sub HeaderError
248{
249 my ($self) = shift;
250 return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
251}
252
253sub TrailerError
254{
255 my ($self) = shift;
256 return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
257}
258
259sub TruncatedHeader
260{
261 my ($self) = shift;
262 return $self->HeaderError("Truncated in $_[0] Section");
263}
264
265sub checkParams
266{
267 my $self = shift ;
268 my $class = shift ;
269
270 my $got = shift || IO::Compress::Base::Parameters::new();
271
272 my $Valid = {
273 'BlockSize' => [1, 1, Parse_unsigned, 16 * 1024],
274 'AutoClose' => [1, 1, Parse_boolean, 0],
275 'Strict' => [1, 1, Parse_boolean, 0],
276 #'Lax' => [1, 1, Parse_boolean, 1],
277 'Append' => [1, 1, Parse_boolean, 0],
278 'Prime' => [1, 1, Parse_any, undef],
279 'MultiStream' => [1, 1, Parse_boolean, 0],
280 'Transparent' => [1, 1, Parse_any, 1],
281 'Scan' => [1, 1, Parse_boolean, 0],
282 'InputLength' => [1, 1, Parse_unsigned, undef],
283 'BinModeOut' => [1, 1, Parse_boolean, 0],
284
285 $self->getExtraParams(),
286
287
288 #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
289 # ContinueAfterEof
290 } ;
291
292
293 $got->parse($Valid, @_ )
294 or $self->croakError("${class}: $got->{Error}") ;
295
296
297 return $got;
298}
299
300sub _create
301{
302 my $obj = shift;
303 my $got = shift;
304 my $append_mode = shift ;
305
306 my $class = ref $obj;
307 $obj->croakError("$class: Missing Input parameter")
308 if ! @_ && ! $got ;
309
310 my $inValue = shift ;
311
312 if (! $got)
313 {
314 $got = $obj->checkParams($class, undef, @_)
315 or return undef ;
316 }
317
318 my $inType = whatIsInput($inValue, 1);
319
320 $obj->ckInputParam($class, $inValue, 1)
321 or return undef ;
322
323 *$obj->{InNew} = 1;
324
325 $obj->ckParams($got)
326 or $obj->croakError("${class}: $obj->{Error}");
327
328 if ($inType eq 'buffer' || $inType eq 'code') {
329 *$obj->{Buffer} = $inValue ;
330 *$obj->{InputEvent} = $inValue
331 if $inType eq 'code' ;
332 }
333 else {
334 if ($inType eq 'handle') {
335 *$obj->{FH} = $inValue ;
336 *$obj->{Handle} = 1 ;
337 # Need to rewind for Scan
338 #seek(*$obj->{FH}, 0, SEEK_SET) if $got->value('Scan');
339 *$obj->{FH}->seek(0, SEEK_SET) if $got->value('Scan');
340 }
341 else {
342 my $mode = '<';
343 $mode = '+<' if $got->value('Scan');
344 *$obj->{StdIO} = ($inValue eq '-');
345 *$obj->{FH} = new IO::File "$mode $inValue"
346 or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
347 }
348
349 *$obj->{LineNo} = $. = 0;
350 setBinModeInput(*$obj->{FH}) ;
351
352 my $buff = "" ;
353 *$obj->{Buffer} = \$buff ;
354 }
355
356
357 *$obj->{InputLength} = $got->parsed('InputLength')
358 ? $got->value('InputLength')
359 : undef ;
360 *$obj->{InputLengthRemaining} = $got->value('InputLength');
361 *$obj->{BufferOffset} = 0 ;
362 *$obj->{AutoClose} = $got->value('AutoClose');
363 *$obj->{Strict} = $got->value('Strict');
364 #*$obj->{Strict} = ! $got->value('Lax');
365 *$obj->{BlockSize} = $got->value('BlockSize');
366 *$obj->{Append} = $got->value('Append');
367 *$obj->{AppendOutput} = $append_mode || $got->value('Append');
368 *$obj->{Transparent} = $got->value('Transparent');
369 *$obj->{MultiStream} = $got->value('MultiStream');
370
371 # TODO - move these two into RawDeflate
372 *$obj->{Scan} = $got->value('Scan');
373 *$obj->{ParseExtra} = $got->value('ParseExtra')
374 || $got->value('Strict') ;
375 #|| ! $got->value('Lax') ;
376 *$obj->{Type} = '';
377 *$obj->{Prime} = $got->value('Prime') || '' ;
378 *$obj->{Pending} = '';
379 *$obj->{Plain} = 0;
380 *$obj->{PlainBytesRead} = 0;
381 *$obj->{InflatedBytesRead} = 0;
382 *$obj->{UnCompSize_32bit} = 0;
383 *$obj->{TotalInflatedBytesRead} = 0;
384 *$obj->{NewStream} = 0 ;
385 *$obj->{EventEof} = 0 ;
386 *$obj->{ClassName} = $class ;
387 *$obj->{Params} = $got ;
388
389 my $status = $obj->mkUncomp($class, $got);
390
391 return undef
392 unless defined $status;
393
394 if ( ! $status) {
395 return undef
396 unless *$obj->{Transparent};
397
398 $obj->clearError();
399 *$obj->{Type} = 'plain';
400 *$obj->{Plain} = 1;
401 #$status = $obj->mkIdentityUncomp($class, $got);
402 $obj->pushBack(*$obj->{HeaderPending}) ;
403 }
404
405 push @{ *$obj->{InfoList} }, *$obj->{Info} ;
406
407 $obj->saveStatus(STATUS_OK) ;
408 *$obj->{InNew} = 0;
409 *$obj->{Closed} = 0;
410
411 return $obj;
412}
413
414sub ckInputParam
415{
416 my $self = shift ;
417 my $from = shift ;
418 my $inType = whatIsInput($_[0], $_[1]);
419
420 $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
421 if ! $inType ;
422
423 if ($inType eq 'filename' )
424 {
425 $self->croakError("$from: input filename is undef or null string")
426 if ! defined $_[0] || $_[0] eq '' ;
427
428 if ($_[0] ne '-' && ! -e $_[0] )
429 {
430 return $self->saveErrorString(undef,
431 "input file '$_[0]' does not exist", STATUS_ERROR);
432 }
433 }
434
435 return 1;
436}
437
438
439sub _inf
440{
441 my $obj = shift ;
442
443 my $class = (caller)[0] ;
444 my $name = (caller(1))[3] ;
445
446 $obj->croakError("$name: expected at least 1 parameters\n")
447 unless @_ >= 1 ;
448
449 my $input = shift ;
450 my $haveOut = @_ ;
451 my $output = shift ;
452
453
454 my $x = new Validator($class, *$obj->{Error}, $name, $input, $output)
455 or return undef ;
456
457 push @_, $output if $haveOut && $x->{Hash};
458
459 my $got = $obj->checkParams($name, undef, @_)
460 or return undef ;
461
462 $x->{Got} = $got ;
463
464 if ($x->{Hash})
465 {
466 while (my($k, $v) = each %$input)
467 {
468 $v = \$input->{$k}
469 unless defined $v ;
470
471 $obj->_singleTarget($x, 1, $k, $v, @_)
472 or return undef ;
473 }
474
475 return keys %$input ;
476 }
477
478 if ($x->{GlobMap})
479 {
480 $x->{oneInput} = 1 ;
481 foreach my $pair (@{ $x->{Pairs} })
482 {
483 my ($from, $to) = @$pair ;
484 $obj->_singleTarget($x, 1, $from, $to, @_)
485 or return undef ;
486 }
487
488 return scalar @{ $x->{Pairs} } ;
489 }
490
491 #if ($x->{outType} eq 'array' || $x->{outType} eq 'hash')
492 if (! $x->{oneOutput} )
493 {
494 my $inFile = ($x->{inType} eq 'filenames'
495 || $x->{inType} eq 'filename');
496
497 $x->{inType} = $inFile ? 'filename' : 'buffer';
498 my $ot = $x->{outType} ;
499 $x->{outType} = 'buffer';
500
501 foreach my $in ($x->{oneInput} ? $input : @$input)
502 {
503 my $out ;
504 $x->{oneInput} = 1 ;
505
506 $obj->_singleTarget($x, $inFile, $in, \$out, @_)
507 or return undef ;
508
509 if ($ot eq 'array')
510 { push @$output, \$out }
511 else
512 { $output->{$in} = \$out }
513 }
514
515 return 1 ;
516 }
517
518 # finally the 1 to 1 and n to 1
519 return $obj->_singleTarget($x, 1, $input, $output, @_);
520
521 croak "should not be here" ;
522}
523
524sub retErr
525{
526 my $x = shift ;
527 my $string = shift ;
528
529 ${ $x->{Error} } = $string ;
530
531 return undef ;
532}
533
534sub _singleTarget
535{
536 my $self = shift ;
537 my $x = shift ;
538 my $inputIsFilename = shift;
539 my $input = shift;
540 my $output = shift;
541
542 $x->{buff} = '' ;
543
544 my $fh ;
545 if ($x->{outType} eq 'filename') {
546 my $mode = '>' ;
547 $mode = '>>'
548 if $x->{Got}->value('Append') ;
549 $x->{fh} = new IO::File "$mode $output"
550 or return retErr($x, "cannot open file '$output': $!") ;
551 binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
552
553 }
554
555 elsif ($x->{outType} eq 'handle') {
556 $x->{fh} = $output;
557 binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
558 if ($x->{Got}->value('Append')) {
559 seek($x->{fh}, 0, SEEK_END)
560 or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
561 }
562 }
563
564
565 elsif ($x->{outType} eq 'buffer' )
566 {
567 $$output = ''
568 unless $x->{Got}->value('Append');
569 $x->{buff} = $output ;
570 }
571
572 if ($x->{oneInput})
573 {
574 defined $self->_rd2($x, $input, $inputIsFilename)
575 or return undef;
576 }
577 else
578 {
579 my $inputIsFilename = ($x->{inType} ne 'array');
580
581 for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
582 {
583 defined $self->_rd2($x, $element, $inputIsFilename)
584 or return undef ;
585 }
586 }
587
588
589 if ( ($x->{outType} eq 'filename' && $output ne '-') ||
590 ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
591 $x->{fh}->close()
592 or return retErr($x, $!);
593 #or return $gunzip->saveErrorString(undef, $!, $!);
594 delete $x->{fh};
595 }
596
597 return 1 ;
598}
599
600sub _rd2
601{
602 my $self = shift ;
603 my $x = shift ;
604 my $input = shift;
605 my $inputIsFilename = shift;
606
607 my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
608
609 $z->_create($x->{Got}, 1, $input, @_)
610 or return undef ;
611
612 my $status ;
613 my $fh = $x->{fh};
614
615 while (($status = $z->read($x->{buff})) > 0) {
616 if ($fh) {
617 print $fh $x->{buff}
618 or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
619 $x->{buff} = '' ;
620 }
621 }
622
623 return $z->closeError(undef)
624 if $status < 0 ;
625
626 $z->close()
627 or return undef ;
628
629 return 1 ;
630}
631
632sub TIEHANDLE
633{
634 return $_[0] if ref($_[0]);
635 die "OOPS\n" ;
636
637}
638
639sub UNTIE
640{
641 my $self = shift ;
642}
643
644
645sub getHeaderInfo
646{
647 my $self = shift ;
648 wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
649}
650
651sub readBlock
652{
653 my $self = shift ;
654 my $buff = shift ;
655 my $size = shift ;
656
657 if (defined *$self->{CompressedInputLength}) {
658 if (*$self->{CompressedInputLengthRemaining} == 0) {
659 delete *$self->{CompressedInputLength};
660 *$self->{CompressedInputLengthDone} = 1;
661 return STATUS_OK ;
662 }
663 $size = min($size, *$self->{CompressedInputLengthRemaining} );
664 *$self->{CompressedInputLengthRemaining} -= $size ;
665 }
666
667 my $status = $self->smartRead($buff, $size) ;
668 return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
669 if $status < 0 ;
670
671 if ($status == 0 ) {
672 *$self->{Closed} = 1 ;
673 *$self->{EndStream} = 1 ;
674 return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
675 }
676
677 return STATUS_OK;
678
679}
680
681sub postBlockChk
682{
683 return STATUS_OK;
684}
685
686sub _raw_read
687{
688 # return codes
689 # >0 - ok, number of bytes read
690 # =0 - ok, eof
691 # <0 - not ok
692
693 my $self = shift ;
694
695 return G_EOF if *$self->{Closed} ;
696 #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
697 return G_EOF if *$self->{EndStream} ;
698
699 my $buffer = shift ;
700 my $scan_mode = shift ;
701
702 if (*$self->{Plain}) {
703 my $tmp_buff ;
704 my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
705
706 return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
707 if $len < 0 ;
708
709 if ($len == 0 ) {
710 *$self->{EndStream} = 1 ;
711 }
712 else {
713 *$self->{PlainBytesRead} += $len ;
714 $$buffer .= $tmp_buff;
715 }
716
717 return $len ;
718 }
719
720 if (*$self->{NewStream}) {
721
722 *$self->{NewStream} = 0 ;
723 *$self->{EndStream} = 0 ;
724 *$self->{Uncomp}->reset();
725
726 return G_ERR
727 unless my $magic = $self->ckMagic();
728 *$self->{Info} = $self->readHeader($magic);
729
730 return G_ERR unless defined *$self->{Info} ;
731
732 push @{ *$self->{InfoList} }, *$self->{Info} ;
733
734 # For the headers that actually uncompressed data, put the
735 # uncompressed data into the output buffer.
736 $$buffer .= *$self->{Pending} ;
737 my $len = length *$self->{Pending} ;
738 *$self->{Pending} = '';
739 return $len;
740 }
741
742 my $temp_buf ;
743 my $outSize = 0;
744 my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
745 return G_ERR
746 if $status == STATUS_ERROR ;
747
748 my $buf_len = 0;
749 if ($status == STATUS_OK) {
750 my $before_len = defined $$buffer ? length $$buffer : 0 ;
751 $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
752 defined *$self->{CompressedInputLengthDone} ||
753 $self->smartEof(), $outSize);
754# (defined *$self->{CompressedInputLength} &&
755# *$self->{CompressedInputLengthRemaining} < 0) ||
756# $self->smartEof(), $outSize);
757
758 return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
759 if $self->saveStatus($status) == STATUS_ERROR;
760
761 $self->postBlockChk($buffer) == STATUS_OK
762 or return G_ERR;
763
764 #$buf_len = *$self->{Uncomp}->count();
765 $buf_len = length($$buffer) - $before_len;
766
767
768 *$self->{InflatedBytesRead} += $buf_len ;
769 *$self->{TotalInflatedBytesRead} += $buf_len ;
770 my $rest = 0xFFFFFFFF - *$self->{UnCompSize_32bit} ;
771 if ($buf_len > $rest) {
772 *$self->{UnCompSize_32bit} = $buf_len - $rest - 1;
773 }
774 else {
775 *$self->{UnCompSize_32bit} += $buf_len ;
776 }
777 }
778
779 if ($status == STATUS_ENDSTREAM) {
780
781 *$self->{EndStream} = 1 ;
782 $self->pushBack($temp_buf) ;
783 $temp_buf = '';
784
785 my $trailer;
786 my $trailer_size = *$self->{Info}{TrailerLength} ;
787 my $got = 0;
788 if (*$self->{Info}{TrailerLength})
789 {
790 $got = $self->smartRead(\$trailer, $trailer_size) ;
791 }
792
793 if ($got == $trailer_size) {
794 $self->chkTrailer($trailer) == STATUS_OK
795 or return G_ERR;
796 }
797 else {
798 return $self->TrailerError("trailer truncated. Expected " .
799 "$trailer_size bytes, got $got")
800 if *$self->{Strict};
801 $self->pushBack($trailer) ;
802 }
803
804 if (*$self->{MultiStream} && ! $self->smartEof()) {
805 #&& (length $temp_buf || ! $self->smartEof())){
806 *$self->{NewStream} = 1 ;
807 *$self->{EndStream} = 0 ;
808 return $buf_len ;
809 }
810
811 }
812
813
814 # return the number of uncompressed bytes read
815 return $buf_len ;
816}
817
818#sub isEndStream
819#{
820# my $self = shift ;
821# return *$self->{NewStream} ||
822# *$self->{EndStream} ;
823#}
824
825sub streamCount
826{
827 my $self = shift ;
828 return 1 if ! defined *$self->{InfoList};
829 return scalar @{ *$self->{InfoList} } ;
830}
831
832sub read
833{
834 # return codes
835 # >0 - ok, number of bytes read
836 # =0 - ok, eof
837 # <0 - not ok
838
839 my $self = shift ;
840
841 return G_EOF if *$self->{Closed} ;
842 return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
843
844 my $buffer ;
845
846 #$self->croakError(*$self->{ClassName} .
847 # "::read: buffer parameter is read-only")
848 # if Compress::Raw::Zlib::_readonly_ref($_[0]);
849
850 if (ref $_[0] ) {
851 $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
852 if readonly(${ $_[0] });
853
854 $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
855 unless ref $_[0] eq 'SCALAR' ;
856 $buffer = $_[0] ;
857 }
858 else {
859 $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
860 if readonly($_[0]);
861
862 $buffer = \$_[0] ;
863 }
864
865 my $length = $_[1] ;
866 my $offset = $_[2] || 0;
867
868 # the core read will return 0 if asked for 0 bytes
869 return 0 if defined $length && $length == 0 ;
870
871 $length = $length || 0;
872
873 $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
874 if $length < 0 ;
875
876 $$buffer = '' unless *$self->{AppendOutput} || $offset ;
877
878 # Short-circuit if this is a simple read, with no length
879 # or offset specified.
880 unless ( $length || $offset) {
881 if (length *$self->{Pending}) {
882 $$buffer .= *$self->{Pending} ;
883 my $len = length *$self->{Pending};
884 *$self->{Pending} = '' ;
885 return $len ;
886 }
887 else {
888 my $len = 0;
889 $len = $self->_raw_read($buffer)
890 while ! *$self->{EndStream} && $len == 0 ;
891 return $len ;
892 }
893 }
894
895 # Need to jump through more hoops - either length or offset
896 # or both are specified.
897 my $out_buffer = \*$self->{Pending} ;
898
899 while (! *$self->{EndStream} && length($$out_buffer) < $length)
900 {
901 my $buf_len = $self->_raw_read($out_buffer);
902 return $buf_len
903 if $buf_len < 0 ;
904 }
905
906 $length = length $$out_buffer
907 if length($$out_buffer) < $length ;
908
909 if ($offset) {
910 $$buffer .= "\x00" x ($offset - length($$buffer))
911 if $offset > length($$buffer) ;
912 #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
913 substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
914 substr($$out_buffer, 0, $length) = '' ;
915 }
916 else {
917 #$$buffer .= substr($$out_buffer, 0, $length, '') ;
918 $$buffer .= substr($$out_buffer, 0, $length) ;
919 substr($$out_buffer, 0, $length) = '' ;
920 }
921
922 return $length ;
923}
924
925sub _getline
926{
927 my $self = shift ;
928
929 # Slurp Mode
930 if ( ! defined $/ ) {
931 my $data ;
932 1 while $self->read($data) > 0 ;
933 $. = ++ *$self->{LineNo} if defined($data);
934 return \$data ;
935 }
936
937 # Paragraph Mode
938 if ( ! length $/ ) {
939 my $paragraph ;
940 while ($self->read($paragraph) > 0 ) {
941 if ($paragraph =~ s/^(.*?\n\n+)//s) {
942 *$self->{Pending} = $paragraph ;
943 my $par = $1 ;
944 $. = ++ *$self->{LineNo} ;
945 return \$par ;
946 }
947 }
948 $. = ++ *$self->{LineNo} if defined($paragraph);
949 return \$paragraph;
950 }
951
952 # Line Mode
953 {
954 my $line ;
955 my $endl = quotemeta($/); # quote in case $/ contains RE meta chars
956 while ($self->read($line) > 0 ) {
957 if ($line =~ s/^(.*?$endl)//s) {
958 *$self->{Pending} = $line ;
959 $. = ++ *$self->{LineNo} ;
960 my $l = $1 ;
961 return \$l ;
962 }
963 }
964 $. = ++ *$self->{LineNo} if defined($line);
965 return \$line;
966 }
967}
968
969sub getline
970{
971 my $self = shift;
972 my $current_append = *$self->{AppendOutput} ;
973 *$self->{AppendOutput} = 1;
974 my $lineref = $self->_getline();
975 *$self->{AppendOutput} = $current_append;
976 return $$lineref ;
977}
978
979sub getlines
980{
981 my $self = shift;
982 $self->croakError(*$self->{ClassName} .
983 "::getlines: called in scalar context\n") unless wantarray;
984 my($line, @lines);
985 push(@lines, $line) while defined($line = $self->getline);
986 return @lines;
987}
988
989sub READLINE
990{
991 goto &getlines if wantarray;
992 goto &getline;
993}
994
995sub getc
996{
997 my $self = shift;
998 my $buf;
999 return $buf if $self->read($buf, 1);
1000 return undef;
1001}
1002
1003sub ungetc
1004{
1005 my $self = shift;
1006 *$self->{Pending} = "" unless defined *$self->{Pending} ;
1007 *$self->{Pending} = $_[0] . *$self->{Pending} ;
1008}
1009
1010
1011sub trailingData
1012{
1013 my $self = shift ;
1014 #return \"" if ! defined *$self->{Trailing} ;
1015 #return \*$self->{Trailing} ;
1016
1017 if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
1018 return *$self->{Prime} ;
1019 }
1020 else {
1021 my $buf = *$self->{Buffer} ;
1022 my $offset = *$self->{BufferOffset} ;
1023 return substr($$buf, $offset, -1) ;
1024 }
1025}
1026
1027
1028sub eof
1029{
1030 my $self = shift ;
1031
1032 return (*$self->{Closed} ||
1033 (!length *$self->{Pending}
1034 && ( $self->smartEof() || *$self->{EndStream}))) ;
1035}
1036
1037sub tell
1038{
1039 my $self = shift ;
1040
1041 my $in ;
1042 if (*$self->{Plain}) {
1043 $in = *$self->{PlainBytesRead} ;
1044 }
1045 else {
1046 $in = *$self->{TotalInflatedBytesRead} ;
1047 }
1048
1049 my $pending = length *$self->{Pending} ;
1050
1051 return 0 if $pending > $in ;
1052 return $in - $pending ;
1053}
1054
1055sub close
1056{
1057 # todo - what to do if close is called before the end of the gzip file
1058 # do we remember any trailing data?
1059 my $self = shift ;
1060
1061 return 1 if *$self->{Closed} ;
1062
1063 untie *$self
1064 if $] >= 5.008 ;
1065
1066 my $status = 1 ;
1067
1068 if (defined *$self->{FH}) {
1069 if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
1070 #if ( *$self->{AutoClose}) {
1071 local $.;
1072 $! = 0 ;
1073 $status = *$self->{FH}->close();
1074 return $self->saveErrorString(0, $!, $!)
1075 if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
1076 }
1077 delete *$self->{FH} ;
1078 $! = 0 ;
1079 }
1080 *$self->{Closed} = 1 ;
1081
1082 return 1;
1083}
1084
1085sub DESTROY
1086{
1087 my $self = shift ;
1088 $self->close() ;
1089}
1090
1091sub seek
1092{
1093 my $self = shift ;
1094 my $position = shift;
1095 my $whence = shift ;
1096
1097 my $here = $self->tell() ;
1098 my $target = 0 ;
1099
1100
1101 if ($whence == SEEK_SET) {
1102 $target = $position ;
1103 }
1104 elsif ($whence == SEEK_CUR) {
1105 $target = $here + $position ;
1106 }
1107 elsif ($whence == SEEK_END) {
1108 $target = $position ;
1109 $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
1110 }
1111 else {
1112 $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
1113 }
1114
1115 # short circuit if seeking to current offset
1116 return 1 if $target == $here ;
1117
1118 # Outlaw any attempt to seek backwards
1119 $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
1120 if $target < $here ;
1121
1122 # Walk the file to the new offset
1123 my $offset = $target - $here ;
1124
1125 my $buffer ;
1126 $self->read($buffer, $offset) == $offset
1127 or return 0 ;
1128
1129 return 1 ;
1130}
1131
1132sub fileno
1133{
1134 my $self = shift ;
1135 return defined *$self->{FH}
1136 ? fileno *$self->{FH}
1137 : undef ;
1138}
1139
1140sub binmode
1141{
1142 1;
1143# my $self = shift ;
1144# return defined *$self->{FH}
1145# ? binmode *$self->{FH}
1146# : 1 ;
1147}
1148
1149sub opened
1150{
1151 my $self = shift ;
1152 return ! *$self->{Closed} ;
1153}
1154
1155sub autoflush
1156{
1157 my $self = shift ;
1158 return defined *$self->{FH}
1159 ? *$self->{FH}->autoflush(@_)
1160 : undef ;
1161}
1162
1163sub input_line_number
1164{
1165 my $self = shift ;
1166 my $last = *$self->{LineNo};
1167 $. = *$self->{LineNo} = $_[1] if @_ ;
1168 return $last;
1169}
1170
1171
1172*BINMODE = \&binmode;
1173*SEEK = \&seek;
1174*READ = \&read;
1175*sysread = \&read;
1176*TELL = \&tell;
1177*EOF = \&eof;
1178
1179*FILENO = \&fileno;
1180*CLOSE = \&close;
1181
1182sub _notAvailable
1183{
1184 my $name = shift ;
1185 #return sub { croak "$name Not Available" ; } ;
1186 return sub { croak "$name Not Available: File opened only for intput" ; } ;
1187}
1188
1189
1190*print = _notAvailable('print');
1191*PRINT = _notAvailable('print');
1192*printf = _notAvailable('printf');
1193*PRINTF = _notAvailable('printf');
1194*write = _notAvailable('write');
1195*WRITE = _notAvailable('write');
1196
1197#*sysread = \&read;
1198#*syswrite = \&_notAvailable;
1199
1200#package IO::_infScan ;
1201#
1202#*_raw_read = \&IO::Uncompress::Base::_raw_read ;
1203#*smartRead = \&IO::Uncompress::Base::smartRead ;
1204#*smartWrite = \&IO::Uncompress::Base::smartWrite ;
1205#*smartSeek = \&IO::Uncompress::Base::smartSeek ;
1206
1207#sub mkIdentityUncomp
1208#{
1209# my $self = shift ;
1210# my $class = shift ;
1211# my $got = shift ;
1212#
1213# *$self->{Uncomp} = UncompressPlugin::Identity::mkUncompObject($self, $class, $got)
1214# or return undef;
1215#
1216# return 1;
1217#
1218#}
1219#
1220#
1221#package UncompressPlugin::Identity;
1222#
1223#use strict ;
1224#use warnings;
1225#
1226#our ($VERSION, @ISA, @EXPORT);
1227#
1228#$VERSION = '2.000_05';
1229#
1230#use constant STATUS_OK => 0;
1231#use constant STATUS_ENDSTREAM => 1;
1232#use constant STATUS_ERROR => 2;
1233#
1234#sub mkUncompObject
1235#{
1236# my $class = shift ;
1237#
1238# bless { 'CompSize' => 0,
1239# 'UnCompSize' => 0,
1240# 'CRC32' => 0,
1241# 'ADLER32' => 0,
1242# }, __PACKAGE__ ;
1243#}
1244#
1245#sub uncompr
1246#{
1247# my $self = shift ;
1248# my $from = shift ;
1249# my $to = shift ;
1250# my $eof = shift ;
1251#
1252#
1253# $self->{CompSize} += length $$from ;
1254# $self->{UnCompSize} = $self->{CompSize} ;
1255#
1256# $$to = $$from ;
1257#
1258# return STATUS_ENDSTREAM if $eof;
1259# return STATUS_OK ;
1260#}
1261#
1262#sub count
1263#{
1264# my $self = shift ;
1265# return $self->{UnCompSize} ;
1266#}
1267#
1268#sub sync
1269#{
1270# return STATUS_OK ;
1271#}
1272#
1273#
1274#sub reset
1275#{
1276# return STATUS_OK ;
1277#}
1278
1279
1280package IO::Uncompress::Base ;
1281
1282
12831 ;
1284__END__
1285
1286=head1 NAME
1287
1288
1289IO::Uncompress::Base - Base Class for IO::Uncompress modules
1290
1291
1292=head1 SYNOPSIS
1293
1294 use IO::Uncompress::Base ;
1295
1296=head1 DESCRIPTION
1297
1298
1299This module is not intended for direct use in application code. Its sole
1300purpose if to to be sub-classed by IO::Unompress modules.
1301
1302
1303
1304
1305=head1 SEE ALSO
1306
1307L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress>
1308
1309L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
1310
1311L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1312L<Archive::Tar|Archive::Tar>,
1313L<IO::Zlib|IO::Zlib>
1314
1315
1316
1317
1318
1319
1320
1321
1322=head1 AUTHOR
1323
1324The I<IO::Uncompress::Base> module was written by Paul Marquess,
1325F<pmqs@cpan.org>.
1326
1327
1328
1329=head1 MODIFICATION HISTORY
1330
1331See the Changes file.
1332
1333=head1 COPYRIGHT AND LICENSE
1334
1335
1336Copyright (c) 2005-2006 Paul Marquess. All rights reserved.
1337
1338This program is free software; you can redistribute it and/or
1339modify it under the same terms as Perl itself.
1340
1341
Unnamed repository; edit this file to name it for gitweb.