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