ext/IO_Compress_Base/lib/IO/Uncompress/Base.pm

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