ext/Compress/IO/Base/lib/IO/Uncompress/Base.pm

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