| Filename | /home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/5.22.0/IO/Compress/Base/Common.pm |
| Statements | Executed 89 statements in 2.99ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 980µs | 1.65ms | IO::Compress::Base::Common::BEGIN@9 |
| 1 | 1 | 1 | 10µs | 17µs | U64::BEGIN@1038 |
| 1 | 1 | 1 | 8µs | 10µs | IO::Compress::Base::Common::BEGIN@520 |
| 1 | 1 | 1 | 8µs | 9µs | IO::Compress::Base::Common::BEGIN@3 |
| 1 | 1 | 1 | 7µs | 9µs | IO::Compress::Base::Common::BEGIN@114 |
| 1 | 1 | 1 | 7µs | 31µs | U64::BEGIN@835 |
| 1 | 1 | 1 | 7µs | 34µs | IO::Compress::Base::Common::BEGIN@480 |
| 1 | 1 | 1 | 6µs | 33µs | IO::Compress::Base::Common::BEGIN@148 |
| 1 | 1 | 1 | 6µs | 21µs | IO::Compress::Base::Common::BEGIN@494 |
| 1 | 1 | 1 | 6µs | 21µs | IO::Compress::Base::Common::BEGIN@483 |
| 1 | 1 | 1 | 6µs | 33µs | IO::Compress::Base::Common::BEGIN@45 |
| 1 | 1 | 1 | 5µs | 10µs | IO::Compress::Base::Common::BEGIN@522 |
| 1 | 1 | 1 | 5µs | 25µs | IO::Compress::Base::Common::BEGIN@523 |
| 1 | 1 | 1 | 5µs | 23µs | IO::Compress::Base::Common::BEGIN@46 |
| 1 | 1 | 1 | 5µs | 23µs | IO::Compress::Base::Common::BEGIN@481 |
| 1 | 1 | 1 | 5µs | 22µs | IO::Compress::Base::Common::BEGIN@8 |
| 1 | 1 | 1 | 4µs | 23µs | U64::BEGIN@836 |
| 1 | 1 | 1 | 4µs | 22µs | IO::Compress::Base::Common::BEGIN@149 |
| 1 | 1 | 1 | 4µs | 21µs | IO::Compress::Base::Common::BEGIN@150 |
| 1 | 1 | 1 | 4µs | 20µs | IO::Compress::Base::Common::BEGIN@482 |
| 1 | 1 | 1 | 4µs | 26µs | IO::Compress::Base::Common::BEGIN@7 |
| 1 | 1 | 1 | 4µs | 19µs | IO::Compress::Base::Common::BEGIN@484 |
| 1 | 1 | 1 | 4µs | 19µs | IO::Compress::Base::Common::BEGIN@152 |
| 1 | 1 | 1 | 4µs | 20µs | IO::Compress::Base::Common::BEGIN@48 |
| 1 | 1 | 1 | 4µs | 19µs | IO::Compress::Base::Common::BEGIN@49 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@492 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@50 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@51 |
| 1 | 1 | 1 | 4µs | 20µs | U64::BEGIN@837 |
| 1 | 1 | 1 | 4µs | 17µs | IO::Compress::Base::Common::BEGIN@493 |
| 1 | 1 | 1 | 4µs | 6µs | IO::Compress::Base::Common::BEGIN@4 |
| 1 | 1 | 1 | 4µs | 20µs | IO::Compress::Base::Common::BEGIN@47 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@489 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@495 |
| 1 | 1 | 1 | 4µs | 18µs | IO::Compress::Base::Common::BEGIN@500 |
| 1 | 1 | 1 | 3µs | 18µs | IO::Compress::Base::Common::BEGIN@485 |
| 1 | 1 | 1 | 3µs | 18µs | IO::Compress::Base::Common::BEGIN@490 |
| 1 | 1 | 1 | 3µs | 18µs | U64::BEGIN@838 |
| 1 | 1 | 1 | 3µs | 4µs | IO::Compress::Base::Common::BEGIN@5 |
| 1 | 1 | 1 | 3µs | 17µs | IO::Compress::Base::Common::BEGIN@499 |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::Init |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::ParseParameters |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::cleanFileGlobString |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::createSelfTiedObject |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::getEncoding |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::hasEncode |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::isGeMax32 |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::isaFileGlobString |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::isaFilehandle |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::isaFilename |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::isaScalar |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::oneTarget |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::setBinModeInput |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::setBinModeOutput |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::whatIs |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::whatIsInput |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Common::whatIsOutput |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::_checkType |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::clone |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::getError |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::getValue |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::new |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::parse |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::parsed |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::setError |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::setValue |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::valueOrDefault |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::valueRef |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Parameters::wantValue |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Validator::croakError |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Validator::new |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Validator::saveErrorString |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Validator::validateInputArray |
| 0 | 0 | 0 | 0s | 0s | IO::Compress::Base::Validator::validateInputFilenames |
| 0 | 0 | 0 | 0s | 0s | U64::Value_VV64 |
| 0 | 0 | 0 | 0s | 0s | U64::add |
| 0 | 0 | 0 | 0s | 0s | U64::add32 |
| 0 | 0 | 0 | 0s | 0s | U64::clone |
| 0 | 0 | 0 | 0s | 0s | U64::cmp |
| 0 | 0 | 0 | 0s | 0s | U64::equal |
| 0 | 0 | 0 | 0s | 0s | U64::full32 |
| 0 | 0 | 0 | 0s | 0s | U64::get32bit |
| 0 | 0 | 0 | 0s | 0s | U64::get64bit |
| 0 | 0 | 0 | 0s | 0s | U64::getHigh |
| 0 | 0 | 0 | 0s | 0s | U64::getLow |
| 0 | 0 | 0 | 0s | 0s | U64::getPacked_V32 |
| 0 | 0 | 0 | 0s | 0s | U64::getPacked_V64 |
| 0 | 0 | 0 | 0s | 0s | U64::gt |
| 0 | 0 | 0 | 0s | 0s | U64::is64bit |
| 0 | 0 | 0 | 0s | 0s | U64::isAlmost64bit |
| 0 | 0 | 0 | 0s | 0s | U64::new |
| 0 | 0 | 0 | 0s | 0s | U64::newUnpack_V32 |
| 0 | 0 | 0 | 0s | 0s | U64::newUnpack_V64 |
| 0 | 0 | 0 | 0s | 0s | U64::pack_V64 |
| 0 | 0 | 0 | 0s | 0s | U64::reset |
| 0 | 0 | 0 | 0s | 0s | U64::subtract |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package IO::Compress::Base::Common; | ||||
| 2 | |||||
| 3 | 2 | 12µs | 2 | 10µs | # spent 9µs (8+1) within IO::Compress::Base::Common::BEGIN@3 which was called:
# once (8µs+1µs) by IO::Compress::Base::BEGIN@9 at line 3 # spent 9µs making 1 call to IO::Compress::Base::Common::BEGIN@3
# spent 1µs making 1 call to strict::import |
| 4 | 2 | 10µs | 2 | 7µs | # spent 6µs (4+2) within IO::Compress::Base::Common::BEGIN@4 which was called:
# once (4µs+2µs) by IO::Compress::Base::BEGIN@9 at line 4 # spent 6µs making 1 call to IO::Compress::Base::Common::BEGIN@4
# spent 2µs making 1 call to warnings::import |
| 5 | 2 | 11µs | 2 | 4µs | # spent 4µs (3+600ns) within IO::Compress::Base::Common::BEGIN@5 which was called:
# once (3µs+600ns) by IO::Compress::Base::BEGIN@9 at line 5 # spent 4µs making 1 call to IO::Compress::Base::Common::BEGIN@5
# spent 600ns making 1 call to bytes::import |
| 6 | |||||
| 7 | 2 | 18µs | 2 | 48µs | # spent 26µs (4+22) within IO::Compress::Base::Common::BEGIN@7 which was called:
# once (4µs+22µs) by IO::Compress::Base::BEGIN@9 at line 7 # spent 26µs making 1 call to IO::Compress::Base::Common::BEGIN@7
# spent 22µs making 1 call to Exporter::import |
| 8 | 2 | 16µs | 2 | 38µs | # spent 22µs (5+17) within IO::Compress::Base::Common::BEGIN@8 which was called:
# once (5µs+17µs) by IO::Compress::Base::BEGIN@9 at line 8 # spent 22µs making 1 call to IO::Compress::Base::Common::BEGIN@8
# spent 17µs making 1 call to Exporter::import |
| 9 | 2 | 115µs | 1 | 1.65ms | # spent 1.65ms (980µs+671µs) within IO::Compress::Base::Common::BEGIN@9 which was called:
# once (980µs+671µs) by IO::Compress::Base::BEGIN@9 at line 9 # spent 1.65ms making 1 call to IO::Compress::Base::Common::BEGIN@9 |
| 10 | |||||
| 11 | 1 | 400ns | require Exporter; | ||
| 12 | our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); | ||||
| 13 | 1 | 4µs | @ISA = qw(Exporter); | ||
| 14 | 1 | 200ns | $VERSION = '2.068'; | ||
| 15 | |||||
| 16 | 1 | 2µs | @EXPORT = qw( isaFilehandle isaFilename isaScalar | ||
| 17 | whatIsInput whatIsOutput | ||||
| 18 | isaFileGlobString cleanFileGlobString oneTarget | ||||
| 19 | setBinModeInput setBinModeOutput | ||||
| 20 | ckInOutParams | ||||
| 21 | createSelfTiedObject | ||||
| 22 | |||||
| 23 | isGeMax32 | ||||
| 24 | |||||
| 25 | MAX32 | ||||
| 26 | |||||
| 27 | WANT_CODE | ||||
| 28 | WANT_EXT | ||||
| 29 | WANT_UNDEF | ||||
| 30 | WANT_HASH | ||||
| 31 | |||||
| 32 | STATUS_OK | ||||
| 33 | STATUS_ENDSTREAM | ||||
| 34 | STATUS_EOF | ||||
| 35 | STATUS_ERROR | ||||
| 36 | ); | ||||
| 37 | |||||
| 38 | 1 | 1µs | %EXPORT_TAGS = ( Status => [qw( STATUS_OK | ||
| 39 | STATUS_ENDSTREAM | ||||
| 40 | STATUS_EOF | ||||
| 41 | STATUS_ERROR | ||||
| 42 | )]); | ||||
| 43 | |||||
| 44 | |||||
| 45 | 2 | 18µs | 2 | 61µs | # spent 33µs (6+28) within IO::Compress::Base::Common::BEGIN@45 which was called:
# once (6µs+28µs) by IO::Compress::Base::BEGIN@9 at line 45 # spent 33µs making 1 call to IO::Compress::Base::Common::BEGIN@45
# spent 28µs making 1 call to constant::import |
| 46 | 2 | 15µs | 2 | 41µs | # spent 23µs (5+18) within IO::Compress::Base::Common::BEGIN@46 which was called:
# once (5µs+18µs) by IO::Compress::Base::BEGIN@9 at line 46 # spent 23µs making 1 call to IO::Compress::Base::Common::BEGIN@46
# spent 18µs making 1 call to constant::import |
| 47 | 2 | 15µs | 2 | 35µs | # spent 20µs (4+16) within IO::Compress::Base::Common::BEGIN@47 which was called:
# once (4µs+16µs) by IO::Compress::Base::BEGIN@9 at line 47 # spent 20µs making 1 call to IO::Compress::Base::Common::BEGIN@47
# spent 16µs making 1 call to constant::import |
| 48 | 2 | 14µs | 2 | 36µs | # spent 20µs (4+16) within IO::Compress::Base::Common::BEGIN@48 which was called:
# once (4µs+16µs) by IO::Compress::Base::BEGIN@9 at line 48 # spent 20µs making 1 call to IO::Compress::Base::Common::BEGIN@48
# spent 16µs making 1 call to constant::import |
| 49 | 2 | 13µs | 2 | 34µs | # spent 19µs (4+15) within IO::Compress::Base::Common::BEGIN@49 which was called:
# once (4µs+15µs) by IO::Compress::Base::BEGIN@9 at line 49 # spent 19µs making 1 call to IO::Compress::Base::Common::BEGIN@49
# spent 15µs making 1 call to constant::import |
| 50 | 2 | 15µs | 2 | 32µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@50 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 50 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@50
# spent 14µs making 1 call to constant::import |
| 51 | 2 | 175µs | 2 | 32µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@51 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 51 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@51
# spent 14µs making 1 call to constant::import |
| 52 | |||||
| 53 | |||||
| 54 | sub isGeMax32 | ||||
| 55 | { | ||||
| 56 | return $_[0] >= MAX32cmp ; | ||||
| 57 | } | ||||
| 58 | |||||
| 59 | sub hasEncode() | ||||
| 60 | { | ||||
| 61 | if (! defined $HAS_ENCODE) { | ||||
| 62 | eval | ||||
| 63 | { | ||||
| 64 | require Encode; | ||||
| 65 | Encode->import(); | ||||
| 66 | }; | ||||
| 67 | |||||
| 68 | $HAS_ENCODE = $@ ? 0 : 1 ; | ||||
| 69 | } | ||||
| 70 | |||||
| 71 | return $HAS_ENCODE; | ||||
| 72 | } | ||||
| 73 | |||||
| 74 | sub getEncoding($$$) | ||||
| 75 | { | ||||
| 76 | my $obj = shift; | ||||
| 77 | my $class = shift ; | ||||
| 78 | my $want_encoding = shift ; | ||||
| 79 | |||||
| 80 | $obj->croakError("$class: Encode module needed to use -Encode") | ||||
| 81 | if ! hasEncode(); | ||||
| 82 | |||||
| 83 | my $encoding = Encode::find_encoding($want_encoding); | ||||
| 84 | |||||
| 85 | $obj->croakError("$class: Encoding '$want_encoding' is not available") | ||||
| 86 | if ! $encoding; | ||||
| 87 | |||||
| 88 | return $encoding; | ||||
| 89 | } | ||||
| 90 | |||||
| 91 | our ($needBinmode); | ||||
| 92 | 1 | 19µs | $needBinmode = ($^O eq 'MSWin32' || # spent 3µs executing statements in string eval | ||
| 93 | ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) | ||||
| 94 | ? 1 : 1 ; | ||||
| 95 | |||||
| 96 | sub setBinModeInput($) | ||||
| 97 | { | ||||
| 98 | my $handle = shift ; | ||||
| 99 | |||||
| 100 | binmode $handle | ||||
| 101 | if $needBinmode; | ||||
| 102 | } | ||||
| 103 | |||||
| 104 | sub setBinModeOutput($) | ||||
| 105 | { | ||||
| 106 | my $handle = shift ; | ||||
| 107 | |||||
| 108 | binmode $handle | ||||
| 109 | if $needBinmode; | ||||
| 110 | } | ||||
| 111 | |||||
| 112 | sub isaFilehandle($) | ||||
| 113 | { | ||||
| 114 | 2 | 137µs | 2 | 12µs | # spent 9µs (7+2) within IO::Compress::Base::Common::BEGIN@114 which was called:
# once (7µs+2µs) by IO::Compress::Base::BEGIN@9 at line 114 # spent 9µs making 1 call to IO::Compress::Base::Common::BEGIN@114
# spent 2µs making 1 call to utf8::import |
| 115 | return (defined $_[0] and | ||||
| 116 | (UNIVERSAL::isa($_[0],'GLOB') or | ||||
| 117 | UNIVERSAL::isa($_[0],'IO::Handle') or | ||||
| 118 | UNIVERSAL::isa(\$_[0],'GLOB')) | ||||
| 119 | ) | ||||
| 120 | } | ||||
| 121 | |||||
| 122 | sub isaScalar | ||||
| 123 | { | ||||
| 124 | return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ; | ||||
| 125 | } | ||||
| 126 | |||||
| 127 | sub isaFilename($) | ||||
| 128 | { | ||||
| 129 | return (defined $_[0] and | ||||
| 130 | ! ref $_[0] and | ||||
| 131 | UNIVERSAL::isa(\$_[0], 'SCALAR')); | ||||
| 132 | } | ||||
| 133 | |||||
| 134 | sub isaFileGlobString | ||||
| 135 | { | ||||
| 136 | return defined $_[0] && $_[0] =~ /^<.*>$/; | ||||
| 137 | } | ||||
| 138 | |||||
| 139 | sub cleanFileGlobString | ||||
| 140 | { | ||||
| 141 | my $string = shift ; | ||||
| 142 | |||||
| 143 | $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; | ||||
| 144 | |||||
| 145 | return $string; | ||||
| 146 | } | ||||
| 147 | |||||
| 148 | 2 | 18µs | 2 | 59µs | # spent 33µs (6+26) within IO::Compress::Base::Common::BEGIN@148 which was called:
# once (6µs+26µs) by IO::Compress::Base::BEGIN@9 at line 148 # spent 33µs making 1 call to IO::Compress::Base::Common::BEGIN@148
# spent 26µs making 1 call to constant::import |
| 149 | 2 | 14µs | 2 | 39µs | # spent 22µs (4+18) within IO::Compress::Base::Common::BEGIN@149 which was called:
# once (4µs+18µs) by IO::Compress::Base::BEGIN@9 at line 149 # spent 22µs making 1 call to IO::Compress::Base::Common::BEGIN@149
# spent 18µs making 1 call to constant::import |
| 150 | 2 | 14µs | 2 | 37µs | # spent 21µs (4+16) within IO::Compress::Base::Common::BEGIN@150 which was called:
# once (4µs+16µs) by IO::Compress::Base::BEGIN@9 at line 150 # spent 21µs making 1 call to IO::Compress::Base::Common::BEGIN@150
# spent 16µs making 1 call to constant::import |
| 151 | #use constant WANT_HASH => 8 ; | ||||
| 152 | 2 | 727µs | 2 | 33µs | # spent 19µs (4+15) within IO::Compress::Base::Common::BEGIN@152 which was called:
# once (4µs+15µs) by IO::Compress::Base::BEGIN@9 at line 152 # spent 19µs making 1 call to IO::Compress::Base::Common::BEGIN@152
# spent 15µs making 1 call to constant::import |
| 153 | |||||
| 154 | sub whatIsInput($;$) | ||||
| 155 | { | ||||
| 156 | my $got = whatIs(@_); | ||||
| 157 | |||||
| 158 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') | ||||
| 159 | { | ||||
| 160 | #use IO::File; | ||||
| 161 | $got = 'handle'; | ||||
| 162 | $_[0] = *STDIN; | ||||
| 163 | #$_[0] = new IO::File("<-"); | ||||
| 164 | } | ||||
| 165 | |||||
| 166 | return $got; | ||||
| 167 | } | ||||
| 168 | |||||
| 169 | sub whatIsOutput($;$) | ||||
| 170 | { | ||||
| 171 | my $got = whatIs(@_); | ||||
| 172 | |||||
| 173 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') | ||||
| 174 | { | ||||
| 175 | $got = 'handle'; | ||||
| 176 | $_[0] = *STDOUT; | ||||
| 177 | #$_[0] = new IO::File(">-"); | ||||
| 178 | } | ||||
| 179 | |||||
| 180 | return $got; | ||||
| 181 | } | ||||
| 182 | |||||
| 183 | sub whatIs ($;$) | ||||
| 184 | { | ||||
| 185 | return 'handle' if isaFilehandle($_[0]); | ||||
| 186 | |||||
| 187 | my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; | ||||
| 188 | my $extended = defined $_[1] && $_[1] & WANT_EXT ; | ||||
| 189 | my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; | ||||
| 190 | my $hash = defined $_[1] && $_[1] & WANT_HASH ; | ||||
| 191 | |||||
| 192 | return 'undef' if ! defined $_[0] && $undef ; | ||||
| 193 | |||||
| 194 | if (ref $_[0]) { | ||||
| 195 | return '' if blessed($_[0]); # is an object | ||||
| 196 | #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object | ||||
| 197 | return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); | ||||
| 198 | return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; | ||||
| 199 | return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; | ||||
| 200 | return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; | ||||
| 201 | return ''; | ||||
| 202 | } | ||||
| 203 | |||||
| 204 | return 'fileglob' if $extended && isaFileGlobString($_[0]); | ||||
| 205 | return 'filename'; | ||||
| 206 | } | ||||
| 207 | |||||
| 208 | sub oneTarget | ||||
| 209 | { | ||||
| 210 | return $_[0] =~ /^(code|handle|buffer|filename)$/; | ||||
| 211 | } | ||||
| 212 | |||||
| 213 | sub IO::Compress::Base::Validator::new | ||||
| 214 | { | ||||
| 215 | my $class = shift ; | ||||
| 216 | |||||
| 217 | my $Class = shift ; | ||||
| 218 | my $error_ref = shift ; | ||||
| 219 | my $reportClass = shift ; | ||||
| 220 | |||||
| 221 | my %data = (Class => $Class, | ||||
| 222 | Error => $error_ref, | ||||
| 223 | reportClass => $reportClass, | ||||
| 224 | ) ; | ||||
| 225 | |||||
| 226 | my $obj = bless \%data, $class ; | ||||
| 227 | |||||
| 228 | local $Carp::CarpLevel = 1; | ||||
| 229 | |||||
| 230 | my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); | ||||
| 231 | my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); | ||||
| 232 | |||||
| 233 | my $oneInput = $data{oneInput} = oneTarget($inType); | ||||
| 234 | my $oneOutput = $data{oneOutput} = oneTarget($outType); | ||||
| 235 | |||||
| 236 | if (! $inType) | ||||
| 237 | { | ||||
| 238 | $obj->croakError("$reportClass: illegal input parameter") ; | ||||
| 239 | #return undef ; | ||||
| 240 | } | ||||
| 241 | |||||
| 242 | # if ($inType eq 'hash') | ||||
| 243 | # { | ||||
| 244 | # $obj->{Hash} = 1 ; | ||||
| 245 | # $obj->{oneInput} = 1 ; | ||||
| 246 | # return $obj->validateHash($_[0]); | ||||
| 247 | # } | ||||
| 248 | |||||
| 249 | if (! $outType) | ||||
| 250 | { | ||||
| 251 | $obj->croakError("$reportClass: illegal output parameter") ; | ||||
| 252 | #return undef ; | ||||
| 253 | } | ||||
| 254 | |||||
| 255 | |||||
| 256 | if ($inType ne 'fileglob' && $outType eq 'fileglob') | ||||
| 257 | { | ||||
| 258 | $obj->croakError("Need input fileglob for outout fileglob"); | ||||
| 259 | } | ||||
| 260 | |||||
| 261 | # if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) | ||||
| 262 | # { | ||||
| 263 | # $obj->croakError("input must ne filename or fileglob when output is a hash"); | ||||
| 264 | # } | ||||
| 265 | |||||
| 266 | if ($inType eq 'fileglob' && $outType eq 'fileglob') | ||||
| 267 | { | ||||
| 268 | $data{GlobMap} = 1 ; | ||||
| 269 | $data{inType} = $data{outType} = 'filename'; | ||||
| 270 | my $mapper = new File::GlobMapper($_[0], $_[1]); | ||||
| 271 | if ( ! $mapper ) | ||||
| 272 | { | ||||
| 273 | return $obj->saveErrorString($File::GlobMapper::Error) ; | ||||
| 274 | } | ||||
| 275 | $data{Pairs} = $mapper->getFileMap(); | ||||
| 276 | |||||
| 277 | return $obj; | ||||
| 278 | } | ||||
| 279 | |||||
| 280 | $obj->croakError("$reportClass: input and output $inType are identical") | ||||
| 281 | if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; | ||||
| 282 | |||||
| 283 | if ($inType eq 'fileglob') # && $outType ne 'fileglob' | ||||
| 284 | { | ||||
| 285 | my $glob = cleanFileGlobString($_[0]); | ||||
| 286 | my @inputs = glob($glob); | ||||
| 287 | |||||
| 288 | if (@inputs == 0) | ||||
| 289 | { | ||||
| 290 | # TODO -- legal or die? | ||||
| 291 | die "globmap matched zero file -- legal or die???" ; | ||||
| 292 | } | ||||
| 293 | elsif (@inputs == 1) | ||||
| 294 | { | ||||
| 295 | $obj->validateInputFilenames($inputs[0]) | ||||
| 296 | or return undef; | ||||
| 297 | $_[0] = $inputs[0] ; | ||||
| 298 | $data{inType} = 'filename' ; | ||||
| 299 | $data{oneInput} = 1; | ||||
| 300 | } | ||||
| 301 | else | ||||
| 302 | { | ||||
| 303 | $obj->validateInputFilenames(@inputs) | ||||
| 304 | or return undef; | ||||
| 305 | $_[0] = [ @inputs ] ; | ||||
| 306 | $data{inType} = 'filenames' ; | ||||
| 307 | } | ||||
| 308 | } | ||||
| 309 | elsif ($inType eq 'filename') | ||||
| 310 | { | ||||
| 311 | $obj->validateInputFilenames($_[0]) | ||||
| 312 | or return undef; | ||||
| 313 | } | ||||
| 314 | elsif ($inType eq 'array') | ||||
| 315 | { | ||||
| 316 | $data{inType} = 'filenames' ; | ||||
| 317 | $obj->validateInputArray($_[0]) | ||||
| 318 | or return undef ; | ||||
| 319 | } | ||||
| 320 | |||||
| 321 | return $obj->saveErrorString("$reportClass: output buffer is read-only") | ||||
| 322 | if $outType eq 'buffer' && readonly(${ $_[1] }); | ||||
| 323 | |||||
| 324 | if ($outType eq 'filename' ) | ||||
| 325 | { | ||||
| 326 | $obj->croakError("$reportClass: output filename is undef or null string") | ||||
| 327 | if ! defined $_[1] || $_[1] eq '' ; | ||||
| 328 | |||||
| 329 | if (-e $_[1]) | ||||
| 330 | { | ||||
| 331 | if (-d _ ) | ||||
| 332 | { | ||||
| 333 | return $obj->saveErrorString("output file '$_[1]' is a directory"); | ||||
| 334 | } | ||||
| 335 | } | ||||
| 336 | } | ||||
| 337 | |||||
| 338 | return $obj ; | ||||
| 339 | } | ||||
| 340 | |||||
| 341 | sub IO::Compress::Base::Validator::saveErrorString | ||||
| 342 | { | ||||
| 343 | my $self = shift ; | ||||
| 344 | ${ $self->{Error} } = shift ; | ||||
| 345 | return undef; | ||||
| 346 | |||||
| 347 | } | ||||
| 348 | |||||
| 349 | sub IO::Compress::Base::Validator::croakError | ||||
| 350 | { | ||||
| 351 | my $self = shift ; | ||||
| 352 | $self->saveErrorString($_[0]); | ||||
| 353 | croak $_[0]; | ||||
| 354 | } | ||||
| 355 | |||||
| - - | |||||
| 358 | sub IO::Compress::Base::Validator::validateInputFilenames | ||||
| 359 | { | ||||
| 360 | my $self = shift ; | ||||
| 361 | |||||
| 362 | foreach my $filename (@_) | ||||
| 363 | { | ||||
| 364 | $self->croakError("$self->{reportClass}: input filename is undef or null string") | ||||
| 365 | if ! defined $filename || $filename eq '' ; | ||||
| 366 | |||||
| 367 | next if $filename eq '-'; | ||||
| 368 | |||||
| 369 | if (! -e $filename ) | ||||
| 370 | { | ||||
| 371 | return $self->saveErrorString("input file '$filename' does not exist"); | ||||
| 372 | } | ||||
| 373 | |||||
| 374 | if (-d _ ) | ||||
| 375 | { | ||||
| 376 | return $self->saveErrorString("input file '$filename' is a directory"); | ||||
| 377 | } | ||||
| 378 | |||||
| 379 | # if (! -r _ ) | ||||
| 380 | # { | ||||
| 381 | # return $self->saveErrorString("cannot open file '$filename': $!"); | ||||
| 382 | # } | ||||
| 383 | } | ||||
| 384 | |||||
| 385 | return 1 ; | ||||
| 386 | } | ||||
| 387 | |||||
| 388 | sub IO::Compress::Base::Validator::validateInputArray | ||||
| 389 | { | ||||
| 390 | my $self = shift ; | ||||
| 391 | |||||
| 392 | if ( @{ $_[0] } == 0 ) | ||||
| 393 | { | ||||
| 394 | return $self->saveErrorString("empty array reference") ; | ||||
| 395 | } | ||||
| 396 | |||||
| 397 | foreach my $element ( @{ $_[0] } ) | ||||
| 398 | { | ||||
| 399 | my $inType = whatIsInput($element); | ||||
| 400 | |||||
| 401 | if (! $inType) | ||||
| 402 | { | ||||
| 403 | $self->croakError("unknown input parameter") ; | ||||
| 404 | } | ||||
| 405 | elsif($inType eq 'filename') | ||||
| 406 | { | ||||
| 407 | $self->validateInputFilenames($element) | ||||
| 408 | or return undef ; | ||||
| 409 | } | ||||
| 410 | else | ||||
| 411 | { | ||||
| 412 | $self->croakError("not a filename") ; | ||||
| 413 | } | ||||
| 414 | } | ||||
| 415 | |||||
| 416 | return 1 ; | ||||
| 417 | } | ||||
| 418 | |||||
| 419 | #sub IO::Compress::Base::Validator::validateHash | ||||
| 420 | #{ | ||||
| 421 | # my $self = shift ; | ||||
| 422 | # my $href = shift ; | ||||
| 423 | # | ||||
| 424 | # while (my($k, $v) = each %$href) | ||||
| 425 | # { | ||||
| 426 | # my $ktype = whatIsInput($k); | ||||
| 427 | # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; | ||||
| 428 | # | ||||
| 429 | # if ($ktype ne 'filename') | ||||
| 430 | # { | ||||
| 431 | # return $self->saveErrorString("hash key not filename") ; | ||||
| 432 | # } | ||||
| 433 | # | ||||
| 434 | # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; | ||||
| 435 | # if (! $valid{$vtype}) | ||||
| 436 | # { | ||||
| 437 | # return $self->saveErrorString("hash value not ok") ; | ||||
| 438 | # } | ||||
| 439 | # } | ||||
| 440 | # | ||||
| 441 | # return $self ; | ||||
| 442 | #} | ||||
| 443 | |||||
| 444 | sub createSelfTiedObject | ||||
| 445 | { | ||||
| 446 | my $class = shift || (caller)[0] ; | ||||
| 447 | my $error_ref = shift ; | ||||
| 448 | |||||
| 449 | my $obj = bless Symbol::gensym(), ref($class) || $class; | ||||
| 450 | tie *$obj, $obj if $] >= 5.005; | ||||
| 451 | *$obj->{Closed} = 1 ; | ||||
| 452 | $$error_ref = ''; | ||||
| 453 | *$obj->{Error} = $error_ref ; | ||||
| 454 | my $errno = 0 ; | ||||
| 455 | *$obj->{ErrorNo} = \$errno ; | ||||
| 456 | |||||
| 457 | return $obj; | ||||
| 458 | } | ||||
| 459 | |||||
| - - | |||||
| 462 | #package Parse::Parameters ; | ||||
| 463 | # | ||||
| 464 | # | ||||
| 465 | #require Exporter; | ||||
| 466 | #our ($VERSION, @ISA, @EXPORT); | ||||
| 467 | #$VERSION = '2.000_08'; | ||||
| 468 | #@ISA = qw(Exporter); | ||||
| 469 | |||||
| 470 | 1 | 1µs | $EXPORT_TAGS{Parse} = [qw( ParseParameters | ||
| 471 | Parse_any Parse_unsigned Parse_signed | ||||
| 472 | Parse_boolean Parse_string | ||||
| 473 | Parse_code | ||||
| 474 | Parse_writable_scalar | ||||
| 475 | ) | ||||
| 476 | ]; | ||||
| 477 | |||||
| 478 | 1 | 1µs | push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; | ||
| 479 | |||||
| 480 | 2 | 20µs | 2 | 60µs | # spent 34µs (7+27) within IO::Compress::Base::Common::BEGIN@480 which was called:
# once (7µs+27µs) by IO::Compress::Base::BEGIN@9 at line 480 # spent 34µs making 1 call to IO::Compress::Base::Common::BEGIN@480
# spent 27µs making 1 call to constant::import |
| 481 | 2 | 16µs | 2 | 41µs | # spent 23µs (5+18) within IO::Compress::Base::Common::BEGIN@481 which was called:
# once (5µs+18µs) by IO::Compress::Base::BEGIN@9 at line 481 # spent 23µs making 1 call to IO::Compress::Base::Common::BEGIN@481
# spent 18µs making 1 call to constant::import |
| 482 | 2 | 14µs | 2 | 36µs | # spent 20µs (4+16) within IO::Compress::Base::Common::BEGIN@482 which was called:
# once (4µs+16µs) by IO::Compress::Base::BEGIN@9 at line 482 # spent 20µs making 1 call to IO::Compress::Base::Common::BEGIN@482
# spent 16µs making 1 call to constant::import |
| 483 | 2 | 14µs | 2 | 36µs | # spent 21µs (6+15) within IO::Compress::Base::Common::BEGIN@483 which was called:
# once (6µs+15µs) by IO::Compress::Base::BEGIN@9 at line 483 # spent 21µs making 1 call to IO::Compress::Base::Common::BEGIN@483
# spent 15µs making 1 call to constant::import |
| 484 | 2 | 14µs | 2 | 34µs | # spent 19µs (4+15) within IO::Compress::Base::Common::BEGIN@484 which was called:
# once (4µs+15µs) by IO::Compress::Base::BEGIN@9 at line 484 # spent 19µs making 1 call to IO::Compress::Base::Common::BEGIN@484
# spent 15µs making 1 call to constant::import |
| 485 | 2 | 13µs | 2 | 33µs | # spent 18µs (3+15) within IO::Compress::Base::Common::BEGIN@485 which was called:
# once (3µs+15µs) by IO::Compress::Base::BEGIN@9 at line 485 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@485
# spent 15µs making 1 call to constant::import |
| 486 | |||||
| 487 | #use constant Parse_store_ref => 0x100 ; | ||||
| 488 | #use constant Parse_multiple => 0x100 ; | ||||
| 489 | 2 | 16µs | 2 | 32µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@489 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 489 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@489
# spent 14µs making 1 call to constant::import |
| 490 | 2 | 13µs | 2 | 33µs | # spent 18µs (3+15) within IO::Compress::Base::Common::BEGIN@490 which was called:
# once (3µs+15µs) by IO::Compress::Base::BEGIN@9 at line 490 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@490
# spent 15µs making 1 call to constant::import |
| 491 | |||||
| 492 | 2 | 13µs | 2 | 31µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@492 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 492 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@492
# spent 14µs making 1 call to constant::import |
| 493 | 2 | 15µs | 2 | 31µs | # spent 17µs (4+14) within IO::Compress::Base::Common::BEGIN@493 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 493 # spent 17µs making 1 call to IO::Compress::Base::Common::BEGIN@493
# spent 14µs making 1 call to constant::import |
| 494 | 2 | 12µs | 2 | 36µs | # spent 21µs (6+15) within IO::Compress::Base::Common::BEGIN@494 which was called:
# once (6µs+15µs) by IO::Compress::Base::BEGIN@9 at line 494 # spent 21µs making 1 call to IO::Compress::Base::Common::BEGIN@494
# spent 15µs making 1 call to constant::import |
| 495 | 2 | 13µs | 2 | 32µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@495 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 495 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@495
# spent 14µs making 1 call to constant::import |
| 496 | #use constant OFF_FIRST_ONLY => 4 ; | ||||
| 497 | #use constant OFF_STICKY => 5 ; | ||||
| 498 | |||||
| 499 | 2 | 14µs | 2 | 30µs | # spent 17µs (3+14) within IO::Compress::Base::Common::BEGIN@499 which was called:
# once (3µs+14µs) by IO::Compress::Base::BEGIN@9 at line 499 # spent 17µs making 1 call to IO::Compress::Base::Common::BEGIN@499
# spent 14µs making 1 call to constant::import |
| 500 | 2 | 81µs | 2 | 32µs | # spent 18µs (4+14) within IO::Compress::Base::Common::BEGIN@500 which was called:
# once (4µs+14µs) by IO::Compress::Base::BEGIN@9 at line 500 # spent 18µs making 1 call to IO::Compress::Base::Common::BEGIN@500
# spent 14µs making 1 call to constant::import |
| 501 | |||||
| 502 | sub ParseParameters | ||||
| 503 | { | ||||
| 504 | my $level = shift || 0 ; | ||||
| 505 | |||||
| 506 | my $sub = (caller($level + 1))[3] ; | ||||
| 507 | local $Carp::CarpLevel = 1 ; | ||||
| 508 | |||||
| 509 | return $_[1] | ||||
| 510 | if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); | ||||
| 511 | |||||
| 512 | my $p = new IO::Compress::Base::Parameters() ; | ||||
| 513 | $p->parse(@_) | ||||
| 514 | or croak "$sub: $p->[IxError]" ; | ||||
| 515 | |||||
| 516 | return $p; | ||||
| 517 | } | ||||
| 518 | |||||
| 519 | |||||
| 520 | 2 | 15µs | 2 | 11µs | # spent 10µs (8+1) within IO::Compress::Base::Common::BEGIN@520 which was called:
# once (8µs+1µs) by IO::Compress::Base::BEGIN@9 at line 520 # spent 10µs making 1 call to IO::Compress::Base::Common::BEGIN@520
# spent 2µs making 1 call to strict::import |
| 521 | |||||
| 522 | 2 | 12µs | 2 | 15µs | # spent 10µs (5+5) within IO::Compress::Base::Common::BEGIN@522 which was called:
# once (5µs+5µs) by IO::Compress::Base::BEGIN@9 at line 522 # spent 10µs making 1 call to IO::Compress::Base::Common::BEGIN@522
# spent 5µs making 1 call to warnings::import |
| 523 | 2 | 749µs | 2 | 44µs | # spent 25µs (5+20) within IO::Compress::Base::Common::BEGIN@523 which was called:
# once (5µs+20µs) by IO::Compress::Base::BEGIN@9 at line 523 # spent 25µs making 1 call to IO::Compress::Base::Common::BEGIN@523
# spent 20µs making 1 call to Exporter::import |
| 524 | |||||
| 525 | |||||
| 526 | sub Init | ||||
| 527 | { | ||||
| 528 | my $default = shift ; | ||||
| 529 | my %got ; | ||||
| 530 | |||||
| 531 | my $obj = IO::Compress::Base::Parameters::new(); | ||||
| 532 | while (my ($key, $v) = each %$default) | ||||
| 533 | { | ||||
| 534 | croak "need 2 params [@$v]" | ||||
| 535 | if @$v != 2 ; | ||||
| 536 | |||||
| 537 | my ($type, $value) = @$v ; | ||||
| 538 | # my ($first_only, $sticky, $type, $value) = @$v ; | ||||
| 539 | my $sticky = 0; | ||||
| 540 | my $x ; | ||||
| 541 | $obj->_checkType($key, \$value, $type, 0, \$x) | ||||
| 542 | or return undef ; | ||||
| 543 | |||||
| 544 | $key = lc $key; | ||||
| 545 | |||||
| 546 | # if (! $sticky) { | ||||
| 547 | # $x = [] | ||||
| 548 | # if $type & Parse_multiple; | ||||
| 549 | |||||
| 550 | # $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ; | ||||
| 551 | $got{$key} = [0, $type, $value, $x] ; | ||||
| 552 | # } | ||||
| 553 | # | ||||
| 554 | # $got{$key}[OFF_PARSED] = 0 ; | ||||
| 555 | } | ||||
| 556 | |||||
| 557 | return bless \%got, "IO::Compress::Base::Parameters::Defaults" ; | ||||
| 558 | } | ||||
| 559 | |||||
| 560 | sub IO::Compress::Base::Parameters::new | ||||
| 561 | { | ||||
| 562 | #my $class = shift ; | ||||
| 563 | |||||
| 564 | my $obj; | ||||
| 565 | $obj->[IxError] = ''; | ||||
| 566 | $obj->[IxGot] = {} ; | ||||
| 567 | |||||
| 568 | return bless $obj, 'IO::Compress::Base::Parameters' ; | ||||
| 569 | } | ||||
| 570 | |||||
| 571 | sub IO::Compress::Base::Parameters::setError | ||||
| 572 | { | ||||
| 573 | my $self = shift ; | ||||
| 574 | my $error = shift ; | ||||
| 575 | my $retval = @_ ? shift : undef ; | ||||
| 576 | |||||
| 577 | |||||
| 578 | $self->[IxError] = $error ; | ||||
| 579 | return $retval; | ||||
| 580 | } | ||||
| 581 | |||||
| 582 | sub IO::Compress::Base::Parameters::getError | ||||
| 583 | { | ||||
| 584 | my $self = shift ; | ||||
| 585 | return $self->[IxError] ; | ||||
| 586 | } | ||||
| 587 | |||||
| 588 | sub IO::Compress::Base::Parameters::parse | ||||
| 589 | { | ||||
| 590 | my $self = shift ; | ||||
| 591 | my $default = shift ; | ||||
| 592 | |||||
| 593 | my $got = $self->[IxGot] ; | ||||
| 594 | my $firstTime = keys %{ $got } == 0 ; | ||||
| 595 | |||||
| 596 | my (@Bad) ; | ||||
| 597 | my @entered = () ; | ||||
| 598 | |||||
| 599 | # Allow the options to be passed as a hash reference or | ||||
| 600 | # as the complete hash. | ||||
| 601 | if (@_ == 0) { | ||||
| 602 | @entered = () ; | ||||
| 603 | } | ||||
| 604 | elsif (@_ == 1) { | ||||
| 605 | my $href = $_[0] ; | ||||
| 606 | |||||
| 607 | return $self->setError("Expected even number of parameters, got 1") | ||||
| 608 | if ! defined $href or ! ref $href or ref $href ne "HASH" ; | ||||
| 609 | |||||
| 610 | foreach my $key (keys %$href) { | ||||
| 611 | push @entered, $key ; | ||||
| 612 | push @entered, \$href->{$key} ; | ||||
| 613 | } | ||||
| 614 | } | ||||
| 615 | else { | ||||
| 616 | |||||
| 617 | my $count = @_; | ||||
| 618 | return $self->setError("Expected even number of parameters, got $count") | ||||
| 619 | if $count % 2 != 0 ; | ||||
| 620 | |||||
| 621 | for my $i (0.. $count / 2 - 1) { | ||||
| 622 | push @entered, $_[2 * $i] ; | ||||
| 623 | push @entered, \$_[2 * $i + 1] ; | ||||
| 624 | } | ||||
| 625 | } | ||||
| 626 | |||||
| 627 | foreach my $key (keys %$default) | ||||
| 628 | { | ||||
| 629 | |||||
| 630 | my ($type, $value) = @{ $default->{$key} } ; | ||||
| 631 | |||||
| 632 | if ($firstTime) { | ||||
| 633 | $got->{$key} = [0, $type, $value, $value] ; | ||||
| 634 | } | ||||
| 635 | else | ||||
| 636 | { | ||||
| 637 | $got->{$key}[OFF_PARSED] = 0 ; | ||||
| 638 | } | ||||
| 639 | } | ||||
| 640 | |||||
| 641 | |||||
| 642 | my %parsed = (); | ||||
| 643 | |||||
| 644 | |||||
| 645 | for my $i (0.. @entered / 2 - 1) { | ||||
| 646 | my $key = $entered[2* $i] ; | ||||
| 647 | my $value = $entered[2* $i+1] ; | ||||
| 648 | |||||
| 649 | #print "Key [$key] Value [$value]" ; | ||||
| 650 | #print defined $$value ? "[$$value]\n" : "[undef]\n"; | ||||
| 651 | |||||
| 652 | $key =~ s/^-// ; | ||||
| 653 | my $canonkey = lc $key; | ||||
| 654 | |||||
| 655 | if ($got->{$canonkey}) | ||||
| 656 | { | ||||
| 657 | my $type = $got->{$canonkey}[OFF_TYPE] ; | ||||
| 658 | my $parsed = $parsed{$canonkey}; | ||||
| 659 | ++ $parsed{$canonkey}; | ||||
| 660 | |||||
| 661 | return $self->setError("Muliple instances of '$key' found") | ||||
| 662 | if $parsed ; | ||||
| 663 | |||||
| 664 | my $s ; | ||||
| 665 | $self->_checkType($key, $value, $type, 1, \$s) | ||||
| 666 | or return undef ; | ||||
| 667 | |||||
| 668 | $value = $$value ; | ||||
| 669 | $got->{$canonkey} = [1, $type, $value, $s] ; | ||||
| 670 | |||||
| 671 | } | ||||
| 672 | else | ||||
| 673 | { push (@Bad, $key) } | ||||
| 674 | } | ||||
| 675 | |||||
| 676 | if (@Bad) { | ||||
| 677 | my ($bad) = join(", ", @Bad) ; | ||||
| 678 | return $self->setError("unknown key value(s) $bad") ; | ||||
| 679 | } | ||||
| 680 | |||||
| 681 | return 1; | ||||
| 682 | } | ||||
| 683 | |||||
| 684 | sub IO::Compress::Base::Parameters::_checkType | ||||
| 685 | { | ||||
| 686 | my $self = shift ; | ||||
| 687 | |||||
| 688 | my $key = shift ; | ||||
| 689 | my $value = shift ; | ||||
| 690 | my $type = shift ; | ||||
| 691 | my $validate = shift ; | ||||
| 692 | my $output = shift; | ||||
| 693 | |||||
| 694 | #local $Carp::CarpLevel = $level ; | ||||
| 695 | #print "PARSE $type $key $value $validate $sub\n" ; | ||||
| 696 | |||||
| 697 | if ($type & Parse_writable_scalar) | ||||
| 698 | { | ||||
| 699 | return $self->setError("Parameter '$key' not writable") | ||||
| 700 | if readonly $$value ; | ||||
| 701 | |||||
| 702 | if (ref $$value) | ||||
| 703 | { | ||||
| 704 | return $self->setError("Parameter '$key' not a scalar reference") | ||||
| 705 | if ref $$value ne 'SCALAR' ; | ||||
| 706 | |||||
| 707 | $$output = $$value ; | ||||
| 708 | } | ||||
| 709 | else | ||||
| 710 | { | ||||
| 711 | return $self->setError("Parameter '$key' not a scalar") | ||||
| 712 | if ref $value ne 'SCALAR' ; | ||||
| 713 | |||||
| 714 | $$output = $value ; | ||||
| 715 | } | ||||
| 716 | |||||
| 717 | return 1; | ||||
| 718 | } | ||||
| 719 | |||||
| 720 | |||||
| 721 | $value = $$value ; | ||||
| 722 | |||||
| 723 | if ($type & Parse_any) | ||||
| 724 | { | ||||
| 725 | $$output = $value ; | ||||
| 726 | return 1; | ||||
| 727 | } | ||||
| 728 | elsif ($type & Parse_unsigned) | ||||
| 729 | { | ||||
| 730 | |||||
| 731 | return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") | ||||
| 732 | if ! defined $value ; | ||||
| 733 | return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") | ||||
| 734 | if $value !~ /^\d+$/; | ||||
| 735 | |||||
| 736 | $$output = defined $value ? $value : 0 ; | ||||
| 737 | return 1; | ||||
| 738 | } | ||||
| 739 | elsif ($type & Parse_signed) | ||||
| 740 | { | ||||
| 741 | return $self->setError("Parameter '$key' must be a signed int, got 'undef'") | ||||
| 742 | if ! defined $value ; | ||||
| 743 | return $self->setError("Parameter '$key' must be a signed int, got '$value'") | ||||
| 744 | if $value !~ /^-?\d+$/; | ||||
| 745 | |||||
| 746 | $$output = defined $value ? $value : 0 ; | ||||
| 747 | return 1 ; | ||||
| 748 | } | ||||
| 749 | elsif ($type & Parse_boolean) | ||||
| 750 | { | ||||
| 751 | return $self->setError("Parameter '$key' must be an int, got '$value'") | ||||
| 752 | if defined $value && $value !~ /^\d*$/; | ||||
| 753 | |||||
| 754 | $$output = defined $value && $value != 0 ? 1 : 0 ; | ||||
| 755 | return 1; | ||||
| 756 | } | ||||
| 757 | |||||
| 758 | elsif ($type & Parse_string) | ||||
| 759 | { | ||||
| 760 | $$output = defined $value ? $value : "" ; | ||||
| 761 | return 1; | ||||
| 762 | } | ||||
| 763 | elsif ($type & Parse_code) | ||||
| 764 | { | ||||
| 765 | return $self->setError("Parameter '$key' must be a code reference, got '$value'") | ||||
| 766 | if (! defined $value || ref $value ne 'CODE') ; | ||||
| 767 | |||||
| 768 | $$output = defined $value ? $value : "" ; | ||||
| 769 | return 1; | ||||
| 770 | } | ||||
| 771 | |||||
| 772 | $$output = $value ; | ||||
| 773 | return 1; | ||||
| 774 | } | ||||
| 775 | |||||
| 776 | sub IO::Compress::Base::Parameters::parsed | ||||
| 777 | { | ||||
| 778 | return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ; | ||||
| 779 | } | ||||
| 780 | |||||
| 781 | |||||
| 782 | sub IO::Compress::Base::Parameters::getValue | ||||
| 783 | { | ||||
| 784 | return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; | ||||
| 785 | } | ||||
| 786 | sub IO::Compress::Base::Parameters::setValue | ||||
| 787 | { | ||||
| 788 | $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1; | ||||
| 789 | $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ; | ||||
| 790 | $_[0]->[IxGot]{$_[1]}[OFF_FIXED] = $_[2] ; | ||||
| 791 | } | ||||
| 792 | |||||
| 793 | sub IO::Compress::Base::Parameters::valueRef | ||||
| 794 | { | ||||
| 795 | return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; | ||||
| 796 | } | ||||
| 797 | |||||
| 798 | sub IO::Compress::Base::Parameters::valueOrDefault | ||||
| 799 | { | ||||
| 800 | my $self = shift ; | ||||
| 801 | my $name = shift ; | ||||
| 802 | my $default = shift ; | ||||
| 803 | |||||
| 804 | my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ; | ||||
| 805 | |||||
| 806 | return $value if defined $value ; | ||||
| 807 | return $default ; | ||||
| 808 | } | ||||
| 809 | |||||
| 810 | sub IO::Compress::Base::Parameters::wantValue | ||||
| 811 | { | ||||
| 812 | return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ; | ||||
| 813 | } | ||||
| 814 | |||||
| 815 | sub IO::Compress::Base::Parameters::clone | ||||
| 816 | { | ||||
| 817 | my $self = shift ; | ||||
| 818 | my $obj = [] ; | ||||
| 819 | my %got ; | ||||
| 820 | |||||
| 821 | my $hash = $self->[IxGot] ; | ||||
| 822 | for my $k (keys %{ $hash }) | ||||
| 823 | { | ||||
| 824 | $got{$k} = [ @{ $hash->{$k} } ]; | ||||
| 825 | } | ||||
| 826 | |||||
| 827 | $obj->[IxError] = $self->[IxError]; | ||||
| 828 | $obj->[IxGot] = \%got ; | ||||
| 829 | |||||
| 830 | return bless $obj, 'IO::Compress::Base::Parameters' ; | ||||
| 831 | } | ||||
| 832 | |||||
| 833 | package U64; | ||||
| 834 | |||||
| 835 | 2 | 24µs | 2 | 56µs | # spent 31µs (7+25) within U64::BEGIN@835 which was called:
# once (7µs+25µs) by IO::Compress::Base::BEGIN@9 at line 835 # spent 31µs making 1 call to U64::BEGIN@835
# spent 24µs making 1 call to constant::import |
| 836 | 2 | 20µs | 2 | 41µs | # spent 23µs (4+18) within U64::BEGIN@836 which was called:
# once (4µs+18µs) by IO::Compress::Base::BEGIN@9 at line 836 # spent 23µs making 1 call to U64::BEGIN@836
# spent 18µs making 1 call to constant::import |
| 837 | 2 | 14µs | 2 | 35µs | # spent 20µs (4+16) within U64::BEGIN@837 which was called:
# once (4µs+16µs) by IO::Compress::Base::BEGIN@9 at line 837 # spent 20µs making 1 call to U64::BEGIN@837
# spent 16µs making 1 call to constant::import |
| 838 | 2 | 448µs | 2 | 33µs | # spent 18µs (3+15) within U64::BEGIN@838 which was called:
# once (3µs+15µs) by IO::Compress::Base::BEGIN@9 at line 838 # spent 18µs making 1 call to U64::BEGIN@838
# spent 15µs making 1 call to constant::import |
| 839 | |||||
| 840 | sub new | ||||
| 841 | { | ||||
| 842 | return bless [ 0, 0 ], $_[0] | ||||
| 843 | if @_ == 1 ; | ||||
| 844 | |||||
| 845 | return bless [ $_[1], 0 ], $_[0] | ||||
| 846 | if @_ == 2 ; | ||||
| 847 | |||||
| 848 | return bless [ $_[2], $_[1] ], $_[0] | ||||
| 849 | if @_ == 3 ; | ||||
| 850 | } | ||||
| 851 | |||||
| 852 | sub newUnpack_V64 | ||||
| 853 | { | ||||
| 854 | my ($low, $hi) = unpack "V V", $_[0] ; | ||||
| 855 | bless [ $low, $hi ], "U64"; | ||||
| 856 | } | ||||
| 857 | |||||
| 858 | sub newUnpack_V32 | ||||
| 859 | { | ||||
| 860 | my $string = shift; | ||||
| 861 | |||||
| 862 | my $low = unpack "V", $string ; | ||||
| 863 | bless [ $low, 0 ], "U64"; | ||||
| 864 | } | ||||
| 865 | |||||
| 866 | sub reset | ||||
| 867 | { | ||||
| 868 | $_[0]->[HIGH] = $_[0]->[LOW] = 0; | ||||
| 869 | } | ||||
| 870 | |||||
| 871 | sub clone | ||||
| 872 | { | ||||
| 873 | bless [ @{$_[0]} ], ref $_[0] ; | ||||
| 874 | } | ||||
| 875 | |||||
| 876 | sub getHigh | ||||
| 877 | { | ||||
| 878 | return $_[0]->[HIGH]; | ||||
| 879 | } | ||||
| 880 | |||||
| 881 | sub getLow | ||||
| 882 | { | ||||
| 883 | return $_[0]->[LOW]; | ||||
| 884 | } | ||||
| 885 | |||||
| 886 | sub get32bit | ||||
| 887 | { | ||||
| 888 | return $_[0]->[LOW]; | ||||
| 889 | } | ||||
| 890 | |||||
| 891 | sub get64bit | ||||
| 892 | { | ||||
| 893 | # Not using << here because the result will still be | ||||
| 894 | # a 32-bit value on systems where int size is 32-bits | ||||
| 895 | return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW]; | ||||
| 896 | } | ||||
| 897 | |||||
| 898 | sub add | ||||
| 899 | { | ||||
| 900 | # my $self = shift; | ||||
| 901 | my $value = $_[1]; | ||||
| 902 | |||||
| 903 | if (ref $value eq 'U64') { | ||||
| 904 | $_[0]->[HIGH] += $value->[HIGH] ; | ||||
| 905 | $value = $value->[LOW]; | ||||
| 906 | } | ||||
| 907 | elsif ($value > MAX32) { | ||||
| 908 | $_[0]->[HIGH] += int($value / HI_1) ; | ||||
| 909 | $value = $value % HI_1; | ||||
| 910 | } | ||||
| 911 | |||||
| 912 | my $available = MAX32 - $_[0]->[LOW] ; | ||||
| 913 | |||||
| 914 | if ($value > $available) { | ||||
| 915 | ++ $_[0]->[HIGH] ; | ||||
| 916 | $_[0]->[LOW] = $value - $available - 1; | ||||
| 917 | } | ||||
| 918 | else { | ||||
| 919 | $_[0]->[LOW] += $value ; | ||||
| 920 | } | ||||
| 921 | } | ||||
| 922 | |||||
| 923 | sub add32 | ||||
| 924 | { | ||||
| 925 | # my $self = shift; | ||||
| 926 | my $value = $_[1]; | ||||
| 927 | |||||
| 928 | if ($value > MAX32) { | ||||
| 929 | $_[0]->[HIGH] += int($value / HI_1) ; | ||||
| 930 | $value = $value % HI_1; | ||||
| 931 | } | ||||
| 932 | |||||
| 933 | my $available = MAX32 - $_[0]->[LOW] ; | ||||
| 934 | |||||
| 935 | if ($value > $available) { | ||||
| 936 | ++ $_[0]->[HIGH] ; | ||||
| 937 | $_[0]->[LOW] = $value - $available - 1; | ||||
| 938 | } | ||||
| 939 | else { | ||||
| 940 | $_[0]->[LOW] += $value ; | ||||
| 941 | } | ||||
| 942 | } | ||||
| 943 | |||||
| 944 | sub subtract | ||||
| 945 | { | ||||
| 946 | my $self = shift; | ||||
| 947 | my $value = shift; | ||||
| 948 | |||||
| 949 | if (ref $value eq 'U64') { | ||||
| 950 | |||||
| 951 | if ($value->[HIGH]) { | ||||
| 952 | die "bad" | ||||
| 953 | if $self->[HIGH] == 0 || | ||||
| 954 | $value->[HIGH] > $self->[HIGH] ; | ||||
| 955 | |||||
| 956 | $self->[HIGH] -= $value->[HIGH] ; | ||||
| 957 | } | ||||
| 958 | |||||
| 959 | $value = $value->[LOW] ; | ||||
| 960 | } | ||||
| 961 | |||||
| 962 | if ($value > $self->[LOW]) { | ||||
| 963 | -- $self->[HIGH] ; | ||||
| 964 | $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ; | ||||
| 965 | } | ||||
| 966 | else { | ||||
| 967 | $self->[LOW] -= $value; | ||||
| 968 | } | ||||
| 969 | } | ||||
| 970 | |||||
| 971 | sub equal | ||||
| 972 | { | ||||
| 973 | my $self = shift; | ||||
| 974 | my $other = shift; | ||||
| 975 | |||||
| 976 | return $self->[LOW] == $other->[LOW] && | ||||
| 977 | $self->[HIGH] == $other->[HIGH] ; | ||||
| 978 | } | ||||
| 979 | |||||
| 980 | sub gt | ||||
| 981 | { | ||||
| 982 | my $self = shift; | ||||
| 983 | my $other = shift; | ||||
| 984 | |||||
| 985 | return $self->cmp($other) > 0 ; | ||||
| 986 | } | ||||
| 987 | |||||
| 988 | sub cmp | ||||
| 989 | { | ||||
| 990 | my $self = shift; | ||||
| 991 | my $other = shift ; | ||||
| 992 | |||||
| 993 | if ($self->[LOW] == $other->[LOW]) { | ||||
| 994 | return $self->[HIGH] - $other->[HIGH] ; | ||||
| 995 | } | ||||
| 996 | else { | ||||
| 997 | return $self->[LOW] - $other->[LOW] ; | ||||
| 998 | } | ||||
| 999 | } | ||||
| 1000 | |||||
| 1001 | |||||
| 1002 | sub is64bit | ||||
| 1003 | { | ||||
| 1004 | return $_[0]->[HIGH] > 0 ; | ||||
| 1005 | } | ||||
| 1006 | |||||
| 1007 | sub isAlmost64bit | ||||
| 1008 | { | ||||
| 1009 | return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ; | ||||
| 1010 | } | ||||
| 1011 | |||||
| 1012 | sub getPacked_V64 | ||||
| 1013 | { | ||||
| 1014 | return pack "V V", @{ $_[0] } ; | ||||
| 1015 | } | ||||
| 1016 | |||||
| 1017 | sub getPacked_V32 | ||||
| 1018 | { | ||||
| 1019 | return pack "V", $_[0]->[LOW] ; | ||||
| 1020 | } | ||||
| 1021 | |||||
| 1022 | sub pack_V64 | ||||
| 1023 | { | ||||
| 1024 | return pack "V V", $_[0], 0; | ||||
| 1025 | } | ||||
| 1026 | |||||
| 1027 | |||||
| 1028 | sub full32 | ||||
| 1029 | { | ||||
| 1030 | return $_[0] == MAX32 ; | ||||
| 1031 | } | ||||
| 1032 | |||||
| 1033 | sub Value_VV64 | ||||
| 1034 | { | ||||
| 1035 | my $buffer = shift; | ||||
| 1036 | |||||
| 1037 | my ($lo, $hi) = unpack ("V V" , $buffer); | ||||
| 1038 | 2 | 44µs | 2 | 25µs | # spent 17µs (10+8) within U64::BEGIN@1038 which was called:
# once (10µs+8µs) by IO::Compress::Base::BEGIN@9 at line 1038 # spent 17µs making 1 call to U64::BEGIN@1038
# spent 8µs making 1 call to warnings::unimport |
| 1039 | return $hi * HI_1 + $lo; | ||||
| 1040 | } | ||||
| 1041 | |||||
| 1042 | |||||
| 1043 | package IO::Compress::Base::Common; | ||||
| 1044 | |||||
| 1045 | 1 | 6µs | 1; |