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