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