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