Profile of /usr/local/lib/perl5/5.10.1/darwin-2level/IO/Uncompress/Base.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For 05.Domain_and_Item.t
Run on Tue May 4 17:21:41 2010
Reported on Tue May 4 17:23:23 2010

File | /usr/local/lib/perl5/5.10.1/darwin-2level/IO/Uncompress/Base.pm
Statements Executed | 71
Statement Execution Time | 5.17ms

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