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