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