Update IO-Compress to CPAN version 2.060
[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.060';
13
14 use constant G_EOF => 0 ;
15 use constant G_ERR => -1 ;
16
17 use IO::Compress::Base::Common 2.060 ;
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                 syswrite $fh, ${ $x->{buff} }
760                     or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
761                 ${ $x->{buff} } = '' ;
762             }
763         }
764
765         if (! $x->{oneOutput} ) {
766             my $ot = $x->{outType} ;
767
768             if ($ot eq 'array') 
769               { push @$output, $x->{buff} }
770             elsif ($ot eq 'hash') 
771               { $output->{$input} = $x->{buff} }
772
773             my $buff = '';
774             $x->{buff} = \$buff;
775         }
776
777         last if $status < 0 || $z->smartEof();
778
779         last 
780             unless *$self->{MultiStream};
781
782         $status = $z->nextStream();
783
784         last 
785             unless $status == 1 ;
786     }
787
788     return $z->closeError(undef)
789         if $status < 0 ;
790
791     ${ *$self->{TrailingData} } = $z->trailingData()
792         if defined *$self->{TrailingData} ;
793
794     $z->close() 
795         or return undef ;
796
797     return 1 ;
798 }
799
800 sub TIEHANDLE
801 {
802     return $_[0] if ref($_[0]);
803     die "OOPS\n" ;
804
805 }
806   
807 sub UNTIE
808 {
809     my $self = shift ;
810 }
811
812
813 sub getHeaderInfo
814 {
815     my $self = shift ;
816     wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
817 }
818
819 sub readBlock
820 {
821     my $self = shift ;
822     my $buff = shift ;
823     my $size = shift ;
824
825     if (defined *$self->{CompressedInputLength}) {
826         if (*$self->{CompressedInputLengthRemaining} == 0) {
827             delete *$self->{CompressedInputLength};
828             *$self->{CompressedInputLengthDone} = 1;
829             return STATUS_OK ;
830         }
831         $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} );
832         *$self->{CompressedInputLengthRemaining} -= $size ;
833     }
834     
835     my $status = $self->smartRead($buff, $size) ;
836     return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!)
837         if $status == STATUS_ERROR  ;
838
839     if ($status == 0 ) {
840         *$self->{Closed} = 1 ;
841         *$self->{EndStream} = 1 ;
842         return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
843     }
844
845     return STATUS_OK;
846 }
847
848 sub postBlockChk
849 {
850     return STATUS_OK;
851 }
852
853 sub _raw_read
854 {
855     # return codes
856     # >0 - ok, number of bytes read
857     # =0 - ok, eof
858     # <0 - not ok
859     
860     my $self = shift ;
861
862     return G_EOF if *$self->{Closed} ;
863     return G_EOF if *$self->{EndStream} ;
864
865     my $buffer = shift ;
866     my $scan_mode = shift ;
867
868     if (*$self->{Plain}) {
869         my $tmp_buff ;
870         my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
871         
872         return $self->saveErrorString(G_ERR, "Error reading data: $!", $!) 
873                 if $len == STATUS_ERROR ;
874
875         if ($len == 0 ) {
876             *$self->{EndStream} = 1 ;
877         }
878         else {
879             *$self->{PlainBytesRead} += $len ;
880             $$buffer .= $tmp_buff;
881         }
882
883         return $len ;
884     }
885
886     if (*$self->{NewStream}) {
887
888         $self->gotoNextStream() > 0
889             or return G_ERR;
890
891         # For the headers that actually uncompressed data, put the
892         # uncompressed data into the output buffer.
893         $$buffer .=  *$self->{Pending} ;
894         my $len = length  *$self->{Pending} ;
895         *$self->{Pending} = '';
896         return $len; 
897     }
898
899     my $temp_buf = '';
900     my $outSize = 0;
901     my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
902     
903     return G_ERR
904         if $status == STATUS_ERROR  ;
905
906     my $buf_len = 0;
907     if ($status == STATUS_OK) {
908         my $beforeC_len = length $temp_buf;
909         my $before_len = defined $$buffer ? length $$buffer : 0 ;
910         $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
911                                     defined *$self->{CompressedInputLengthDone} ||
912                                                 $self->smartEof(), $outSize);
913                                                 
914         # Remember the input buffer if it wasn't consumed completely
915         $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput};
916
917         return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
918             if $self->saveStatus($status) == STATUS_ERROR;    
919
920         $self->postBlockChk($buffer, $before_len) == STATUS_OK
921             or return G_ERR;
922
923         $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0;
924     
925         *$self->{CompSize}->add($beforeC_len - length $temp_buf) ;
926
927         *$self->{InflatedBytesRead} += $buf_len ;
928         *$self->{TotalInflatedBytesRead} += $buf_len ;
929         *$self->{UnCompSize}->add($buf_len) ;
930
931         $self->filterUncompressed($buffer, $before_len);
932
933 #        if (*$self->{Encoding}) {
934 #            use Encode ;
935 #            *$self->{PendingDecode} .= substr($$buffer, $before_len) ;
936 #            my $got = *$self->{Encoding}->decode(*$self->{PendingDecode}, Encode::FB_QUIET) ;
937 #            substr($$buffer, $before_len) = $got;
938 #        }
939     }
940
941     if ($status == STATUS_ENDSTREAM) {
942
943         *$self->{EndStream} = 1 ;
944
945         my $trailer;
946         my $trailer_size = *$self->{Info}{TrailerLength} ;
947         my $got = 0;
948         if (*$self->{Info}{TrailerLength})
949         {
950             $got = $self->smartRead(\$trailer, $trailer_size) ;
951         }
952
953         if ($got == $trailer_size) {
954             $self->chkTrailer($trailer) == STATUS_OK
955                 or return G_ERR;
956         }
957         else {
958             return $self->TrailerError("trailer truncated. Expected " . 
959                                       "$trailer_size bytes, got $got")
960                 if *$self->{Strict};
961             $self->pushBack($trailer)  ;
962         }
963
964         # TODO - if want to file file pointer, do it here
965
966         if (! $self->smartEof()) {
967             *$self->{NewStream} = 1 ;
968
969             if (*$self->{MultiStream}) {
970                 *$self->{EndStream} = 0 ;
971                 return $buf_len ;
972             }
973         }
974
975     }
976     
977
978     # return the number of uncompressed bytes read
979     return $buf_len ;
980 }
981
982 sub reset
983 {
984     my $self = shift ;
985
986     return *$self->{Uncomp}->reset();
987 }
988
989 sub filterUncompressed
990 {
991 }
992
993 #sub isEndStream
994 #{
995 #    my $self = shift ;
996 #    return *$self->{NewStream} ||
997 #           *$self->{EndStream} ;
998 #}
999
1000 sub nextStream
1001 {
1002     my $self = shift ;
1003
1004     my $status = $self->gotoNextStream();
1005     $status == 1
1006         or return $status ;
1007
1008     *$self->{TotalInflatedBytesRead} = 0 ;
1009     *$self->{LineNo} = $. = 0;
1010
1011     return 1;
1012 }
1013
1014 sub gotoNextStream
1015 {
1016     my $self = shift ;
1017
1018     if (! *$self->{NewStream}) {
1019         my $status = 1;
1020         my $buffer ;
1021
1022         # TODO - make this more efficient if know the offset for the end of
1023         # the stream and seekable
1024         $status = $self->read($buffer) 
1025             while $status > 0 ;
1026
1027         return $status
1028             if $status < 0;
1029     }
1030
1031     *$self->{NewStream} = 0 ;
1032     *$self->{EndStream} = 0 ;
1033     *$self->{CompressedInputLengthDone} = undef ;
1034     *$self->{CompressedInputLength} = undef ;
1035     $self->reset();
1036     *$self->{UnCompSize}->reset();
1037     *$self->{CompSize}->reset();
1038
1039     my $magic = $self->ckMagic();
1040
1041     if ( ! defined $magic) {
1042         if (! *$self->{Transparent} || $self->eof())
1043         {
1044             *$self->{EndStream} = 1 ;
1045             return 0;
1046         }
1047
1048         $self->clearError();
1049         *$self->{Type} = 'plain';
1050         *$self->{Plain} = 1;
1051         $self->pushBack(*$self->{HeaderPending})  ;
1052     }
1053     else
1054     {
1055         *$self->{Info} = $self->readHeader($magic);
1056
1057         if ( ! defined *$self->{Info} ) {
1058             *$self->{EndStream} = 1 ;
1059             return -1;
1060         }
1061     }
1062
1063     push @{ *$self->{InfoList} }, *$self->{Info} ;
1064
1065     return 1; 
1066 }
1067
1068 sub streamCount
1069 {
1070     my $self = shift ;
1071     return 1 if ! defined *$self->{InfoList};
1072     return scalar @{ *$self->{InfoList} }  ;
1073 }
1074
1075 #sub read
1076 #{
1077 #    my $status = myRead(@_);
1078 #    return undef if $status < 0;
1079 #    return $status;
1080 #}
1081
1082 sub read
1083 {
1084     # return codes
1085     # >0 - ok, number of bytes read
1086     # =0 - ok, eof
1087     # <0 - not ok
1088     
1089     my $self = shift ;
1090
1091     if (defined *$self->{ReadStatus} ) {
1092         my $status = *$self->{ReadStatus}[0];
1093         $self->saveErrorString( @{ *$self->{ReadStatus} } );
1094         delete  *$self->{ReadStatus} ;
1095         return $status ;
1096     }
1097
1098     return G_EOF if *$self->{Closed} ;
1099
1100     my $buffer ;
1101
1102     if (ref $_[0] ) {
1103         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1104             if Scalar::Util::readonly(${ $_[0] });
1105
1106         $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
1107             unless ref $_[0] eq 'SCALAR' ;
1108         $buffer = $_[0] ;
1109     }
1110     else {
1111         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1112             if Scalar::Util::readonly($_[0]);
1113
1114         $buffer = \$_[0] ;
1115     }
1116
1117     my $length = $_[1] ;
1118     my $offset = $_[2] || 0;
1119
1120     if (! *$self->{AppendOutput}) {
1121         if (! $offset) {    
1122             $$buffer = '' ;
1123         }
1124         else {
1125             if ($offset > length($$buffer)) {
1126                 $$buffer .= "\x00" x ($offset - length($$buffer));
1127             }
1128             else {
1129                 substr($$buffer, $offset) = '';
1130             }
1131         }
1132     }
1133     elsif (! defined $$buffer) {
1134         $$buffer = '' ;
1135     }
1136
1137     return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
1138
1139     # the core read will return 0 if asked for 0 bytes
1140     return 0 if defined $length && $length == 0 ;
1141
1142     $length = $length || 0;
1143
1144     $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
1145         if $length < 0 ;
1146
1147     # Short-circuit if this is a simple read, with no length
1148     # or offset specified.
1149     unless ( $length || $offset) {
1150         if (length *$self->{Pending}) {
1151             $$buffer .= *$self->{Pending} ;
1152             my $len = length *$self->{Pending};
1153             *$self->{Pending} = '' ;
1154             return $len ;
1155         }
1156         else {
1157             my $len = 0;
1158             $len = $self->_raw_read($buffer) 
1159                 while ! *$self->{EndStream} && $len == 0 ;
1160             return $len ;
1161         }
1162     }
1163
1164     # Need to jump through more hoops - either length or offset 
1165     # or both are specified.
1166     my $out_buffer = *$self->{Pending} ;
1167     *$self->{Pending} = '';
1168
1169
1170     while (! *$self->{EndStream} && length($out_buffer) < $length)
1171     {
1172         my $buf_len = $self->_raw_read(\$out_buffer);
1173         return $buf_len 
1174             if $buf_len < 0 ;
1175     }
1176
1177     $length = length $out_buffer 
1178         if length($out_buffer) < $length ;
1179
1180     return 0 
1181         if $length == 0 ;
1182
1183     $$buffer = '' 
1184         if ! defined $$buffer;
1185
1186     $offset = length $$buffer
1187         if *$self->{AppendOutput} ;
1188
1189     *$self->{Pending} = $out_buffer;
1190     $out_buffer = \*$self->{Pending} ;
1191
1192     substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
1193     substr($$out_buffer, 0, $length) =  '' ;
1194
1195     return $length ;
1196 }
1197
1198 sub _getline
1199 {
1200     my $self = shift ;
1201     my $status = 0 ;
1202
1203     # Slurp Mode
1204     if ( ! defined $/ ) {
1205         my $data ;
1206         1 while ($status = $self->read($data)) > 0 ;
1207         return ($status, \$data);
1208     }
1209
1210     # Record Mode
1211     if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
1212         my $reclen = ${$/} ;
1213         my $data ;
1214         $status = $self->read($data, $reclen) ;
1215         return ($status, \$data);
1216     }
1217
1218     # Paragraph Mode
1219     if ( ! length $/ ) {
1220         my $paragraph ;    
1221         while (($status = $self->read($paragraph)) > 0 ) {
1222             if ($paragraph =~ s/^(.*?\n\n+)//s) {
1223                 *$self->{Pending}  = $paragraph ;
1224                 my $par = $1 ;
1225                 return (1, \$par);
1226             }
1227         }
1228         return ($status, \$paragraph);
1229     }
1230
1231     # $/ isn't empty, or a reference, so it's Line Mode.
1232     {
1233         my $line ;    
1234         my $p = \*$self->{Pending}  ;
1235         while (($status = $self->read($line)) > 0 ) {
1236             my $offset = index($line, $/);
1237             if ($offset >= 0) {
1238                 my $l = substr($line, 0, $offset + length $/ );
1239                 substr($line, 0, $offset + length $/) = '';    
1240                 $$p = $line;
1241                 return (1, \$l);
1242             }
1243         }
1244
1245         return ($status, \$line);
1246     }
1247 }
1248
1249 sub getline
1250 {
1251     my $self = shift;
1252
1253     if (defined *$self->{ReadStatus} ) {
1254         $self->saveErrorString( @{ *$self->{ReadStatus} } );
1255         delete  *$self->{ReadStatus} ;
1256         return undef;
1257     }
1258
1259     return undef 
1260         if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ;
1261
1262     my $current_append = *$self->{AppendOutput} ;
1263     *$self->{AppendOutput} = 1;
1264
1265     my ($status, $lineref) = $self->_getline();
1266     *$self->{AppendOutput} = $current_append;
1267
1268     return undef 
1269         if $status < 0 || length $$lineref == 0 ;
1270
1271     $. = ++ *$self->{LineNo} ;
1272
1273     return $$lineref ;
1274 }
1275
1276 sub getlines
1277 {
1278     my $self = shift;
1279     $self->croakError(*$self->{ClassName} . 
1280             "::getlines: called in scalar context\n") unless wantarray;
1281     my($line, @lines);
1282     push(@lines, $line) 
1283         while defined($line = $self->getline);
1284     return @lines;
1285 }
1286
1287 sub READLINE
1288 {
1289     goto &getlines if wantarray;
1290     goto &getline;
1291 }
1292
1293 sub getc
1294 {
1295     my $self = shift;
1296     my $buf;
1297     return $buf if $self->read($buf, 1);
1298     return undef;
1299 }
1300
1301 sub ungetc
1302 {
1303     my $self = shift;
1304     *$self->{Pending} = ""  unless defined *$self->{Pending} ;    
1305     *$self->{Pending} = $_[0] . *$self->{Pending} ;    
1306 }
1307
1308
1309 sub trailingData
1310 {
1311     my $self = shift ;
1312
1313     if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
1314         return *$self->{Prime} ;
1315     }
1316     else {
1317         my $buf = *$self->{Buffer} ;
1318         my $offset = *$self->{BufferOffset} ;
1319         return substr($$buf, $offset) ;
1320     }
1321 }
1322
1323
1324 sub eof
1325 {
1326     my $self = shift ;
1327
1328     return (*$self->{Closed} ||
1329               (!length *$self->{Pending} 
1330                 && ( $self->smartEof() || *$self->{EndStream}))) ;
1331 }
1332
1333 sub tell
1334 {
1335     my $self = shift ;
1336
1337     my $in ;
1338     if (*$self->{Plain}) {
1339         $in = *$self->{PlainBytesRead} ;
1340     }
1341     else {
1342         $in = *$self->{TotalInflatedBytesRead} ;
1343     }
1344
1345     my $pending = length *$self->{Pending} ;
1346
1347     return 0 if $pending > $in ;
1348     return $in - $pending ;
1349 }
1350
1351 sub close
1352 {
1353     # todo - what to do if close is called before the end of the gzip file
1354     #        do we remember any trailing data?
1355     my $self = shift ;
1356
1357     return 1 if *$self->{Closed} ;
1358
1359     untie *$self 
1360         if $] >= 5.008 ;
1361
1362     my $status = 1 ;
1363
1364     if (defined *$self->{FH}) {
1365         if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
1366             local $.; 
1367             $! = 0 ;
1368             $status = *$self->{FH}->close();
1369             return $self->saveErrorString(0, $!, $!)
1370                 if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
1371         }
1372         delete *$self->{FH} ;
1373         $! = 0 ;
1374     }
1375     *$self->{Closed} = 1 ;
1376
1377     return 1;
1378 }
1379
1380 sub DESTROY
1381 {
1382     my $self = shift ;
1383     local ($., $@, $!, $^E, $?);
1384
1385     $self->close() ;
1386 }
1387
1388 sub seek
1389 {
1390     my $self     = shift ;
1391     my $position = shift;
1392     my $whence   = shift ;
1393
1394     my $here = $self->tell() ;
1395     my $target = 0 ;
1396
1397
1398     if ($whence == SEEK_SET) {
1399         $target = $position ;
1400     }
1401     elsif ($whence == SEEK_CUR) {
1402         $target = $here + $position ;
1403     }
1404     elsif ($whence == SEEK_END) {
1405         $target = $position ;
1406         $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
1407     }
1408     else {
1409         $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
1410     }
1411
1412     # short circuit if seeking to current offset
1413     if ($target == $here) {
1414         # On ordinary filehandles, seeking to the current
1415         # position also clears the EOF condition, so we
1416         # emulate this behavior locally while simultaneously
1417         # cascading it to the underlying filehandle
1418         if (*$self->{Plain}) {
1419             *$self->{EndStream} = 0;
1420             seek(*$self->{FH},0,1) if *$self->{FH};
1421         }
1422         return 1;
1423     }
1424
1425     # Outlaw any attempt to seek backwards
1426     $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
1427         if $target < $here ;
1428
1429     # Walk the file to the new offset
1430     my $offset = $target - $here ;
1431
1432     my $got;
1433     while (($got = $self->read(my $buffer, List::Util::min($offset, *$self->{BlockSize})) ) > 0)
1434     {
1435         $offset -= $got;
1436         last if $offset == 0 ;
1437     }
1438
1439     $here = $self->tell() ;
1440     return $offset == 0 ? 1 : 0 ;
1441 }
1442
1443 sub fileno
1444 {
1445     my $self = shift ;
1446     return defined *$self->{FH} 
1447            ? fileno *$self->{FH} 
1448            : undef ;
1449 }
1450
1451 sub binmode
1452 {
1453     1;
1454 #    my $self     = shift ;
1455 #    return defined *$self->{FH} 
1456 #            ? binmode *$self->{FH} 
1457 #            : 1 ;
1458 }
1459
1460 sub opened
1461 {
1462     my $self     = shift ;
1463     return ! *$self->{Closed} ;
1464 }
1465
1466 sub autoflush
1467 {
1468     my $self     = shift ;
1469     return defined *$self->{FH} 
1470             ? *$self->{FH}->autoflush(@_) 
1471             : undef ;
1472 }
1473
1474 sub input_line_number
1475 {
1476     my $self = shift ;
1477     my $last = *$self->{LineNo};
1478     $. = *$self->{LineNo} = $_[1] if @_ ;
1479     return $last;
1480 }
1481
1482
1483 *BINMODE  = \&binmode;
1484 *SEEK     = \&seek; 
1485 *READ     = \&read;
1486 *sysread  = \&read;
1487 *TELL     = \&tell;
1488 *EOF      = \&eof;
1489
1490 *FILENO   = \&fileno;
1491 *CLOSE    = \&close;
1492
1493 sub _notAvailable
1494 {
1495     my $name = shift ;
1496     return sub { croak "$name Not Available: File opened only for intput" ; } ;
1497 }
1498
1499
1500 *print    = _notAvailable('print');
1501 *PRINT    = _notAvailable('print');
1502 *printf   = _notAvailable('printf');
1503 *PRINTF   = _notAvailable('printf');
1504 *write    = _notAvailable('write');
1505 *WRITE    = _notAvailable('write');
1506
1507 #*sysread  = \&read;
1508 #*syswrite = \&_notAvailable;
1509
1510
1511
1512 package IO::Uncompress::Base ;
1513
1514
1515 1 ;
1516 __END__
1517
1518 =head1 NAME
1519
1520 IO::Uncompress::Base - Base Class for IO::Uncompress modules 
1521
1522 =head1 SYNOPSIS
1523
1524     use IO::Uncompress::Base ;
1525
1526 =head1 DESCRIPTION
1527
1528 This module is not intended for direct use in application code. Its sole
1529 purpose if to to be sub-classed by IO::Uncompress modules.
1530
1531 =head1 SEE ALSO
1532
1533 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>
1534
1535 L<IO::Compress::FAQ|IO::Compress::FAQ>
1536
1537 L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1538 L<Archive::Tar|Archive::Tar>,
1539 L<IO::Zlib|IO::Zlib>
1540
1541 =head1 AUTHOR
1542
1543 This module was written by Paul Marquess, F<pmqs@cpan.org>. 
1544
1545 =head1 MODIFICATION HISTORY
1546
1547 See the Changes file.
1548
1549 =head1 COPYRIGHT AND LICENSE
1550
1551 Copyright (c) 2005-2013 Paul Marquess. All rights reserved.
1552
1553 This program is free software; you can redistribute it and/or
1554 modify it under the same terms as Perl itself.
1555