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

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