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