| Filename | /home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/5.22.0/IO/Compress/Zlib/Extra.pm |
| Statements | Executed 12 statements in 488µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 8µs | 144µs | IO::Compress::Zlib::Extra::BEGIN@13 |
| 1 | 1 | 1 | 8µs | 9µs | IO::Compress::Zlib::Extra::BEGIN@5 |
| 1 | 1 | 1 | 4µs | 7µs | IO::Compress::Zlib::Extra::BEGIN@6 |
| 1 | 1 | 1 | 4µs | 5µs | IO::Compress::Zlib::Extra::BEGIN@7 |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::ExtraFieldError |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::findID |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::mkSubField |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::parseExtraField |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::parseRawExtra |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Zlib::Extra::validateExtraFieldPair |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package IO::Compress::Zlib::Extra; | ||||
| 2 | |||||
| 3 | 1 | 5µs | require 5.006 ; | ||
| 4 | |||||
| 5 | 2 | 14µs | 2 | 11µs | # spent 9µs (8+1) within IO::Compress::Zlib::Extra::BEGIN@5 which was called:
# once (8µs+1µs) by IO::Compress::Gzip::BEGIN@16 at line 5 # spent 9µs making 1 call to IO::Compress::Zlib::Extra::BEGIN@5
# spent 1µs making 1 call to strict::import |
| 6 | 2 | 11µs | 2 | 10µs | # spent 7µs (4+3) within IO::Compress::Zlib::Extra::BEGIN@6 which was called:
# once (4µs+3µs) by IO::Compress::Gzip::BEGIN@16 at line 6 # spent 7µs making 1 call to IO::Compress::Zlib::Extra::BEGIN@6
# spent 3µs making 1 call to warnings::import |
| 7 | 2 | 31µs | 2 | 5µs | # spent 5µs (4+700ns) within IO::Compress::Zlib::Extra::BEGIN@7 which was called:
# once (4µs+700ns) by IO::Compress::Gzip::BEGIN@16 at line 7 # spent 5µs making 1 call to IO::Compress::Zlib::Extra::BEGIN@7
# spent 700ns making 1 call to bytes::import |
| 8 | |||||
| 9 | our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); | ||||
| 10 | |||||
| 11 | 1 | 200ns | $VERSION = '2.068'; | ||
| 12 | |||||
| 13 | 3 | 424µs | 3 | 281µs | # spent 144µs (8+136) within IO::Compress::Zlib::Extra::BEGIN@13 which was called:
# once (8µs+136µs) by IO::Compress::Gzip::BEGIN@16 at line 13 # spent 144µs making 1 call to IO::Compress::Zlib::Extra::BEGIN@13
# spent 132µs making 1 call to Exporter::import
# spent 5µs making 1 call to UNIVERSAL::VERSION |
| 14 | |||||
| 15 | sub ExtraFieldError | ||||
| 16 | { | ||||
| 17 | return $_[0]; | ||||
| 18 | return "Error with ExtraField Parameter: $_[0]" ; | ||||
| 19 | } | ||||
| 20 | |||||
| 21 | sub validateExtraFieldPair | ||||
| 22 | { | ||||
| 23 | my $pair = shift ; | ||||
| 24 | my $strict = shift; | ||||
| 25 | my $gzipMode = shift ; | ||||
| 26 | |||||
| 27 | return ExtraFieldError("Not an array ref") | ||||
| 28 | unless ref $pair && ref $pair eq 'ARRAY'; | ||||
| 29 | |||||
| 30 | return ExtraFieldError("SubField must have two parts") | ||||
| 31 | unless @$pair == 2 ; | ||||
| 32 | |||||
| 33 | return ExtraFieldError("SubField ID is a reference") | ||||
| 34 | if ref $pair->[0] ; | ||||
| 35 | |||||
| 36 | return ExtraFieldError("SubField Data is a reference") | ||||
| 37 | if ref $pair->[1] ; | ||||
| 38 | |||||
| 39 | # ID is exactly two chars | ||||
| 40 | return ExtraFieldError("SubField ID not two chars long") | ||||
| 41 | unless length $pair->[0] == GZIP_FEXTRA_SUBFIELD_ID_SIZE ; | ||||
| 42 | |||||
| 43 | # Check that the 2nd byte of the ID isn't 0 | ||||
| 44 | return ExtraFieldError("SubField ID 2nd byte is 0x00") | ||||
| 45 | if $strict && $gzipMode && substr($pair->[0], 1, 1) eq "\x00" ; | ||||
| 46 | |||||
| 47 | return ExtraFieldError("SubField Data too long") | ||||
| 48 | if length $pair->[1] > GZIP_FEXTRA_SUBFIELD_MAX_SIZE ; | ||||
| 49 | |||||
| 50 | |||||
| 51 | return undef ; | ||||
| 52 | } | ||||
| 53 | |||||
| 54 | sub parseRawExtra | ||||
| 55 | { | ||||
| 56 | my $data = shift ; | ||||
| 57 | my $extraRef = shift; | ||||
| 58 | my $strict = shift; | ||||
| 59 | my $gzipMode = shift ; | ||||
| 60 | |||||
| 61 | #my $lax = shift ; | ||||
| 62 | |||||
| 63 | #return undef | ||||
| 64 | # if $lax ; | ||||
| 65 | |||||
| 66 | my $XLEN = length $data ; | ||||
| 67 | |||||
| 68 | return ExtraFieldError("Too Large") | ||||
| 69 | if $XLEN > GZIP_FEXTRA_MAX_SIZE; | ||||
| 70 | |||||
| 71 | my $offset = 0 ; | ||||
| 72 | while ($offset < $XLEN) { | ||||
| 73 | |||||
| 74 | return ExtraFieldError("Truncated in FEXTRA Body Section") | ||||
| 75 | if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; | ||||
| 76 | |||||
| 77 | my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); | ||||
| 78 | $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; | ||||
| 79 | |||||
| 80 | my $subLen = unpack("v", substr($data, $offset, | ||||
| 81 | GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); | ||||
| 82 | $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; | ||||
| 83 | |||||
| 84 | return ExtraFieldError("Truncated in FEXTRA Body Section") | ||||
| 85 | if $offset + $subLen > $XLEN ; | ||||
| 86 | |||||
| 87 | my $bad = validateExtraFieldPair( [$id, | ||||
| 88 | substr($data, $offset, $subLen)], | ||||
| 89 | $strict, $gzipMode ); | ||||
| 90 | return $bad if $bad ; | ||||
| 91 | push @$extraRef, [$id => substr($data, $offset, $subLen)] | ||||
| 92 | if defined $extraRef;; | ||||
| 93 | |||||
| 94 | $offset += $subLen ; | ||||
| 95 | } | ||||
| 96 | |||||
| 97 | |||||
| 98 | return undef ; | ||||
| 99 | } | ||||
| 100 | |||||
| 101 | sub findID | ||||
| 102 | { | ||||
| 103 | my $id_want = shift ; | ||||
| 104 | my $data = shift; | ||||
| 105 | |||||
| 106 | my $XLEN = length $data ; | ||||
| 107 | |||||
| 108 | my $offset = 0 ; | ||||
| 109 | while ($offset < $XLEN) { | ||||
| 110 | |||||
| 111 | return undef | ||||
| 112 | if $offset + GZIP_FEXTRA_SUBFIELD_HEADER_SIZE > $XLEN ; | ||||
| 113 | |||||
| 114 | my $id = substr($data, $offset, GZIP_FEXTRA_SUBFIELD_ID_SIZE); | ||||
| 115 | $offset += GZIP_FEXTRA_SUBFIELD_ID_SIZE; | ||||
| 116 | |||||
| 117 | my $subLen = unpack("v", substr($data, $offset, | ||||
| 118 | GZIP_FEXTRA_SUBFIELD_LEN_SIZE)); | ||||
| 119 | $offset += GZIP_FEXTRA_SUBFIELD_LEN_SIZE ; | ||||
| 120 | |||||
| 121 | return undef | ||||
| 122 | if $offset + $subLen > $XLEN ; | ||||
| 123 | |||||
| 124 | return substr($data, $offset, $subLen) | ||||
| 125 | if $id eq $id_want ; | ||||
| 126 | |||||
| 127 | $offset += $subLen ; | ||||
| 128 | } | ||||
| 129 | |||||
| 130 | return undef ; | ||||
| 131 | } | ||||
| 132 | |||||
| 133 | |||||
| 134 | sub mkSubField | ||||
| 135 | { | ||||
| 136 | my $id = shift ; | ||||
| 137 | my $data = shift ; | ||||
| 138 | |||||
| 139 | return $id . pack("v", length $data) . $data ; | ||||
| 140 | } | ||||
| 141 | |||||
| 142 | sub parseExtraField | ||||
| 143 | { | ||||
| 144 | my $dataRef = $_[0]; | ||||
| 145 | my $strict = $_[1]; | ||||
| 146 | my $gzipMode = $_[2]; | ||||
| 147 | #my $lax = @_ == 2 ? $_[1] : 1; | ||||
| 148 | |||||
| 149 | |||||
| 150 | # ExtraField can be any of | ||||
| 151 | # | ||||
| 152 | # -ExtraField => $data | ||||
| 153 | # | ||||
| 154 | # -ExtraField => [$id1, $data1, | ||||
| 155 | # $id2, $data2] | ||||
| 156 | # ... | ||||
| 157 | # ] | ||||
| 158 | # | ||||
| 159 | # -ExtraField => [ [$id1 => $data1], | ||||
| 160 | # [$id2 => $data2], | ||||
| 161 | # ... | ||||
| 162 | # ] | ||||
| 163 | # | ||||
| 164 | # -ExtraField => { $id1 => $data1, | ||||
| 165 | # $id2 => $data2, | ||||
| 166 | # ... | ||||
| 167 | # } | ||||
| 168 | |||||
| 169 | if ( ! ref $dataRef ) { | ||||
| 170 | |||||
| 171 | return undef | ||||
| 172 | if ! $strict; | ||||
| 173 | |||||
| 174 | return parseRawExtra($dataRef, undef, 1, $gzipMode); | ||||
| 175 | } | ||||
| 176 | |||||
| 177 | my $data = $dataRef; | ||||
| 178 | my $out = '' ; | ||||
| 179 | |||||
| 180 | if (ref $data eq 'ARRAY') { | ||||
| 181 | if (ref $data->[0]) { | ||||
| 182 | |||||
| 183 | foreach my $pair (@$data) { | ||||
| 184 | return ExtraFieldError("Not list of lists") | ||||
| 185 | unless ref $pair eq 'ARRAY' ; | ||||
| 186 | |||||
| 187 | my $bad = validateExtraFieldPair($pair, $strict, $gzipMode) ; | ||||
| 188 | return $bad if $bad ; | ||||
| 189 | |||||
| 190 | $out .= mkSubField(@$pair); | ||||
| 191 | } | ||||
| 192 | } | ||||
| 193 | else { | ||||
| 194 | return ExtraFieldError("Not even number of elements") | ||||
| 195 | unless @$data % 2 == 0; | ||||
| 196 | |||||
| 197 | for (my $ix = 0; $ix <= @$data -1 ; $ix += 2) { | ||||
| 198 | my $bad = validateExtraFieldPair([$data->[$ix], | ||||
| 199 | $data->[$ix+1]], | ||||
| 200 | $strict, $gzipMode) ; | ||||
| 201 | return $bad if $bad ; | ||||
| 202 | |||||
| 203 | $out .= mkSubField($data->[$ix], $data->[$ix+1]); | ||||
| 204 | } | ||||
| 205 | } | ||||
| 206 | } | ||||
| 207 | elsif (ref $data eq 'HASH') { | ||||
| 208 | while (my ($id, $info) = each %$data) { | ||||
| 209 | my $bad = validateExtraFieldPair([$id, $info], $strict, $gzipMode); | ||||
| 210 | return $bad if $bad ; | ||||
| 211 | |||||
| 212 | $out .= mkSubField($id, $info); | ||||
| 213 | } | ||||
| 214 | } | ||||
| 215 | else { | ||||
| 216 | return ExtraFieldError("Not a scalar, array ref or hash ref") ; | ||||
| 217 | } | ||||
| 218 | |||||
| 219 | return ExtraFieldError("Too Large") | ||||
| 220 | if length $out > GZIP_FEXTRA_MAX_SIZE; | ||||
| 221 | |||||
| 222 | $_[0] = $out ; | ||||
| 223 | |||||
| 224 | return undef; | ||||
| 225 | } | ||||
| 226 | |||||
| 227 | 1 | 3µs | 1; | ||
| 228 | |||||
| 229 | __END__ |