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