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