| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package IO::Compress::Base::Common; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 84 |  |  | 84 |  | 596 | use strict ; | 
|  | 84 |  |  |  |  | 166 |  | 
|  | 84 |  |  |  |  | 2424 |  | 
| 4 | 84 |  |  | 84 |  | 412 | use warnings; | 
|  | 84 |  |  |  |  | 175 |  | 
|  | 84 |  |  |  |  | 1948 |  | 
| 5 | 84 |  |  | 84 |  | 1035 | use bytes; | 
|  | 84 |  |  |  |  | 196 |  | 
|  | 84 |  |  |  |  | 1994 |  | 
| 6 |  |  |  |  |  |  |  | 
| 7 | 84 |  |  | 84 |  | 1963 | use Carp; | 
|  | 84 |  |  |  |  | 166 |  | 
|  | 84 |  |  |  |  | 8274 |  | 
| 8 | 84 |  |  | 84 |  | 567 | use Scalar::Util qw(blessed readonly); | 
|  | 84 |  |  |  |  | 228 |  | 
|  | 84 |  |  |  |  | 9446 |  | 
| 9 | 84 |  |  | 84 |  | 42050 | use File::GlobMapper; | 
|  | 84 |  |  |  |  | 235 |  | 
|  | 84 |  |  |  |  | 11081 |  | 
| 10 |  |  |  |  |  |  |  | 
| 11 |  |  |  |  |  |  | require Exporter; | 
| 12 |  |  |  |  |  |  | our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); | 
| 13 |  |  |  |  |  |  | @ISA = qw(Exporter); | 
| 14 |  |  |  |  |  |  | $VERSION = '2.205'; | 
| 15 |  |  |  |  |  |  |  | 
| 16 |  |  |  |  |  |  | @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 |  |  |  |  |  |  | %EXPORT_TAGS = ( Status => [qw( STATUS_OK | 
| 39 |  |  |  |  |  |  | STATUS_ENDSTREAM | 
| 40 |  |  |  |  |  |  | STATUS_EOF | 
| 41 |  |  |  |  |  |  | STATUS_ERROR | 
| 42 |  |  |  |  |  |  | )]); | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  |  | 
| 45 | 84 |  |  | 84 |  | 954 | use constant STATUS_OK        => 0; | 
|  | 84 |  |  |  |  | 240 |  | 
|  | 84 |  |  |  |  | 10047 |  | 
| 46 | 84 |  |  | 84 |  | 627 | use constant STATUS_ENDSTREAM => 1; | 
|  | 84 |  |  |  |  | 192 |  | 
|  | 84 |  |  |  |  | 4828 |  | 
| 47 | 84 |  |  | 84 |  | 527 | use constant STATUS_EOF       => 2; | 
|  | 84 |  |  |  |  | 1054 |  | 
|  | 84 |  |  |  |  | 5382 |  | 
| 48 | 84 |  |  | 84 |  | 576 | use constant STATUS_ERROR     => -1; | 
|  | 84 |  |  |  |  | 219 |  | 
|  | 84 |  |  |  |  | 4803 |  | 
| 49 | 84 |  |  | 84 |  | 541 | use constant MAX16            => 0xFFFF ; | 
|  | 84 |  |  |  |  | 203 |  | 
|  | 84 |  |  |  |  | 4979 |  | 
| 50 | 84 |  |  | 84 |  | 547 | use constant MAX32            => 0xFFFFFFFF ; | 
|  | 84 |  |  |  |  | 206 |  | 
|  | 84 |  |  |  |  | 4888 |  | 
| 51 | 84 |  |  | 84 |  | 521 | use constant MAX32cmp         => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value | 
|  | 84 |  |  |  |  | 200 |  | 
|  | 84 |  |  |  |  | 34098 |  | 
| 52 |  |  |  |  |  |  |  | 
| 53 |  |  |  |  |  |  |  | 
| 54 |  |  |  |  |  |  | sub isGeMax32 | 
| 55 |  |  |  |  |  |  | { | 
| 56 | 184 |  |  | 184 | 0 | 634 | return $_[0] >= MAX32cmp ; | 
| 57 |  |  |  |  |  |  | } | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  | sub hasEncode() | 
| 60 |  |  |  |  |  |  | { | 
| 61 | 20 | 100 |  | 20 | 0 | 61 | if (! defined $HAS_ENCODE) { | 
| 62 |  |  |  |  |  |  | eval | 
| 63 | 5 |  |  |  |  | 10 | { | 
| 64 | 5 |  |  |  |  | 44 | require Encode; | 
| 65 | 5 |  |  |  |  | 354 | Encode->import(); | 
| 66 |  |  |  |  |  |  | }; | 
| 67 |  |  |  |  |  |  |  | 
| 68 | 5 | 50 |  |  |  | 30 | $HAS_ENCODE = $@ ? 0 : 1 ; | 
| 69 |  |  |  |  |  |  | } | 
| 70 |  |  |  |  |  |  |  | 
| 71 | 20 |  |  |  |  | 49 | return $HAS_ENCODE; | 
| 72 |  |  |  |  |  |  | } | 
| 73 |  |  |  |  |  |  |  | 
| 74 |  |  |  |  |  |  | sub getEncoding($$$) | 
| 75 |  |  |  |  |  |  | { | 
| 76 | 20 |  |  | 20 | 0 | 35 | my $obj = shift; | 
| 77 | 20 |  |  |  |  | 34 | my $class = shift ; | 
| 78 | 20 |  |  |  |  | 33 | my $want_encoding = shift ; | 
| 79 |  |  |  |  |  |  |  | 
| 80 | 20 | 50 |  |  |  | 50 | $obj->croakError("$class: Encode module needed to use -Encode") | 
| 81 |  |  |  |  |  |  | if ! hasEncode(); | 
| 82 |  |  |  |  |  |  |  | 
| 83 | 20 |  |  |  |  | 58 | my $encoding = Encode::find_encoding($want_encoding); | 
| 84 |  |  |  |  |  |  |  | 
| 85 | 20 | 100 |  |  |  | 4527 | $obj->croakError("$class: Encoding '$want_encoding' is not available") | 
| 86 |  |  |  |  |  |  | if ! $encoding; | 
| 87 |  |  |  |  |  |  |  | 
| 88 | 15 |  |  |  |  | 58 | return $encoding; | 
| 89 |  |  |  |  |  |  | } | 
| 90 |  |  |  |  |  |  |  | 
| 91 |  |  |  |  |  |  | our ($needBinmode); | 
| 92 |  |  |  |  |  |  | $needBinmode = ($^O eq 'MSWin32' || | 
| 93 |  |  |  |  |  |  | ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) | 
| 94 |  |  |  |  |  |  | ? 1 : 1 ; | 
| 95 |  |  |  |  |  |  |  | 
| 96 |  |  |  |  |  |  | sub setBinModeInput($) | 
| 97 |  |  |  |  |  |  | { | 
| 98 | 2170 |  |  | 2170 | 0 | 4075 | my $handle = shift ; | 
| 99 |  |  |  |  |  |  |  | 
| 100 | 2170 | 50 |  |  |  | 9281 | binmode $handle | 
| 101 |  |  |  |  |  |  | if  $needBinmode; | 
| 102 |  |  |  |  |  |  | } | 
| 103 |  |  |  |  |  |  |  | 
| 104 |  |  |  |  |  |  | sub setBinModeOutput($) | 
| 105 |  |  |  |  |  |  | { | 
| 106 | 1018 |  |  | 1018 | 0 | 2513 | my $handle = shift ; | 
| 107 |  |  |  |  |  |  |  | 
| 108 | 1018 | 50 |  |  |  | 5256 | binmode $handle | 
| 109 |  |  |  |  |  |  | if  $needBinmode; | 
| 110 |  |  |  |  |  |  | } | 
| 111 |  |  |  |  |  |  |  | 
| 112 |  |  |  |  |  |  | sub isaFilehandle($) | 
| 113 |  |  |  |  |  |  | { | 
| 114 | 84 |  |  | 84 |  | 52005 | use utf8; # Pragma needed to keep Perl 5.6.0 happy | 
|  | 84 |  |  |  |  | 1299 |  | 
|  | 84 |  |  |  |  | 496 |  | 
| 115 | 16424 |  | 66 | 16424 | 0 | 4385625 | 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 | 1018 |  | 100 | 1018 | 0 | 5779 | return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ; | 
| 125 |  |  |  |  |  |  | } | 
| 126 |  |  |  |  |  |  |  | 
| 127 |  |  |  |  |  |  | sub isaFilename($) | 
| 128 |  |  |  |  |  |  | { | 
| 129 | 1458 |  | 100 | 1458 | 0 | 11640 | return (defined $_[0] and | 
| 130 |  |  |  |  |  |  | ! ref $_[0]    and | 
| 131 |  |  |  |  |  |  | UNIVERSAL::isa(\$_[0], 'SCALAR')); | 
| 132 |  |  |  |  |  |  | } | 
| 133 |  |  |  |  |  |  |  | 
| 134 |  |  |  |  |  |  | sub isaFileGlobString | 
| 135 |  |  |  |  |  |  | { | 
| 136 | 947 |  | 100 | 947 | 0 | 6622 | return defined $_[0] && $_[0] =~ /^<.*>$/; | 
| 137 |  |  |  |  |  |  | } | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | sub cleanFileGlobString | 
| 140 |  |  |  |  |  |  | { | 
| 141 | 110 |  |  | 110 | 0 | 202 | my $string = shift ; | 
| 142 |  |  |  |  |  |  |  | 
| 143 | 110 |  |  |  |  | 872 | $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; | 
| 144 |  |  |  |  |  |  |  | 
| 145 | 110 |  |  |  |  | 340 | return $string; | 
| 146 |  |  |  |  |  |  | } | 
| 147 |  |  |  |  |  |  |  | 
| 148 | 84 |  |  | 84 |  | 22732 | use constant WANT_CODE  => 1 ; | 
|  | 84 |  |  |  |  | 204 |  | 
|  | 84 |  |  |  |  | 5031 |  | 
| 149 | 84 |  |  | 84 |  | 545 | use constant WANT_EXT   => 2 ; | 
|  | 84 |  |  |  |  | 181 |  | 
|  | 84 |  |  |  |  | 4542 |  | 
| 150 | 84 |  |  | 84 |  | 566 | use constant WANT_UNDEF => 4 ; | 
|  | 84 |  |  |  |  | 172 |  | 
|  | 84 |  |  |  |  | 5250 |  | 
| 151 |  |  |  |  |  |  | #use constant WANT_HASH  => 8 ; | 
| 152 | 84 |  |  | 84 |  | 592 | use constant WANT_HASH  => 0 ; | 
|  | 84 |  |  |  |  | 215 |  | 
|  | 84 |  |  |  |  | 145325 |  | 
| 153 |  |  |  |  |  |  |  | 
| 154 |  |  |  |  |  |  | sub whatIsInput($;$) | 
| 155 |  |  |  |  |  |  | { | 
| 156 | 9039 |  |  | 9039 | 0 | 18981 | my $got = whatIs(@_); | 
| 157 |  |  |  |  |  |  |  | 
| 158 | 9039 | 100 | 66 |  |  | 41148 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') | 
|  |  |  | 100 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
| 159 |  |  |  |  |  |  | { | 
| 160 |  |  |  |  |  |  | #use IO::File; | 
| 161 | 67 |  |  |  |  | 181 | $got = 'handle'; | 
| 162 | 67 |  |  |  |  | 271 | $_[0] = *STDIN; | 
| 163 |  |  |  |  |  |  | #$_[0] = IO::File->new("<-"); | 
| 164 |  |  |  |  |  |  | } | 
| 165 |  |  |  |  |  |  |  | 
| 166 | 9039 |  |  |  |  | 20147 | return $got; | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  |  | 
| 169 |  |  |  |  |  |  | sub whatIsOutput($;$) | 
| 170 |  |  |  |  |  |  | { | 
| 171 | 5251 |  |  | 5251 | 0 | 10813 | my $got = whatIs(@_); | 
| 172 |  |  |  |  |  |  |  | 
| 173 | 5251 | 100 | 66 |  |  | 24417 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') | 
|  |  |  | 66 |  |  |  |  | 
|  |  |  | 100 |  |  |  |  | 
| 174 |  |  |  |  |  |  | { | 
| 175 | 7 |  |  |  |  | 19 | $got = 'handle'; | 
| 176 | 7 |  |  |  |  | 38 | $_[0] = *STDOUT; | 
| 177 |  |  |  |  |  |  | #$_[0] = IO::File->new(">-"); | 
| 178 |  |  |  |  |  |  | } | 
| 179 |  |  |  |  |  |  |  | 
| 180 | 5251 |  |  |  |  | 11854 | return $got; | 
| 181 |  |  |  |  |  |  | } | 
| 182 |  |  |  |  |  |  |  | 
| 183 |  |  |  |  |  |  | sub whatIs ($;$) | 
| 184 |  |  |  |  |  |  | { | 
| 185 | 14290 | 100 |  | 14290 | 0 | 26757 | return 'handle' if isaFilehandle($_[0]); | 
| 186 |  |  |  |  |  |  |  | 
| 187 | 12498 |  | 100 |  |  | 38602 | my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; | 
| 188 | 12498 |  | 100 |  |  | 30703 | my $extended = defined $_[1] && $_[1] & WANT_EXT ; | 
| 189 | 12498 |  | 66 |  |  | 29239 | my $undef    = defined $_[1] && $_[1] & WANT_UNDEF ; | 
| 190 | 12498 |  | 66 |  |  | 29079 | my $hash     = defined $_[1] && $_[1] & WANT_HASH ; | 
| 191 |  |  |  |  |  |  |  | 
| 192 | 12498 | 50 | 66 |  |  | 26628 | return 'undef'  if ! defined $_[0] && $undef ; | 
| 193 |  |  |  |  |  |  |  | 
| 194 | 12498 | 100 |  |  |  | 24412 | if (ref $_[0]) { | 
| 195 | 6193 | 100 |  |  |  | 16187 | return ''       if blessed($_[0]); # is an object | 
| 196 |  |  |  |  |  |  | #return ''       if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object | 
| 197 | 6133 | 100 |  |  |  | 18160 | return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); | 
| 198 | 334 | 100 | 100 |  |  | 1702 | return 'array'  if UNIVERSAL::isa($_[0], 'ARRAY')  && $extended ; | 
| 199 | 44 | 50 | 33 |  |  | 177 | return 'hash'   if UNIVERSAL::isa($_[0], 'HASH')   && $hash ; | 
| 200 | 44 | 100 | 100 |  |  | 167 | return 'code'   if UNIVERSAL::isa($_[0], 'CODE')   && $wantCode ; | 
| 201 | 42 |  |  |  |  | 95 | return ''; | 
| 202 |  |  |  |  |  |  | } | 
| 203 |  |  |  |  |  |  |  | 
| 204 | 6305 | 100 | 100 |  |  | 15683 | return 'fileglob' if $extended && isaFileGlobString($_[0]); | 
| 205 | 6110 |  |  |  |  | 11526 | return 'filename'; | 
| 206 |  |  |  |  |  |  | } | 
| 207 |  |  |  |  |  |  |  | 
| 208 |  |  |  |  |  |  | sub oneTarget | 
| 209 |  |  |  |  |  |  | { | 
| 210 | 3026 |  |  | 3026 | 0 | 12881 | return $_[0] =~ /^(code|handle|buffer|filename)$/; | 
| 211 |  |  |  |  |  |  | } | 
| 212 |  |  |  |  |  |  |  | 
| 213 |  |  |  |  |  |  | sub IO::Compress::Base::Validator::new | 
| 214 |  |  |  |  |  |  | { | 
| 215 | 1513 |  |  | 1513 |  | 3175 | my $class = shift ; | 
| 216 |  |  |  |  |  |  |  | 
| 217 | 1513 |  |  |  |  | 2352 | my $Class = shift ; | 
| 218 | 1513 |  |  |  |  | 2241 | my $error_ref = shift ; | 
| 219 | 1513 |  |  |  |  | 2402 | my $reportClass = shift ; | 
| 220 |  |  |  |  |  |  |  | 
| 221 | 1513 |  |  |  |  | 5902 | my %data = (Class       => $Class, | 
| 222 |  |  |  |  |  |  | Error       => $error_ref, | 
| 223 |  |  |  |  |  |  | reportClass => $reportClass, | 
| 224 |  |  |  |  |  |  | ) ; | 
| 225 |  |  |  |  |  |  |  | 
| 226 | 1513 |  |  |  |  | 3353 | my $obj = bless \%data, $class ; | 
| 227 |  |  |  |  |  |  |  | 
| 228 | 1513 |  |  |  |  | 3001 | local $Carp::CarpLevel = 1; | 
| 229 |  |  |  |  |  |  |  | 
| 230 | 1513 |  |  |  |  | 3717 | my $inType    = $data{inType}    = whatIsInput($_[0], WANT_EXT|WANT_HASH); | 
| 231 | 1513 |  |  |  |  | 3617 | my $outType   = $data{outType}   = whatIsOutput($_[1], WANT_EXT|WANT_HASH); | 
| 232 |  |  |  |  |  |  |  | 
| 233 | 1513 |  |  |  |  | 3294 | my $oneInput  = $data{oneInput}  = oneTarget($inType); | 
| 234 | 1513 |  |  |  |  | 3225 | my $oneOutput = $data{oneOutput} = oneTarget($outType); | 
| 235 |  |  |  |  |  |  |  | 
| 236 | 1513 | 100 |  |  |  | 3679 | if (! $inType) | 
| 237 |  |  |  |  |  |  | { | 
| 238 | 30 |  |  |  |  | 111 | $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 | 1483 | 100 |  |  |  | 3072 | if (! $outType) | 
| 250 |  |  |  |  |  |  | { | 
| 251 | 30 |  |  |  |  | 122 | $obj->croakError("$reportClass: illegal output parameter") ; | 
| 252 |  |  |  |  |  |  | #return undef ; | 
| 253 |  |  |  |  |  |  | } | 
| 254 |  |  |  |  |  |  |  | 
| 255 |  |  |  |  |  |  |  | 
| 256 | 1453 | 100 | 100 |  |  | 5348 | if ($inType ne 'fileglob' && $outType eq 'fileglob') | 
| 257 |  |  |  |  |  |  | { | 
| 258 | 15 |  |  |  |  | 54 | $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 | 1438 | 100 | 100 |  |  | 3707 | if ($inType eq 'fileglob' && $outType eq 'fileglob') | 
| 267 |  |  |  |  |  |  | { | 
| 268 | 35 |  |  |  |  | 144 | $data{GlobMap} = 1 ; | 
| 269 | 35 |  |  |  |  | 111 | $data{inType} = $data{outType} = 'filename'; | 
| 270 | 35 |  |  |  |  | 311 | my $mapper = File::GlobMapper->new($_[0], $_[1]); | 
| 271 | 35 | 100 |  |  |  | 117 | if ( ! $mapper ) | 
| 272 |  |  |  |  |  |  | { | 
| 273 | 15 |  |  |  |  | 40 | return $obj->saveErrorString($File::GlobMapper::Error) ; | 
| 274 |  |  |  |  |  |  | } | 
| 275 | 20 |  |  |  |  | 93 | $data{Pairs} = $mapper->getFileMap(); | 
| 276 |  |  |  |  |  |  |  | 
| 277 | 20 |  |  |  |  | 148 | return $obj; | 
| 278 |  |  |  |  |  |  | } | 
| 279 |  |  |  |  |  |  |  | 
| 280 | 1403 | 100 | 100 |  |  | 4723 | $obj->croakError("$reportClass: input and output $inType are identical") | 
|  |  |  | 66 |  |  |  |  | 
| 281 |  |  |  |  |  |  | if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; | 
| 282 |  |  |  |  |  |  |  | 
| 283 | 1358 | 100 |  |  |  | 4461 | if ($inType eq 'fileglob') # && $outType ne 'fileglob' | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 284 |  |  |  |  |  |  | { | 
| 285 | 110 |  |  |  |  | 325 | my $glob = cleanFileGlobString($_[0]); | 
| 286 | 110 |  |  |  |  | 8327 | my @inputs = glob($glob); | 
| 287 |  |  |  |  |  |  |  | 
| 288 | 110 | 50 |  |  |  | 722 | if (@inputs == 0) | 
|  |  | 100 |  |  |  |  |  | 
| 289 |  |  |  |  |  |  | { | 
| 290 |  |  |  |  |  |  | # TODO -- legal or die? | 
| 291 | 0 |  |  |  |  | 0 | die "globmap matched zero file -- legal or die???" ; | 
| 292 |  |  |  |  |  |  | } | 
| 293 |  |  |  |  |  |  | elsif (@inputs == 1) | 
| 294 |  |  |  |  |  |  | { | 
| 295 | 35 | 50 |  |  |  | 126 | $obj->validateInputFilenames($inputs[0]) | 
| 296 |  |  |  |  |  |  | or return undef; | 
| 297 | 35 |  |  |  |  | 98 | $_[0] = $inputs[0]  ; | 
| 298 | 35 |  |  |  |  | 83 | $data{inType} = 'filename' ; | 
| 299 | 35 |  |  |  |  | 83 | $data{oneInput} = 1; | 
| 300 |  |  |  |  |  |  | } | 
| 301 |  |  |  |  |  |  | else | 
| 302 |  |  |  |  |  |  | { | 
| 303 | 75 | 50 |  |  |  | 279 | $obj->validateInputFilenames(@inputs) | 
| 304 |  |  |  |  |  |  | or return undef; | 
| 305 | 75 |  |  |  |  | 333 | $_[0] = [ @inputs ] ; | 
| 306 | 75 |  |  |  |  | 245 | $data{inType} = 'filenames' ; | 
| 307 |  |  |  |  |  |  | } | 
| 308 |  |  |  |  |  |  | } | 
| 309 |  |  |  |  |  |  | elsif ($inType eq 'filename') | 
| 310 |  |  |  |  |  |  | { | 
| 311 | 341 | 100 |  |  |  | 1061 | $obj->validateInputFilenames($_[0]) | 
| 312 |  |  |  |  |  |  | or return undef; | 
| 313 |  |  |  |  |  |  | } | 
| 314 |  |  |  |  |  |  | elsif ($inType eq 'array') | 
| 315 |  |  |  |  |  |  | { | 
| 316 | 175 |  |  |  |  | 464 | $data{inType} = 'filenames' ; | 
| 317 | 175 | 100 |  |  |  | 559 | $obj->validateInputArray($_[0]) | 
| 318 |  |  |  |  |  |  | or return undef ; | 
| 319 |  |  |  |  |  |  | } | 
| 320 |  |  |  |  |  |  |  | 
| 321 |  |  |  |  |  |  | return $obj->saveErrorString("$reportClass: output buffer is read-only") | 
| 322 | 1243 | 100 | 100 |  |  | 3704 | if $outType eq 'buffer' && readonly(${ $_[1] }); | 
|  | 597 |  |  |  |  | 2834 |  | 
| 323 |  |  |  |  |  |  |  | 
| 324 | 1228 | 100 |  |  |  | 3174 | if ($outType eq 'filename' ) | 
| 325 |  |  |  |  |  |  | { | 
| 326 | 321 | 50 | 33 |  |  | 1415 | $obj->croakError("$reportClass: output filename is undef or null string") | 
| 327 |  |  |  |  |  |  | if ! defined $_[1] || $_[1] eq ''  ; | 
| 328 |  |  |  |  |  |  |  | 
| 329 | 321 | 100 |  |  |  | 3966 | if (-e $_[1]) | 
| 330 |  |  |  |  |  |  | { | 
| 331 | 156 | 100 |  |  |  | 658 | if (-d _ ) | 
| 332 |  |  |  |  |  |  | { | 
| 333 | 15 |  |  |  |  | 86 | return $obj->saveErrorString("output file '$_[1]' is a directory"); | 
| 334 |  |  |  |  |  |  | } | 
| 335 |  |  |  |  |  |  | } | 
| 336 |  |  |  |  |  |  | } | 
| 337 |  |  |  |  |  |  |  | 
| 338 | 1213 |  |  |  |  | 6298 | return $obj ; | 
| 339 |  |  |  |  |  |  | } | 
| 340 |  |  |  |  |  |  |  | 
| 341 |  |  |  |  |  |  | sub IO::Compress::Base::Validator::saveErrorString | 
| 342 |  |  |  |  |  |  | { | 
| 343 | 280 |  |  | 280 |  | 463 | my $self   = shift ; | 
| 344 | 280 |  |  |  |  | 410 | ${ $self->{Error} } = shift ; | 
|  | 280 |  |  |  |  | 624 |  | 
| 345 | 280 |  |  |  |  | 1111 | return undef; | 
| 346 |  |  |  |  |  |  |  | 
| 347 |  |  |  |  |  |  | } | 
| 348 |  |  |  |  |  |  |  | 
| 349 |  |  |  |  |  |  | sub IO::Compress::Base::Validator::croakError | 
| 350 |  |  |  |  |  |  | { | 
| 351 | 200 |  |  | 200 |  | 336 | my $self   = shift ; | 
| 352 | 200 |  |  |  |  | 492 | $self->saveErrorString($_[0]); | 
| 353 | 200 |  |  |  |  | 35114 | croak $_[0]; | 
| 354 |  |  |  |  |  |  | } | 
| 355 |  |  |  |  |  |  |  | 
| 356 |  |  |  |  |  |  |  | 
| 357 |  |  |  |  |  |  |  | 
| 358 |  |  |  |  |  |  | sub IO::Compress::Base::Validator::validateInputFilenames | 
| 359 |  |  |  |  |  |  | { | 
| 360 | 671 |  |  | 671 |  | 1166 | my $self = shift ; | 
| 361 |  |  |  |  |  |  |  | 
| 362 | 671 |  |  |  |  | 1653 | foreach my $filename (@_) | 
| 363 |  |  |  |  |  |  | { | 
| 364 | 821 | 100 | 100 |  |  | 3217 | $self->croakError("$self->{reportClass}: input filename is undef or null string") | 
| 365 |  |  |  |  |  |  | if ! defined $filename || $filename eq ''  ; | 
| 366 |  |  |  |  |  |  |  | 
| 367 | 781 | 50 |  |  |  | 1898 | next if $filename eq '-'; | 
| 368 |  |  |  |  |  |  |  | 
| 369 | 781 | 100 |  |  |  | 10729 | if (! -e $filename ) | 
| 370 |  |  |  |  |  |  | { | 
| 371 | 15 |  |  |  |  | 98 | return $self->saveErrorString("input file '$filename' does not exist"); | 
| 372 |  |  |  |  |  |  | } | 
| 373 |  |  |  |  |  |  |  | 
| 374 | 766 | 100 |  |  |  | 3061 | if (-d _ ) | 
| 375 |  |  |  |  |  |  | { | 
| 376 | 15 |  |  |  |  | 88 | 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 | 601 |  |  |  |  | 2316 | return 1 ; | 
| 386 |  |  |  |  |  |  | } | 
| 387 |  |  |  |  |  |  |  | 
| 388 |  |  |  |  |  |  | sub IO::Compress::Base::Validator::validateInputArray | 
| 389 |  |  |  |  |  |  | { | 
| 390 | 175 |  |  | 175 |  | 315 | my $self = shift ; | 
| 391 |  |  |  |  |  |  |  | 
| 392 | 175 | 100 |  |  |  | 273 | if ( @{ $_[0] } == 0 ) | 
|  | 175 |  |  |  |  | 573 |  | 
| 393 |  |  |  |  |  |  | { | 
| 394 | 5 |  |  |  |  | 24 | return $self->saveErrorString("empty array reference") ; | 
| 395 |  |  |  |  |  |  | } | 
| 396 |  |  |  |  |  |  |  | 
| 397 | 170 |  |  |  |  | 312 | foreach my $element ( @{ $_[0] } ) | 
|  | 170 |  |  |  |  | 464 |  | 
| 398 |  |  |  |  |  |  | { | 
| 399 | 260 |  |  |  |  | 525 | my $inType  = whatIsInput($element); | 
| 400 |  |  |  |  |  |  |  | 
| 401 | 260 | 100 |  |  |  | 861 | if (! $inType) | 
|  |  | 100 |  |  |  |  |  | 
| 402 |  |  |  |  |  |  | { | 
| 403 | 20 |  |  |  |  | 61 | $self->croakError("unknown input parameter") ; | 
| 404 |  |  |  |  |  |  | } | 
| 405 |  |  |  |  |  |  | elsif($inType eq 'filename') | 
| 406 |  |  |  |  |  |  | { | 
| 407 | 220 | 50 |  |  |  | 548 | $self->validateInputFilenames($element) | 
| 408 |  |  |  |  |  |  | or return undef ; | 
| 409 |  |  |  |  |  |  | } | 
| 410 |  |  |  |  |  |  | else | 
| 411 |  |  |  |  |  |  | { | 
| 412 | 20 |  |  |  |  | 51 | $self->croakError("not a filename") ; | 
| 413 |  |  |  |  |  |  | } | 
| 414 |  |  |  |  |  |  | } | 
| 415 |  |  |  |  |  |  |  | 
| 416 | 120 |  |  |  |  | 385 | 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 | 6381 |  | 66 | 6381 | 0 | 24835 | my $class = shift || (caller)[0] ; | 
| 447 | 6381 |  |  |  |  | 11790 | my $error_ref = shift ; | 
| 448 |  |  |  |  |  |  |  | 
| 449 | 6381 |  | 33 |  |  | 17364 | my $obj = bless Symbol::gensym(), ref($class) || $class; | 
| 450 | 6381 | 50 |  |  |  | 151250 | tie *$obj, $obj if $] >= 5.005; | 
| 451 | 6381 |  |  |  |  | 19996 | *$obj->{Closed} = 1 ; | 
| 452 | 6381 |  |  |  |  | 12619 | $$error_ref = ''; | 
| 453 | 6381 |  |  |  |  | 12145 | *$obj->{Error} = $error_ref ; | 
| 454 | 6381 |  |  |  |  | 9765 | my $errno = 0 ; | 
| 455 | 6381 |  |  |  |  | 11968 | *$obj->{ErrorNo} = \$errno ; | 
| 456 |  |  |  |  |  |  |  | 
| 457 | 6381 |  |  |  |  | 16100 | return $obj; | 
| 458 |  |  |  |  |  |  | } | 
| 459 |  |  |  |  |  |  |  | 
| 460 |  |  |  |  |  |  |  | 
| 461 |  |  |  |  |  |  |  | 
| 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 |  |  |  |  |  |  | $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 |  |  |  |  |  |  | push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; | 
| 479 |  |  |  |  |  |  |  | 
| 480 | 84 |  |  | 84 |  | 735 | use constant Parse_any      => 0x01; | 
|  | 84 |  |  |  |  | 201 |  | 
|  | 84 |  |  |  |  | 10405 |  | 
| 481 | 84 |  |  | 84 |  | 2391 | use constant Parse_unsigned => 0x02; | 
|  | 84 |  |  |  |  | 3876 |  | 
|  | 84 |  |  |  |  | 6102 |  | 
| 482 | 84 |  |  | 84 |  | 562 | use constant Parse_signed   => 0x04; | 
|  | 84 |  |  |  |  | 207 |  | 
|  | 84 |  |  |  |  | 4314 |  | 
| 483 | 84 |  |  | 84 |  | 3932 | use constant Parse_boolean  => 0x08; | 
|  | 84 |  |  |  |  | 1944 |  | 
|  | 84 |  |  |  |  | 11124 |  | 
| 484 | 84 |  |  | 84 |  | 2240 | use constant Parse_string   => 0x10; | 
|  | 84 |  |  |  |  | 190 |  | 
|  | 84 |  |  |  |  | 12460 |  | 
| 485 | 84 |  |  | 84 |  | 537 | use constant Parse_code     => 0x20; | 
|  | 84 |  |  |  |  | 1873 |  | 
|  | 84 |  |  |  |  | 10767 |  | 
| 486 |  |  |  |  |  |  |  | 
| 487 |  |  |  |  |  |  | #use constant Parse_store_ref        => 0x100 ; | 
| 488 |  |  |  |  |  |  | #use constant Parse_multiple         => 0x100 ; | 
| 489 | 84 |  |  | 84 |  | 604 | use constant Parse_writable         => 0x200 ; | 
|  | 84 |  |  |  |  | 181 |  | 
|  | 84 |  |  |  |  | 10163 |  | 
| 490 | 84 |  |  | 84 |  | 2196 | use constant Parse_writable_scalar  => 0x400 | Parse_writable ; | 
|  | 84 |  |  |  |  | 1912 |  | 
|  | 84 |  |  |  |  | 5936 |  | 
| 491 |  |  |  |  |  |  |  | 
| 492 | 84 |  |  | 84 |  | 2328 | use constant OFF_PARSED     => 0 ; | 
|  | 84 |  |  |  |  | 3594 |  | 
|  | 84 |  |  |  |  | 7301 |  | 
| 493 | 84 |  |  | 84 |  | 2290 | use constant OFF_TYPE       => 1 ; | 
|  | 84 |  |  |  |  | 167 |  | 
|  | 84 |  |  |  |  | 6986 |  | 
| 494 | 84 |  |  | 84 |  | 500 | use constant OFF_DEFAULT    => 2 ; | 
|  | 84 |  |  |  |  | 217 |  | 
|  | 84 |  |  |  |  | 5291 |  | 
| 495 | 84 |  |  | 84 |  | 2396 | use constant OFF_FIXED      => 3 ; | 
|  | 84 |  |  |  |  | 176 |  | 
|  | 84 |  |  |  |  | 7343 |  | 
| 496 |  |  |  |  |  |  | #use constant OFF_FIRST_ONLY => 4 ; | 
| 497 |  |  |  |  |  |  | #use constant OFF_STICKY     => 5 ; | 
| 498 |  |  |  |  |  |  |  | 
| 499 | 84 |  |  | 84 |  | 501 | use constant IxError => 0; | 
|  | 84 |  |  |  |  | 1720 |  | 
|  | 84 |  |  |  |  | 5591 |  | 
| 500 | 84 |  |  | 84 |  | 519 | use constant IxGot   => 1 ; | 
|  | 84 |  |  |  |  | 177 |  | 
|  | 84 |  |  |  |  | 14970 |  | 
| 501 |  |  |  |  |  |  |  | 
| 502 |  |  |  |  |  |  | sub ParseParameters | 
| 503 |  |  |  |  |  |  | { | 
| 504 | 55 |  | 100 | 55 | 0 | 10113 | my $level = shift || 0 ; | 
| 505 |  |  |  |  |  |  |  | 
| 506 | 55 |  |  |  |  | 327 | my $sub = (caller($level + 1))[3] ; | 
| 507 | 55 |  |  |  |  | 116 | local $Carp::CarpLevel = 1 ; | 
| 508 |  |  |  |  |  |  |  | 
| 509 | 55 | 100 | 100 |  |  | 215 | return $_[1] | 
|  |  |  | 100 |  |  |  |  | 
| 510 |  |  |  |  |  |  | if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); | 
| 511 |  |  |  |  |  |  |  | 
| 512 | 54 |  |  |  |  | 154 | my $p = IO::Compress::Base::Parameters->new(); | 
| 513 | 54 | 100 |  |  |  | 141 | $p->parse(@_) | 
| 514 |  |  |  |  |  |  | or croak "$sub: $p->[IxError]" ; | 
| 515 |  |  |  |  |  |  |  | 
| 516 | 34 |  |  |  |  | 93 | return $p; | 
| 517 |  |  |  |  |  |  | } | 
| 518 |  |  |  |  |  |  |  | 
| 519 |  |  |  |  |  |  |  | 
| 520 | 84 |  |  | 84 |  | 591 | use strict; | 
|  | 84 |  |  |  |  | 1916 |  | 
|  | 84 |  |  |  |  | 2377 |  | 
| 521 |  |  |  |  |  |  |  | 
| 522 | 84 |  |  | 84 |  | 1938 | use warnings; | 
|  | 84 |  |  |  |  | 178 |  | 
|  | 84 |  |  |  |  | 6588 |  | 
| 523 | 84 |  |  | 84 |  | 550 | use Carp; | 
|  | 84 |  |  |  |  | 180 |  | 
|  | 84 |  |  |  |  | 152838 |  | 
| 524 |  |  |  |  |  |  |  | 
| 525 |  |  |  |  |  |  |  | 
| 526 |  |  |  |  |  |  | sub Init | 
| 527 |  |  |  |  |  |  | { | 
| 528 | 0 |  |  | 0 | 0 | 0 | my $default = shift ; | 
| 529 | 0 |  |  |  |  | 0 | my %got ; | 
| 530 |  |  |  |  |  |  |  | 
| 531 | 0 |  |  |  |  | 0 | my $obj = IO::Compress::Base::Parameters::new(); | 
| 532 | 0 |  |  |  |  | 0 | while (my ($key, $v) = each %$default) | 
| 533 |  |  |  |  |  |  | { | 
| 534 | 0 | 0 |  |  |  | 0 | croak "need 2 params [@$v]" | 
| 535 |  |  |  |  |  |  | if @$v != 2 ; | 
| 536 |  |  |  |  |  |  |  | 
| 537 | 0 |  |  |  |  | 0 | my ($type, $value) = @$v ; | 
| 538 |  |  |  |  |  |  | #        my ($first_only, $sticky, $type, $value) = @$v ; | 
| 539 | 0 |  |  |  |  | 0 | my $sticky = 0; | 
| 540 | 0 |  |  |  |  | 0 | my $x ; | 
| 541 | 0 | 0 |  |  |  | 0 | $obj->_checkType($key, \$value, $type, 0, \$x) | 
| 542 |  |  |  |  |  |  | or return undef ; | 
| 543 |  |  |  |  |  |  |  | 
| 544 | 0 |  |  |  |  | 0 | $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 | 0 |  |  |  |  | 0 | $got{$key} = [0, $type, $value, $x] ; | 
| 552 |  |  |  |  |  |  | #        } | 
| 553 |  |  |  |  |  |  | # | 
| 554 |  |  |  |  |  |  | #        $got{$key}[OFF_PARSED] = 0 ; | 
| 555 |  |  |  |  |  |  | } | 
| 556 |  |  |  |  |  |  |  | 
| 557 | 0 |  |  |  |  | 0 | return bless \%got, "IO::Compress::Base::Parameters::Defaults" ; | 
| 558 |  |  |  |  |  |  | } | 
| 559 |  |  |  |  |  |  |  | 
| 560 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::new | 
| 561 |  |  |  |  |  |  | { | 
| 562 |  |  |  |  |  |  | #my $class = shift ; | 
| 563 |  |  |  |  |  |  |  | 
| 564 | 5453 |  |  | 5453 |  | 8692 | my $obj; | 
| 565 | 5453 |  |  |  |  | 13052 | $obj->[IxError] = ''; | 
| 566 | 5453 |  |  |  |  | 10675 | $obj->[IxGot] = {} ; | 
| 567 |  |  |  |  |  |  |  | 
| 568 | 5453 |  |  |  |  | 29527 | return bless $obj, 'IO::Compress::Base::Parameters' ; | 
| 569 |  |  |  |  |  |  | } | 
| 570 |  |  |  |  |  |  |  | 
| 571 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::setError | 
| 572 |  |  |  |  |  |  | { | 
| 573 | 77 |  |  | 77 |  | 150 | my $self = shift ; | 
| 574 | 77 |  |  |  |  | 123 | my $error = shift ; | 
| 575 | 77 | 50 |  |  |  | 201 | my $retval = @_ ? shift : undef ; | 
| 576 |  |  |  |  |  |  |  | 
| 577 |  |  |  |  |  |  |  | 
| 578 | 77 |  |  |  |  | 151 | $self->[IxError] = $error ; | 
| 579 | 77 |  |  |  |  | 3205 | return $retval; | 
| 580 |  |  |  |  |  |  | } | 
| 581 |  |  |  |  |  |  |  | 
| 582 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::getError | 
| 583 |  |  |  |  |  |  | { | 
| 584 | 57 |  |  | 57 |  | 268 | my $self = shift ; | 
| 585 | 57 |  |  |  |  | 368 | return $self->[IxError] ; | 
| 586 |  |  |  |  |  |  | } | 
| 587 |  |  |  |  |  |  |  | 
| 588 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::parse | 
| 589 |  |  |  |  |  |  | { | 
| 590 | 5629 |  |  | 5629 |  | 9872 | my $self = shift ; | 
| 591 | 5629 |  |  |  |  | 8268 | my $default = shift ; | 
| 592 |  |  |  |  |  |  |  | 
| 593 | 5629 |  |  |  |  | 9257 | my $got = $self->[IxGot] ; | 
| 594 | 5629 |  |  |  |  | 8511 | my $firstTime = keys %{ $got } == 0 ; | 
|  | 5629 |  |  |  |  | 15892 |  | 
| 595 |  |  |  |  |  |  |  | 
| 596 | 5629 |  |  |  |  | 9593 | my (@Bad) ; | 
| 597 | 5629 |  |  |  |  | 9570 | my @entered = () ; | 
| 598 |  |  |  |  |  |  |  | 
| 599 |  |  |  |  |  |  | # Allow the options to be passed as a hash reference or | 
| 600 |  |  |  |  |  |  | # as the complete hash. | 
| 601 | 5629 | 100 |  |  |  | 15408 | if (@_ == 0) { | 
|  |  | 100 |  |  |  |  |  | 
| 602 | 1197 |  |  |  |  | 2192 | @entered = () ; | 
| 603 |  |  |  |  |  |  | } | 
| 604 |  |  |  |  |  |  | elsif (@_ == 1) { | 
| 605 | 20 |  |  |  |  | 38 | my $href = $_[0] ; | 
| 606 |  |  |  |  |  |  |  | 
| 607 | 20 | 100 | 100 |  |  | 146 | return $self->setError("Expected even number of parameters, got 1") | 
|  |  |  | 100 |  |  |  |  | 
| 608 |  |  |  |  |  |  | if ! defined $href or ! ref $href or ref $href ne "HASH" ; | 
| 609 |  |  |  |  |  |  |  | 
| 610 | 5 |  |  |  |  | 16 | foreach my $key (keys %$href) { | 
| 611 | 6 |  |  |  |  | 8 | push @entered, $key ; | 
| 612 | 6 |  |  |  |  | 14 | push @entered, \$href->{$key} ; | 
| 613 |  |  |  |  |  |  | } | 
| 614 |  |  |  |  |  |  | } | 
| 615 |  |  |  |  |  |  | else { | 
| 616 |  |  |  |  |  |  |  | 
| 617 | 4412 |  |  |  |  | 7279 | my $count = @_; | 
| 618 | 4412 | 50 |  |  |  | 11509 | return $self->setError("Expected even number of parameters, got $count") | 
| 619 |  |  |  |  |  |  | if $count % 2 != 0 ; | 
| 620 |  |  |  |  |  |  |  | 
| 621 | 4412 |  |  |  |  | 15909 | for my $i (0.. $count / 2 - 1) { | 
| 622 | 12480 |  |  |  |  | 22470 | push @entered, $_[2 * $i] ; | 
| 623 | 12480 |  |  |  |  | 25064 | push @entered, \$_[2 * $i + 1] ; | 
| 624 |  |  |  |  |  |  | } | 
| 625 |  |  |  |  |  |  | } | 
| 626 |  |  |  |  |  |  |  | 
| 627 | 5614 |  |  |  |  | 25124 | foreach my $key (keys %$default) | 
| 628 |  |  |  |  |  |  | { | 
| 629 |  |  |  |  |  |  |  | 
| 630 | 77967 |  |  |  |  | 100133 | my ($type, $value) = @{ $default->{$key} } ; | 
|  | 77967 |  |  |  |  | 130858 |  | 
| 631 |  |  |  |  |  |  |  | 
| 632 | 77967 | 100 |  |  |  | 119270 | if ($firstTime) { | 
| 633 | 74146 |  |  |  |  | 159353 | $got->{$key} = [0, $type, $value, $value] ; | 
| 634 |  |  |  |  |  |  | } | 
| 635 |  |  |  |  |  |  | else | 
| 636 |  |  |  |  |  |  | { | 
| 637 | 3821 |  |  |  |  | 6135 | $got->{$key}[OFF_PARSED] = 0 ; | 
| 638 |  |  |  |  |  |  | } | 
| 639 |  |  |  |  |  |  | } | 
| 640 |  |  |  |  |  |  |  | 
| 641 |  |  |  |  |  |  |  | 
| 642 | 5614 |  |  |  |  | 14022 | my %parsed = (); | 
| 643 |  |  |  |  |  |  |  | 
| 644 |  |  |  |  |  |  |  | 
| 645 | 5614 |  |  |  |  | 16435 | for my $i (0.. @entered / 2 - 1) { | 
| 646 | 12486 |  |  |  |  | 22598 | my $key = $entered[2* $i] ; | 
| 647 | 12486 |  |  |  |  | 19618 | my $value = $entered[2* $i+1] ; | 
| 648 |  |  |  |  |  |  |  | 
| 649 |  |  |  |  |  |  | #print "Key [$key] Value [$value]" ; | 
| 650 |  |  |  |  |  |  | #print defined $$value ? "[$$value]\n" : "[undef]\n"; | 
| 651 |  |  |  |  |  |  |  | 
| 652 | 12486 |  |  |  |  | 25470 | $key =~ s/^-// ; | 
| 653 | 12486 |  |  |  |  | 22480 | my $canonkey = lc $key; | 
| 654 |  |  |  |  |  |  |  | 
| 655 | 12486 | 100 |  |  |  | 25136 | if ($got->{$canonkey}) | 
| 656 |  |  |  |  |  |  | { | 
| 657 | 12459 |  |  |  |  | 20013 | my $type = $got->{$canonkey}[OFF_TYPE] ; | 
| 658 | 12459 |  |  |  |  | 19457 | my $parsed = $parsed{$canonkey}; | 
| 659 | 12459 |  |  |  |  | 21414 | ++ $parsed{$canonkey}; | 
| 660 |  |  |  |  |  |  |  | 
| 661 | 12459 | 100 |  |  |  | 23394 | return $self->setError("Muliple instances of '$key' found") | 
| 662 |  |  |  |  |  |  | if $parsed ; | 
| 663 |  |  |  |  |  |  |  | 
| 664 | 12458 |  |  |  |  | 16273 | my $s ; | 
| 665 | 12458 | 100 |  |  |  | 26199 | $self->_checkType($key, $value, $type, 1, \$s) | 
| 666 |  |  |  |  |  |  | or return undef ; | 
| 667 |  |  |  |  |  |  |  | 
| 668 | 12424 |  |  |  |  | 20397 | $value = $$value ; | 
| 669 | 12424 |  |  |  |  | 38985 | $got->{$canonkey} = [1, $type, $value, $s] ; | 
| 670 |  |  |  |  |  |  |  | 
| 671 |  |  |  |  |  |  | } | 
| 672 |  |  |  |  |  |  | else | 
| 673 | 27 |  |  |  |  | 76 | { push (@Bad, $key) } | 
| 674 |  |  |  |  |  |  | } | 
| 675 |  |  |  |  |  |  |  | 
| 676 | 5579 | 100 |  |  |  | 13750 | if (@Bad) { | 
| 677 | 27 |  |  |  |  | 88 | my ($bad) = join(", ", @Bad) ; | 
| 678 | 27 |  |  |  |  | 719 | return $self->setError("unknown key value(s) $bad") ; | 
| 679 |  |  |  |  |  |  | } | 
| 680 |  |  |  |  |  |  |  | 
| 681 | 5552 |  |  |  |  | 22731 | return 1; | 
| 682 |  |  |  |  |  |  | } | 
| 683 |  |  |  |  |  |  |  | 
| 684 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::_checkType | 
| 685 |  |  |  |  |  |  | { | 
| 686 | 12458 |  |  | 12458 |  | 18025 | my $self = shift ; | 
| 687 |  |  |  |  |  |  |  | 
| 688 | 12458 |  |  |  |  | 17205 | my $key   = shift ; | 
| 689 | 12458 |  |  |  |  | 16659 | my $value = shift ; | 
| 690 | 12458 |  |  |  |  | 16562 | my $type  = shift ; | 
| 691 | 12458 |  |  |  |  | 16654 | my $validate  = shift ; | 
| 692 | 12458 |  |  |  |  | 16702 | my $output  = shift; | 
| 693 |  |  |  |  |  |  |  | 
| 694 |  |  |  |  |  |  | #local $Carp::CarpLevel = $level ; | 
| 695 |  |  |  |  |  |  | #print "PARSE $type $key $value $validate $sub\n" ; | 
| 696 |  |  |  |  |  |  |  | 
| 697 | 12458 | 100 |  |  |  | 24514 | if ($type & Parse_writable_scalar) | 
| 698 |  |  |  |  |  |  | { | 
| 699 | 25 | 100 |  |  |  | 115 | return $self->setError("Parameter '$key' not writable") | 
| 700 |  |  |  |  |  |  | if  readonly $$value ; | 
| 701 |  |  |  |  |  |  |  | 
| 702 | 24 | 100 |  |  |  | 109 | if (ref $$value) | 
| 703 |  |  |  |  |  |  | { | 
| 704 | 12 | 100 |  |  |  | 81 | return $self->setError("Parameter '$key' not a scalar reference") | 
| 705 |  |  |  |  |  |  | if ref $$value ne 'SCALAR' ; | 
| 706 |  |  |  |  |  |  |  | 
| 707 | 1 |  |  |  |  | 3 | $$output = $$value ; | 
| 708 |  |  |  |  |  |  | } | 
| 709 |  |  |  |  |  |  | else | 
| 710 |  |  |  |  |  |  | { | 
| 711 | 12 | 100 |  |  |  | 55 | return $self->setError("Parameter '$key' not a scalar") | 
| 712 |  |  |  |  |  |  | if ref $value ne 'SCALAR' ; | 
| 713 |  |  |  |  |  |  |  | 
| 714 | 11 |  |  |  |  | 28 | $$output = $value ; | 
| 715 |  |  |  |  |  |  | } | 
| 716 |  |  |  |  |  |  |  | 
| 717 | 12 |  |  |  |  | 40 | return 1; | 
| 718 |  |  |  |  |  |  | } | 
| 719 |  |  |  |  |  |  |  | 
| 720 |  |  |  |  |  |  |  | 
| 721 | 12433 |  |  |  |  | 18829 | $value = $$value ; | 
| 722 |  |  |  |  |  |  |  | 
| 723 | 12433 | 100 |  |  |  | 34400 | if ($type & Parse_any) | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 724 |  |  |  |  |  |  | { | 
| 725 | 2455 |  |  |  |  | 4096 | $$output = $value ; | 
| 726 | 2455 |  |  |  |  | 6516 | return 1; | 
| 727 |  |  |  |  |  |  | } | 
| 728 |  |  |  |  |  |  | elsif ($type & Parse_unsigned) | 
| 729 |  |  |  |  |  |  | { | 
| 730 |  |  |  |  |  |  |  | 
| 731 | 447 | 100 |  |  |  | 1103 | return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") | 
| 732 |  |  |  |  |  |  | if ! defined $value ; | 
| 733 | 443 | 100 |  |  |  | 2481 | return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") | 
| 734 |  |  |  |  |  |  | if $value !~ /^\d+$/; | 
| 735 |  |  |  |  |  |  |  | 
| 736 | 432 | 50 |  |  |  | 1033 | $$output = defined $value ? $value : 0 ; | 
| 737 | 432 |  |  |  |  | 1322 | return 1; | 
| 738 |  |  |  |  |  |  | } | 
| 739 |  |  |  |  |  |  | elsif ($type & Parse_signed) | 
| 740 |  |  |  |  |  |  | { | 
| 741 | 77 | 100 |  |  |  | 188 | return $self->setError("Parameter '$key' must be a signed int, got 'undef'") | 
| 742 |  |  |  |  |  |  | if ! defined $value ; | 
| 743 | 76 | 100 |  |  |  | 320 | return $self->setError("Parameter '$key' must be a signed int, got '$value'") | 
| 744 |  |  |  |  |  |  | if $value !~ /^-?\d+$/; | 
| 745 |  |  |  |  |  |  |  | 
| 746 | 75 | 50 |  |  |  | 211 | $$output = defined $value ? $value : 0 ; | 
| 747 | 75 |  |  |  |  | 172 | return 1 ; | 
| 748 |  |  |  |  |  |  | } | 
| 749 |  |  |  |  |  |  | elsif ($type & Parse_boolean) | 
| 750 |  |  |  |  |  |  | { | 
| 751 | 9448 | 100 | 66 |  |  | 48628 | return $self->setError("Parameter '$key' must be an int, got '$value'") | 
| 752 |  |  |  |  |  |  | if defined $value && $value !~ /^\d*$/; | 
| 753 |  |  |  |  |  |  |  | 
| 754 | 9445 | 100 | 66 |  |  | 30240 | $$output =  defined $value && $value != 0 ? 1 : 0 ; | 
| 755 | 9445 |  |  |  |  | 24509 | return 1; | 
| 756 |  |  |  |  |  |  | } | 
| 757 |  |  |  |  |  |  |  | 
| 758 |  |  |  |  |  |  | elsif ($type & Parse_string) | 
| 759 |  |  |  |  |  |  | { | 
| 760 | 1 | 50 |  |  |  | 12 | $$output = defined $value ? $value : "" ; | 
| 761 | 1 |  |  |  |  | 4 | return 1; | 
| 762 |  |  |  |  |  |  | } | 
| 763 |  |  |  |  |  |  | elsif ($type & Parse_code) | 
| 764 |  |  |  |  |  |  | { | 
| 765 | 4 | 100 | 66 |  |  | 29 | return $self->setError("Parameter '$key' must be a code reference, got '$value'") | 
| 766 |  |  |  |  |  |  | if (! defined $value || ref $value ne 'CODE') ; | 
| 767 |  |  |  |  |  |  |  | 
| 768 | 3 | 50 |  |  |  | 9 | $$output = defined $value ? $value : "" ; | 
| 769 | 3 |  |  |  |  | 10 | return 1; | 
| 770 |  |  |  |  |  |  | } | 
| 771 |  |  |  |  |  |  |  | 
| 772 | 1 |  |  |  |  | 3 | $$output = $value ; | 
| 773 | 1 |  |  |  |  | 3 | return 1; | 
| 774 |  |  |  |  |  |  | } | 
| 775 |  |  |  |  |  |  |  | 
| 776 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::parsed | 
| 777 |  |  |  |  |  |  | { | 
| 778 | 11721 |  |  | 11721 |  | 46136 | return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ; | 
| 779 |  |  |  |  |  |  | } | 
| 780 |  |  |  |  |  |  |  | 
| 781 |  |  |  |  |  |  |  | 
| 782 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::getValue | 
| 783 |  |  |  |  |  |  | { | 
| 784 | 89003 |  |  | 89003 |  | 260694 | return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; | 
| 785 |  |  |  |  |  |  | } | 
| 786 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::setValue | 
| 787 |  |  |  |  |  |  | { | 
| 788 | 7971 |  |  | 7971 |  | 19831 | $_[0]->[IxGot]{$_[1]}[OFF_PARSED]  = 1; | 
| 789 | 7971 |  |  |  |  | 14047 | $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ; | 
| 790 | 7971 |  |  |  |  | 15485 | $_[0]->[IxGot]{$_[1]}[OFF_FIXED]   = $_[2] ; | 
| 791 |  |  |  |  |  |  | } | 
| 792 |  |  |  |  |  |  |  | 
| 793 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::valueRef | 
| 794 |  |  |  |  |  |  | { | 
| 795 | 0 |  |  | 0 |  | 0 | return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED]  ; | 
| 796 |  |  |  |  |  |  | } | 
| 797 |  |  |  |  |  |  |  | 
| 798 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::valueOrDefault | 
| 799 |  |  |  |  |  |  | { | 
| 800 | 2300 |  |  | 2300 |  | 4504 | my $self = shift ; | 
| 801 | 2300 |  |  |  |  | 3181 | my $name = shift ; | 
| 802 | 2300 |  |  |  |  | 3236 | my $default = shift ; | 
| 803 |  |  |  |  |  |  |  | 
| 804 | 2300 |  |  |  |  | 4099 | my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ; | 
| 805 |  |  |  |  |  |  |  | 
| 806 | 2300 | 100 |  |  |  | 6290 | return $value if defined $value ; | 
| 807 | 389 |  |  |  |  | 890 | return $default ; | 
| 808 |  |  |  |  |  |  | } | 
| 809 |  |  |  |  |  |  |  | 
| 810 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::wantValue | 
| 811 |  |  |  |  |  |  | { | 
| 812 | 1149 |  |  | 1149 |  | 3544 | return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ; | 
| 813 |  |  |  |  |  |  | } | 
| 814 |  |  |  |  |  |  |  | 
| 815 |  |  |  |  |  |  | sub IO::Compress::Base::Parameters::clone | 
| 816 |  |  |  |  |  |  | { | 
| 817 | 255 |  |  | 255 |  | 457 | my $self = shift ; | 
| 818 | 255 |  |  |  |  | 526 | my $obj = [] ; | 
| 819 | 255 |  |  |  |  | 419 | my %got ; | 
| 820 |  |  |  |  |  |  |  | 
| 821 | 255 |  |  |  |  | 494 | my $hash = $self->[IxGot] ; | 
| 822 | 255 |  |  |  |  | 559 | for my $k (keys %{ $hash }) | 
|  | 255 |  |  |  |  | 1414 |  | 
| 823 |  |  |  |  |  |  | { | 
| 824 | 5616 |  |  |  |  | 7235 | $got{$k} = [ @{ $hash->{$k} } ]; | 
|  | 5616 |  |  |  |  | 12558 |  | 
| 825 |  |  |  |  |  |  | } | 
| 826 |  |  |  |  |  |  |  | 
| 827 | 255 |  |  |  |  | 853 | $obj->[IxError] = $self->[IxError]; | 
| 828 | 255 |  |  |  |  | 509 | $obj->[IxGot] = \%got ; | 
| 829 |  |  |  |  |  |  |  | 
| 830 | 255 |  |  |  |  | 1966 | return bless $obj, 'IO::Compress::Base::Parameters' ; | 
| 831 |  |  |  |  |  |  | } | 
| 832 |  |  |  |  |  |  |  | 
| 833 |  |  |  |  |  |  | package U64; | 
| 834 |  |  |  |  |  |  |  | 
| 835 | 84 |  |  | 84 |  | 787 | use constant MAX32 => 0xFFFFFFFF ; | 
|  | 84 |  |  |  |  | 236 |  | 
|  | 84 |  |  |  |  | 5561 |  | 
| 836 | 84 |  |  | 84 |  | 592 | use constant HI_1 => MAX32 + 1 ; | 
|  | 84 |  |  |  |  | 188 |  | 
|  | 84 |  |  |  |  | 4769 |  | 
| 837 | 84 |  |  | 84 |  | 562 | use constant LOW   => 0 ; | 
|  | 84 |  |  |  |  | 176 |  | 
|  | 84 |  |  |  |  | 4242 |  | 
| 838 | 84 |  |  | 84 |  | 512 | use constant HIGH  => 1; | 
|  | 84 |  |  |  |  | 174 |  | 
|  | 84 |  |  |  |  | 100739 |  | 
| 839 |  |  |  |  |  |  |  | 
| 840 |  |  |  |  |  |  | sub new | 
| 841 |  |  |  |  |  |  | { | 
| 842 | 11150 | 100 |  | 11150 |  | 41783 | return bless [ 0, 0 ], $_[0] | 
| 843 |  |  |  |  |  |  | if @_ == 1 ; | 
| 844 |  |  |  |  |  |  |  | 
| 845 | 20 | 100 |  |  |  | 56 | return bless [ $_[1], 0 ], $_[0] | 
| 846 |  |  |  |  |  |  | if @_ == 2 ; | 
| 847 |  |  |  |  |  |  |  | 
| 848 | 17 | 50 |  |  |  | 94 | return bless [ $_[2], $_[1] ], $_[0] | 
| 849 |  |  |  |  |  |  | if @_ == 3 ; | 
| 850 |  |  |  |  |  |  | } | 
| 851 |  |  |  |  |  |  |  | 
| 852 |  |  |  |  |  |  | sub newUnpack_V64 | 
| 853 |  |  |  |  |  |  | { | 
| 854 | 118 |  |  | 118 |  | 386 | my ($low, $hi) = unpack "V V", $_[0] ; | 
| 855 | 118 |  |  |  |  | 364 | bless [ $low, $hi ], "U64"; | 
| 856 |  |  |  |  |  |  | } | 
| 857 |  |  |  |  |  |  |  | 
| 858 |  |  |  |  |  |  | sub newUnpack_V32 | 
| 859 |  |  |  |  |  |  | { | 
| 860 | 3948 |  |  | 3948 |  | 8831 | my $string = shift; | 
| 861 |  |  |  |  |  |  |  | 
| 862 | 3948 |  |  |  |  | 7117 | my $low = unpack "V", $string ; | 
| 863 | 3948 |  |  |  |  | 10590 | bless [ $low, 0 ], "U64"; | 
| 864 |  |  |  |  |  |  | } | 
| 865 |  |  |  |  |  |  |  | 
| 866 |  |  |  |  |  |  | sub reset | 
| 867 |  |  |  |  |  |  | { | 
| 868 | 3907 |  |  | 3907 |  | 7624 | $_[0]->[HIGH] = $_[0]->[LOW] = 0; | 
| 869 |  |  |  |  |  |  | } | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | sub clone | 
| 872 |  |  |  |  |  |  | { | 
| 873 | 530 |  |  | 530 |  | 838 | bless [ @{$_[0]}  ], ref $_[0] ; | 
|  | 530 |  |  |  |  | 2702 |  | 
| 874 |  |  |  |  |  |  | } | 
| 875 |  |  |  |  |  |  |  | 
| 876 |  |  |  |  |  |  | sub getHigh | 
| 877 |  |  |  |  |  |  | { | 
| 878 | 23 |  |  | 23 |  | 196 | return $_[0]->[HIGH]; | 
| 879 |  |  |  |  |  |  | } | 
| 880 |  |  |  |  |  |  |  | 
| 881 |  |  |  |  |  |  | sub getLow | 
| 882 |  |  |  |  |  |  | { | 
| 883 | 23 |  |  | 23 |  | 118 | return $_[0]->[LOW]; | 
| 884 |  |  |  |  |  |  | } | 
| 885 |  |  |  |  |  |  |  | 
| 886 |  |  |  |  |  |  | sub get32bit | 
| 887 |  |  |  |  |  |  | { | 
| 888 | 1436 |  |  | 1436 |  | 5353 | 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 | 2653 |  |  | 2653 |  | 8311 | return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW]; | 
| 896 |  |  |  |  |  |  | } | 
| 897 |  |  |  |  |  |  |  | 
| 898 |  |  |  |  |  |  | sub add | 
| 899 |  |  |  |  |  |  | { | 
| 900 |  |  |  |  |  |  | #    my $self = shift; | 
| 901 | 15857 |  |  | 15857 |  | 23137 | my $value = $_[1]; | 
| 902 |  |  |  |  |  |  |  | 
| 903 | 15857 | 100 |  |  |  | 39150 | if (ref $value eq 'U64') { | 
|  |  | 50 |  |  |  |  |  | 
| 904 | 384 |  |  |  |  | 667 | $_[0]->[HIGH] += $value->[HIGH] ; | 
| 905 | 384 |  |  |  |  | 644 | $value = $value->[LOW]; | 
| 906 |  |  |  |  |  |  | } | 
| 907 |  |  |  |  |  |  | elsif ($value > MAX32) { | 
| 908 | 0 |  |  |  |  | 0 | $_[0]->[HIGH] += int($value / HI_1) ; | 
| 909 | 0 |  |  |  |  | 0 | $value = $value % HI_1; | 
| 910 |  |  |  |  |  |  | } | 
| 911 |  |  |  |  |  |  |  | 
| 912 | 15857 |  |  |  |  | 26554 | my $available = MAX32 - $_[0]->[LOW] ; | 
| 913 |  |  |  |  |  |  |  | 
| 914 | 15857 | 100 |  |  |  | 27792 | if ($value > $available) { | 
| 915 | 2 |  |  |  |  | 5 | ++ $_[0]->[HIGH] ; | 
| 916 | 2 |  |  |  |  | 8 | $_[0]->[LOW] = $value - $available - 1; | 
| 917 |  |  |  |  |  |  | } | 
| 918 |  |  |  |  |  |  | else { | 
| 919 | 15855 |  |  |  |  | 29302 | $_[0]->[LOW] += $value ; | 
| 920 |  |  |  |  |  |  | } | 
| 921 |  |  |  |  |  |  | } | 
| 922 |  |  |  |  |  |  |  | 
| 923 |  |  |  |  |  |  | sub add32 | 
| 924 |  |  |  |  |  |  | { | 
| 925 |  |  |  |  |  |  | #    my $self = shift; | 
| 926 | 787 |  |  | 787 |  | 1284 | my $value = $_[1]; | 
| 927 |  |  |  |  |  |  |  | 
| 928 | 787 | 50 |  |  |  | 1726 | if ($value > MAX32) { | 
| 929 | 0 |  |  |  |  | 0 | $_[0]->[HIGH] += int($value / HI_1) ; | 
| 930 | 0 |  |  |  |  | 0 | $value = $value % HI_1; | 
| 931 |  |  |  |  |  |  | } | 
| 932 |  |  |  |  |  |  |  | 
| 933 | 787 |  |  |  |  | 1391 | my $available = MAX32 - $_[0]->[LOW] ; | 
| 934 |  |  |  |  |  |  |  | 
| 935 | 787 | 50 |  |  |  | 1520 | if ($value > $available) { | 
| 936 | 0 |  |  |  |  | 0 | ++ $_[0]->[HIGH] ; | 
| 937 | 0 |  |  |  |  | 0 | $_[0]->[LOW] = $value - $available - 1; | 
| 938 |  |  |  |  |  |  | } | 
| 939 |  |  |  |  |  |  | else { | 
| 940 | 787 |  |  |  |  | 1675 | $_[0]->[LOW] += $value ; | 
| 941 |  |  |  |  |  |  | } | 
| 942 |  |  |  |  |  |  | } | 
| 943 |  |  |  |  |  |  |  | 
| 944 |  |  |  |  |  |  | sub subtract | 
| 945 |  |  |  |  |  |  | { | 
| 946 | 4 |  |  | 4 |  | 12 | my $self = shift; | 
| 947 | 4 |  |  |  |  | 8 | my $value = shift; | 
| 948 |  |  |  |  |  |  |  | 
| 949 | 4 | 100 |  |  |  | 12 | if (ref $value eq 'U64') { | 
| 950 |  |  |  |  |  |  |  | 
| 951 | 2 | 50 |  |  |  | 7 | if ($value->[HIGH]) { | 
| 952 | 2 | 50 | 33 |  |  | 12 | die "bad" | 
| 953 |  |  |  |  |  |  | if $self->[HIGH] == 0 || | 
| 954 |  |  |  |  |  |  | $value->[HIGH] > $self->[HIGH] ; | 
| 955 |  |  |  |  |  |  |  | 
| 956 | 2 |  |  |  |  | 4 | $self->[HIGH] -= $value->[HIGH] ; | 
| 957 |  |  |  |  |  |  | } | 
| 958 |  |  |  |  |  |  |  | 
| 959 | 2 |  |  |  |  | 4 | $value = $value->[LOW] ; | 
| 960 |  |  |  |  |  |  | } | 
| 961 |  |  |  |  |  |  |  | 
| 962 | 4 | 100 |  |  |  | 13 | if ($value > $self->[LOW]) { | 
| 963 | 3 |  |  |  |  | 4 | -- $self->[HIGH] ; | 
| 964 | 3 |  |  |  |  | 8 | $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ; | 
| 965 |  |  |  |  |  |  | } | 
| 966 |  |  |  |  |  |  | else { | 
| 967 | 1 |  |  |  |  | 3 | $self->[LOW] -= $value; | 
| 968 |  |  |  |  |  |  | } | 
| 969 |  |  |  |  |  |  | } | 
| 970 |  |  |  |  |  |  |  | 
| 971 |  |  |  |  |  |  | sub equal | 
| 972 |  |  |  |  |  |  | { | 
| 973 | 1030 |  |  | 1030 |  | 1499 | my $self = shift; | 
| 974 | 1030 |  |  |  |  | 1328 | my $other = shift; | 
| 975 |  |  |  |  |  |  |  | 
| 976 | 1030 |  | 66 |  |  | 4351 | return $self->[LOW]  == $other->[LOW] && | 
| 977 |  |  |  |  |  |  | $self->[HIGH] == $other->[HIGH] ; | 
| 978 |  |  |  |  |  |  | } | 
| 979 |  |  |  |  |  |  |  | 
| 980 |  |  |  |  |  |  | sub isZero | 
| 981 |  |  |  |  |  |  | { | 
| 982 | 0 |  |  | 0 |  | 0 | my $self = shift; | 
| 983 |  |  |  |  |  |  |  | 
| 984 | 0 |  | 0 |  |  | 0 | return $self->[LOW]  == 0 && | 
| 985 |  |  |  |  |  |  | $self->[HIGH] == 0 ; | 
| 986 |  |  |  |  |  |  | } | 
| 987 |  |  |  |  |  |  |  | 
| 988 |  |  |  |  |  |  | sub gt | 
| 989 |  |  |  |  |  |  | { | 
| 990 | 1 |  |  | 1 |  | 2 | my $self = shift; | 
| 991 | 1 |  |  |  |  | 3 | my $other = shift; | 
| 992 |  |  |  |  |  |  |  | 
| 993 | 1 |  |  |  |  | 3 | return $self->cmp($other) > 0 ; | 
| 994 |  |  |  |  |  |  | } | 
| 995 |  |  |  |  |  |  |  | 
| 996 |  |  |  |  |  |  | sub cmp | 
| 997 |  |  |  |  |  |  | { | 
| 998 | 3 |  |  | 3 |  | 14 | my $self = shift; | 
| 999 | 3 |  |  |  |  | 4 | my $other = shift ; | 
| 1000 |  |  |  |  |  |  |  | 
| 1001 | 3 | 50 |  |  |  | 11 | if ($self->[LOW] == $other->[LOW]) { | 
| 1002 | 0 |  |  |  |  | 0 | return $self->[HIGH] - $other->[HIGH] ; | 
| 1003 |  |  |  |  |  |  | } | 
| 1004 |  |  |  |  |  |  | else { | 
| 1005 | 3 |  |  |  |  | 21 | return $self->[LOW] - $other->[LOW] ; | 
| 1006 |  |  |  |  |  |  | } | 
| 1007 |  |  |  |  |  |  | } | 
| 1008 |  |  |  |  |  |  |  | 
| 1009 |  |  |  |  |  |  |  | 
| 1010 |  |  |  |  |  |  | sub is64bit | 
| 1011 |  |  |  |  |  |  | { | 
| 1012 | 1105 |  |  | 1105 |  | 3938 | return $_[0]->[HIGH] > 0 ; | 
| 1013 |  |  |  |  |  |  | } | 
| 1014 |  |  |  |  |  |  |  | 
| 1015 |  |  |  |  |  |  | sub isAlmost64bit | 
| 1016 |  |  |  |  |  |  | { | 
| 1017 | 766 |  | 33 | 766 |  | 3470 | return $_[0]->[HIGH] > 0 ||  $_[0]->[LOW] == MAX32 ; | 
| 1018 |  |  |  |  |  |  | } | 
| 1019 |  |  |  |  |  |  |  | 
| 1020 |  |  |  |  |  |  | sub getPacked_V64 | 
| 1021 |  |  |  |  |  |  | { | 
| 1022 | 860 |  |  | 860 |  | 1310 | return pack "V V", @{ $_[0] } ; | 
|  | 860 |  |  |  |  | 2292 |  | 
| 1023 |  |  |  |  |  |  | } | 
| 1024 |  |  |  |  |  |  |  | 
| 1025 |  |  |  |  |  |  | sub getPacked_V32 | 
| 1026 |  |  |  |  |  |  | { | 
| 1027 | 1863 |  |  | 1863 |  | 5053 | return pack "V", $_[0]->[LOW] ; | 
| 1028 |  |  |  |  |  |  | } | 
| 1029 |  |  |  |  |  |  |  | 
| 1030 |  |  |  |  |  |  | sub pack_V64 | 
| 1031 |  |  |  |  |  |  | { | 
| 1032 | 84 |  |  | 84 |  | 214 | return pack "V V", $_[0], 0; | 
| 1033 |  |  |  |  |  |  | } | 
| 1034 |  |  |  |  |  |  |  | 
| 1035 |  |  |  |  |  |  |  | 
| 1036 |  |  |  |  |  |  | sub full32 | 
| 1037 |  |  |  |  |  |  | { | 
| 1038 | 32 |  |  | 32 |  | 118 | return $_[0] == MAX32 ; | 
| 1039 |  |  |  |  |  |  | } | 
| 1040 |  |  |  |  |  |  |  | 
| 1041 |  |  |  |  |  |  | sub Value_VV64 | 
| 1042 |  |  |  |  |  |  | { | 
| 1043 | 0 |  |  | 0 |  |  | my $buffer = shift; | 
| 1044 |  |  |  |  |  |  |  | 
| 1045 | 0 |  |  |  |  |  | my ($lo, $hi) = unpack ("V V" , $buffer); | 
| 1046 | 84 |  |  | 84 |  | 713 | no warnings 'uninitialized'; | 
|  | 84 |  |  |  |  | 241 |  | 
|  | 84 |  |  |  |  | 8086 |  | 
| 1047 | 0 |  |  |  |  |  | return $hi * HI_1 + $lo; | 
| 1048 |  |  |  |  |  |  | } | 
| 1049 |  |  |  |  |  |  |  | 
| 1050 |  |  |  |  |  |  |  | 
| 1051 |  |  |  |  |  |  | package IO::Compress::Base::Common; | 
| 1052 |  |  |  |  |  |  |  | 
| 1053 |  |  |  |  |  |  | 1; |