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