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

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