1b39c5158Smillertpackage IO::Compress::Base::Common; 2b39c5158Smillert 3b39c5158Smillertuse strict ; 4b39c5158Smillertuse warnings; 5b39c5158Smillertuse bytes; 6b39c5158Smillert 7b39c5158Smillertuse Carp; 8b39c5158Smillertuse Scalar::Util qw(blessed readonly); 9b39c5158Smillertuse File::GlobMapper; 10b39c5158Smillert 11b39c5158Smillertrequire Exporter; 12b39c5158Smillertour ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); 13b39c5158Smillert@ISA = qw(Exporter); 14*3d61058aSafresh1$VERSION = '2.212'; 15b39c5158Smillert 16898184e3Ssthen@EXPORT = qw( isaFilehandle isaFilename isaScalar 17898184e3Ssthen whatIsInput whatIsOutput 18b39c5158Smillert isaFileGlobString cleanFileGlobString oneTarget 19b39c5158Smillert setBinModeInput setBinModeOutput 20b39c5158Smillert ckInOutParams 21b39c5158Smillert createSelfTiedObject 22b39c5158Smillert 23898184e3Ssthen isGeMax32 24898184e3Ssthen 25898184e3Ssthen MAX32 26898184e3Ssthen 27b39c5158Smillert WANT_CODE 28b39c5158Smillert WANT_EXT 29b39c5158Smillert WANT_UNDEF 30b39c5158Smillert WANT_HASH 31b39c5158Smillert 32b39c5158Smillert STATUS_OK 33b39c5158Smillert STATUS_ENDSTREAM 34b39c5158Smillert STATUS_EOF 35b39c5158Smillert STATUS_ERROR 36b39c5158Smillert ); 37b39c5158Smillert 38b39c5158Smillert%EXPORT_TAGS = ( Status => [qw( STATUS_OK 39b39c5158Smillert STATUS_ENDSTREAM 40b39c5158Smillert STATUS_EOF 41b39c5158Smillert STATUS_ERROR 42b39c5158Smillert )]); 43b39c5158Smillert 44b39c5158Smillert 45b39c5158Smillertuse constant STATUS_OK => 0; 46b39c5158Smillertuse constant STATUS_ENDSTREAM => 1; 47b39c5158Smillertuse constant STATUS_EOF => 2; 48b39c5158Smillertuse constant STATUS_ERROR => -1; 49898184e3Ssthenuse constant MAX16 => 0xFFFF ; 50898184e3Ssthenuse constant MAX32 => 0xFFFFFFFF ; 51898184e3Ssthenuse constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value 52898184e3Ssthen 53898184e3Ssthen 54898184e3Ssthensub isGeMax32 55898184e3Ssthen{ 56898184e3Ssthen return $_[0] >= MAX32cmp ; 57898184e3Ssthen} 58b39c5158Smillert 59b39c5158Smillertsub hasEncode() 60b39c5158Smillert{ 61b39c5158Smillert if (! defined $HAS_ENCODE) { 62b39c5158Smillert eval 63b39c5158Smillert { 64b39c5158Smillert require Encode; 65b39c5158Smillert Encode->import(); 66b39c5158Smillert }; 67b39c5158Smillert 68b39c5158Smillert $HAS_ENCODE = $@ ? 0 : 1 ; 69b39c5158Smillert } 70b39c5158Smillert 71b39c5158Smillert return $HAS_ENCODE; 72b39c5158Smillert} 73b39c5158Smillert 74b39c5158Smillertsub getEncoding($$$) 75b39c5158Smillert{ 76b39c5158Smillert my $obj = shift; 77b39c5158Smillert my $class = shift ; 78b39c5158Smillert my $want_encoding = shift ; 79b39c5158Smillert 80b39c5158Smillert $obj->croakError("$class: Encode module needed to use -Encode") 81b39c5158Smillert if ! hasEncode(); 82b39c5158Smillert 83b39c5158Smillert my $encoding = Encode::find_encoding($want_encoding); 84b39c5158Smillert 85b39c5158Smillert $obj->croakError("$class: Encoding '$want_encoding' is not available") 86b39c5158Smillert if ! $encoding; 87b39c5158Smillert 88b39c5158Smillert return $encoding; 89b39c5158Smillert} 90b39c5158Smillert 91b39c5158Smillertour ($needBinmode); 92b39c5158Smillert$needBinmode = ($^O eq 'MSWin32' || 93b39c5158Smillert ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) 94b39c5158Smillert ? 1 : 1 ; 95b39c5158Smillert 96b39c5158Smillertsub setBinModeInput($) 97b39c5158Smillert{ 98b39c5158Smillert my $handle = shift ; 99b39c5158Smillert 100b39c5158Smillert binmode $handle 101b39c5158Smillert if $needBinmode; 102b39c5158Smillert} 103b39c5158Smillert 104b39c5158Smillertsub setBinModeOutput($) 105b39c5158Smillert{ 106b39c5158Smillert my $handle = shift ; 107b39c5158Smillert 108b39c5158Smillert binmode $handle 109b39c5158Smillert if $needBinmode; 110b39c5158Smillert} 111b39c5158Smillert 112b39c5158Smillertsub isaFilehandle($) 113b39c5158Smillert{ 114b39c5158Smillert use utf8; # Pragma needed to keep Perl 5.6.0 happy 115b39c5158Smillert return (defined $_[0] and 116b39c5158Smillert (UNIVERSAL::isa($_[0],'GLOB') or 117b39c5158Smillert UNIVERSAL::isa($_[0],'IO::Handle') or 118b39c5158Smillert UNIVERSAL::isa(\$_[0],'GLOB')) 119b39c5158Smillert ) 120b39c5158Smillert} 121b39c5158Smillert 122898184e3Ssthensub isaScalar 123898184e3Ssthen{ 124898184e3Ssthen return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ; 125898184e3Ssthen} 126898184e3Ssthen 127b39c5158Smillertsub isaFilename($) 128b39c5158Smillert{ 129b39c5158Smillert return (defined $_[0] and 130b39c5158Smillert ! ref $_[0] and 131b39c5158Smillert UNIVERSAL::isa(\$_[0], 'SCALAR')); 132b39c5158Smillert} 133b39c5158Smillert 134b39c5158Smillertsub isaFileGlobString 135b39c5158Smillert{ 136b39c5158Smillert return defined $_[0] && $_[0] =~ /^<.*>$/; 137b39c5158Smillert} 138b39c5158Smillert 139b39c5158Smillertsub cleanFileGlobString 140b39c5158Smillert{ 141b39c5158Smillert my $string = shift ; 142b39c5158Smillert 143b39c5158Smillert $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; 144b39c5158Smillert 145b39c5158Smillert return $string; 146b39c5158Smillert} 147b39c5158Smillert 148b39c5158Smillertuse constant WANT_CODE => 1 ; 149b39c5158Smillertuse constant WANT_EXT => 2 ; 150b39c5158Smillertuse constant WANT_UNDEF => 4 ; 151b39c5158Smillert#use constant WANT_HASH => 8 ; 152b39c5158Smillertuse constant WANT_HASH => 0 ; 153b39c5158Smillert 154b39c5158Smillertsub whatIsInput($;$) 155b39c5158Smillert{ 156b39c5158Smillert my $got = whatIs(@_); 157b39c5158Smillert 158b39c5158Smillert if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') 159b39c5158Smillert { 160b39c5158Smillert #use IO::File; 161b39c5158Smillert $got = 'handle'; 162b39c5158Smillert $_[0] = *STDIN; 163eac174f2Safresh1 #$_[0] = IO::File->new("<-"); 164b39c5158Smillert } 165b39c5158Smillert 166b39c5158Smillert return $got; 167b39c5158Smillert} 168b39c5158Smillert 169b39c5158Smillertsub whatIsOutput($;$) 170b39c5158Smillert{ 171b39c5158Smillert my $got = whatIs(@_); 172b39c5158Smillert 173b39c5158Smillert if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') 174b39c5158Smillert { 175b39c5158Smillert $got = 'handle'; 176b39c5158Smillert $_[0] = *STDOUT; 177eac174f2Safresh1 #$_[0] = IO::File->new(">-"); 178b39c5158Smillert } 179b39c5158Smillert 180b39c5158Smillert return $got; 181b39c5158Smillert} 182b39c5158Smillert 183b39c5158Smillertsub whatIs ($;$) 184b39c5158Smillert{ 185b39c5158Smillert return 'handle' if isaFilehandle($_[0]); 186b39c5158Smillert 187b39c5158Smillert my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; 188b39c5158Smillert my $extended = defined $_[1] && $_[1] & WANT_EXT ; 189b39c5158Smillert my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; 190b39c5158Smillert my $hash = defined $_[1] && $_[1] & WANT_HASH ; 191b39c5158Smillert 192b39c5158Smillert return 'undef' if ! defined $_[0] && $undef ; 193b39c5158Smillert 194b39c5158Smillert if (ref $_[0]) { 195b39c5158Smillert return '' if blessed($_[0]); # is an object 196b39c5158Smillert #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object 197b39c5158Smillert return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); 198b39c5158Smillert return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; 199b39c5158Smillert return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; 200b39c5158Smillert return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; 201b39c5158Smillert return ''; 202b39c5158Smillert } 203b39c5158Smillert 204b39c5158Smillert return 'fileglob' if $extended && isaFileGlobString($_[0]); 205b39c5158Smillert return 'filename'; 206b39c5158Smillert} 207b39c5158Smillert 208b39c5158Smillertsub oneTarget 209b39c5158Smillert{ 210b39c5158Smillert return $_[0] =~ /^(code|handle|buffer|filename)$/; 211b39c5158Smillert} 212b39c5158Smillert 213b39c5158Smillertsub IO::Compress::Base::Validator::new 214b39c5158Smillert{ 215b39c5158Smillert my $class = shift ; 216b39c5158Smillert 217b39c5158Smillert my $Class = shift ; 218b39c5158Smillert my $error_ref = shift ; 219b39c5158Smillert my $reportClass = shift ; 220b39c5158Smillert 221b39c5158Smillert my %data = (Class => $Class, 222b39c5158Smillert Error => $error_ref, 223b39c5158Smillert reportClass => $reportClass, 224b39c5158Smillert ) ; 225b39c5158Smillert 226b39c5158Smillert my $obj = bless \%data, $class ; 227b39c5158Smillert 228b39c5158Smillert local $Carp::CarpLevel = 1; 229b39c5158Smillert 230b39c5158Smillert my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); 231b39c5158Smillert my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); 232b39c5158Smillert 233b39c5158Smillert my $oneInput = $data{oneInput} = oneTarget($inType); 234b39c5158Smillert my $oneOutput = $data{oneOutput} = oneTarget($outType); 235b39c5158Smillert 236b39c5158Smillert if (! $inType) 237b39c5158Smillert { 238b39c5158Smillert $obj->croakError("$reportClass: illegal input parameter") ; 239b39c5158Smillert #return undef ; 240b39c5158Smillert } 241b39c5158Smillert 242b39c5158Smillert# if ($inType eq 'hash') 243b39c5158Smillert# { 244b39c5158Smillert# $obj->{Hash} = 1 ; 245b39c5158Smillert# $obj->{oneInput} = 1 ; 246b39c5158Smillert# return $obj->validateHash($_[0]); 247b39c5158Smillert# } 248b39c5158Smillert 249b39c5158Smillert if (! $outType) 250b39c5158Smillert { 251b39c5158Smillert $obj->croakError("$reportClass: illegal output parameter") ; 252b39c5158Smillert #return undef ; 253b39c5158Smillert } 254b39c5158Smillert 255b39c5158Smillert 256b39c5158Smillert if ($inType ne 'fileglob' && $outType eq 'fileglob') 257b39c5158Smillert { 258b39c5158Smillert $obj->croakError("Need input fileglob for outout fileglob"); 259b39c5158Smillert } 260b39c5158Smillert 261b39c5158Smillert# if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) 262b39c5158Smillert# { 263b39c5158Smillert# $obj->croakError("input must ne filename or fileglob when output is a hash"); 264b39c5158Smillert# } 265b39c5158Smillert 266b39c5158Smillert if ($inType eq 'fileglob' && $outType eq 'fileglob') 267b39c5158Smillert { 268b39c5158Smillert $data{GlobMap} = 1 ; 269b39c5158Smillert $data{inType} = $data{outType} = 'filename'; 270eac174f2Safresh1 my $mapper = File::GlobMapper->new($_[0], $_[1]); 271b39c5158Smillert if ( ! $mapper ) 272b39c5158Smillert { 273b39c5158Smillert return $obj->saveErrorString($File::GlobMapper::Error) ; 274b39c5158Smillert } 275b39c5158Smillert $data{Pairs} = $mapper->getFileMap(); 276b39c5158Smillert 277b39c5158Smillert return $obj; 278b39c5158Smillert } 279b39c5158Smillert 280b39c5158Smillert $obj->croakError("$reportClass: input and output $inType are identical") 281b39c5158Smillert if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; 282b39c5158Smillert 283b39c5158Smillert if ($inType eq 'fileglob') # && $outType ne 'fileglob' 284b39c5158Smillert { 285b39c5158Smillert my $glob = cleanFileGlobString($_[0]); 286b39c5158Smillert my @inputs = glob($glob); 287b39c5158Smillert 288b39c5158Smillert if (@inputs == 0) 289b39c5158Smillert { 290b39c5158Smillert # TODO -- legal or die? 291b39c5158Smillert die "globmap matched zero file -- legal or die???" ; 292b39c5158Smillert } 293b39c5158Smillert elsif (@inputs == 1) 294b39c5158Smillert { 295b39c5158Smillert $obj->validateInputFilenames($inputs[0]) 296b39c5158Smillert or return undef; 297b39c5158Smillert $_[0] = $inputs[0] ; 298b39c5158Smillert $data{inType} = 'filename' ; 299b39c5158Smillert $data{oneInput} = 1; 300b39c5158Smillert } 301b39c5158Smillert else 302b39c5158Smillert { 303b39c5158Smillert $obj->validateInputFilenames(@inputs) 304b39c5158Smillert or return undef; 305b39c5158Smillert $_[0] = [ @inputs ] ; 306b39c5158Smillert $data{inType} = 'filenames' ; 307b39c5158Smillert } 308b39c5158Smillert } 309b39c5158Smillert elsif ($inType eq 'filename') 310b39c5158Smillert { 311b39c5158Smillert $obj->validateInputFilenames($_[0]) 312b39c5158Smillert or return undef; 313b39c5158Smillert } 314b39c5158Smillert elsif ($inType eq 'array') 315b39c5158Smillert { 316b39c5158Smillert $data{inType} = 'filenames' ; 317b39c5158Smillert $obj->validateInputArray($_[0]) 318b39c5158Smillert or return undef ; 319b39c5158Smillert } 320b39c5158Smillert 321b39c5158Smillert return $obj->saveErrorString("$reportClass: output buffer is read-only") 322b39c5158Smillert if $outType eq 'buffer' && readonly(${ $_[1] }); 323b39c5158Smillert 324b39c5158Smillert if ($outType eq 'filename' ) 325b39c5158Smillert { 326b39c5158Smillert $obj->croakError("$reportClass: output filename is undef or null string") 327b39c5158Smillert if ! defined $_[1] || $_[1] eq '' ; 328b39c5158Smillert 329b39c5158Smillert if (-e $_[1]) 330b39c5158Smillert { 331b39c5158Smillert if (-d _ ) 332b39c5158Smillert { 333b39c5158Smillert return $obj->saveErrorString("output file '$_[1]' is a directory"); 334b39c5158Smillert } 335b39c5158Smillert } 336b39c5158Smillert } 337b39c5158Smillert 338b39c5158Smillert return $obj ; 339b39c5158Smillert} 340b39c5158Smillert 341b39c5158Smillertsub IO::Compress::Base::Validator::saveErrorString 342b39c5158Smillert{ 343b39c5158Smillert my $self = shift ; 344b39c5158Smillert ${ $self->{Error} } = shift ; 345b39c5158Smillert return undef; 346b39c5158Smillert 347b39c5158Smillert} 348b39c5158Smillert 349b39c5158Smillertsub IO::Compress::Base::Validator::croakError 350b39c5158Smillert{ 351b39c5158Smillert my $self = shift ; 352b39c5158Smillert $self->saveErrorString($_[0]); 353b39c5158Smillert croak $_[0]; 354b39c5158Smillert} 355b39c5158Smillert 356b39c5158Smillert 357b39c5158Smillert 358b39c5158Smillertsub IO::Compress::Base::Validator::validateInputFilenames 359b39c5158Smillert{ 360b39c5158Smillert my $self = shift ; 361b39c5158Smillert 362b39c5158Smillert foreach my $filename (@_) 363b39c5158Smillert { 364b39c5158Smillert $self->croakError("$self->{reportClass}: input filename is undef or null string") 365b39c5158Smillert if ! defined $filename || $filename eq '' ; 366b39c5158Smillert 367b39c5158Smillert next if $filename eq '-'; 368b39c5158Smillert 369b39c5158Smillert if (! -e $filename ) 370b39c5158Smillert { 371b39c5158Smillert return $self->saveErrorString("input file '$filename' does not exist"); 372b39c5158Smillert } 373b39c5158Smillert 374b39c5158Smillert if (-d _ ) 375b39c5158Smillert { 376b39c5158Smillert return $self->saveErrorString("input file '$filename' is a directory"); 377b39c5158Smillert } 378b39c5158Smillert 37991f110e0Safresh1# if (! -r _ ) 38091f110e0Safresh1# { 38191f110e0Safresh1# return $self->saveErrorString("cannot open file '$filename': $!"); 38291f110e0Safresh1# } 383b39c5158Smillert } 384b39c5158Smillert 385b39c5158Smillert return 1 ; 386b39c5158Smillert} 387b39c5158Smillert 388b39c5158Smillertsub IO::Compress::Base::Validator::validateInputArray 389b39c5158Smillert{ 390b39c5158Smillert my $self = shift ; 391b39c5158Smillert 392b39c5158Smillert if ( @{ $_[0] } == 0 ) 393b39c5158Smillert { 394b39c5158Smillert return $self->saveErrorString("empty array reference") ; 395b39c5158Smillert } 396b39c5158Smillert 397b39c5158Smillert foreach my $element ( @{ $_[0] } ) 398b39c5158Smillert { 399b39c5158Smillert my $inType = whatIsInput($element); 400b39c5158Smillert 401b39c5158Smillert if (! $inType) 402b39c5158Smillert { 403b39c5158Smillert $self->croakError("unknown input parameter") ; 404b39c5158Smillert } 405b39c5158Smillert elsif($inType eq 'filename') 406b39c5158Smillert { 407b39c5158Smillert $self->validateInputFilenames($element) 408b39c5158Smillert or return undef ; 409b39c5158Smillert } 410b39c5158Smillert else 411b39c5158Smillert { 412b39c5158Smillert $self->croakError("not a filename") ; 413b39c5158Smillert } 414b39c5158Smillert } 415b39c5158Smillert 416b39c5158Smillert return 1 ; 417b39c5158Smillert} 418b39c5158Smillert 419b39c5158Smillert#sub IO::Compress::Base::Validator::validateHash 420b39c5158Smillert#{ 421b39c5158Smillert# my $self = shift ; 422b39c5158Smillert# my $href = shift ; 423b39c5158Smillert# 424b39c5158Smillert# while (my($k, $v) = each %$href) 425b39c5158Smillert# { 426b39c5158Smillert# my $ktype = whatIsInput($k); 427b39c5158Smillert# my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; 428b39c5158Smillert# 429b39c5158Smillert# if ($ktype ne 'filename') 430b39c5158Smillert# { 431b39c5158Smillert# return $self->saveErrorString("hash key not filename") ; 432b39c5158Smillert# } 433b39c5158Smillert# 434b39c5158Smillert# my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; 435b39c5158Smillert# if (! $valid{$vtype}) 436b39c5158Smillert# { 437b39c5158Smillert# return $self->saveErrorString("hash value not ok") ; 438b39c5158Smillert# } 439b39c5158Smillert# } 440b39c5158Smillert# 441b39c5158Smillert# return $self ; 442b39c5158Smillert#} 443b39c5158Smillert 444b39c5158Smillertsub createSelfTiedObject 445b39c5158Smillert{ 446b39c5158Smillert my $class = shift || (caller)[0] ; 447b39c5158Smillert my $error_ref = shift ; 448b39c5158Smillert 449b39c5158Smillert my $obj = bless Symbol::gensym(), ref($class) || $class; 450b39c5158Smillert tie *$obj, $obj if $] >= 5.005; 451b39c5158Smillert *$obj->{Closed} = 1 ; 452b39c5158Smillert $$error_ref = ''; 453b39c5158Smillert *$obj->{Error} = $error_ref ; 454b39c5158Smillert my $errno = 0 ; 455b39c5158Smillert *$obj->{ErrorNo} = \$errno ; 456b39c5158Smillert 457b39c5158Smillert return $obj; 458b39c5158Smillert} 459b39c5158Smillert 460b39c5158Smillert 461b39c5158Smillert 462b39c5158Smillert#package Parse::Parameters ; 463b39c5158Smillert# 464b39c5158Smillert# 465b39c5158Smillert#require Exporter; 466b39c5158Smillert#our ($VERSION, @ISA, @EXPORT); 467b8851fccSafresh1#$VERSION = '2.000_08'; 468b39c5158Smillert#@ISA = qw(Exporter); 469b39c5158Smillert 470b39c5158Smillert$EXPORT_TAGS{Parse} = [qw( ParseParameters 471b39c5158Smillert Parse_any Parse_unsigned Parse_signed 472898184e3Ssthen Parse_boolean Parse_string 473898184e3Ssthen Parse_code 47491f110e0Safresh1 Parse_writable_scalar 475b39c5158Smillert ) 476b39c5158Smillert ]; 477b39c5158Smillert 478b39c5158Smillertpush @EXPORT, @{ $EXPORT_TAGS{Parse} } ; 479b39c5158Smillert 480b39c5158Smillertuse constant Parse_any => 0x01; 481b39c5158Smillertuse constant Parse_unsigned => 0x02; 482b39c5158Smillertuse constant Parse_signed => 0x04; 483b39c5158Smillertuse constant Parse_boolean => 0x08; 484b39c5158Smillertuse constant Parse_string => 0x10; 485898184e3Ssthenuse constant Parse_code => 0x20; 486b39c5158Smillert 487b39c5158Smillert#use constant Parse_store_ref => 0x100 ; 48891f110e0Safresh1#use constant Parse_multiple => 0x100 ; 489b39c5158Smillertuse constant Parse_writable => 0x200 ; 490b39c5158Smillertuse constant Parse_writable_scalar => 0x400 | Parse_writable ; 491b39c5158Smillert 492b39c5158Smillertuse constant OFF_PARSED => 0 ; 493b39c5158Smillertuse constant OFF_TYPE => 1 ; 494b39c5158Smillertuse constant OFF_DEFAULT => 2 ; 495b39c5158Smillertuse constant OFF_FIXED => 3 ; 49691f110e0Safresh1#use constant OFF_FIRST_ONLY => 4 ; 49791f110e0Safresh1#use constant OFF_STICKY => 5 ; 498b39c5158Smillert 49991f110e0Safresh1use constant IxError => 0; 50091f110e0Safresh1use constant IxGot => 1 ; 501b39c5158Smillert 502b39c5158Smillertsub ParseParameters 503b39c5158Smillert{ 504b39c5158Smillert my $level = shift || 0 ; 505b39c5158Smillert 506b39c5158Smillert my $sub = (caller($level + 1))[3] ; 507b39c5158Smillert local $Carp::CarpLevel = 1 ; 508b39c5158Smillert 509b39c5158Smillert return $_[1] 510b39c5158Smillert if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters"); 511b39c5158Smillert 512eac174f2Safresh1 my $p = IO::Compress::Base::Parameters->new(); 513b39c5158Smillert $p->parse(@_) 51491f110e0Safresh1 or croak "$sub: $p->[IxError]" ; 515b39c5158Smillert 516b39c5158Smillert return $p; 517b39c5158Smillert} 518b39c5158Smillert 519b39c5158Smillert 520b39c5158Smillertuse strict; 521898184e3Ssthen 522b39c5158Smillertuse warnings; 523b39c5158Smillertuse Carp; 524b39c5158Smillert 52591f110e0Safresh1 52691f110e0Safresh1sub Init 52791f110e0Safresh1{ 52891f110e0Safresh1 my $default = shift ; 52991f110e0Safresh1 my %got ; 53091f110e0Safresh1 53191f110e0Safresh1 my $obj = IO::Compress::Base::Parameters::new(); 53291f110e0Safresh1 while (my ($key, $v) = each %$default) 53391f110e0Safresh1 { 53491f110e0Safresh1 croak "need 2 params [@$v]" 53591f110e0Safresh1 if @$v != 2 ; 53691f110e0Safresh1 53791f110e0Safresh1 my ($type, $value) = @$v ; 53891f110e0Safresh1# my ($first_only, $sticky, $type, $value) = @$v ; 53991f110e0Safresh1 my $sticky = 0; 54091f110e0Safresh1 my $x ; 54191f110e0Safresh1 $obj->_checkType($key, \$value, $type, 0, \$x) 54291f110e0Safresh1 or return undef ; 54391f110e0Safresh1 54491f110e0Safresh1 $key = lc $key; 54591f110e0Safresh1 54691f110e0Safresh1# if (! $sticky) { 54791f110e0Safresh1# $x = [] 54891f110e0Safresh1# if $type & Parse_multiple; 54991f110e0Safresh1 55091f110e0Safresh1# $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ; 55191f110e0Safresh1 $got{$key} = [0, $type, $value, $x] ; 55291f110e0Safresh1# } 55391f110e0Safresh1# 55491f110e0Safresh1# $got{$key}[OFF_PARSED] = 0 ; 55591f110e0Safresh1 } 55691f110e0Safresh1 55791f110e0Safresh1 return bless \%got, "IO::Compress::Base::Parameters::Defaults" ; 55891f110e0Safresh1} 55991f110e0Safresh1 560b39c5158Smillertsub IO::Compress::Base::Parameters::new 561b39c5158Smillert{ 56291f110e0Safresh1 #my $class = shift ; 563b39c5158Smillert 56491f110e0Safresh1 my $obj; 56591f110e0Safresh1 $obj->[IxError] = ''; 56691f110e0Safresh1 $obj->[IxGot] = {} ; 567b39c5158Smillert 568b39c5158Smillert return bless $obj, 'IO::Compress::Base::Parameters' ; 569b39c5158Smillert} 570b39c5158Smillert 571b39c5158Smillertsub IO::Compress::Base::Parameters::setError 572b39c5158Smillert{ 573b39c5158Smillert my $self = shift ; 574b39c5158Smillert my $error = shift ; 575b39c5158Smillert my $retval = @_ ? shift : undef ; 576b39c5158Smillert 57791f110e0Safresh1 57891f110e0Safresh1 $self->[IxError] = $error ; 579b39c5158Smillert return $retval; 580b39c5158Smillert} 581b39c5158Smillert 58291f110e0Safresh1sub IO::Compress::Base::Parameters::getError 58391f110e0Safresh1{ 58491f110e0Safresh1 my $self = shift ; 58591f110e0Safresh1 return $self->[IxError] ; 58691f110e0Safresh1} 587b39c5158Smillert 588b39c5158Smillertsub IO::Compress::Base::Parameters::parse 589b39c5158Smillert{ 590b39c5158Smillert my $self = shift ; 591b39c5158Smillert my $default = shift ; 592b39c5158Smillert 59391f110e0Safresh1 my $got = $self->[IxGot] ; 594b39c5158Smillert my $firstTime = keys %{ $got } == 0 ; 595b39c5158Smillert 596b39c5158Smillert my (@Bad) ; 597b39c5158Smillert my @entered = () ; 598b39c5158Smillert 599b39c5158Smillert # Allow the options to be passed as a hash reference or 600b39c5158Smillert # as the complete hash. 601b39c5158Smillert if (@_ == 0) { 602b39c5158Smillert @entered = () ; 603b39c5158Smillert } 604b39c5158Smillert elsif (@_ == 1) { 605b39c5158Smillert my $href = $_[0] ; 606b39c5158Smillert 607b39c5158Smillert return $self->setError("Expected even number of parameters, got 1") 608b39c5158Smillert if ! defined $href or ! ref $href or ref $href ne "HASH" ; 609b39c5158Smillert 610b39c5158Smillert foreach my $key (keys %$href) { 611b39c5158Smillert push @entered, $key ; 612b39c5158Smillert push @entered, \$href->{$key} ; 613b39c5158Smillert } 614b39c5158Smillert } 615b39c5158Smillert else { 61691f110e0Safresh1 617b39c5158Smillert my $count = @_; 618b39c5158Smillert return $self->setError("Expected even number of parameters, got $count") 619b39c5158Smillert if $count % 2 != 0 ; 620b39c5158Smillert 621b39c5158Smillert for my $i (0.. $count / 2 - 1) { 622b39c5158Smillert push @entered, $_[2 * $i] ; 623b39c5158Smillert push @entered, \$_[2 * $i + 1] ; 624b39c5158Smillert } 625b39c5158Smillert } 626b39c5158Smillert 62791f110e0Safresh1 foreach my $key (keys %$default) 628b39c5158Smillert { 629b39c5158Smillert 63091f110e0Safresh1 my ($type, $value) = @{ $default->{$key} } ; 631b39c5158Smillert 63291f110e0Safresh1 if ($firstTime) { 63391f110e0Safresh1 $got->{$key} = [0, $type, $value, $value] ; 634b39c5158Smillert } 63591f110e0Safresh1 else 63691f110e0Safresh1 { 637b39c5158Smillert $got->{$key}[OFF_PARSED] = 0 ; 638b39c5158Smillert } 63991f110e0Safresh1 } 64091f110e0Safresh1 641b39c5158Smillert 642b39c5158Smillert my %parsed = (); 643b39c5158Smillert 644b39c5158Smillert 645b39c5158Smillert for my $i (0.. @entered / 2 - 1) { 646b39c5158Smillert my $key = $entered[2* $i] ; 647b39c5158Smillert my $value = $entered[2* $i+1] ; 648b39c5158Smillert 649b39c5158Smillert #print "Key [$key] Value [$value]" ; 650b39c5158Smillert #print defined $$value ? "[$$value]\n" : "[undef]\n"; 651b39c5158Smillert 652b39c5158Smillert $key =~ s/^-// ; 653b39c5158Smillert my $canonkey = lc $key; 654b39c5158Smillert 65591f110e0Safresh1 if ($got->{$canonkey}) 656b39c5158Smillert { 657b39c5158Smillert my $type = $got->{$canonkey}[OFF_TYPE] ; 658b39c5158Smillert my $parsed = $parsed{$canonkey}; 659b39c5158Smillert ++ $parsed{$canonkey}; 660b39c5158Smillert 661b39c5158Smillert return $self->setError("Muliple instances of '$key' found") 66291f110e0Safresh1 if $parsed ; 663b39c5158Smillert 664b39c5158Smillert my $s ; 665b39c5158Smillert $self->_checkType($key, $value, $type, 1, \$s) 666b39c5158Smillert or return undef ; 667b39c5158Smillert 668b39c5158Smillert $value = $$value ; 669b39c5158Smillert $got->{$canonkey} = [1, $type, $value, $s] ; 67091f110e0Safresh1 671b39c5158Smillert } 672b39c5158Smillert else 673b39c5158Smillert { push (@Bad, $key) } 674b39c5158Smillert } 675b39c5158Smillert 676b39c5158Smillert if (@Bad) { 677b39c5158Smillert my ($bad) = join(", ", @Bad) ; 678b39c5158Smillert return $self->setError("unknown key value(s) $bad") ; 679b39c5158Smillert } 680b39c5158Smillert 681b39c5158Smillert return 1; 682b39c5158Smillert} 683b39c5158Smillert 684b39c5158Smillertsub IO::Compress::Base::Parameters::_checkType 685b39c5158Smillert{ 686b39c5158Smillert my $self = shift ; 687b39c5158Smillert 688b39c5158Smillert my $key = shift ; 689b39c5158Smillert my $value = shift ; 690b39c5158Smillert my $type = shift ; 691b39c5158Smillert my $validate = shift ; 692b39c5158Smillert my $output = shift; 693b39c5158Smillert 694b39c5158Smillert #local $Carp::CarpLevel = $level ; 695b39c5158Smillert #print "PARSE $type $key $value $validate $sub\n" ; 696b39c5158Smillert 697b39c5158Smillert if ($type & Parse_writable_scalar) 698b39c5158Smillert { 699b39c5158Smillert return $self->setError("Parameter '$key' not writable") 70091f110e0Safresh1 if readonly $$value ; 701b39c5158Smillert 702b39c5158Smillert if (ref $$value) 703b39c5158Smillert { 704b39c5158Smillert return $self->setError("Parameter '$key' not a scalar reference") 70591f110e0Safresh1 if ref $$value ne 'SCALAR' ; 706b39c5158Smillert 707b39c5158Smillert $$output = $$value ; 708b39c5158Smillert } 709b39c5158Smillert else 710b39c5158Smillert { 711b39c5158Smillert return $self->setError("Parameter '$key' not a scalar") 71291f110e0Safresh1 if ref $value ne 'SCALAR' ; 713b39c5158Smillert 714b39c5158Smillert $$output = $value ; 715b39c5158Smillert } 716b39c5158Smillert 717b39c5158Smillert return 1; 718b39c5158Smillert } 719b39c5158Smillert 720b39c5158Smillert 721b39c5158Smillert $value = $$value ; 722b39c5158Smillert 723b39c5158Smillert if ($type & Parse_any) 724b39c5158Smillert { 725b39c5158Smillert $$output = $value ; 726b39c5158Smillert return 1; 727b39c5158Smillert } 728b39c5158Smillert elsif ($type & Parse_unsigned) 729b39c5158Smillert { 73091f110e0Safresh1 731b39c5158Smillert return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") 73291f110e0Safresh1 if ! defined $value ; 733b39c5158Smillert return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") 73491f110e0Safresh1 if $value !~ /^\d+$/; 735b39c5158Smillert 736b39c5158Smillert $$output = defined $value ? $value : 0 ; 737b39c5158Smillert return 1; 738b39c5158Smillert } 739b39c5158Smillert elsif ($type & Parse_signed) 740b39c5158Smillert { 741b39c5158Smillert return $self->setError("Parameter '$key' must be a signed int, got 'undef'") 74291f110e0Safresh1 if ! defined $value ; 743b39c5158Smillert return $self->setError("Parameter '$key' must be a signed int, got '$value'") 74491f110e0Safresh1 if $value !~ /^-?\d+$/; 745b39c5158Smillert 746b39c5158Smillert $$output = defined $value ? $value : 0 ; 747b39c5158Smillert return 1 ; 748b39c5158Smillert } 749b39c5158Smillert elsif ($type & Parse_boolean) 750b39c5158Smillert { 751b39c5158Smillert return $self->setError("Parameter '$key' must be an int, got '$value'") 75291f110e0Safresh1 if defined $value && $value !~ /^\d*$/; 75391f110e0Safresh1 75491f110e0Safresh1 $$output = defined $value && $value != 0 ? 1 : 0 ; 75591f110e0Safresh1 return 1; 75691f110e0Safresh1 } 75791f110e0Safresh1 75891f110e0Safresh1 elsif ($type & Parse_string) 75991f110e0Safresh1 { 76091f110e0Safresh1 $$output = defined $value ? $value : "" ; 761b39c5158Smillert return 1; 762b39c5158Smillert } 763898184e3Ssthen elsif ($type & Parse_code) 764898184e3Ssthen { 765898184e3Ssthen return $self->setError("Parameter '$key' must be a code reference, got '$value'") 76691f110e0Safresh1 if (! defined $value || ref $value ne 'CODE') ; 76791f110e0Safresh1 768b39c5158Smillert $$output = defined $value ? $value : "" ; 769b39c5158Smillert return 1; 770b39c5158Smillert } 771b39c5158Smillert 772b39c5158Smillert $$output = $value ; 773b39c5158Smillert return 1; 774b39c5158Smillert} 775b39c5158Smillert 776b39c5158Smillertsub IO::Compress::Base::Parameters::parsed 777b39c5158Smillert{ 77891f110e0Safresh1 return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ; 779b39c5158Smillert} 780b39c5158Smillert 781b39c5158Smillert 78291f110e0Safresh1sub IO::Compress::Base::Parameters::getValue 783b39c5158Smillert{ 78491f110e0Safresh1 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; 78591f110e0Safresh1} 78691f110e0Safresh1sub IO::Compress::Base::Parameters::setValue 78791f110e0Safresh1{ 78891f110e0Safresh1 $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1; 78991f110e0Safresh1 $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ; 79091f110e0Safresh1 $_[0]->[IxGot]{$_[1]}[OFF_FIXED] = $_[2] ; 791b39c5158Smillert} 792b39c5158Smillert 79391f110e0Safresh1sub IO::Compress::Base::Parameters::valueRef 79491f110e0Safresh1{ 79591f110e0Safresh1 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ; 796b39c5158Smillert} 797b39c5158Smillert 798b39c5158Smillertsub IO::Compress::Base::Parameters::valueOrDefault 799b39c5158Smillert{ 800b39c5158Smillert my $self = shift ; 801b39c5158Smillert my $name = shift ; 802b39c5158Smillert my $default = shift ; 803b39c5158Smillert 80491f110e0Safresh1 my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ; 805b39c5158Smillert 806b39c5158Smillert return $value if defined $value ; 807b39c5158Smillert return $default ; 808b39c5158Smillert} 809b39c5158Smillert 810b39c5158Smillertsub IO::Compress::Base::Parameters::wantValue 811b39c5158Smillert{ 81291f110e0Safresh1 return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ; 813b39c5158Smillert} 814b39c5158Smillert 815b39c5158Smillertsub IO::Compress::Base::Parameters::clone 816b39c5158Smillert{ 817b39c5158Smillert my $self = shift ; 81891f110e0Safresh1 my $obj = [] ; 819b39c5158Smillert my %got ; 820b39c5158Smillert 82191f110e0Safresh1 my $hash = $self->[IxGot] ; 82291f110e0Safresh1 for my $k (keys %{ $hash }) 82391f110e0Safresh1 { 82491f110e0Safresh1 $got{$k} = [ @{ $hash->{$k} } ]; 825b39c5158Smillert } 826b39c5158Smillert 82791f110e0Safresh1 $obj->[IxError] = $self->[IxError]; 82891f110e0Safresh1 $obj->[IxGot] = \%got ; 829b39c5158Smillert 830b39c5158Smillert return bless $obj, 'IO::Compress::Base::Parameters' ; 831b39c5158Smillert} 832b39c5158Smillert 833b39c5158Smillertpackage U64; 834b39c5158Smillert 835b39c5158Smillertuse constant MAX32 => 0xFFFFFFFF ; 836b39c5158Smillertuse constant HI_1 => MAX32 + 1 ; 837b39c5158Smillertuse constant LOW => 0 ; 838b39c5158Smillertuse constant HIGH => 1; 839b39c5158Smillert 840b39c5158Smillertsub new 841b39c5158Smillert{ 84291f110e0Safresh1 return bless [ 0, 0 ], $_[0] 84391f110e0Safresh1 if @_ == 1 ; 844b39c5158Smillert 84591f110e0Safresh1 return bless [ $_[1], 0 ], $_[0] 84691f110e0Safresh1 if @_ == 2 ; 847b39c5158Smillert 84891f110e0Safresh1 return bless [ $_[2], $_[1] ], $_[0] 84991f110e0Safresh1 if @_ == 3 ; 850b39c5158Smillert} 851b39c5158Smillert 852b39c5158Smillertsub newUnpack_V64 853b39c5158Smillert{ 85491f110e0Safresh1 my ($low, $hi) = unpack "V V", $_[0] ; 855b39c5158Smillert bless [ $low, $hi ], "U64"; 856b39c5158Smillert} 857b39c5158Smillert 858b39c5158Smillertsub newUnpack_V32 859b39c5158Smillert{ 860b39c5158Smillert my $string = shift; 861b39c5158Smillert 862b39c5158Smillert my $low = unpack "V", $string ; 863b39c5158Smillert bless [ $low, 0 ], "U64"; 864b39c5158Smillert} 865b39c5158Smillert 866b39c5158Smillertsub reset 867b39c5158Smillert{ 86891f110e0Safresh1 $_[0]->[HIGH] = $_[0]->[LOW] = 0; 869b39c5158Smillert} 870b39c5158Smillert 871b39c5158Smillertsub clone 872b39c5158Smillert{ 87391f110e0Safresh1 bless [ @{$_[0]} ], ref $_[0] ; 874b39c5158Smillert} 875b39c5158Smillert 876b39c5158Smillertsub getHigh 877b39c5158Smillert{ 87891f110e0Safresh1 return $_[0]->[HIGH]; 879b39c5158Smillert} 880b39c5158Smillert 881b39c5158Smillertsub getLow 882b39c5158Smillert{ 88391f110e0Safresh1 return $_[0]->[LOW]; 884b39c5158Smillert} 885b39c5158Smillert 886b39c5158Smillertsub get32bit 887b39c5158Smillert{ 88891f110e0Safresh1 return $_[0]->[LOW]; 889b39c5158Smillert} 890b39c5158Smillert 891b39c5158Smillertsub get64bit 892b39c5158Smillert{ 893b39c5158Smillert # Not using << here because the result will still be 894b39c5158Smillert # a 32-bit value on systems where int size is 32-bits 89591f110e0Safresh1 return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW]; 896b39c5158Smillert} 897b39c5158Smillert 898b39c5158Smillertsub add 899b39c5158Smillert{ 90091f110e0Safresh1# my $self = shift; 90191f110e0Safresh1 my $value = $_[1]; 902b39c5158Smillert 903b39c5158Smillert if (ref $value eq 'U64') { 90491f110e0Safresh1 $_[0]->[HIGH] += $value->[HIGH] ; 905b39c5158Smillert $value = $value->[LOW]; 906b39c5158Smillert } 907898184e3Ssthen elsif ($value > MAX32) { 90891f110e0Safresh1 $_[0]->[HIGH] += int($value / HI_1) ; 909898184e3Ssthen $value = $value % HI_1; 910898184e3Ssthen } 911b39c5158Smillert 91291f110e0Safresh1 my $available = MAX32 - $_[0]->[LOW] ; 913b39c5158Smillert 914b39c5158Smillert if ($value > $available) { 91591f110e0Safresh1 ++ $_[0]->[HIGH] ; 91691f110e0Safresh1 $_[0]->[LOW] = $value - $available - 1; 917b39c5158Smillert } 918b39c5158Smillert else { 91991f110e0Safresh1 $_[0]->[LOW] += $value ; 92091f110e0Safresh1 } 92191f110e0Safresh1} 92291f110e0Safresh1 92391f110e0Safresh1sub add32 92491f110e0Safresh1{ 92591f110e0Safresh1# my $self = shift; 92691f110e0Safresh1 my $value = $_[1]; 92791f110e0Safresh1 92891f110e0Safresh1 if ($value > MAX32) { 92991f110e0Safresh1 $_[0]->[HIGH] += int($value / HI_1) ; 93091f110e0Safresh1 $value = $value % HI_1; 93191f110e0Safresh1 } 93291f110e0Safresh1 93391f110e0Safresh1 my $available = MAX32 - $_[0]->[LOW] ; 93491f110e0Safresh1 93591f110e0Safresh1 if ($value > $available) { 93691f110e0Safresh1 ++ $_[0]->[HIGH] ; 93791f110e0Safresh1 $_[0]->[LOW] = $value - $available - 1; 93891f110e0Safresh1 } 93991f110e0Safresh1 else { 94091f110e0Safresh1 $_[0]->[LOW] += $value ; 941b39c5158Smillert } 942898184e3Ssthen} 943b39c5158Smillert 944898184e3Ssthensub subtract 945898184e3Ssthen{ 946898184e3Ssthen my $self = shift; 947898184e3Ssthen my $value = shift; 948898184e3Ssthen 949898184e3Ssthen if (ref $value eq 'U64') { 950898184e3Ssthen 951898184e3Ssthen if ($value->[HIGH]) { 952898184e3Ssthen die "bad" 953898184e3Ssthen if $self->[HIGH] == 0 || 954898184e3Ssthen $value->[HIGH] > $self->[HIGH] ; 955898184e3Ssthen 956898184e3Ssthen $self->[HIGH] -= $value->[HIGH] ; 957898184e3Ssthen } 958898184e3Ssthen 959898184e3Ssthen $value = $value->[LOW] ; 960898184e3Ssthen } 961898184e3Ssthen 962898184e3Ssthen if ($value > $self->[LOW]) { 963898184e3Ssthen -- $self->[HIGH] ; 964898184e3Ssthen $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ; 965898184e3Ssthen } 966898184e3Ssthen else { 967898184e3Ssthen $self->[LOW] -= $value; 968898184e3Ssthen } 969b39c5158Smillert} 970b39c5158Smillert 971b39c5158Smillertsub equal 972b39c5158Smillert{ 973b39c5158Smillert my $self = shift; 974b39c5158Smillert my $other = shift; 975b39c5158Smillert 976b39c5158Smillert return $self->[LOW] == $other->[LOW] && 977b39c5158Smillert $self->[HIGH] == $other->[HIGH] ; 978b39c5158Smillert} 979b39c5158Smillert 980b46d8ef2Safresh1sub isZero 981b46d8ef2Safresh1{ 982b46d8ef2Safresh1 my $self = shift; 983b46d8ef2Safresh1 984b46d8ef2Safresh1 return $self->[LOW] == 0 && 985b46d8ef2Safresh1 $self->[HIGH] == 0 ; 986b46d8ef2Safresh1} 987b46d8ef2Safresh1 988898184e3Ssthensub gt 989898184e3Ssthen{ 990898184e3Ssthen my $self = shift; 991898184e3Ssthen my $other = shift; 992898184e3Ssthen 993898184e3Ssthen return $self->cmp($other) > 0 ; 994898184e3Ssthen} 995898184e3Ssthen 996898184e3Ssthensub cmp 997898184e3Ssthen{ 998898184e3Ssthen my $self = shift; 999898184e3Ssthen my $other = shift ; 1000898184e3Ssthen 1001898184e3Ssthen if ($self->[LOW] == $other->[LOW]) { 1002898184e3Ssthen return $self->[HIGH] - $other->[HIGH] ; 1003898184e3Ssthen } 1004898184e3Ssthen else { 1005898184e3Ssthen return $self->[LOW] - $other->[LOW] ; 1006898184e3Ssthen } 1007898184e3Ssthen} 1008898184e3Ssthen 1009898184e3Ssthen 1010b39c5158Smillertsub is64bit 1011b39c5158Smillert{ 101291f110e0Safresh1 return $_[0]->[HIGH] > 0 ; 1013b39c5158Smillert} 1014b39c5158Smillert 1015898184e3Ssthensub isAlmost64bit 1016898184e3Ssthen{ 101791f110e0Safresh1 return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ; 1018898184e3Ssthen} 1019898184e3Ssthen 1020b39c5158Smillertsub getPacked_V64 1021b39c5158Smillert{ 102291f110e0Safresh1 return pack "V V", @{ $_[0] } ; 1023b39c5158Smillert} 1024b39c5158Smillert 1025b39c5158Smillertsub getPacked_V32 1026b39c5158Smillert{ 102791f110e0Safresh1 return pack "V", $_[0]->[LOW] ; 1028b39c5158Smillert} 1029b39c5158Smillert 1030b39c5158Smillertsub pack_V64 1031b39c5158Smillert{ 103291f110e0Safresh1 return pack "V V", $_[0], 0; 1033b39c5158Smillert} 1034b39c5158Smillert 1035b39c5158Smillert 1036898184e3Ssthensub full32 1037898184e3Ssthen{ 1038898184e3Ssthen return $_[0] == MAX32 ; 1039898184e3Ssthen} 1040898184e3Ssthen 1041898184e3Ssthensub Value_VV64 1042898184e3Ssthen{ 1043898184e3Ssthen my $buffer = shift; 1044898184e3Ssthen 1045898184e3Ssthen my ($lo, $hi) = unpack ("V V" , $buffer); 1046898184e3Ssthen no warnings 'uninitialized'; 1047898184e3Ssthen return $hi * HI_1 + $lo; 1048898184e3Ssthen} 1049898184e3Ssthen 1050898184e3Ssthen 1051b39c5158Smillertpackage IO::Compress::Base::Common; 1052b39c5158Smillert 1053b39c5158Smillert1; 1054