1package IO::Compress::Base::Common;
2
3use strict ;
4use warnings;
5use bytes;
6
7use Carp;
8use Scalar::Util qw(blessed readonly);
9use File::GlobMapper;
10
11require Exporter;
12our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13@ISA = qw(Exporter);
14$VERSION = '2.212';
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
45use constant STATUS_OK        => 0;
46use constant STATUS_ENDSTREAM => 1;
47use constant STATUS_EOF       => 2;
48use constant STATUS_ERROR     => -1;
49use constant MAX16            => 0xFFFF ;
50use constant MAX32            => 0xFFFFFFFF ;
51use constant MAX32cmp         => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
52
53
54sub isGeMax32
55{
56    return $_[0] >= MAX32cmp ;
57}
58
59sub 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
74sub 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
91our ($needBinmode);
92$needBinmode = ($^O eq 'MSWin32' ||
93                    ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
94                    ? 1 : 1 ;
95
96sub setBinModeInput($)
97{
98    my $handle = shift ;
99
100    binmode $handle
101        if  $needBinmode;
102}
103
104sub setBinModeOutput($)
105{
106    my $handle = shift ;
107
108    binmode $handle
109        if  $needBinmode;
110}
111
112sub 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
122sub isaScalar
123{
124    return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
125}
126
127sub isaFilename($)
128{
129    return (defined $_[0] and
130           ! ref $_[0]    and
131           UNIVERSAL::isa(\$_[0], 'SCALAR'));
132}
133
134sub isaFileGlobString
135{
136    return defined $_[0] && $_[0] =~ /^<.*>$/;
137}
138
139sub cleanFileGlobString
140{
141    my $string = shift ;
142
143    $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
144
145    return $string;
146}
147
148use constant WANT_CODE  => 1 ;
149use constant WANT_EXT   => 2 ;
150use constant WANT_UNDEF => 4 ;
151#use constant WANT_HASH  => 8 ;
152use constant WANT_HASH  => 0 ;
153
154sub 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] = IO::File->new("<-");
164    }
165
166    return $got;
167}
168
169sub 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] = IO::File->new(">-");
178    }
179
180    return $got;
181}
182
183sub 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
208sub oneTarget
209{
210    return $_[0] =~ /^(code|handle|buffer|filename)$/;
211}
212
213sub 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 = File::GlobMapper->new($_[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
341sub IO::Compress::Base::Validator::saveErrorString
342{
343    my $self   = shift ;
344    ${ $self->{Error} } = shift ;
345    return undef;
346
347}
348
349sub IO::Compress::Base::Validator::croakError
350{
351    my $self   = shift ;
352    $self->saveErrorString($_[0]);
353    croak $_[0];
354}
355
356
357
358sub 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
388sub 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
444sub 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
478push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
479
480use constant Parse_any      => 0x01;
481use constant Parse_unsigned => 0x02;
482use constant Parse_signed   => 0x04;
483use constant Parse_boolean  => 0x08;
484use constant Parse_string   => 0x10;
485use constant Parse_code     => 0x20;
486
487#use constant Parse_store_ref        => 0x100 ;
488#use constant Parse_multiple         => 0x100 ;
489use constant Parse_writable         => 0x200 ;
490use constant Parse_writable_scalar  => 0x400 | Parse_writable ;
491
492use constant OFF_PARSED     => 0 ;
493use constant OFF_TYPE       => 1 ;
494use constant OFF_DEFAULT    => 2 ;
495use constant OFF_FIXED      => 3 ;
496#use constant OFF_FIRST_ONLY => 4 ;
497#use constant OFF_STICKY     => 5 ;
498
499use constant IxError => 0;
500use constant IxGot   => 1 ;
501
502sub 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 = IO::Compress::Base::Parameters->new();
513    $p->parse(@_)
514        or croak "$sub: $p->[IxError]" ;
515
516    return $p;
517}
518
519
520use strict;
521
522use warnings;
523use Carp;
524
525
526sub 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
560sub 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
571sub 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
582sub IO::Compress::Base::Parameters::getError
583{
584    my $self = shift ;
585    return $self->[IxError] ;
586}
587
588sub 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
684sub 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
776sub IO::Compress::Base::Parameters::parsed
777{
778    return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
779}
780
781
782sub IO::Compress::Base::Parameters::getValue
783{
784    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
785}
786sub 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
793sub IO::Compress::Base::Parameters::valueRef
794{
795    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED]  ;
796}
797
798sub 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
810sub IO::Compress::Base::Parameters::wantValue
811{
812    return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
813}
814
815sub 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
833package U64;
834
835use constant MAX32 => 0xFFFFFFFF ;
836use constant HI_1 => MAX32 + 1 ;
837use constant LOW   => 0 ;
838use constant HIGH  => 1;
839
840sub 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
852sub newUnpack_V64
853{
854    my ($low, $hi) = unpack "V V", $_[0] ;
855    bless [ $low, $hi ], "U64";
856}
857
858sub newUnpack_V32
859{
860    my $string = shift;
861
862    my $low = unpack "V", $string ;
863    bless [ $low, 0 ], "U64";
864}
865
866sub reset
867{
868    $_[0]->[HIGH] = $_[0]->[LOW] = 0;
869}
870
871sub clone
872{
873    bless [ @{$_[0]}  ], ref $_[0] ;
874}
875
876sub getHigh
877{
878    return $_[0]->[HIGH];
879}
880
881sub getLow
882{
883    return $_[0]->[LOW];
884}
885
886sub get32bit
887{
888    return $_[0]->[LOW];
889}
890
891sub 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
898sub 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
923sub 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
944sub 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
971sub equal
972{
973    my $self = shift;
974    my $other = shift;
975
976    return $self->[LOW]  == $other->[LOW] &&
977           $self->[HIGH] == $other->[HIGH] ;
978}
979
980sub isZero
981{
982    my $self = shift;
983
984    return $self->[LOW]  == 0 &&
985           $self->[HIGH] == 0 ;
986}
987
988sub gt
989{
990    my $self = shift;
991    my $other = shift;
992
993    return $self->cmp($other) > 0 ;
994}
995
996sub cmp
997{
998    my $self = shift;
999    my $other = shift ;
1000
1001    if ($self->[LOW] == $other->[LOW]) {
1002        return $self->[HIGH] - $other->[HIGH] ;
1003    }
1004    else {
1005        return $self->[LOW] - $other->[LOW] ;
1006    }
1007}
1008
1009
1010sub is64bit
1011{
1012    return $_[0]->[HIGH] > 0 ;
1013}
1014
1015sub isAlmost64bit
1016{
1017    return $_[0]->[HIGH] > 0 ||  $_[0]->[LOW] == MAX32 ;
1018}
1019
1020sub getPacked_V64
1021{
1022    return pack "V V", @{ $_[0] } ;
1023}
1024
1025sub getPacked_V32
1026{
1027    return pack "V", $_[0]->[LOW] ;
1028}
1029
1030sub pack_V64
1031{
1032    return pack "V V", $_[0], 0;
1033}
1034
1035
1036sub full32
1037{
1038    return $_[0] == MAX32 ;
1039}
1040
1041sub Value_VV64
1042{
1043    my $buffer = shift;
1044
1045    my ($lo, $hi) = unpack ("V V" , $buffer);
1046    no warnings 'uninitialized';
1047    return $hi * HI_1 + $lo;
1048}
1049
1050
1051package IO::Compress::Base::Common;
1052
10531;
1054