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