local-lib5/lib/perl5/IO/Compress/Base/Common.pm

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