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, $HAS_ENCODE);
  13 @ISA = qw(Exporter);
  14 $VERSION = '2.004';
  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 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 Validator::saveErrorString
 324 {
 325     my $self   = shift ;
 326     ${ $self->{Error} } = shift ;
 327     return undef;
 328
 329 }
 330
 331 sub Validator::croakError
 332 {
 333     my $self   = shift ;
 334     $self->saveErrorString($_[0]);
 335     croak $_[0];
 336 }
 337
 338
 339
 340 sub 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 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 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     my $p = new IO::Compress::Base::Parameters() ;
 489     $p->parse(@_)
 490         or croak "$sub: $p->{Error}" ;
 491
 492     return $p;
 493 }
 494
 495 #package IO::Compress::Base::Parameters;
 496
 497 use strict;
 498 use warnings;
 499 use Carp;
 500
 501 sub IO::Compress::Base::Parameters::new
 502 {
 503     my $class = shift ;
 504
 505     my $obj = { Error => '',
 506                 Got   => {},
 507               } ;
 508
 509     #return bless $obj, ref($class) || $class || __PACKAGE__ ;
 510     return bless $obj, 'IO::Compress::Base::Parameters' ;
 511 }
 512
 513 sub IO::Compress::Base::Parameters::setError
 514 {
 515     my $self = shift ;
 516     my $error = shift ;
 517     my $retval = @_ ? shift : undef ;
 518
 519     $self->{Error} = $error ;
 520     return $retval;
 521 }
 522
 523 #sub getError
 524 #{
 525 #    my $self = shift ;
 526 #    return $self->{Error} ;
 527 #}
 528
 529 sub IO::Compress::Base::Parameters::parse
 530 {
 531     my $self = shift ;
 532
 533     my $default = shift ;
 534
 535     my $got = $self->{Got} ;
 536     my $firstTime = keys %{ $got } == 0 ;
 537
 538     my (@Bad) ;
 539     my @entered = () ;
 540
 541     # Allow the options to be passed as a hash reference or
 542     # as the complete hash.
 543     if (@_ == 0) {
 544         @entered = () ;
 545     }
 546     elsif (@_ == 1) {
 547         my $href = $_[0] ;
 548         return $self->setError("Expected even number of parameters, got 1")
 549             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
 550
 551         foreach my $key (keys %$href) {
 552             push @entered, $key ;
 553             push @entered, \$href->{$key} ;
 554         }
 555     }
 556     else {
 557         my $count = @_;
 558         return $self->setError("Expected even number of parameters, got $count")
 559             if $count % 2 != 0 ;
 560
 561         for my $i (0.. $count / 2 - 1) {
 562             push @entered, $_[2* $i] ;
 563             push @entered, \$_[2* $i+1] ;
 564         }
 565     }
 566
 567
 568     while (my ($key, $v) = each %$default)
 569     {
 570         croak "need 4 params [@$v]"
 571             if @$v != 4 ;
 572
 573         my ($first_only, $sticky, $type, $value) = @$v ;
 574         my $x ;
 575         $self->_checkType($key, \$value, $type, 0, \$x)
 576             or return undef ;
 577
 578         $key = lc $key;
 579
 580         if ($firstTime || ! $sticky) {
 581             $x = [ $x ]
 582                 if $type & Parse_multiple;
 583
 584             $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
 585         }
 586
 587         $got->{$key}[OFF_PARSED] = 0 ;
 588     }
 589
 590     my %parsed = ();
 591     for my $i (0.. @entered / 2 - 1) {
 592         my $key = $entered[2* $i] ;
 593         my $value = $entered[2* $i+1] ;
 594
 595         #print "Key [$key] Value [$value]" ;
 596         #print defined $$value ? "[$$value]\n" : "[undef]\n";
 597
 598         $key =~ s/^-// ;
 599         my $canonkey = lc $key;
 600
 601         if ($got->{$canonkey} && ($firstTime ||
 602                                   ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
 603         {
 604             my $type = $got->{$canonkey}[OFF_TYPE] ;
 605             my $parsed = $parsed{$canonkey};
 606             ++ $parsed{$canonkey};
 607
 608             return $self->setError("Muliple instances of '$key' found")
 609                 if $parsed && $type & Parse_multiple == 0 ;
 610
 611             my $s ;
 612             $self->_checkType($key, $value, $type, 1, \$s)
 613                 or return undef ;
 614
 615             $value = $$value ;
 616             if ($type & Parse_multiple) {
 617                 $got->{$canonkey}[OFF_PARSED] = 1;
 618                 push @{ $got->{$canonkey}[OFF_FIXED] }, $s ;
 619             }
 620             else {
 621                 $got->{$canonkey} = [1, $type, $value, $s] ;
 622             }
 623         }
 624         else
 625           { push (@Bad, $key) }
 626     }
 627
 628     if (@Bad) {
 629         my ($bad) = join(", ", @Bad) ;
 630         return $self->setError("unknown key value(s) @Bad") ;
 631     }
 632
 633     return 1;
 634 }
 635
 636 sub IO::Compress::Base::Parameters::_checkType
 637 {
 638     my $self = shift ;
 639
 640     my $key   = shift ;
 641     my $value = shift ;
 642     my $type  = shift ;
 643     my $validate  = shift ;
 644     my $output  = shift;
 645
 646     #local $Carp::CarpLevel = $level ;
 647     #print "PARSE $type $key $value $validate $sub\n" ;
 648
 649     if ($type & Parse_writable_scalar)
 650     {
 651         return $self->setError("Parameter '$key' not writable")
 652             if $validate &&  readonly $$value ;
 653
 654         if (ref $$value)
 655         {
 656             return $self->setError("Parameter '$key' not a scalar reference")
 657                 if $validate &&  ref $$value ne 'SCALAR' ;
 658
 659             $$output = $$value ;
 660         }
 661         else
 662         {
 663             return $self->setError("Parameter '$key' not a scalar")
 664                 if $validate &&  ref $value ne 'SCALAR' ;
 665
 666             $$output = $value ;
 667         }
 668
 669         return 1;
 670     }
 671
 672 #    if ($type & Parse_store_ref)
 673 #    {
 674 #        #$value = $$value
 675 #        #    if ref ${ $value } ;
 676 #
 677 #        $$output = $value ;
 678 #        return 1;
 679 #    }
 680
 681     $value = $$value ;
 682
 683     if ($type & Parse_any)
 684     {
 685         $$output = $value ;
 686         return 1;
 687     }
 688     elsif ($type & Parse_unsigned)
 689     {
 690         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
 691             if $validate && ! defined $value ;
 692         return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
 693             if $validate && $value !~ /^\d+$/;
 694
 695         $$output = defined $value ? $value : 0 ;
 696         return 1;
 697     }
 698     elsif ($type & Parse_signed)
 699     {
 700         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
 701             if $validate && ! defined $value ;
 702         return $self->setError("Parameter '$key' must be a signed int, got '$value'")
 703             if $validate && $value !~ /^-?\d+$/;
 704
 705         $$output = defined $value ? $value : 0 ;
 706         return 1 ;
 707     }
 708     elsif ($type & Parse_boolean)
 709     {
 710         return $self->setError("Parameter '$key' must be an int, got '$value'")
 711             if $validate && defined $value && $value !~ /^\d*$/;
 712         $$output =  defined $value ? $value != 0 : 0 ;
 713         return 1;
 714     }
 715     elsif ($type & Parse_string)
 716     {
 717         $$output = defined $value ? $value : "" ;
 718         return 1;
 719     }
 720
 721     $$output = $value ;
 722     return 1;
 723 }
 724
 725
 726
 727 sub IO::Compress::Base::Parameters::parsed
 728 {
 729     my $self = shift ;
 730     my $name = shift ;
 731
 732     return $self->{Got}{lc $name}[OFF_PARSED] ;
 733 }
 734
 735 sub IO::Compress::Base::Parameters::value
 736 {
 737     my $self = shift ;
 738     my $name = shift ;
 739
 740     if (@_)
 741     {
 742         $self->{Got}{lc $name}[OFF_PARSED]  = 1;
 743         $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
 744         $self->{Got}{lc $name}[OFF_FIXED]   = $_[0] ;
 745     }
 746
 747     return $self->{Got}{lc $name}[OFF_FIXED] ;
 748 }
 749
 750 sub IO::Compress::Base::Parameters::valueOrDefault
 751 {
 752     my $self = shift ;
 753     my $name = shift ;
 754     my $default = shift ;
 755
 756     my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
 757
 758     return $value if defined $value ;
 759     return $default ;
 760 }
 761
 762 sub IO::Compress::Base::Parameters::wantValue
 763 {
 764     my $self = shift ;
 765     my $name = shift ;
 766
 767     return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
 768
 769 }
 770
 771 sub IO::Compress::Base::Parameters::clone
 772 {
 773     my $self = shift ;
 774     my $obj = { };
 775     my %got ;
 776
 777     while (my ($k, $v) = each %{ $self->{Got} }) {
 778         $got{$k} = [ @$v ];
 779     }
 780
 781     $obj->{Error} = $self->{Error};
 782     $obj->{Got} = \%got ;
 783
 784     return bless $obj, 'IO::Compress::Base::Parameters' ;
 785 }
 786
 787 package U64;
 788
 789 use constant MAX32 => 0xFFFFFFFF ;
 790 use constant LOW   => 0 ;
 791 use constant HIGH  => 1;
 792
 793 sub new
 794 {
 795     my $class = shift ;
 796
 797     my $high = 0 ;
 798     my $low  = 0 ;
 799
 800     if (@_ == 2) {
 801         $high = shift ;
 802         $low  = shift ;
 803     }
 804     elsif (@_ == 1) {
 805         $low  = shift ;
 806     }
 807
 808     bless [$low, $high], $class;
 809 }
 810
 811 sub newUnpack_V64
 812 {
 813     my $string = shift;
 814
 815     my ($low, $hi) = unpack "V V", $string ;
 816     bless [ $low, $hi ], "U64";
 817 }
 818
 819 sub newUnpack_V32
 820 {
 821     my $string = shift;
 822
 823     my $low = unpack "V", $string ;
 824     bless [ $low, 0 ], "U64";
 825 }
 826
 827 sub reset
 828 {
 829     my $self = shift;
 830     $self->[HIGH] = $self->[LOW] = 0;
 831 }
 832
 833 sub clone
 834 {
 835     my $self = shift;
 836     bless [ @$self ], ref $self ;
 837 }
 838
 839 sub getHigh
 840 {
 841     my $self = shift;
 842     return $self->[HIGH];
 843 }
 844
 845 sub getLow
 846 {
 847     my $self = shift;
 848     return $self->[LOW];
 849 }
 850
 851 sub get32bit
 852 {
 853     my $self = shift;
 854     return $self->[LOW];
 855 }
 856
 857 sub add
 858 {
 859     my $self = shift;
 860     my $value = shift;
 861
 862     if (ref $value eq 'U64') {
 863         $self->[HIGH] += $value->[HIGH] ;
 864         $value = $value->[LOW];
 865     }
 866
 867     my $available = MAX32 - $self->[LOW] ;
 868
 869     if ($value > $available) {
 870        ++ $self->[HIGH] ;
 871        $self->[LOW] = $value - $available - 1;
 872     }
 873     else {
 874        $self->[LOW] += $value ;
 875     }
 876 }
 877
 878 sub equal
 879 {
 880     my $self = shift;
 881     my $other = shift;
 882
 883     return $self->[LOW]  == $other->[LOW] &&
 884            $self->[HIGH] == $other->[HIGH] ;
 885 }
 886
 887 sub getPacked_V64
 888 {
 889     my $self = shift;
 890
 891     return pack "V V", @$self ;
 892 }
 893
 894 sub getPacked_V32
 895 {
 896     my $self = shift;
 897
 898     return pack "V", $self->[LOW] ;
 899 }
 900
 901 sub pack_V64
 902 {
 903     my $low  = shift;
 904
 905     return pack "V V", $low, 0;
 906 }
 907
 908
 909 package IO::Compress::Base::Common;
 910
 911 1;