← Index
NYTProf Performance Profile   « line view »
For ../prof.pl
  Run on Wed Dec 14 15:57:08 2022
Reported on Wed Dec 14 16:00:30 2022

Filename/Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/IO/Uncompress/Base.pm
StatementsExecuted 61 statements in 4.76ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11141µs46µsIO::Uncompress::Base::::BEGIN@4IO::Uncompress::Base::BEGIN@4
11121µs23µsIO::Uncompress::Base::::BEGIN@6IO::Uncompress::Base::BEGIN@6
11112µs41µsIO::Uncompress::Base::::BEGIN@1500IO::Uncompress::Base::BEGIN@1500
11111µs59µsIO::Uncompress::Base::::BEGIN@5IO::Uncompress::Base::BEGIN@5
11110µs138µsIO::Uncompress::Base::::BEGIN@17IO::Uncompress::Base::BEGIN@17
11110µs116µsIO::Uncompress::Base::::BEGIN@19IO::Uncompress::Base::BEGIN@19
11110µs36µsIO::Uncompress::Base::::BEGIN@429IO::Uncompress::Base::BEGIN@429
1118µs56µsIO::Uncompress::Base::::BEGIN@14IO::Uncompress::Base::BEGIN@14
1116µs26µsIO::Uncompress::Base::::BEGIN@15IO::Uncompress::Base::BEGIN@15
6616µs6µsIO::Uncompress::Base::::_notAvailableIO::Uncompress::Base::_notAvailable
1115µs21µsIO::Uncompress::Base::::BEGIN@20IO::Uncompress::Base::BEGIN@20
1115µs52µsIO::Uncompress::Base::::BEGIN@90IO::Uncompress::Base::BEGIN@90
1113µs23µsIO::Uncompress::Base::::BEGIN@23IO::Uncompress::Base::BEGIN@23
1112µs2µsIO::Uncompress::Base::::BEGIN@21IO::Uncompress::Base::BEGIN@21
1111µs1µsIO::Uncompress::Base::::BEGIN@22IO::Uncompress::Base::BEGIN@22
0000s0sIO::Uncompress::Base::::DESTROYIO::Uncompress::Base::DESTROY
0000s0sIO::Uncompress::Base::::HeaderErrorIO::Uncompress::Base::HeaderError
0000s0sIO::Uncompress::Base::::READLINEIO::Uncompress::Base::READLINE
0000s0sIO::Uncompress::Base::::TIEHANDLEIO::Uncompress::Base::TIEHANDLE
0000s0sIO::Uncompress::Base::::TrailerErrorIO::Uncompress::Base::TrailerError
0000s0sIO::Uncompress::Base::::TruncatedHeaderIO::Uncompress::Base::TruncatedHeader
0000s0sIO::Uncompress::Base::::TruncatedTrailerIO::Uncompress::Base::TruncatedTrailer
0000s0sIO::Uncompress::Base::::UNTIEIO::Uncompress::Base::UNTIE
0000s0sIO::Uncompress::Base::::__ANON__[:1496]IO::Uncompress::Base::__ANON__[:1496]
0000s0sIO::Uncompress::Base::::_createIO::Uncompress::Base::_create
0000s0sIO::Uncompress::Base::::_getlineIO::Uncompress::Base::_getline
0000s0sIO::Uncompress::Base::::_infIO::Uncompress::Base::_inf
0000s0sIO::Uncompress::Base::::_raw_readIO::Uncompress::Base::_raw_read
0000s0sIO::Uncompress::Base::::_rd2IO::Uncompress::Base::_rd2
0000s0sIO::Uncompress::Base::::_singleTargetIO::Uncompress::Base::_singleTarget
0000s0sIO::Uncompress::Base::::autoflushIO::Uncompress::Base::autoflush
0000s0sIO::Uncompress::Base::::binmodeIO::Uncompress::Base::binmode
0000s0sIO::Uncompress::Base::::checkParamsIO::Uncompress::Base::checkParams
0000s0sIO::Uncompress::Base::::ckInputParamIO::Uncompress::Base::ckInputParam
0000s0sIO::Uncompress::Base::::clearErrorIO::Uncompress::Base::clearError
0000s0sIO::Uncompress::Base::::closeIO::Uncompress::Base::close
0000s0sIO::Uncompress::Base::::closeErrorIO::Uncompress::Base::closeError
0000s0sIO::Uncompress::Base::::croakErrorIO::Uncompress::Base::croakError
0000s0sIO::Uncompress::Base::::eofIO::Uncompress::Base::eof
0000s0sIO::Uncompress::Base::::errorIO::Uncompress::Base::error
0000s0sIO::Uncompress::Base::::errorNoIO::Uncompress::Base::errorNo
0000s0sIO::Uncompress::Base::::filenoIO::Uncompress::Base::fileno
0000s0sIO::Uncompress::Base::::filterUncompressedIO::Uncompress::Base::filterUncompressed
0000s0sIO::Uncompress::Base::::getErrInfoIO::Uncompress::Base::getErrInfo
0000s0sIO::Uncompress::Base::::getHeaderInfoIO::Uncompress::Base::getHeaderInfo
0000s0sIO::Uncompress::Base::::getcIO::Uncompress::Base::getc
0000s0sIO::Uncompress::Base::::getlineIO::Uncompress::Base::getline
0000s0sIO::Uncompress::Base::::getlinesIO::Uncompress::Base::getlines
0000s0sIO::Uncompress::Base::::gotoNextStreamIO::Uncompress::Base::gotoNextStream
0000s0sIO::Uncompress::Base::::input_line_numberIO::Uncompress::Base::input_line_number
0000s0sIO::Uncompress::Base::::nextStreamIO::Uncompress::Base::nextStream
0000s0sIO::Uncompress::Base::::openedIO::Uncompress::Base::opened
0000s0sIO::Uncompress::Base::::postBlockChkIO::Uncompress::Base::postBlockChk
0000s0sIO::Uncompress::Base::::postCheckParamsIO::Uncompress::Base::postCheckParams
0000s0sIO::Uncompress::Base::::pushBackIO::Uncompress::Base::pushBack
0000s0sIO::Uncompress::Base::::readIO::Uncompress::Base::read
0000s0sIO::Uncompress::Base::::readBlockIO::Uncompress::Base::readBlock
0000s0sIO::Uncompress::Base::::resetIO::Uncompress::Base::reset
0000s0sIO::Uncompress::Base::::retErrIO::Uncompress::Base::retErr
0000s0sIO::Uncompress::Base::::saveErrorStringIO::Uncompress::Base::saveErrorString
0000s0sIO::Uncompress::Base::::saveStatusIO::Uncompress::Base::saveStatus
0000s0sIO::Uncompress::Base::::seekIO::Uncompress::Base::seek
0000s0sIO::Uncompress::Base::::setErrInfoIO::Uncompress::Base::setErrInfo
0000s0sIO::Uncompress::Base::::smartEofIO::Uncompress::Base::smartEof
0000s0sIO::Uncompress::Base::::smartReadIO::Uncompress::Base::smartRead
0000s0sIO::Uncompress::Base::::smartReadExactIO::Uncompress::Base::smartReadExact
0000s0sIO::Uncompress::Base::::smartSeekIO::Uncompress::Base::smartSeek
0000s0sIO::Uncompress::Base::::smartTellIO::Uncompress::Base::smartTell
0000s0sIO::Uncompress::Base::::smartWriteIO::Uncompress::Base::smartWrite
0000s0sIO::Uncompress::Base::::streamCountIO::Uncompress::Base::streamCount
0000s0sIO::Uncompress::Base::::tellIO::Uncompress::Base::tell
0000s0sIO::Uncompress::Base::::trailingDataIO::Uncompress::Base::trailingData
0000s0sIO::Uncompress::Base::::ungetcIO::Uncompress::Base::ungetc
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1
2package IO::Uncompress::Base ;
3
4273µs251µs
# spent 46µs (41+5) within IO::Uncompress::Base::BEGIN@4 which was called: # once (41µs+5µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 4
use strict ;
# spent 46µs making 1 call to IO::Uncompress::Base::BEGIN@4 # spent 5µs making 1 call to strict::import
5233µs2107µs
# spent 59µs (11+48) within IO::Uncompress::Base::BEGIN@5 which was called: # once (11µs+48µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 5
use warnings;
# spent 59µs making 1 call to IO::Uncompress::Base::BEGIN@5 # spent 48µs making 1 call to warnings::import
6278µs225µs
# spent 23µs (21+2) within IO::Uncompress::Base::BEGIN@6 which was called: # once (21µs+2µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 6
use bytes;
# spent 23µs making 1 call to IO::Uncompress::Base::BEGIN@6 # spent 2µs making 1 call to bytes::import
7
8our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS);
9117µs@ISA = qw(IO::File Exporter);
10
11
1211µs$VERSION = '2.106';
13
14230µs2104µs
# spent 56µs (8+48) within IO::Uncompress::Base::BEGIN@14 which was called: # once (8µs+48µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 14
use constant G_EOF => 0 ;
# spent 56µs making 1 call to IO::Uncompress::Base::BEGIN@14 # spent 48µs making 1 call to constant::import
15223µs246µs
# spent 26µs (6+20) within IO::Uncompress::Base::BEGIN@15 which was called: # once (6µs+20µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 15
use constant G_ERR => -1 ;
# spent 26µs making 1 call to IO::Uncompress::Base::BEGIN@15 # spent 20µs making 1 call to constant::import
16
17329µs3266µs
# spent 138µs (10+128) within IO::Uncompress::Base::BEGIN@17 which was called: # once (10µs+128µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 17
use IO::Compress::Base::Common 2.106 ;
# spent 138µs making 1 call to IO::Uncompress::Base::BEGIN@17 # spent 119µs making 1 call to Exporter::import # spent 9µs making 1 call to UNIVERSAL::VERSION
18
19220µs2222µs
# spent 116µs (10+106) within IO::Uncompress::Base::BEGIN@19 which was called: # once (10µs+106µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 19
use IO::File ;
# spent 116µs making 1 call to IO::Uncompress::Base::BEGIN@19 # spent 106µs making 1 call to Exporter::import
20214µs237µs
# spent 21µs (5+16) within IO::Uncompress::Base::BEGIN@20 which was called: # once (5µs+16µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 20
use Symbol;
# spent 21µs making 1 call to IO::Uncompress::Base::BEGIN@20 # spent 16µs making 1 call to Exporter::import
2127µs12µs
# spent 2µs within IO::Uncompress::Base::BEGIN@21 which was called: # once (2µs+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 21
use Scalar::Util ();
# spent 2µs making 1 call to IO::Uncompress::Base::BEGIN@21
22210µs11µs
# spent 1µs within IO::Uncompress::Base::BEGIN@22 which was called: # once (1µs+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 22
use List::Util ();
# spent 1µs making 1 call to IO::Uncompress::Base::BEGIN@22
232176µs243µs
# spent 23µs (3+20) within IO::Uncompress::Base::BEGIN@23 which was called: # once (3µs+20µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 23
use Carp ;
# spent 23µs making 1 call to IO::Uncompress::Base::BEGIN@23 # spent 20µs making 1 call to Exporter::import
24
2511µs%EXPORT_TAGS = ( );
2611µspush @{ $EXPORT_TAGS{all} }, @EXPORT_OK ;
27
28sub smartRead
29{
30 my $self = $_[0];
31 my $out = $_[1];
32 my $size = $_[2];
33 $$out = "" ;
34
35 my $offset = 0 ;
36 my $status = 1;
37
38
39 if (defined *$self->{InputLength}) {
40 return 0
41 if *$self->{InputLengthRemaining} <= 0 ;
42 $size = List::Util::min($size, *$self->{InputLengthRemaining});
43 }
44
45 if ( length *$self->{Prime} ) {
46 $$out = substr(*$self->{Prime}, 0, $size) ;
47 substr(*$self->{Prime}, 0, $size) = '' ;
48 if (length $$out == $size) {
49 *$self->{InputLengthRemaining} -= length $$out
50 if defined *$self->{InputLength};
51
52 return length $$out ;
53 }
54 $offset = length $$out ;
55 }
56
57 my $get_size = $size - $offset ;
58
59 if (defined *$self->{FH}) {
60 if ($offset) {
61 # Not using this
62 #
63 # *$self->{FH}->read($$out, $get_size, $offset);
64 #
65 # because the filehandle may not support the offset parameter
66 # An example is Net::FTP
67 my $tmp = '';
68 $status = *$self->{FH}->read($tmp, $get_size) ;
69 substr($$out, $offset) = $tmp
70 if defined $status && $status > 0 ;
71 }
72 else
73 { $status = *$self->{FH}->read($$out, $get_size) }
74 }
75 elsif (defined *$self->{InputEvent}) {
76 my $got = 1 ;
77 while (length $$out < $size) {
78 last
79 if ($got = *$self->{InputEvent}->($$out, $get_size)) <= 0;
80 }
81
82 if (length $$out > $size ) {
83 *$self->{Prime} = substr($$out, $size, length($$out));
84 substr($$out, $size, length($$out)) = '';
85 }
86
87 *$self->{EventEof} = 1 if $got <= 0 ;
88 }
89 else {
9021.44ms299µs
# spent 52µs (5+47) within IO::Uncompress::Base::BEGIN@90 which was called: # once (5µs+47µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 90
no warnings 'uninitialized';
# spent 52µs making 1 call to IO::Uncompress::Base::BEGIN@90 # spent 47µs making 1 call to warnings::unimport
91 my $buf = *$self->{Buffer} ;
92 $$buf = '' unless defined $$buf ;
93 substr($$out, $offset) = substr($$buf, *$self->{BufferOffset}, $get_size);
94 if (*$self->{ConsumeInput})
95 { substr($$buf, 0, $get_size) = '' }
96 else
97 { *$self->{BufferOffset} += length($$out) - $offset }
98 }
99
100 *$self->{InputLengthRemaining} -= length($$out) #- $offset
101 if defined *$self->{InputLength};
102
103 if (! defined $status) {
104 $self->saveStatus($!) ;
105 return STATUS_ERROR;
106 }
107
108 $self->saveStatus(length $$out < 0 ? STATUS_ERROR : STATUS_OK) ;
109
110 return length $$out;
111}
112
113sub pushBack
114{
115 my $self = shift ;
116
117 return if ! defined $_[0] || length $_[0] == 0 ;
118
119 if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
120 *$self->{Prime} = $_[0] . *$self->{Prime} ;
121 *$self->{InputLengthRemaining} += length($_[0]);
122 }
123 else {
124 my $len = length $_[0];
125
126 if($len > *$self->{BufferOffset}) {
127 *$self->{Prime} = substr($_[0], 0, $len - *$self->{BufferOffset}) . *$self->{Prime} ;
128 *$self->{InputLengthRemaining} = *$self->{InputLength};
129 *$self->{BufferOffset} = 0
130 }
131 else {
132 *$self->{InputLengthRemaining} += length($_[0]);
133 *$self->{BufferOffset} -= length($_[0]) ;
134 }
135 }
136}
137
138sub smartSeek
139{
140 my $self = shift ;
141 my $offset = shift ;
142 my $truncate = shift;
143 my $position = shift || SEEK_SET;
144
145 # TODO -- need to take prime into account
146 *$self->{Prime} = '';
147 if (defined *$self->{FH})
148 { *$self->{FH}->seek($offset, $position) }
149 else {
150 if ($position == SEEK_END) {
151 *$self->{BufferOffset} = length(${ *$self->{Buffer} }) + $offset ;
152 }
153 elsif ($position == SEEK_CUR) {
154 *$self->{BufferOffset} += $offset ;
155 }
156 else {
157 *$self->{BufferOffset} = $offset ;
158 }
159
160 substr(${ *$self->{Buffer} }, *$self->{BufferOffset}) = ''
161 if $truncate;
162 return 1;
163 }
164}
165
166sub smartTell
167{
168 my $self = shift ;
169
170 if (defined *$self->{FH})
171 { return *$self->{FH}->tell() }
172 else
173 { return *$self->{BufferOffset} }
174}
175
176sub smartWrite
177{
178 my $self = shift ;
179 my $out_data = shift ;
180
181 if (defined *$self->{FH}) {
182 # flush needed for 5.8.0
183 defined *$self->{FH}->write($out_data, length $out_data) &&
184 defined *$self->{FH}->flush() ;
185 }
186 else {
187 my $buf = *$self->{Buffer} ;
188 substr($$buf, *$self->{BufferOffset}, length $out_data) = $out_data ;
189 *$self->{BufferOffset} += length($out_data) ;
190 return 1;
191 }
192}
193
194sub smartReadExact
195{
196 return $_[0]->smartRead($_[1], $_[2]) == $_[2];
197}
198
199sub smartEof
200{
201 my ($self) = $_[0];
202 local $.;
203
204 return 0 if length *$self->{Prime} || *$self->{PushMode};
205
206 if (defined *$self->{FH})
207 {
208 # Could use
209 #
210 # *$self->{FH}->eof()
211 #
212 # here, but this can cause trouble if
213 # the filehandle is itself a tied handle, but it uses sysread.
214 # Then we get into mixing buffered & non-buffered IO,
215 # which will cause trouble
216
217 my $info = $self->getErrInfo();
218
219 my $buffer = '';
220 my $status = $self->smartRead(\$buffer, 1);
221 $self->pushBack($buffer) if length $buffer;
222 $self->setErrInfo($info);
223
224 return $status == 0 ;
225 }
226 elsif (defined *$self->{InputEvent})
227 { *$self->{EventEof} }
228 else
229 { *$self->{BufferOffset} >= length(${ *$self->{Buffer} }) }
230}
231
232sub clearError
233{
234 my $self = shift ;
235
236 *$self->{ErrorNo} = 0 ;
237 ${ *$self->{Error} } = '' ;
238}
239
240sub getErrInfo
241{
242 my $self = shift ;
243
244 return [ *$self->{ErrorNo}, ${ *$self->{Error} } ] ;
245}
246
247sub setErrInfo
248{
249 my $self = shift ;
250 my $ref = shift;
251
252 *$self->{ErrorNo} = $ref->[0] ;
253 ${ *$self->{Error} } = $ref->[1] ;
254}
255
256sub saveStatus
257{
258 my $self = shift ;
259 my $errno = shift() + 0 ;
260
261 *$self->{ErrorNo} = $errno;
262 ${ *$self->{Error} } = '' ;
263
264 return *$self->{ErrorNo} ;
265}
266
267
268sub saveErrorString
269{
270 my $self = shift ;
271 my $retval = shift ;
272
273 ${ *$self->{Error} } = shift ;
274 *$self->{ErrorNo} = @_ ? shift() + 0 : STATUS_ERROR ;
275
276 return $retval;
277}
278
279sub croakError
280{
281 my $self = shift ;
282 $self->saveErrorString(0, $_[0]);
283 croak $_[0];
284}
285
286
287sub closeError
288{
289 my $self = shift ;
290 my $retval = shift ;
291
292 my $errno = *$self->{ErrorNo};
293 my $error = ${ *$self->{Error} };
294
295 $self->close();
296
297 *$self->{ErrorNo} = $errno ;
298 ${ *$self->{Error} } = $error ;
299
300 return $retval;
301}
302
303sub error
304{
305 my $self = shift ;
306 return ${ *$self->{Error} } ;
307}
308
309sub errorNo
310{
311 my $self = shift ;
312 return *$self->{ErrorNo};
313}
314
315sub HeaderError
316{
317 my ($self) = shift;
318 return $self->saveErrorString(undef, "Header Error: $_[0]", STATUS_ERROR);
319}
320
321sub TrailerError
322{
323 my ($self) = shift;
324 return $self->saveErrorString(G_ERR, "Trailer Error: $_[0]", STATUS_ERROR);
325}
326
327sub TruncatedHeader
328{
329 my ($self) = shift;
330 return $self->HeaderError("Truncated in $_[0] Section");
331}
332
333sub TruncatedTrailer
334{
335 my ($self) = shift;
336 return $self->TrailerError("Truncated in $_[0] Section");
337}
338
339sub postCheckParams
340{
341 return 1;
342}
343
344sub checkParams
345{
346 my $self = shift ;
347 my $class = shift ;
348
349 my $got = shift || IO::Compress::Base::Parameters::new();
350
351 my $Valid = {
352 'blocksize' => [IO::Compress::Base::Common::Parse_unsigned, 16 * 1024],
353 'autoclose' => [IO::Compress::Base::Common::Parse_boolean, 0],
354 'strict' => [IO::Compress::Base::Common::Parse_boolean, 0],
355 'append' => [IO::Compress::Base::Common::Parse_boolean, 0],
356 'prime' => [IO::Compress::Base::Common::Parse_any, undef],
357 'multistream' => [IO::Compress::Base::Common::Parse_boolean, 0],
358 'transparent' => [IO::Compress::Base::Common::Parse_any, 1],
359 'scan' => [IO::Compress::Base::Common::Parse_boolean, 0],
360 'inputlength' => [IO::Compress::Base::Common::Parse_unsigned, undef],
361 'binmodeout' => [IO::Compress::Base::Common::Parse_boolean, 0],
362 #'decode' => [IO::Compress::Base::Common::Parse_any, undef],
363
364 #'consumeinput' => [IO::Compress::Base::Common::Parse_boolean, 0],
365
366 $self->getExtraParams(),
367
368 #'Todo - Revert to ordinary file on end Z_STREAM_END'=> 0,
369 # ContinueAfterEof
370 } ;
371
372 $Valid->{trailingdata} = [IO::Compress::Base::Common::Parse_writable_scalar, undef]
373 if *$self->{OneShot} ;
374
375 $got->parse($Valid, @_ )
376 or $self->croakError("${class}: " . $got->getError()) ;
377
378 $self->postCheckParams($got)
379 or $self->croakError("${class}: " . $self->error()) ;
380
381 return $got;
382}
383
384sub _create
385{
386 my $obj = shift;
387 my $got = shift;
388 my $append_mode = shift ;
389
390 my $class = ref $obj;
391 $obj->croakError("$class: Missing Input parameter")
392 if ! @_ && ! $got ;
393
394 my $inValue = shift ;
395
396 *$obj->{OneShot} = 0 ;
397
398 if (! $got)
399 {
400 $got = $obj->checkParams($class, undef, @_)
401 or return undef ;
402 }
403
404 my $inType = whatIsInput($inValue, 1);
405
406 $obj->ckInputParam($class, $inValue, 1)
407 or return undef ;
408
409 *$obj->{InNew} = 1;
410
411 $obj->ckParams($got)
412 or $obj->croakError("${class}: " . *$obj->{Error});
413
414 if ($inType eq 'buffer' || $inType eq 'code') {
415 *$obj->{Buffer} = $inValue ;
416 *$obj->{InputEvent} = $inValue
417 if $inType eq 'code' ;
418 }
419 else {
420 if ($inType eq 'handle') {
421 *$obj->{FH} = $inValue ;
422 *$obj->{Handle} = 1 ;
423
424 # Need to rewind for Scan
425 *$obj->{FH}->seek(0, SEEK_SET)
426 if $got->getValue('scan');
427 }
428 else {
42922.61ms262µs
# spent 36µs (10+26) within IO::Uncompress::Base::BEGIN@429 which was called: # once (10µs+26µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 429
no warnings ;
# spent 36µs making 1 call to IO::Uncompress::Base::BEGIN@429 # spent 26µs making 1 call to warnings::unimport
430 my $mode = '<';
431 $mode = '+<' if $got->getValue('scan');
432 *$obj->{StdIO} = ($inValue eq '-');
433 *$obj->{FH} = IO::File->new( "$mode $inValue" )
434 or return $obj->saveErrorString(undef, "cannot open file '$inValue': $!", $!) ;
435 }
436
437 *$obj->{LineNo} = $. = 0;
438 setBinModeInput(*$obj->{FH}) ;
439
440 my $buff = "" ;
441 *$obj->{Buffer} = \$buff ;
442 }
443
444# if ($got->getValue('decode')) {
445# my $want_encoding = $got->getValue('decode');
446# *$obj->{Encoding} = IO::Compress::Base::Common::getEncoding($obj, $class, $want_encoding);
447# }
448# else {
449# *$obj->{Encoding} = undef;
450# }
451
452 *$obj->{InputLength} = $got->parsed('inputlength')
453 ? $got->getValue('inputlength')
454 : undef ;
455 *$obj->{InputLengthRemaining} = $got->getValue('inputlength');
456 *$obj->{BufferOffset} = 0 ;
457 *$obj->{AutoClose} = $got->getValue('autoclose');
458 *$obj->{Strict} = $got->getValue('strict');
459 *$obj->{BlockSize} = $got->getValue('blocksize');
460 *$obj->{Append} = $got->getValue('append');
461 *$obj->{AppendOutput} = $append_mode || $got->getValue('append');
462 *$obj->{ConsumeInput} = $got->getValue('consumeinput');
463 *$obj->{Transparent} = $got->getValue('transparent');
464 *$obj->{MultiStream} = $got->getValue('multistream');
465
466 # TODO - move these two into RawDeflate
467 *$obj->{Scan} = $got->getValue('scan');
468 *$obj->{ParseExtra} = $got->getValue('parseextra')
469 || $got->getValue('strict') ;
470 *$obj->{Type} = '';
471 *$obj->{Prime} = $got->getValue('prime') || '' ;
472 *$obj->{Pending} = '';
473 *$obj->{Plain} = 0;
474 *$obj->{PlainBytesRead} = 0;
475 *$obj->{InflatedBytesRead} = 0;
476 *$obj->{UnCompSize} = U64->new;
477 *$obj->{CompSize} = U64->new;
478 *$obj->{TotalInflatedBytesRead} = 0;
479 *$obj->{NewStream} = 0 ;
480 *$obj->{EventEof} = 0 ;
481 *$obj->{ClassName} = $class ;
482 *$obj->{Params} = $got ;
483
484 if (*$obj->{ConsumeInput}) {
485 *$obj->{InNew} = 0;
486 *$obj->{Closed} = 0;
487 return $obj
488 }
489
490 my $status = $obj->mkUncomp($got);
491
492 return undef
493 unless defined $status;
494
495 *$obj->{InNew} = 0;
496 *$obj->{Closed} = 0;
497
498 return $obj
499 if *$obj->{Pause} ;
500
501 if ($status) {
502 # Need to try uncompressing to catch the case
503 # where the compressed file uncompresses to an
504 # empty string - so eof is set immediately.
505
506 my $out_buffer = '';
507
508 $status = $obj->read(\$out_buffer);
509
510 if ($status < 0) {
511 *$obj->{ReadStatus} = [ $status, $obj->error(), $obj->errorNo() ];
512 }
513
514 $obj->ungetc($out_buffer)
515 if length $out_buffer;
516 }
517 else {
518 return undef
519 unless *$obj->{Transparent};
520
521 $obj->clearError();
522 *$obj->{Type} = 'plain';
523 *$obj->{Plain} = 1;
524 $obj->pushBack(*$obj->{HeaderPending}) ;
525 }
526
527 push @{ *$obj->{InfoList} }, *$obj->{Info} ;
528
529 $obj->saveStatus(STATUS_OK) ;
530 *$obj->{InNew} = 0;
531 *$obj->{Closed} = 0;
532
533 return $obj;
534}
535
536sub ckInputParam
537{
538 my $self = shift ;
539 my $from = shift ;
540 my $inType = whatIsInput($_[0], $_[1]);
541
542 $self->croakError("$from: input parameter not a filename, filehandle, array ref or scalar ref")
543 if ! $inType ;
544
545# if ($inType eq 'filename' )
546# {
547# return $self->saveErrorString(1, "$from: input filename is undef or null string", STATUS_ERROR)
548# if ! defined $_[0] || $_[0] eq '' ;
549#
550# if ($_[0] ne '-' && ! -e $_[0] )
551# {
552# return $self->saveErrorString(1,
553# "input file '$_[0]' does not exist", STATUS_ERROR);
554# }
555# }
556
557 return 1;
558}
559
560
561sub _inf
562{
563 my $obj = shift ;
564
565 my $class = (caller)[0] ;
566 my $name = (caller(1))[3] ;
567
568 $obj->croakError("$name: expected at least 1 parameters\n")
569 unless @_ >= 1 ;
570
571 my $input = shift ;
572 my $haveOut = @_ ;
573 my $output = shift ;
574
575
576 my $x = IO::Compress::Base::Validator->new($class, *$obj->{Error}, $name, $input, $output)
577 or return undef ;
578
579 push @_, $output if $haveOut && $x->{Hash};
580
581 *$obj->{OneShot} = 1 ;
582
583 my $got = $obj->checkParams($name, undef, @_)
584 or return undef ;
585
586 if ($got->parsed('trailingdata'))
587 {
588# my $value = $got->valueRef('TrailingData');
589# warn "TD $value ";
590# #$value = $$value;
591## warn "TD $value $$value ";
592#
593# return retErr($obj, "Parameter 'TrailingData' not writable")
594# if readonly $$value ;
595#
596# if (ref $$value)
597# {
598# return retErr($obj,"Parameter 'TrailingData' not a scalar reference")
599# if ref $$value ne 'SCALAR' ;
600#
601# *$obj->{TrailingData} = $$value ;
602# }
603# else
604# {
605# return retErr($obj,"Parameter 'TrailingData' not a scalar")
606# if ref $value ne 'SCALAR' ;
607#
608# *$obj->{TrailingData} = $value ;
609# }
610
611 *$obj->{TrailingData} = $got->getValue('trailingdata');
612 }
613
614 *$obj->{MultiStream} = $got->getValue('multistream');
615 $got->setValue('multistream', 0);
616
617 $x->{Got} = $got ;
618
619# if ($x->{Hash})
620# {
621# while (my($k, $v) = each %$input)
622# {
623# $v = \$input->{$k}
624# unless defined $v ;
625#
626# $obj->_singleTarget($x, $k, $v, @_)
627# or return undef ;
628# }
629#
630# return keys %$input ;
631# }
632
633 if ($x->{GlobMap})
634 {
635 $x->{oneInput} = 1 ;
636 foreach my $pair (@{ $x->{Pairs} })
637 {
638 my ($from, $to) = @$pair ;
639 $obj->_singleTarget($x, $from, $to, @_)
640 or return undef ;
641 }
642
643 return scalar @{ $x->{Pairs} } ;
644 }
645
646 if (! $x->{oneOutput} )
647 {
648 my $inFile = ($x->{inType} eq 'filenames'
649 || $x->{inType} eq 'filename');
650
651 $x->{inType} = $inFile ? 'filename' : 'buffer';
652
653 foreach my $in ($x->{oneInput} ? $input : @$input)
654 {
655 my $out ;
656 $x->{oneInput} = 1 ;
657
658 $obj->_singleTarget($x, $in, $output, @_)
659 or return undef ;
660 }
661
662 return 1 ;
663 }
664
665 # finally the 1 to 1 and n to 1
666 return $obj->_singleTarget($x, $input, $output, @_);
667
668 croak "should not be here" ;
669}
670
671sub retErr
672{
673 my $x = shift ;
674 my $string = shift ;
675
676 ${ $x->{Error} } = $string ;
677
678 return undef ;
679}
680
681sub _singleTarget
682{
683 my $self = shift ;
684 my $x = shift ;
685 my $input = shift;
686 my $output = shift;
687
688 my $buff = '';
689 $x->{buff} = \$buff ;
690
691 my $fh ;
692 if ($x->{outType} eq 'filename') {
693 my $mode = '>' ;
694 $mode = '>>'
695 if $x->{Got}->getValue('append') ;
696 $x->{fh} = IO::File->new( "$mode $output" )
697 or return retErr($x, "cannot open file '$output': $!") ;
698 binmode $x->{fh} ;
699
700 }
701
702 elsif ($x->{outType} eq 'handle') {
703 $x->{fh} = $output;
704 binmode $x->{fh} ;
705 if ($x->{Got}->getValue('append')) {
706 seek($x->{fh}, 0, SEEK_END)
707 or return retErr($x, "Cannot seek to end of output filehandle: $!") ;
708 }
709 }
710
711
712 elsif ($x->{outType} eq 'buffer' )
713 {
714 $$output = ''
715 unless $x->{Got}->getValue('append');
716 $x->{buff} = $output ;
717 }
718
719 if ($x->{oneInput})
720 {
721 defined $self->_rd2($x, $input, $output)
722 or return undef;
723 }
724 else
725 {
726 for my $element ( ($x->{inType} eq 'hash') ? keys %$input : @$input)
727 {
728 defined $self->_rd2($x, $element, $output)
729 or return undef ;
730 }
731 }
732
733
734 if ( ($x->{outType} eq 'filename' && $output ne '-') ||
735 ($x->{outType} eq 'handle' && $x->{Got}->getValue('autoclose'))) {
736 $x->{fh}->close()
737 or return retErr($x, $!);
738 delete $x->{fh};
739 }
740
741 return 1 ;
742}
743
744sub _rd2
745{
746 my $self = shift ;
747 my $x = shift ;
748 my $input = shift;
749 my $output = shift;
750
751 my $z = IO::Compress::Base::Common::createSelfTiedObject($x->{Class}, *$self->{Error});
752
753 $z->_create($x->{Got}, 1, $input, @_)
754 or return undef ;
755
756 my $status ;
757 my $fh = $x->{fh};
758
759 while (1) {
760
761 while (($status = $z->read($x->{buff})) > 0) {
762 if ($fh) {
763 local $\;
764 print $fh ${ $x->{buff} }
765 or return $z->saveErrorString(undef, "Error writing to output file: $!", $!);
766 ${ $x->{buff} } = '' ;
767 }
768 }
769
770 if (! $x->{oneOutput} ) {
771 my $ot = $x->{outType} ;
772
773 if ($ot eq 'array')
774 { push @$output, $x->{buff} }
775 elsif ($ot eq 'hash')
776 { $output->{$input} = $x->{buff} }
777
778 my $buff = '';
779 $x->{buff} = \$buff;
780 }
781
782 last if $status < 0 || $z->smartEof();
783
784 last
785 unless *$self->{MultiStream};
786
787 $status = $z->nextStream();
788
789 last
790 unless $status == 1 ;
791 }
792
793 return $z->closeError(undef)
794 if $status < 0 ;
795
796 ${ *$self->{TrailingData} } = $z->trailingData()
797 if defined *$self->{TrailingData} ;
798
799 $z->close()
800 or return undef ;
801
802 return 1 ;
803}
804
805sub TIEHANDLE
806{
807 return $_[0] if ref($_[0]);
808 die "OOPS\n" ;
809
810}
811
812sub UNTIE
813{
814 my $self = shift ;
815}
816
817
818sub getHeaderInfo
819{
820 my $self = shift ;
821 wantarray ? @{ *$self->{InfoList} } : *$self->{Info};
822}
823
824sub readBlock
825{
826 my $self = shift ;
827 my $buff = shift ;
828 my $size = shift ;
829
830 if (defined *$self->{CompressedInputLength}) {
831 if (*$self->{CompressedInputLengthRemaining} == 0) {
832 delete *$self->{CompressedInputLength};
833 *$self->{CompressedInputLengthDone} = 1;
834 return STATUS_OK ;
835 }
836 $size = List::Util::min($size, *$self->{CompressedInputLengthRemaining} );
837 *$self->{CompressedInputLengthRemaining} -= $size ;
838 }
839
840 my $status = $self->smartRead($buff, $size) ;
841 return $self->saveErrorString(STATUS_ERROR, "Error Reading Data: $!", $!)
842 if $status == STATUS_ERROR ;
843
844 if ($status == 0 ) {
845 *$self->{Closed} = 1 ;
846 *$self->{EndStream} = 1 ;
847 return $self->saveErrorString(STATUS_ERROR, "unexpected end of file", STATUS_ERROR);
848 }
849
850 return STATUS_OK;
851}
852
853sub postBlockChk
854{
855 return STATUS_OK;
856}
857
858sub _raw_read
859{
860 # return codes
861 # >0 - ok, number of bytes read
862 # =0 - ok, eof
863 # <0 - not ok
864
865 my $self = shift ;
866
867 return G_EOF if *$self->{Closed} ;
868 return G_EOF if *$self->{EndStream} ;
869
870 my $buffer = shift ;
871 my $scan_mode = shift ;
872
873 if (*$self->{Plain}) {
874 my $tmp_buff ;
875 my $len = $self->smartRead(\$tmp_buff, *$self->{BlockSize}) ;
876
877 return $self->saveErrorString(G_ERR, "Error reading data: $!", $!)
878 if $len == STATUS_ERROR ;
879
880 if ($len == 0 ) {
881 *$self->{EndStream} = 1 ;
882 }
883 else {
884 *$self->{PlainBytesRead} += $len ;
885 $$buffer .= $tmp_buff;
886 }
887
888 return $len ;
889 }
890
891 if (*$self->{NewStream}) {
892
893 $self->gotoNextStream() > 0
894 or return G_ERR;
895
896 # For the headers that actually uncompressed data, put the
897 # uncompressed data into the output buffer.
898 $$buffer .= *$self->{Pending} ;
899 my $len = length *$self->{Pending} ;
900 *$self->{Pending} = '';
901 return $len;
902 }
903
904 my $temp_buf = '';
905 my $outSize = 0;
906 my $status = $self->readBlock(\$temp_buf, *$self->{BlockSize}, $outSize) ;
907
908 return G_ERR
909 if $status == STATUS_ERROR ;
910
911 my $buf_len = 0;
912 if ($status == STATUS_OK) {
913 my $beforeC_len = length $temp_buf;
914 my $before_len = defined $$buffer ? length $$buffer : 0 ;
915 $status = *$self->{Uncomp}->uncompr(\$temp_buf, $buffer,
916 defined *$self->{CompressedInputLengthDone} ||
917 $self->smartEof(), $outSize);
918
919 # Remember the input buffer if it wasn't consumed completely
920 $self->pushBack($temp_buf) if *$self->{Uncomp}{ConsumesInput};
921
922 return $self->saveErrorString(G_ERR, *$self->{Uncomp}{Error}, *$self->{Uncomp}{ErrorNo})
923 if $self->saveStatus($status) == STATUS_ERROR;
924
925 $self->postBlockChk($buffer, $before_len) == STATUS_OK
926 or return G_ERR;
927
928 $buf_len = defined $$buffer ? length($$buffer) - $before_len : 0;
929
930 *$self->{CompSize}->add($beforeC_len - length $temp_buf) ;
931
932 *$self->{InflatedBytesRead} += $buf_len ;
933 *$self->{TotalInflatedBytesRead} += $buf_len ;
934 *$self->{UnCompSize}->add($buf_len) ;
935
936 $self->filterUncompressed($buffer, $before_len);
937
938# if (*$self->{Encoding}) {
939# use Encode ;
940# *$self->{PendingDecode} .= substr($$buffer, $before_len) ;
941# my $got = *$self->{Encoding}->decode(*$self->{PendingDecode}, Encode::FB_QUIET) ;
942# substr($$buffer, $before_len) = $got;
943# }
944 }
945
946 if ($status == STATUS_ENDSTREAM) {
947
948 *$self->{EndStream} = 1 ;
949
950 my $trailer;
951 my $trailer_size = *$self->{Info}{TrailerLength} ;
952 my $got = 0;
953 if (*$self->{Info}{TrailerLength})
954 {
955 $got = $self->smartRead(\$trailer, $trailer_size) ;
956 }
957
958 if ($got == $trailer_size) {
959 $self->chkTrailer($trailer) == STATUS_OK
960 or return G_ERR;
961 }
962 else {
963 return $self->TrailerError("trailer truncated. Expected " .
964 "$trailer_size bytes, got $got")
965 if *$self->{Strict};
966 $self->pushBack($trailer) ;
967 }
968
969 # TODO - if want file pointer, do it here
970
971 if (! $self->smartEof()) {
972 *$self->{NewStream} = 1 ;
973
974 if (*$self->{MultiStream}) {
975 *$self->{EndStream} = 0 ;
976 return $buf_len ;
977 }
978 }
979
980 }
981
982
983 # return the number of uncompressed bytes read
984 return $buf_len ;
985}
986
987sub reset
988{
989 my $self = shift ;
990
991 return *$self->{Uncomp}->reset();
992}
993
994sub filterUncompressed
995{
996}
997
998#sub isEndStream
999#{
1000# my $self = shift ;
1001# return *$self->{NewStream} ||
1002# *$self->{EndStream} ;
1003#}
1004
1005sub nextStream
1006{
1007 my $self = shift ;
1008
1009 # An uncompressed file cannot have a next stream, so
1010 # return immediately.
1011 return 0
1012 if *$self->{Plain} ;
1013
1014 my $status = $self->gotoNextStream();
1015 $status == 1
1016 or return $status ;
1017
1018 *$self->{Pending} = ''
1019 if $self !~ /IO::Uncompress::RawInflate/ && ! *$self->{MultiStream};
1020
1021 *$self->{TotalInflatedBytesRead} = 0 ;
1022 *$self->{LineNo} = $. = 0;
1023
1024 return 1;
1025}
1026
1027sub gotoNextStream
1028{
1029 my $self = shift ;
1030
1031 if (! *$self->{NewStream}) {
1032 my $status = 1;
1033 my $buffer ;
1034
1035 # TODO - make this more efficient if know the offset for the end of
1036 # the stream and seekable
1037 $status = $self->read($buffer)
1038 while $status > 0 ;
1039
1040 return $status
1041 if $status < 0;
1042 }
1043
1044 *$self->{NewStream} = 0 ;
1045 *$self->{EndStream} = 0 ;
1046 *$self->{CompressedInputLengthDone} = undef ;
1047 *$self->{CompressedInputLength} = undef ;
1048 $self->reset();
1049 *$self->{UnCompSize}->reset();
1050 *$self->{CompSize}->reset();
1051
1052 my $magic = $self->ckMagic();
1053
1054 if ( ! defined $magic) {
1055 if (! *$self->{Transparent} || $self->eof())
1056 {
1057 *$self->{EndStream} = 1 ;
1058 return 0;
1059 }
1060
1061 # Not EOF, so Transparent mode kicks in now for trailing data
1062 # Reset member name in case anyone calls getHeaderInfo()->{Name}
1063 *$self->{Info} = { Name => undef, Type => 'plain' };
1064
1065 $self->clearError();
1066 *$self->{Type} = 'plain';
1067 *$self->{Plain} = 1;
1068 $self->pushBack(*$self->{HeaderPending}) ;
1069 }
1070 else
1071 {
1072 *$self->{Info} = $self->readHeader($magic);
1073
1074 if ( ! defined *$self->{Info} ) {
1075 *$self->{EndStream} = 1 ;
1076 return -1;
1077 }
1078 }
1079
1080 push @{ *$self->{InfoList} }, *$self->{Info} ;
1081
1082 return 1;
1083}
1084
1085sub streamCount
1086{
1087 my $self = shift ;
1088 return 1 if ! defined *$self->{InfoList};
1089 return scalar @{ *$self->{InfoList} } ;
1090}
1091
1092sub read
1093{
1094 # return codes
1095 # >0 - ok, number of bytes read
1096 # =0 - ok, eof
1097 # <0 - not ok
1098
1099 my $self = shift ;
1100
1101 if (defined *$self->{ReadStatus} ) {
1102 my $status = *$self->{ReadStatus}[0];
1103 $self->saveErrorString( @{ *$self->{ReadStatus} } );
1104 delete *$self->{ReadStatus} ;
1105 return $status ;
1106 }
1107
1108 return G_EOF if *$self->{Closed} ;
1109
1110 my $buffer ;
1111
1112 if (ref $_[0] ) {
1113 $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1114 if Scalar::Util::readonly(${ $_[0] });
1115
1116 $self->croakError(*$self->{ClassName} . "::read: not a scalar reference $_[0]" )
1117 unless ref $_[0] eq 'SCALAR' ;
1118 $buffer = $_[0] ;
1119 }
1120 else {
1121 $self->croakError(*$self->{ClassName} . "::read: buffer parameter is read-only")
1122 if Scalar::Util::readonly($_[0]);
1123
1124 $buffer = \$_[0] ;
1125 }
1126
1127 my $length = $_[1] ;
1128 my $offset = $_[2] || 0;
1129
1130 if (! *$self->{AppendOutput}) {
1131 if (! $offset) {
1132
1133 $$buffer = '' ;
1134 }
1135 else {
1136 if ($offset > length($$buffer)) {
1137 $$buffer .= "\x00" x ($offset - length($$buffer));
1138 }
1139 else {
1140 substr($$buffer, $offset) = '';
1141 }
1142 }
1143 }
1144 elsif (! defined $$buffer) {
1145 $$buffer = '' ;
1146 }
1147
1148 return G_EOF if !length *$self->{Pending} && *$self->{EndStream} ;
1149
1150 # the core read will return 0 if asked for 0 bytes
1151 return 0 if defined $length && $length == 0 ;
1152
1153 $length = $length || 0;
1154
1155 $self->croakError(*$self->{ClassName} . "::read: length parameter is negative")
1156 if $length < 0 ;
1157
1158 # Short-circuit if this is a simple read, with no length
1159 # or offset specified.
1160 unless ( $length || $offset) {
1161 if (length *$self->{Pending}) {
1162 $$buffer .= *$self->{Pending} ;
1163 my $len = length *$self->{Pending};
1164 *$self->{Pending} = '' ;
1165 return $len ;
1166 }
1167 else {
1168 my $len = 0;
1169 $len = $self->_raw_read($buffer)
1170 while ! *$self->{EndStream} && $len == 0 ;
1171 return $len ;
1172 }
1173 }
1174
1175 # Need to jump through more hoops - either length or offset
1176 # or both are specified.
1177 my $out_buffer = *$self->{Pending} ;
1178 *$self->{Pending} = '';
1179
1180
1181 while (! *$self->{EndStream} && length($out_buffer) < $length)
1182 {
1183 my $buf_len = $self->_raw_read(\$out_buffer);
1184 return $buf_len
1185 if $buf_len < 0 ;
1186 }
1187
1188 $length = length $out_buffer
1189 if length($out_buffer) < $length ;
1190
1191 return 0
1192 if $length == 0 ;
1193
1194 $$buffer = ''
1195 if ! defined $$buffer;
1196
1197 $offset = length $$buffer
1198 if *$self->{AppendOutput} ;
1199
1200 *$self->{Pending} = $out_buffer;
1201 $out_buffer = \*$self->{Pending} ;
1202
1203 substr($$buffer, $offset) = substr($$out_buffer, 0, $length) ;
1204 substr($$out_buffer, 0, $length) = '' ;
1205
1206 return $length ;
1207}
1208
1209sub _getline
1210{
1211 my $self = shift ;
1212 my $status = 0 ;
1213
1214 # Slurp Mode
1215 if ( ! defined $/ ) {
1216 my $data ;
1217 1 while ($status = $self->read($data)) > 0 ;
1218 return ($status, \$data);
1219 }
1220
1221 # Record Mode
1222 if ( ref $/ eq 'SCALAR' && ${$/} =~ /^\d+$/ && ${$/} > 0) {
1223 my $reclen = ${$/} ;
1224 my $data ;
1225 $status = $self->read($data, $reclen) ;
1226 return ($status, \$data);
1227 }
1228
1229 # Paragraph Mode
1230 if ( ! length $/ ) {
1231 my $paragraph ;
1232 while (($status = $self->read($paragraph)) > 0 ) {
1233 if ($paragraph =~ s/^(.*?\n\n+)//s) {
1234 *$self->{Pending} = $paragraph ;
1235 my $par = $1 ;
1236 return (1, \$par);
1237 }
1238 }
1239 return ($status, \$paragraph);
1240 }
1241
1242 # $/ isn't empty, or a reference, so it's Line Mode.
1243 {
1244 my $line ;
1245 my $p = \*$self->{Pending} ;
1246 while (($status = $self->read($line)) > 0 ) {
1247 my $offset = index($line, $/);
1248 if ($offset >= 0) {
1249 my $l = substr($line, 0, $offset + length $/ );
1250 substr($line, 0, $offset + length $/) = '';
1251 $$p = $line;
1252 return (1, \$l);
1253 }
1254 }
1255
1256 return ($status, \$line);
1257 }
1258}
1259
1260sub getline
1261{
1262 my $self = shift;
1263
1264 if (defined *$self->{ReadStatus} ) {
1265 $self->saveErrorString( @{ *$self->{ReadStatus} } );
1266 delete *$self->{ReadStatus} ;
1267 return undef;
1268 }
1269
1270 return undef
1271 if *$self->{Closed} || (!length *$self->{Pending} && *$self->{EndStream}) ;
1272
1273 my $current_append = *$self->{AppendOutput} ;
1274 *$self->{AppendOutput} = 1;
1275
1276 my ($status, $lineref) = $self->_getline();
1277 *$self->{AppendOutput} = $current_append;
1278
1279 return undef
1280 if $status < 0 || length $$lineref == 0 ;
1281
1282 $. = ++ *$self->{LineNo} ;
1283
1284 return $$lineref ;
1285}
1286
1287sub getlines
1288{
1289 my $self = shift;
1290 $self->croakError(*$self->{ClassName} .
1291 "::getlines: called in scalar context\n") unless wantarray;
1292 my($line, @lines);
1293 push(@lines, $line)
1294 while defined($line = $self->getline);
1295 return @lines;
1296}
1297
1298sub READLINE
1299{
1300 goto &getlines if wantarray;
1301 goto &getline;
1302}
1303
1304sub getc
1305{
1306 my $self = shift;
1307 my $buf;
1308 return $buf if $self->read($buf, 1);
1309 return undef;
1310}
1311
1312sub ungetc
1313{
1314 my $self = shift;
1315 *$self->{Pending} = "" unless defined *$self->{Pending} ;
1316 *$self->{Pending} = $_[0] . *$self->{Pending} ;
1317}
1318
1319
1320sub trailingData
1321{
1322 my $self = shift ;
1323
1324 if (defined *$self->{FH} || defined *$self->{InputEvent} ) {
1325 return *$self->{Prime} ;
1326 }
1327 else {
1328 my $buf = *$self->{Buffer} ;
1329 my $offset = *$self->{BufferOffset} ;
1330 return substr($$buf, $offset) ;
1331 }
1332}
1333
1334
1335sub eof
1336{
1337 my $self = shift ;
1338
1339 return (*$self->{Closed} ||
1340 (!length *$self->{Pending}
1341 && ( $self->smartEof() || *$self->{EndStream}))) ;
1342}
1343
1344sub tell
1345{
1346 my $self = shift ;
1347
1348 my $in ;
1349 if (*$self->{Plain}) {
1350 $in = *$self->{PlainBytesRead} ;
1351 }
1352 else {
1353 $in = *$self->{TotalInflatedBytesRead} ;
1354 }
1355
1356 my $pending = length *$self->{Pending} ;
1357
1358 return 0 if $pending > $in ;
1359 return $in - $pending ;
1360}
1361
1362sub close
1363{
1364 # todo - what to do if close is called before the end of the gzip file
1365 # do we remember any trailing data?
1366 my $self = shift ;
1367
1368 return 1 if *$self->{Closed} ;
1369
1370 untie *$self
1371 if $] >= 5.008 ;
1372
1373 my $status = 1 ;
1374
1375 if (defined *$self->{FH}) {
1376 if ((! *$self->{Handle} || *$self->{AutoClose}) && ! *$self->{StdIO}) {
1377 local $.;
1378 $! = 0 ;
1379 $status = *$self->{FH}->close();
1380 return $self->saveErrorString(0, $!, $!)
1381 if !*$self->{InNew} && $self->saveStatus($!) != 0 ;
1382 }
1383 delete *$self->{FH} ;
1384 $! = 0 ;
1385 }
1386 *$self->{Closed} = 1 ;
1387
1388 return 1;
1389}
1390
1391sub DESTROY
1392{
1393 my $self = shift ;
1394 local ($., $@, $!, $^E, $?);
1395
1396 $self->close() ;
1397}
1398
1399sub seek
1400{
1401 my $self = shift ;
1402 my $position = shift;
1403 my $whence = shift ;
1404
1405 my $here = $self->tell() ;
1406 my $target = 0 ;
1407
1408
1409 if ($whence == SEEK_SET) {
1410 $target = $position ;
1411 }
1412 elsif ($whence == SEEK_CUR) {
1413 $target = $here + $position ;
1414 }
1415 elsif ($whence == SEEK_END) {
1416 $target = $position ;
1417 $self->croakError(*$self->{ClassName} . "::seek: SEEK_END not allowed") ;
1418 }
1419 else {
1420 $self->croakError(*$self->{ClassName} ."::seek: unknown value, $whence, for whence parameter");
1421 }
1422
1423 # short circuit if seeking to current offset
1424 if ($target == $here) {
1425 # On ordinary filehandles, seeking to the current
1426 # position also clears the EOF condition, so we
1427 # emulate this behavior locally while simultaneously
1428 # cascading it to the underlying filehandle
1429 if (*$self->{Plain}) {
1430 *$self->{EndStream} = 0;
1431 seek(*$self->{FH},0,1) if *$self->{FH};
1432 }
1433 return 1;
1434 }
1435
1436 # Outlaw any attempt to seek backwards
1437 $self->croakError( *$self->{ClassName} ."::seek: cannot seek backwards")
1438 if $target < $here ;
1439
1440 # Walk the file to the new offset
1441 my $offset = $target - $here ;
1442
1443 my $got;
1444 while (($got = $self->read(my $buffer, List::Util::min($offset, *$self->{BlockSize})) ) > 0)
1445 {
1446 $offset -= $got;
1447 last if $offset == 0 ;
1448 }
1449
1450 $here = $self->tell() ;
1451 return $offset == 0 ? 1 : 0 ;
1452}
1453
1454sub fileno
1455{
1456 my $self = shift ;
1457 return defined *$self->{FH}
1458 ? fileno *$self->{FH}
1459 : undef ;
1460}
1461
1462sub binmode
1463{
1464 1;
1465# my $self = shift ;
1466# return defined *$self->{FH}
1467# ? binmode *$self->{FH}
1468# : 1 ;
1469}
1470
1471sub opened
1472{
1473 my $self = shift ;
1474 return ! *$self->{Closed} ;
1475}
1476
1477sub autoflush
1478{
1479 my $self = shift ;
1480 return defined *$self->{FH}
1481 ? *$self->{FH}->autoflush(@_)
1482 : undef ;
1483}
1484
1485sub input_line_number
1486{
1487 my $self = shift ;
1488 my $last = *$self->{LineNo};
1489 $. = *$self->{LineNo} = $_[1] if @_ ;
1490 return $last;
1491}
1492
1493sub _notAvailable
1494
# spent 6µs within IO::Uncompress::Base::_notAvailable which was called 6 times, avg 1µs/call: # once (4µs+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1512 # once (1µs+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1517 # once (1µs+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1514 # once (0s+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1513 # once (0s+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1515 # once (0s+0s) by IO::Uncompress::RawInflate::BEGIN@11 at line 1516
{
149561µs my $name = shift ;
1496613µs return sub { croak "$name Not Available: File opened only for intput" ; } ;
1497}
1498
1499{
15003160µs270µs
# spent 41µs (12+29) within IO::Uncompress::Base::BEGIN@1500 which was called: # once (12µs+29µs) by IO::Uncompress::RawInflate::BEGIN@11 at line 1500
no warnings 'once';
# spent 41µs making 1 call to IO::Uncompress::Base::BEGIN@1500 # spent 29µs making 1 call to warnings::unimport
1501
150212µs *BINMODE = \&binmode;
150310s *SEEK = \&seek;
150411µs *READ = \&read;
150510s *sysread = \&read;
150610s *TELL = \&tell;
150711µs *EOF = \&eof;
1508
150910s *FILENO = \&fileno;
151010s *CLOSE = \&close;
1511
151211µs14µs *print = _notAvailable('print');
# spent 4µs making 1 call to IO::Uncompress::Base::_notAvailable
151310s10s *PRINT = _notAvailable('print');
# spent 0s making 1 call to IO::Uncompress::Base::_notAvailable
151410s11µs *printf = _notAvailable('printf');
# spent 1µs making 1 call to IO::Uncompress::Base::_notAvailable
151511µs10s *PRINTF = _notAvailable('printf');
# spent 0s making 1 call to IO::Uncompress::Base::_notAvailable
151610s10s *write = _notAvailable('write');
# spent 0s making 1 call to IO::Uncompress::Base::_notAvailable
151711µs11µs *WRITE = _notAvailable('write');
# spent 1µs making 1 call to IO::Uncompress::Base::_notAvailable
1518
1519 #*sysread = \&read;
1520 #*syswrite = \&_notAvailable;
1521}
1522
- -
1525package IO::Uncompress::Base ;
1526
1527
1528115µs1 ;
1529__END__
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.