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