git.maemo.org Git - pkg-perl/blob - deb-src/libio-compress-base-perl/libio-compress-base-perl-2.012/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.012';
  13
  14 use constant G_EOF => 0 ;
  15 use constant G_ERR => -1 ;
  16
  17 use IO::Compress::Base::Common 2.012 ;
  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) > 0 &&
  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             my $mode = '<';
 414             $mode = '+<' if $got->value('Scan');
 415             *$obj->{StdIO} = ($inValue eq '-');
 416             *$obj->{FH} = new IO::File "$mode $inValue"
 417                 or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
 418         }
 419
 420         *$obj->{LineNo} = $. = 0;
 421         setBinModeInput(*$obj->{FH}) ;
 422
 423         my $buff = "" ;
 424         *$obj->{Buffer} = \$buff ;
 425     }
 426
 427     if ($got->parsed('Encode')) {
 428         my $want_encoding = $got->value('Encode');
 429         *$obj->{Encoding} = getEncoding($obj, $class, $want_encoding);
 430     }
 431
 432
 433     *$obj->{InputLength}       = $got->parsed('InputLength')
 434                                     ? $got->value('InputLength')
 435                                     : undef ;
 436     *$obj->{InputLengthRemaining} = $got->value('InputLength');
 437     *$obj->{BufferOffset}      = 0 ;
 438     *$obj->{AutoClose}         = $got->value('AutoClose');
 439     *$obj->{Strict}            = $got->value('Strict');
 440     *$obj->{BlockSize}         = $got->value('BlockSize');
 441     *$obj->{Append}            = $got->value('Append');
 442     *$obj->{AppendOutput}      = $append_mode || $got->value('Append');
 443     *$obj->{ConsumeInput}      = $got->value('ConsumeInput');
 444     *$obj->{Transparent}       = $got->value('Transparent');
 445     *$obj->{MultiStream}       = $got->value('MultiStream');
 446
 447     # TODO - move these two into RawDeflate
 448     *$obj->{Scan}              = $got->value('Scan');
 449     *$obj->{ParseExtra}        = $got->value('ParseExtra')
 450                                   || $got->value('Strict')  ;
 451     *$obj->{Type}              = '';
 452     *$obj->{Prime}             = $got->value('Prime') || '' ;
 453     *$obj->{Pending}           = '';
 454     *$obj->{Plain}             = 0;
 455     *$obj->{PlainBytesRead}    = 0;
 456     *$obj->{InflatedBytesRead} = 0;
 457     *$obj->{UnCompSize}        = new U64;
 458     *$obj->{CompSize}          = new U64;
 459     *$obj->{TotalInflatedBytesRead} = 0;
 460     *$obj->{NewStream}         = 0 ;
 461     *$obj->{EventEof}          = 0 ;
 462     *$obj->{ClassName}         = $class ;
 463     *$obj->{Params}            = $got ;
 464
 465     if (*$obj->{ConsumeInput}) {
 466         *$obj->{InNew} = 0;
 467         *$obj->{Closed} = 0;
 468         return $obj
 469     }
 470
 471     my $status = $obj->mkUncomp($got);
 472
 473     return undef
 474         unless defined $status;
 475
 476     if ( !  $status) {
 477         return undef
 478             unless *$obj->{Transparent};
 479
 480         $obj->clearError();
 481         *$obj->{Type} = 'plain';
 482         *$obj->{Plain} = 1;
 483         #$status = $obj->mkIdentityUncomp($class, $got);
 484         $obj->pushBack(*$obj->{HeaderPending})  ;
 485     }
 486
 487     push @{ *$obj->{InfoList} }, *$obj->{Info} ;
 488
 489     $obj->saveStatus(STATUS_OK) ;
 490     *$obj->{InNew} = 0;
 491     *$obj->{Closed} = 0;
 492
 493     return $obj;
 494 }
 495
 496 sub ckInputParam
 497 {
 498     my $self = shift ;
 499     my $from = shift ;
 500     my $inType = whatIsInput($_[0], $_[1]);
 501
 502     $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
 503         if ! $inType ;
 504
 505     if ($inType  eq 'filename' )
 506     {
 507         $self->croakError("$from: input filename is undef or null string")
 508             if ! defined $_[0] || $_[0] eq ''  ;
 509
 510         if ($_[0] ne '-' && ! -e $_[0] )
 511         {
 512             return $self->saveErrorString(undef,
 513                             "input file '$_[0]' does not exist", STATUS_ERROR);
 514         }
 515     }
 516
 517     return 1;
 518 }
 519
 520
 521 sub _inf
 522 {
 523     my $obj = shift ;
 524
 525     my $class = (caller)[0] ;
 526     my $name = (caller(1))[3] ;
 527
 528     $obj->croakError("$name: expected at least 1 parameters\n")
 529         unless @_ >= 1 ;
 530
 531     my $input = shift ;
 532     my $haveOut = @_ ;
 533     my $output = shift ;
 534
 535
 536     my $x = new IO::Compress::Base::Validator($class, *$obj->{Error}, $name, $input, $output)
 537         or return undef ;
 538
 539     push @_, $output if $haveOut && $x->{Hash};
 540
 541     *$obj->{OneShot} = 1 ;
 542
 543     my $got = $obj->checkParams($name, undef, @_)
 544         or return undef ;
 545
 546     if ($got->parsed('TrailingData'))
 547     {
 548         *$obj->{TrailingData} = $got->value('TrailingData');
 549     }
 550
 551     *$obj->{MultiStream} = $got->value('MultiStream');
 552     $got->value('MultiStream', 0);
 553
 554     $x->{Got} = $got ;
 555
 556 #    if ($x->{Hash})
 557 #    {
 558 #        while (my($k, $v) = each %$input)
 559 #        {
 560 #            $v = \$input->{$k}
 561 #                unless defined $v ;
 562 #
 563 #            $obj->_singleTarget($x, $k, $v, @_)
 564 #                or return undef ;
 565 #        }
 566 #
 567 #        return keys %$input ;
 568 #    }
 569
 570     if ($x->{GlobMap})
 571     {
 572         $x->{oneInput} = 1 ;
 573         foreach my $pair (@{ $x->{Pairs} })
 574         {
 575             my ($from, $to) = @$pair ;
 576             $obj->_singleTarget($x, $from, $to, @_)
 577                 or return undef ;
 578         }
 579
 580         return scalar @{ $x->{Pairs} } ;
 581     }
 582
 583     if (! $x->{oneOutput} )
 584     {
 585         my $inFile = ($x->{inType} eq 'filenames'
 586                         || $x->{inType} eq 'filename');
 587
 588         $x->{inType} = $inFile ? 'filename' : 'buffer';
 589
 590         foreach my $in ($x->{oneInput} ? $input : @$input)
 591         {
 592             my $out ;
 593             $x->{oneInput} = 1 ;
 594
 595             $obj->_singleTarget($x, $in, $output, @_)
 596                 or return undef ;
 597         }
 598
 599         return 1 ;
 600     }
 601
 602     # finally the 1 to 1 and n to 1
 603     return $obj->_singleTarget($x, $input, $output, @_);
 604
 605     croak "should not be here" ;
 606 }
 607
 608 sub retErr
 609 {
 610     my $x = shift ;
 611     my $string = shift ;
 612
 613     ${ $x->{Error} } = $string ;
 614
 615     return undef ;
 616 }
 617
 618 sub _singleTarget
 619 {
 620     my $self      = shift ;
 621     my $x         = shift ;
 622     my $input     = shift;
 623     my $output    = shift;
 624
 625     my $buff = '';
 626     $x->{buff} = \$buff ;
 627
 628     my $fh ;
 629     if ($x->{outType} eq 'filename') {
 630         my $mode = '>' ;
 631         $mode = '>>'
 632             if $x->{Got}->value('Append') ;
 633         $x->{fh} = new IO::File "$mode $output"
 634             or return retErr($x, "cannot open file '$output': $!") ;
 635         binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
 636
 637     }
 638
 639     elsif ($x->{outType} eq 'handle') {
 640         $x->{fh} = $output;
 641         binmode $x->{fh} if $x->{Got}->valueOrDefault('BinModeOut');
 642         if ($x->{Got}->value('Append')) {
 643                 seek($x->{fh}, 0, SEEK_END)
 644                     or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
 645             }
 646     }
 647
 648
 649     elsif ($x->{outType} eq 'buffer' )
 650     {
 651         $$output = ''
 652             unless $x->{Got}->value('Append');
 653         $x->{buff} = $output ;
 654     }
 655
 656     if ($x->{oneInput})
 657     {
 658         defined $self->_rd2($x, $input, $output)
 659             or return undef;
 660     }
 661     else
 662     {
 663         for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
 664         {
 665             defined $self->_rd2($x, $element, $output)
 666                 or return undef ;
 667         }
 668     }
 669
 670
 671     if ( ($x->{outType} eq 'filename' && $output ne '-') ||
 672          ($x->{outType} eq 'handle' && $x->{Got}->value('AutoClose'))) {
 673         $x->{fh}->close()
 674             or return retErr($x, $!);
 675         delete $x->{fh};
 676     }
 677
 678     return 1 ;
 679 }
 680
 681 sub _rd2
 682 {
 683     my $self      = shift ;
 684     my $x         = shift ;
 685     my $input     = shift;
 686     my $output    = shift;
 687
 688     my $z = createSelfTiedObject($x->{Class}, *$self->{Error});
 689
 690     $z->_create($x->{Got}, 1, $input, @_)
 691         or return undef ;
 692
 693     my $status ;
 694     my $fh = $x->{fh};
 695
 696     while (1) {
 697
 698         while (($status = $z->read($x->{buff})) > 0) {
 699             if ($fh) {
 700                 print $fh ${ $x->{buff} }
 701                     or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
 702                 ${ $x->{buff} } = '' ;
 703             }
 704         }
 705
 706         if (! $x->{oneOutput} ) {
 707             my $ot = $x->{outType} ;
 708
 709             if ($ot eq 'array')
 710               { push @$output, $x->{buff} }
 711             elsif ($ot eq 'hash')
 712               { $output->{$input} = $x->{buff} }
 713
 714             my $buff = '';
 715             $x->{buff} = \$buff;
 716         }
 717
 718         last
 719             unless *$self->{MultiStream};
 720
 721         $status = $z->nextStream();
 722
 723         last
 724             unless $status == 1 ;
 725     }
 726
 727     return $z->closeError(undef)
 728         if $status < 0 ;
 729
 730     ${ *$self->{TrailingData} } = $z->trailingData()
 731         if defined *$self->{TrailingData} ;
 732
 733     $z->close()
 734         or return undef ;
 735
 736     return 1 ;
 737 }
 738
 739 sub TIEHANDLE
 740 {
 741     return $_[0] if ref($_[0]);
 742     die "OOPS\n" ;
 743
 744 }
 745
 746 sub UNTIE
 747 {
 748     my $self = shift ;
 749 }
 750
 751
 752 sub getHeaderInfo
 753 {
 754     my $self = shift ;
 755     wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
 756 }
 757
 758 sub readBlock
 759 {
 760     my $self = shift ;
 761     my $buff = shift ;
 762     my $size = shift ;
 763
 764     if (defined *$self->{CompressedInputLength}) {
 765         if (*$self->{CompressedInputLengthRemaining} == 0) {
 766             delete *$self->{CompressedInputLength};
 767             *$self->{CompressedInputLengthDone} = 1;
 768             return STATUS_OK ;
 769         }
 770         $size = min($size, *$self->{CompressedInputLengthRemaining} );
 771         *$self->{CompressedInputLengthRemaining} -= $size ;
 772     }
 773
 774     my $status = $self->smartRead($buff, $size) ;
 775     return $self->saveErrorString(STATUS_ERROR, "Error Reading Data")
 776         if $status < 0  ;
 777
 778     if ($status == 0 ) {
 779         *$self->{Closed} = 1 ;
 780         *$self->{EndStream} = 1 ;
 781         return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
 782     }
 783
 784     return STATUS_OK;
 785 }
 786
 787 sub postBlockChk
 788 {
 789     return STATUS_OK;
 790 }
 791
 792 sub _raw_read
 793 {
 794     # return codes
 795     # >0 - ok, number of bytes read
 796     # =0 - ok, eof
 797     # <0 - not ok
 798
 799     my $self = shift ;
 800
 801     return G_EOF if *$self->{Closed} ;
 802     #return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
 803     return G_EOF if *$self->{EndStream} ;
 804
 805     my $buffer = shift ;
 806     my $scan_mode = shift ;
 807
 808     if (*$self->{Plain}) {
 809         my $tmp_buff ;
 810         my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
 811
 812         return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
 813                 if $len < 0 ;
 814
 815         if ($len == 0 ) {
 816             *$self->{EndStream} = 1 ;
 817         }
 818         else {
 819             *$self->{PlainBytesRead} += $len ;
 820             $$buffer .= $tmp_buff;
 821         }
 822
 823         return $len ;
 824     }
 825
 826     if (*$self->{NewStream}) {
 827
 828         $self->gotoNextStream() > 0
 829             or return G_ERR;
 830
 831         # For the headers that actually uncompressed data, put the
 832         # uncompressed data into the output buffer.
 833         $$buffer .=  *$self->{Pending} ;
 834         my $len = length  *$self->{Pending} ;
 835         *$self->{Pending} = '';
 836         return $len;
 837     }
 838
 839     my $temp_buf = '';
 840     my $outSize = 0;
 841     my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
 842     return G_ERR
 843         if $status == STATUS_ERROR  ;
 844
 845     my $buf_len = 0;
 846     if ($status == STATUS_OK) {
 847         my $beforeC_len = length $temp_buf;
 848         my $before_len = defined $$buffer ? length $$buffer : 0 ;
 849         $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
 850                                     defined *$self->{CompressedInputLengthDone} ||
 851                                                 $self->smartEof(), $outSize);
 852
 853         return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
 854             if $self->saveStatus($status) == STATUS_ERROR;
 855
 856         $self->postBlockChk($buffer, $before_len) == STATUS_OK
 857             or return G_ERR;
 858
 859         $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0;
 860
 861         *$self->{CompSize}->add($beforeC_len - length $temp_buf) ;
 862
 863         *$self->{InflatedBytesRead} += $buf_len ;
 864         *$self->{TotalInflatedBytesRead} += $buf_len ;
 865         *$self->{UnCompSize}->add($buf_len) ;
 866
 867         $self->filterUncompressed($buffer);
 868
 869         if (*$self->{Encoding}) {
 870             $$buffer = *$self->{Encoding}->decode($$buffer);
 871         }
 872     }
 873
 874     if ($status == STATUS_ENDSTREAM) {
 875
 876         *$self->{EndStream} = 1 ;
 877         $self->pushBack($temp_buf)  ;
 878         $temp_buf = '';
 879
 880         my $trailer;
 881         my $trailer_size = *$self->{Info}{TrailerLength} ;
 882         my $got = 0;
 883         if (*$self->{Info}{TrailerLength})
 884         {
 885             $got = $self->smartRead(\$trailer, $trailer_size) ;
 886         }
 887
 888         if ($got == $trailer_size) {
 889             $self->chkTrailer($trailer) == STATUS_OK
 890                 or return G_ERR;
 891         }
 892         else {
 893             return $self->TrailerError("trailer truncated. Expected " .
 894                                       "$trailer_size bytes, got $got")
 895                 if *$self->{Strict};
 896             $self->pushBack($trailer)  ;
 897         }
 898
 899         # TODO - if want to file file pointer, do it here
 900
 901         if (! $self->smartEof()) {
 902             *$self->{NewStream} = 1 ;
 903
 904             if (*$self->{MultiStream}) {
 905                 *$self->{EndStream} = 0 ;
 906                 return $buf_len ;
 907             }
 908         }
 909
 910     }
 911
 912
 913     # return the number of uncompressed bytes read
 914     return $buf_len ;
 915 }
 916
 917 sub reset
 918 {
 919     my $self = shift ;
 920
 921     return *$self->{Uncomp}->reset();
 922 }
 923
 924 sub filterUncompressed
 925 {
 926 }
 927
 928 #sub isEndStream
 929 #{
 930 #    my $self = shift ;
 931 #    return *$self->{NewStream} ||
 932 #           *$self->{EndStream} ;
 933 #}
 934
 935 sub nextStream
 936 {
 937     my $self = shift ;
 938
 939     my $status = $self->gotoNextStream();
 940     $status == 1
 941         or return $status ;
 942
 943     *$self->{TotalInflatedBytesRead} = 0 ;
 944     *$self->{LineNo} = $. = 0;
 945
 946     return 1;
 947 }
 948
 949 sub gotoNextStream
 950 {
 951     my $self = shift ;
 952
 953     if (! *$self->{NewStream}) {
 954         my $status = 1;
 955         my $buffer ;
 956
 957         # TODO - make this more efficient if know the offset for the end of
 958         # the stream and seekable
 959         $status = $self->read($buffer)
 960             while $status > 0 ;
 961
 962         return $status
 963             if $status < 0;
 964     }
 965
 966     *$self->{NewStream} = 0 ;
 967     *$self->{EndStream} = 0 ;
 968     $self->reset();
 969     *$self->{UnCompSize}->reset();
 970     *$self->{CompSize}->reset();
 971
 972     my $magic = $self->ckMagic();
 973     #*$self->{EndStream} = 0 ;
 974
 975     if ( ! defined $magic) {
 976         if (! *$self->{Transparent} )
 977         {
 978             *$self->{EndStream} = 1 ;
 979             return 0;
 980         }
 981
 982         $self->clearError();
 983         *$self->{Type} = 'plain';
 984         *$self->{Plain} = 1;
 985         $self->pushBack(*$self->{HeaderPending})  ;
 986     }
 987     else
 988     {
 989         *$self->{Info} = $self->readHeader($magic);
 990
 991         if ( ! defined *$self->{Info} ) {
 992             *$self->{EndStream} = 1 ;
 993             return -1;
 994         }
 995     }
 996
 997     push @{ *$self->{InfoList} }, *$self->{Info} ;
 998
 999     return 1;
1000 }
1001
1002 sub streamCount
1003 {
1004     my $self = shift ;
1005     return 1 if ! defined *$self->{InfoList};
1006     return scalar @{ *$self->{InfoList} }  ;
1007 }
1008
1009 sub read
1010 {
1011     # return codes
1012     # >0 - ok, number of bytes read
1013     # =0 - ok, eof
1014     # <0 - not ok
1015
1016     my $self = shift ;
1017
1018     return G_EOF if *$self->{Closed} ;
1019
1020     my $buffer ;
1021
1022     if (ref $_[0] ) {
1023         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1024             if readonly(${ $_[0] });
1025
1026         $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
1027             unless ref $_[0] eq 'SCALAR' ;
1028         $buffer = $_[0] ;
1029     }
1030     else {
1031         $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1032             if readonly($_[0]);
1033
1034         $buffer = \$_[0] ;
1035     }
1036
1037     my $length = $_[1] ;
1038     my $offset = $_[2] || 0;
1039
1040     if (! *$self->{AppendOutput}) {
1041         if (! $offset) {
1042             $$buffer = '' ;
1043         }
1044         else {
1045             if ($offset > length($$buffer)) {
1046                 $$buffer .= "\x00" x ($offset - length($$buffer));
1047             }
1048             else {
1049                 substr($$buffer, $offset) = '';
1050             }
1051         }
1052     }
1053
1054     return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
1055
1056     # the core read will return 0 if asked for 0 bytes
1057     return 0 if defined $length && $length == 0 ;
1058
1059     $length = $length || 0;
1060
1061     $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
1062         if $length < 0 ;
1063
1064     # Short-circuit if this is a simple read, with no length
1065     # or offset specified.
1066     unless ( $length || $offset) {
1067         if (length *$self->{Pending}) {
1068             $$buffer .= *$self->{Pending} ;
1069             my $len = length *$self->{Pending};
1070             *$self->{Pending} = '' ;
1071             return $len ;
1072         }
1073         else {
1074             my $len = 0;
1075             $len = $self->_raw_read($buffer)
1076                 while ! *$self->{EndStream} && $len == 0 ;
1077             return $len ;
1078         }
1079     }
1080
1081     # Need to jump through more hoops - either length or offset
1082     # or both are specified.
1083     my $out_buffer = *$self->{Pending} ;
1084
1085
1086     while (! *$self->{EndStream} && length($out_buffer) < $length)
1087     {
1088         my $buf_len = $self->_raw_read(\$out_buffer);
1089         return $buf_len
1090             if $buf_len < 0 ;
1091     }
1092
1093     $length = length $out_buffer
1094         if length($out_buffer) < $length ;
1095
1096     return 0
1097         if $length == 0 ;
1098
1099     $$buffer = ''
1100         if ! defined $$buffer;
1101
1102     $offset = length $$buffer
1103         if *$self->{AppendOutput} ;
1104
1105     *$self->{Pending} = $out_buffer;
1106     $out_buffer = \*$self->{Pending} ;
1107
1108     #substr($$buffer, $offset) = substr($$out_buffer, 0, $length, '') ;
1109     substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
1110     substr($$out_buffer, 0, $length) =  '' ;
1111
1112     return $length ;
1113 }
1114
1115 sub _getline
1116 {
1117     my $self = shift ;
1118
1119     # Slurp Mode
1120     if ( ! defined $/ ) {
1121         my $data ;
1122         1 while $self->read($data) > 0 ;
1123         return \$data ;
1124     }
1125
1126     # Record Mode
1127     if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
1128         my $reclen = ${$/} ;
1129         my $data ;
1130         $self->read($data, $reclen) ;
1131         return \$data ;
1132     }
1133
1134     # Paragraph Mode
1135     if ( ! length $/ ) {
1136         my $paragraph ;
1137         while ($self->read($paragraph) > 0 ) {
1138             if ($paragraph =~ s/^(.*?\n\n+)//s) {
1139                 *$self->{Pending}  = $paragraph ;
1140                 my $par = $1 ;
1141                 return \$par ;
1142             }
1143         }
1144         return \$paragraph;
1145     }
1146
1147     # $/ isn't empty, or a reference, so it's Line Mode.
1148     {
1149         my $line ;
1150         my $offset;
1151         my $p = \*$self->{Pending}  ;
1152
1153         if (length(*$self->{Pending}) &&
1154                     ($offset = index(*$self->{Pending}, $/)) >=0) {
1155             my $l = substr(*$self->{Pending}, 0, $offset + length $/ );
1156             substr(*$self->{Pending}, 0, $offset + length $/) = '';
1157             return \$l;
1158         }
1159
1160         while ($self->read($line) > 0 ) {
1161             my $offset = index($line, $/);
1162             if ($offset >= 0) {
1163                 my $l = substr($line, 0, $offset + length $/ );
1164                 substr($line, 0, $offset + length $/) = '';
1165                 $$p = $line;
1166                 return \$l;
1167             }
1168         }
1169
1170         return \$line;
1171     }
1172 }
1173
1174 sub getline
1175 {
1176     my $self = shift;
1177     my $current_append = *$self->{AppendOutput} ;
1178     *$self->{AppendOutput} = 1;
1179     my $lineref = $self->_getline();
1180     $. = ++ *$self->{LineNo} if defined $$lineref ;
1181     *$self->{AppendOutput} = $current_append;
1182     return $$lineref ;
1183 }
1184
1185 sub getlines
1186 {
1187     my $self = shift;
1188     $self->croakError(*$self->{ClassName} .
1189             "::getlines: called in scalar context\n") unless wantarray;
1190     my($line, @lines);
1191     push(@lines, $line)
1192         while defined($line = $self->getline);
1193     return @lines;
1194 }
1195
1196 sub READLINE
1197 {
1198     goto &getlines if wantarray;
1199     goto &getline;
1200 }
1201
1202 sub getc
1203 {
1204     my $self = shift;
1205     my $buf;
1206     return $buf if $self->read($buf, 1);
1207     return undef;
1208 }
1209
1210 sub ungetc
1211 {
1212     my $self = shift;
1213     *$self->{Pending} = ""  unless defined *$self->{Pending} ;
1214     *$self->{Pending} = $_[0] . *$self->{Pending} ;
1215 }
1216
1217
1218 sub trailingData
1219 {
1220     my $self = shift ;
1221
1222     if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
1223         return *$self->{Prime} ;
1224     }
1225     else {
1226         my $buf = *$self->{Buffer} ;
1227         my $offset = *$self->{BufferOffset} ;
1228         return substr($$buf, $offset) ;
1229     }
1230 }
1231
1232
1233 sub eof
1234 {
1235     my $self = shift ;
1236
1237     return (*$self->{Closed} ||
1238               (!length *$self->{Pending}
1239                 && ( $self->smartEof() || *$self->{EndStream}))) ;
1240 }
1241
1242 sub tell
1243 {
1244     my $self = shift ;
1245
1246     my $in ;
1247     if (*$self->{Plain}) {
1248         $in = *$self->{PlainBytesRead} ;
1249     }
1250     else {
1251         $in = *$self->{TotalInflatedBytesRead} ;
1252     }
1253
1254     my $pending = length *$self->{Pending} ;
1255
1256     return 0 if $pending > $in ;
1257     return $in - $pending ;
1258 }
1259
1260 sub close
1261 {
1262     # todo - what to do if close is called before the end of the gzip file
1263     #        do we remember any trailing data?
1264     my $self = shift ;
1265
1266     return 1 if *$self->{Closed} ;
1267
1268     untie *$self
1269         if $] >= 5.008 ;
1270
1271     my $status = 1 ;
1272
1273     if (defined *$self->{FH}) {
1274         if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
1275         #if ( *$self->{AutoClose}) {
1276             local $.;
1277             $! = 0 ;
1278             $status = *$self->{FH}->close();
1279             return $self->saveErrorString(0, $!, $!)
1280                 if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
1281         }
1282         delete *$self->{FH} ;
1283         $! = 0 ;
1284     }
1285     *$self->{Closed} = 1 ;
1286
1287     return 1;
1288 }
1289
1290 sub DESTROY
1291 {
1292     my $self = shift ;
1293     local ($., $@, $!, $^E, $?);
1294
1295     $self->close() ;
1296 }
1297
1298 sub seek
1299 {
1300     my $self     = shift ;
1301     my $position = shift;
1302     my $whence   = shift ;
1303
1304     my $here = $self->tell() ;
1305     my $target = 0 ;
1306
1307
1308     if ($whence == SEEK_SET) {
1309         $target = $position ;
1310     }
1311     elsif ($whence == SEEK_CUR) {
1312         $target = $here + $position ;
1313     }
1314     elsif ($whence == SEEK_END) {
1315         $target = $position ;
1316         $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
1317     }
1318     else {
1319         $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
1320     }
1321
1322     # short circuit if seeking to current offset
1323     return 1 if $target == $here ;
1324
1325     # Outlaw any attempt to seek backwards
1326     $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
1327         if $target < $here ;
1328
1329     # Walk the file to the new offset
1330     my $offset = $target - $here ;
1331
1332     my $got;
1333     while (($got = $self->read(my $buffer, min($offset, *$self->{BlockSize})) ) > 0)
1334     {
1335         $offset -= $got;
1336         last if $offset == 0 ;
1337     }
1338
1339     return $offset == 0 ? 1 : 0 ;
1340 }
1341
1342 sub fileno
1343 {
1344     my $self = shift ;
1345     return defined *$self->{FH}
1346            ? fileno *$self->{FH}
1347            : undef ;
1348 }
1349
1350 sub binmode
1351 {
1352     1;
1353 #    my $self     = shift ;
1354 #    return defined *$self->{FH}
1355 #            ? binmode *$self->{FH}
1356 #            : 1 ;
1357 }
1358
1359 sub opened
1360 {
1361     my $self     = shift ;
1362     return ! *$self->{Closed} ;
1363 }
1364
1365 sub autoflush
1366 {
1367     my $self     = shift ;
1368     return defined *$self->{FH}
1369             ? *$self->{FH}->autoflush(@_)
1370             : undef ;
1371 }
1372
1373 sub input_line_number
1374 {
1375     my $self = shift ;
1376     my $last = *$self->{LineNo};
1377     $. = *$self->{LineNo} = $_[1] if @_ ;
1378     return $last;
1379 }
1380
1381
1382 *BINMODE  = \&binmode;
1383 *SEEK     = \&seek;
1384 *READ     = \&read;
1385 *sysread  = \&read;
1386 *TELL     = \&tell;
1387 *EOF      = \&eof;
1388
1389 *FILENO   = \&fileno;
1390 *CLOSE    = \&close;
1391
1392 sub _notAvailable
1393 {
1394     my $name = shift ;
1395     #return sub { croak "$name Not Available" ; } ;
1396     return sub { croak "$name Not Available: File opened only for intput" ; } ;
1397 }
1398
1399
1400 *print    = _notAvailable('print');
1401 *PRINT    = _notAvailable('print');
1402 *printf   = _notAvailable('printf');
1403 *PRINTF   = _notAvailable('printf');
1404 *write    = _notAvailable('write');
1405 *WRITE    = _notAvailable('write');
1406
1407 #*sysread  = \&read;
1408 #*syswrite = \&_notAvailable;
1409
1410
1411
1412 package IO::Uncompress::Base ;
1413
1414
1415 1 ;
1416 __END__
1417
1418 =head1 NAME
1419
1420 IO::Uncompress::Base - Base Class for IO::Uncompress modules
1421
1422 =head1 SYNOPSIS
1423
1424     use IO::Uncompress::Base ;
1425
1426 =head1 DESCRIPTION
1427
1428 This module is not intended for direct use in application code. Its sole
1429 purpose if to to be sub-classed by IO::Unompress modules.
1430
1431 =head1 SEE ALSO
1432
1433 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>
1434
1435 L<Compress::Zlib::FAQ|Compress::Zlib::FAQ>
1436
1437 L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>,
1438 L<Archive::Tar|Archive::Tar>,
1439 L<IO::Zlib|IO::Zlib>
1440
1441 =head1 AUTHOR
1442
1443 This module was written by Paul Marquess, F<pmqs@cpan.org>.
1444
1445 =head1 MODIFICATION HISTORY
1446
1447 See the Changes file.
1448
1449 =head1 COPYRIGHT AND LICENSE
1450
1451 Copyright (c) 2005-2008 Paul Marquess. All rights reserved.
1452
1453 This program is free software; you can redistribute it and/or
1454 modify it under the same terms as Perl itself.
1455