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