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