← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:46 2010

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