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