xref: /openbsd-src/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm (revision 9f11ffb7133c203312a01e4b986886bc88c7d74b) 
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.074';
13
14use constant G_EOF => 0 ;
15use constant G_ERR => -1 ;
16
17use IO::Compress::Base::Common 2.074 ;
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    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
165sub 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
175sub 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
193sub smartReadExact
194{
195    return $_[0]->smartRead($_[1], $_[2]) == $_[2];
196}
197
198sub 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
231sub clearError
232{
233    my $self   = shift ;
234
235    *$self->{ErrorNo}  =  0 ;
236    ${ *$self->{Error} } = '' ;
237}
238
239sub getErrInfo
240{
241    my $self   = shift ;
242
243    return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ;
244}
245
246sub setErrInfo
247{
248    my $self   = shift ;
249    my $ref    = shift;
250
251    *$self->{ErrorNo}  =  $ref->[0] ;
252    ${ *$self->{Error} } = $ref->[1] ;
253}
254
255sub 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
267sub 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
278sub croakError
279{
280    my $self   = shift ;
281    $self->saveErrorString(0, $_[0]);
282    croak $_[0];
283}
284
285
286sub 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
302sub error
303{
304    my $self   = shift ;
305    return ${ *$self->{Error} } ;
306}
307
308sub errorNo
309{
310    my $self   = shift ;
311    return *$self->{ErrorNo};
312}
313
314sub HeaderError
315{
316    my ($self) = shift;
317    return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
318}
319
320sub TrailerError
321{
322    my ($self) = shift;
323    return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
324}
325
326sub TruncatedHeader
327{
328    my ($self) = shift;
329    return $self->HeaderError("Truncated in $_[0] Section");
330}
331
332sub TruncatedTrailer
333{
334    my ($self) = shift;
335    return $self->TrailerError("Truncated in $_[0] Section");
336}
337
338sub postCheckParams
339{
340    return 1;
341}
342
343sub 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
383sub _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
532sub 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
557sub _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
667sub retErr
668{
669    my $x = shift ;
670    my $string = shift ;
671
672    ${ $x->{Error} } = $string ;
673
674    return undef ;
675}
676
677sub _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
740sub _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
801sub TIEHANDLE
802{
803    return $_[0] if ref($_[0]);
804    die "OOPS\n" ;
805
806}
807
808sub UNTIE
809{
810    my $self = shift ;
811}
812
813
814sub getHeaderInfo
815{
816    my $self = shift ;
817    wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
818}
819
820sub 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
849sub postBlockChk
850{
851    return STATUS_OK;
852}
853
854sub _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
983sub reset
984{
985    my $self = shift ;
986
987    return *$self->{Uncomp}->reset();
988}
989
990sub filterUncompressed
991{
992}
993
994#sub isEndStream
995#{
996#    my $self = shift ;
997#    return *$self->{NewStream} ||
998#           *$self->{EndStream} ;
999#}
1000
1001sub 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
1015sub 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
1069sub 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
1083sub 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
1199sub _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
1250sub 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
1277sub 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
1288sub READLINE
1289{
1290    goto &getlines if wantarray;
1291    goto &getline;
1292}
1293
1294sub getc
1295{
1296    my $self = shift;
1297    my $buf;
1298    return $buf if $self->read($buf, 1);
1299    return undef;
1300}
1301
1302sub ungetc
1303{
1304    my $self = shift;
1305    *$self->{Pending} = ""  unless defined *$self->{Pending} ;
1306    *$self->{Pending} = $_[0] . *$self->{Pending} ;
1307}
1308
1309
1310sub 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
1325sub eof
1326{
1327    my $self = shift ;
1328
1329    return (*$self->{Closed} ||
1330              (!length *$self->{Pending}
1331                && ( $self->smartEof() || *$self->{EndStream}))) ;
1332}
1333
1334sub 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
1352sub 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
1381sub DESTROY
1382{
1383    my $self = shift ;
1384    local ($., $@, $!, $^E, $?);
1385
1386    $self->close() ;
1387}
1388
1389sub 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
1444sub fileno
1445{
1446    my $self = shift ;
1447    return defined *$self->{FH}
1448           ? fileno *$self->{FH}
1449           : undef ;
1450}
1451
1452sub binmode
1453{
1454    1;
1455#    my $self     = shift ;
1456#    return defined *$self->{FH}
1457#            ? binmode *$self->{FH}
1458#            : 1 ;
1459}
1460
1461sub opened
1462{
1463    my $self     = shift ;
1464    return ! *$self->{Closed} ;
1465}
1466
1467sub autoflush
1468{
1469    my $self     = shift ;
1470    return defined *$self->{FH}
1471            ? *$self->{FH}->autoflush(@_)
1472            : undef ;
1473}
1474
1475sub 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
1494sub _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
1513package IO::Uncompress::Base ;
1514
1515
15161 ;
1517__END__
1518
1519=head1 NAME
1520
1521IO::Uncompress::Base - Base Class for IO::Uncompress modules
1522
1523=head1 SYNOPSIS
1524
1525    use IO::Uncompress::Base ;
1526
1527=head1 DESCRIPTION
1528
1529This module is not intended for direct use in application code. Its sole
1530purpose is to be sub-classed by IO::Uncompress modules.
1531
1532=head1 SEE ALSO
1533
1534L<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
1536L<IO::Compress::FAQ|IO::Compress::FAQ>
1537
1538L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1539L<Archive::Tar|Archive::Tar>,
1540L<IO::Zlib|IO::Zlib>
1541
1542=head1 AUTHOR
1543
1544This module was written by Paul Marquess, C<pmqs@cpan.org>.
1545
1546=head1 MODIFICATION HISTORY
1547
1548See the Changes file.
1549
1550=head1 COPYRIGHT AND LICENSE
1551
1552Copyright (c) 2005-2017 Paul Marquess. All rights reserved.
1553
1554This program is free software; you can redistribute it and/or
1555modify it under the same terms as Perl itself.
1556
1557