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