xref: /openbsd-src/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm (revision 3d61058aa5c692477b6d18acfbbdb653a9930ff9)
1b39c5158Smillertpackage IO::Compress::Base::Common;
2b39c5158Smillert
3b39c5158Smillertuse strict ;
4b39c5158Smillertuse warnings;
5b39c5158Smillertuse bytes;
6b39c5158Smillert
7b39c5158Smillertuse Carp;
8b39c5158Smillertuse Scalar::Util qw(blessed readonly);
9b39c5158Smillertuse File::GlobMapper;
10b39c5158Smillert
11b39c5158Smillertrequire Exporter;
12b39c5158Smillertour ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13b39c5158Smillert@ISA = qw(Exporter);
14*3d61058aSafresh1$VERSION = '2.212';
15b39c5158Smillert
16898184e3Ssthen@EXPORT = qw( isaFilehandle isaFilename isaScalar
17898184e3Ssthen              whatIsInput whatIsOutput
18b39c5158Smillert              isaFileGlobString cleanFileGlobString oneTarget
19b39c5158Smillert              setBinModeInput setBinModeOutput
20b39c5158Smillert              ckInOutParams
21b39c5158Smillert              createSelfTiedObject
22b39c5158Smillert
23898184e3Ssthen              isGeMax32
24898184e3Ssthen
25898184e3Ssthen              MAX32
26898184e3Ssthen
27b39c5158Smillert              WANT_CODE
28b39c5158Smillert              WANT_EXT
29b39c5158Smillert              WANT_UNDEF
30b39c5158Smillert              WANT_HASH
31b39c5158Smillert
32b39c5158Smillert              STATUS_OK
33b39c5158Smillert              STATUS_ENDSTREAM
34b39c5158Smillert              STATUS_EOF
35b39c5158Smillert              STATUS_ERROR
36b39c5158Smillert          );
37b39c5158Smillert
38b39c5158Smillert%EXPORT_TAGS = ( Status => [qw( STATUS_OK
39b39c5158Smillert                                 STATUS_ENDSTREAM
40b39c5158Smillert                                 STATUS_EOF
41b39c5158Smillert                                 STATUS_ERROR
42b39c5158Smillert                           )]);
43b39c5158Smillert
44b39c5158Smillert
45b39c5158Smillertuse constant STATUS_OK        => 0;
46b39c5158Smillertuse constant STATUS_ENDSTREAM => 1;
47b39c5158Smillertuse constant STATUS_EOF       => 2;
48b39c5158Smillertuse constant STATUS_ERROR     => -1;
49898184e3Ssthenuse constant MAX16            => 0xFFFF ;
50898184e3Ssthenuse constant MAX32            => 0xFFFFFFFF ;
51898184e3Ssthenuse constant MAX32cmp         => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
52898184e3Ssthen
53898184e3Ssthen
54898184e3Ssthensub isGeMax32
55898184e3Ssthen{
56898184e3Ssthen    return $_[0] >= MAX32cmp ;
57898184e3Ssthen}
58b39c5158Smillert
59b39c5158Smillertsub hasEncode()
60b39c5158Smillert{
61b39c5158Smillert    if (! defined $HAS_ENCODE) {
62b39c5158Smillert        eval
63b39c5158Smillert        {
64b39c5158Smillert            require Encode;
65b39c5158Smillert            Encode->import();
66b39c5158Smillert        };
67b39c5158Smillert
68b39c5158Smillert        $HAS_ENCODE = $@ ? 0 : 1 ;
69b39c5158Smillert    }
70b39c5158Smillert
71b39c5158Smillert    return $HAS_ENCODE;
72b39c5158Smillert}
73b39c5158Smillert
74b39c5158Smillertsub getEncoding($$$)
75b39c5158Smillert{
76b39c5158Smillert    my $obj = shift;
77b39c5158Smillert    my $class = shift ;
78b39c5158Smillert    my $want_encoding = shift ;
79b39c5158Smillert
80b39c5158Smillert    $obj->croakError("$class: Encode module needed to use -Encode")
81b39c5158Smillert        if ! hasEncode();
82b39c5158Smillert
83b39c5158Smillert    my $encoding = Encode::find_encoding($want_encoding);
84b39c5158Smillert
85b39c5158Smillert    $obj->croakError("$class: Encoding '$want_encoding' is not available")
86b39c5158Smillert       if ! $encoding;
87b39c5158Smillert
88b39c5158Smillert    return $encoding;
89b39c5158Smillert}
90b39c5158Smillert
91b39c5158Smillertour ($needBinmode);
92b39c5158Smillert$needBinmode = ($^O eq 'MSWin32' ||
93b39c5158Smillert                    ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
94b39c5158Smillert                    ? 1 : 1 ;
95b39c5158Smillert
96b39c5158Smillertsub setBinModeInput($)
97b39c5158Smillert{
98b39c5158Smillert    my $handle = shift ;
99b39c5158Smillert
100b39c5158Smillert    binmode $handle
101b39c5158Smillert        if  $needBinmode;
102b39c5158Smillert}
103b39c5158Smillert
104b39c5158Smillertsub setBinModeOutput($)
105b39c5158Smillert{
106b39c5158Smillert    my $handle = shift ;
107b39c5158Smillert
108b39c5158Smillert    binmode $handle
109b39c5158Smillert        if  $needBinmode;
110b39c5158Smillert}
111b39c5158Smillert
112b39c5158Smillertsub isaFilehandle($)
113b39c5158Smillert{
114b39c5158Smillert    use utf8; # Pragma needed to keep Perl 5.6.0 happy
115b39c5158Smillert    return (defined $_[0] and
116b39c5158Smillert             (UNIVERSAL::isa($_[0],'GLOB') or
117b39c5158Smillert              UNIVERSAL::isa($_[0],'IO::Handle') or
118b39c5158Smillert              UNIVERSAL::isa(\$_[0],'GLOB'))
119b39c5158Smillert          )
120b39c5158Smillert}
121b39c5158Smillert
122898184e3Ssthensub isaScalar
123898184e3Ssthen{
124898184e3Ssthen    return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
125898184e3Ssthen}
126898184e3Ssthen
127b39c5158Smillertsub isaFilename($)
128b39c5158Smillert{
129b39c5158Smillert    return (defined $_[0] and
130b39c5158Smillert           ! ref $_[0]    and
131b39c5158Smillert           UNIVERSAL::isa(\$_[0], 'SCALAR'));
132b39c5158Smillert}
133b39c5158Smillert
134b39c5158Smillertsub isaFileGlobString
135b39c5158Smillert{
136b39c5158Smillert    return defined $_[0] && $_[0] =~ /^<.*>$/;
137b39c5158Smillert}
138b39c5158Smillert
139b39c5158Smillertsub cleanFileGlobString
140b39c5158Smillert{
141b39c5158Smillert    my $string = shift ;
142b39c5158Smillert
143b39c5158Smillert    $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
144b39c5158Smillert
145b39c5158Smillert    return $string;
146b39c5158Smillert}
147b39c5158Smillert
148b39c5158Smillertuse constant WANT_CODE  => 1 ;
149b39c5158Smillertuse constant WANT_EXT   => 2 ;
150b39c5158Smillertuse constant WANT_UNDEF => 4 ;
151b39c5158Smillert#use constant WANT_HASH  => 8 ;
152b39c5158Smillertuse constant WANT_HASH  => 0 ;
153b39c5158Smillert
154b39c5158Smillertsub whatIsInput($;$)
155b39c5158Smillert{
156b39c5158Smillert    my $got = whatIs(@_);
157b39c5158Smillert
158b39c5158Smillert    if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
159b39c5158Smillert    {
160b39c5158Smillert        #use IO::File;
161b39c5158Smillert        $got = 'handle';
162b39c5158Smillert        $_[0] = *STDIN;
163eac174f2Safresh1        #$_[0] = IO::File->new("<-");
164b39c5158Smillert    }
165b39c5158Smillert
166b39c5158Smillert    return $got;
167b39c5158Smillert}
168b39c5158Smillert
169b39c5158Smillertsub whatIsOutput($;$)
170b39c5158Smillert{
171b39c5158Smillert    my $got = whatIs(@_);
172b39c5158Smillert
173b39c5158Smillert    if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
174b39c5158Smillert    {
175b39c5158Smillert        $got = 'handle';
176b39c5158Smillert        $_[0] = *STDOUT;
177eac174f2Safresh1        #$_[0] = IO::File->new(">-");
178b39c5158Smillert    }
179b39c5158Smillert
180b39c5158Smillert    return $got;
181b39c5158Smillert}
182b39c5158Smillert
183b39c5158Smillertsub whatIs ($;$)
184b39c5158Smillert{
185b39c5158Smillert    return 'handle' if isaFilehandle($_[0]);
186b39c5158Smillert
187b39c5158Smillert    my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
188b39c5158Smillert    my $extended = defined $_[1] && $_[1] & WANT_EXT ;
189b39c5158Smillert    my $undef    = defined $_[1] && $_[1] & WANT_UNDEF ;
190b39c5158Smillert    my $hash     = defined $_[1] && $_[1] & WANT_HASH ;
191b39c5158Smillert
192b39c5158Smillert    return 'undef'  if ! defined $_[0] && $undef ;
193b39c5158Smillert
194b39c5158Smillert    if (ref $_[0]) {
195b39c5158Smillert        return ''       if blessed($_[0]); # is an object
196b39c5158Smillert        #return ''       if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
197b39c5158Smillert        return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
198b39c5158Smillert        return 'array'  if UNIVERSAL::isa($_[0], 'ARRAY')  && $extended ;
199b39c5158Smillert        return 'hash'   if UNIVERSAL::isa($_[0], 'HASH')   && $hash ;
200b39c5158Smillert        return 'code'   if UNIVERSAL::isa($_[0], 'CODE')   && $wantCode ;
201b39c5158Smillert        return '';
202b39c5158Smillert    }
203b39c5158Smillert
204b39c5158Smillert    return 'fileglob' if $extended && isaFileGlobString($_[0]);
205b39c5158Smillert    return 'filename';
206b39c5158Smillert}
207b39c5158Smillert
208b39c5158Smillertsub oneTarget
209b39c5158Smillert{
210b39c5158Smillert    return $_[0] =~ /^(code|handle|buffer|filename)$/;
211b39c5158Smillert}
212b39c5158Smillert
213b39c5158Smillertsub IO::Compress::Base::Validator::new
214b39c5158Smillert{
215b39c5158Smillert    my $class = shift ;
216b39c5158Smillert
217b39c5158Smillert    my $Class = shift ;
218b39c5158Smillert    my $error_ref = shift ;
219b39c5158Smillert    my $reportClass = shift ;
220b39c5158Smillert
221b39c5158Smillert    my %data = (Class       => $Class,
222b39c5158Smillert                Error       => $error_ref,
223b39c5158Smillert                reportClass => $reportClass,
224b39c5158Smillert               ) ;
225b39c5158Smillert
226b39c5158Smillert    my $obj = bless \%data, $class ;
227b39c5158Smillert
228b39c5158Smillert    local $Carp::CarpLevel = 1;
229b39c5158Smillert
230b39c5158Smillert    my $inType    = $data{inType}    = whatIsInput($_[0], WANT_EXT|WANT_HASH);
231b39c5158Smillert    my $outType   = $data{outType}   = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
232b39c5158Smillert
233b39c5158Smillert    my $oneInput  = $data{oneInput}  = oneTarget($inType);
234b39c5158Smillert    my $oneOutput = $data{oneOutput} = oneTarget($outType);
235b39c5158Smillert
236b39c5158Smillert    if (! $inType)
237b39c5158Smillert    {
238b39c5158Smillert        $obj->croakError("$reportClass: illegal input parameter") ;
239b39c5158Smillert        #return undef ;
240b39c5158Smillert    }
241b39c5158Smillert
242b39c5158Smillert#    if ($inType eq 'hash')
243b39c5158Smillert#    {
244b39c5158Smillert#        $obj->{Hash} = 1 ;
245b39c5158Smillert#        $obj->{oneInput} = 1 ;
246b39c5158Smillert#        return $obj->validateHash($_[0]);
247b39c5158Smillert#    }
248b39c5158Smillert
249b39c5158Smillert    if (! $outType)
250b39c5158Smillert    {
251b39c5158Smillert        $obj->croakError("$reportClass: illegal output parameter") ;
252b39c5158Smillert        #return undef ;
253b39c5158Smillert    }
254b39c5158Smillert
255b39c5158Smillert
256b39c5158Smillert    if ($inType ne 'fileglob' && $outType eq 'fileglob')
257b39c5158Smillert    {
258b39c5158Smillert        $obj->croakError("Need input fileglob for outout fileglob");
259b39c5158Smillert    }
260b39c5158Smillert
261b39c5158Smillert#    if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
262b39c5158Smillert#    {
263b39c5158Smillert#        $obj->croakError("input must ne filename or fileglob when output is a hash");
264b39c5158Smillert#    }
265b39c5158Smillert
266b39c5158Smillert    if ($inType eq 'fileglob' && $outType eq 'fileglob')
267b39c5158Smillert    {
268b39c5158Smillert        $data{GlobMap} = 1 ;
269b39c5158Smillert        $data{inType} = $data{outType} = 'filename';
270eac174f2Safresh1        my $mapper = File::GlobMapper->new($_[0], $_[1]);
271b39c5158Smillert        if ( ! $mapper )
272b39c5158Smillert        {
273b39c5158Smillert            return $obj->saveErrorString($File::GlobMapper::Error) ;
274b39c5158Smillert        }
275b39c5158Smillert        $data{Pairs} = $mapper->getFileMap();
276b39c5158Smillert
277b39c5158Smillert        return $obj;
278b39c5158Smillert    }
279b39c5158Smillert
280b39c5158Smillert    $obj->croakError("$reportClass: input and output $inType are identical")
281b39c5158Smillert        if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
282b39c5158Smillert
283b39c5158Smillert    if ($inType eq 'fileglob') # && $outType ne 'fileglob'
284b39c5158Smillert    {
285b39c5158Smillert        my $glob = cleanFileGlobString($_[0]);
286b39c5158Smillert        my @inputs = glob($glob);
287b39c5158Smillert
288b39c5158Smillert        if (@inputs == 0)
289b39c5158Smillert        {
290b39c5158Smillert            # TODO -- legal or die?
291b39c5158Smillert            die "globmap matched zero file -- legal or die???" ;
292b39c5158Smillert        }
293b39c5158Smillert        elsif (@inputs == 1)
294b39c5158Smillert        {
295b39c5158Smillert            $obj->validateInputFilenames($inputs[0])
296b39c5158Smillert                or return undef;
297b39c5158Smillert            $_[0] = $inputs[0]  ;
298b39c5158Smillert            $data{inType} = 'filename' ;
299b39c5158Smillert            $data{oneInput} = 1;
300b39c5158Smillert        }
301b39c5158Smillert        else
302b39c5158Smillert        {
303b39c5158Smillert            $obj->validateInputFilenames(@inputs)
304b39c5158Smillert                or return undef;
305b39c5158Smillert            $_[0] = [ @inputs ] ;
306b39c5158Smillert            $data{inType} = 'filenames' ;
307b39c5158Smillert        }
308b39c5158Smillert    }
309b39c5158Smillert    elsif ($inType eq 'filename')
310b39c5158Smillert    {
311b39c5158Smillert        $obj->validateInputFilenames($_[0])
312b39c5158Smillert            or return undef;
313b39c5158Smillert    }
314b39c5158Smillert    elsif ($inType eq 'array')
315b39c5158Smillert    {
316b39c5158Smillert        $data{inType} = 'filenames' ;
317b39c5158Smillert        $obj->validateInputArray($_[0])
318b39c5158Smillert            or return undef ;
319b39c5158Smillert    }
320b39c5158Smillert
321b39c5158Smillert    return $obj->saveErrorString("$reportClass: output buffer is read-only")
322b39c5158Smillert        if $outType eq 'buffer' && readonly(${ $_[1] });
323b39c5158Smillert
324b39c5158Smillert    if ($outType eq 'filename' )
325b39c5158Smillert    {
326b39c5158Smillert        $obj->croakError("$reportClass: output filename is undef or null string")
327b39c5158Smillert            if ! defined $_[1] || $_[1] eq ''  ;
328b39c5158Smillert
329b39c5158Smillert        if (-e $_[1])
330b39c5158Smillert        {
331b39c5158Smillert            if (-d _ )
332b39c5158Smillert            {
333b39c5158Smillert                return $obj->saveErrorString("output file '$_[1]' is a directory");
334b39c5158Smillert            }
335b39c5158Smillert        }
336b39c5158Smillert    }
337b39c5158Smillert
338b39c5158Smillert    return $obj ;
339b39c5158Smillert}
340b39c5158Smillert
341b39c5158Smillertsub IO::Compress::Base::Validator::saveErrorString
342b39c5158Smillert{
343b39c5158Smillert    my $self   = shift ;
344b39c5158Smillert    ${ $self->{Error} } = shift ;
345b39c5158Smillert    return undef;
346b39c5158Smillert
347b39c5158Smillert}
348b39c5158Smillert
349b39c5158Smillertsub IO::Compress::Base::Validator::croakError
350b39c5158Smillert{
351b39c5158Smillert    my $self   = shift ;
352b39c5158Smillert    $self->saveErrorString($_[0]);
353b39c5158Smillert    croak $_[0];
354b39c5158Smillert}
355b39c5158Smillert
356b39c5158Smillert
357b39c5158Smillert
358b39c5158Smillertsub IO::Compress::Base::Validator::validateInputFilenames
359b39c5158Smillert{
360b39c5158Smillert    my $self = shift ;
361b39c5158Smillert
362b39c5158Smillert    foreach my $filename (@_)
363b39c5158Smillert    {
364b39c5158Smillert        $self->croakError("$self->{reportClass}: input filename is undef or null string")
365b39c5158Smillert            if ! defined $filename || $filename eq ''  ;
366b39c5158Smillert
367b39c5158Smillert        next if $filename eq '-';
368b39c5158Smillert
369b39c5158Smillert        if (! -e $filename )
370b39c5158Smillert        {
371b39c5158Smillert            return $self->saveErrorString("input file '$filename' does not exist");
372b39c5158Smillert        }
373b39c5158Smillert
374b39c5158Smillert        if (-d _ )
375b39c5158Smillert        {
376b39c5158Smillert            return $self->saveErrorString("input file '$filename' is a directory");
377b39c5158Smillert        }
378b39c5158Smillert
37991f110e0Safresh1#        if (! -r _ )
38091f110e0Safresh1#        {
38191f110e0Safresh1#            return $self->saveErrorString("cannot open file '$filename': $!");
38291f110e0Safresh1#        }
383b39c5158Smillert    }
384b39c5158Smillert
385b39c5158Smillert    return 1 ;
386b39c5158Smillert}
387b39c5158Smillert
388b39c5158Smillertsub IO::Compress::Base::Validator::validateInputArray
389b39c5158Smillert{
390b39c5158Smillert    my $self = shift ;
391b39c5158Smillert
392b39c5158Smillert    if ( @{ $_[0] } == 0 )
393b39c5158Smillert    {
394b39c5158Smillert        return $self->saveErrorString("empty array reference") ;
395b39c5158Smillert    }
396b39c5158Smillert
397b39c5158Smillert    foreach my $element ( @{ $_[0] } )
398b39c5158Smillert    {
399b39c5158Smillert        my $inType  = whatIsInput($element);
400b39c5158Smillert
401b39c5158Smillert        if (! $inType)
402b39c5158Smillert        {
403b39c5158Smillert            $self->croakError("unknown input parameter") ;
404b39c5158Smillert        }
405b39c5158Smillert        elsif($inType eq 'filename')
406b39c5158Smillert        {
407b39c5158Smillert            $self->validateInputFilenames($element)
408b39c5158Smillert                or return undef ;
409b39c5158Smillert        }
410b39c5158Smillert        else
411b39c5158Smillert        {
412b39c5158Smillert            $self->croakError("not a filename") ;
413b39c5158Smillert        }
414b39c5158Smillert    }
415b39c5158Smillert
416b39c5158Smillert    return 1 ;
417b39c5158Smillert}
418b39c5158Smillert
419b39c5158Smillert#sub IO::Compress::Base::Validator::validateHash
420b39c5158Smillert#{
421b39c5158Smillert#    my $self = shift ;
422b39c5158Smillert#    my $href = shift ;
423b39c5158Smillert#
424b39c5158Smillert#    while (my($k, $v) = each %$href)
425b39c5158Smillert#    {
426b39c5158Smillert#        my $ktype = whatIsInput($k);
427b39c5158Smillert#        my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
428b39c5158Smillert#
429b39c5158Smillert#        if ($ktype ne 'filename')
430b39c5158Smillert#        {
431b39c5158Smillert#            return $self->saveErrorString("hash key not filename") ;
432b39c5158Smillert#        }
433b39c5158Smillert#
434b39c5158Smillert#        my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
435b39c5158Smillert#        if (! $valid{$vtype})
436b39c5158Smillert#        {
437b39c5158Smillert#            return $self->saveErrorString("hash value not ok") ;
438b39c5158Smillert#        }
439b39c5158Smillert#    }
440b39c5158Smillert#
441b39c5158Smillert#    return $self ;
442b39c5158Smillert#}
443b39c5158Smillert
444b39c5158Smillertsub createSelfTiedObject
445b39c5158Smillert{
446b39c5158Smillert    my $class = shift || (caller)[0] ;
447b39c5158Smillert    my $error_ref = shift ;
448b39c5158Smillert
449b39c5158Smillert    my $obj = bless Symbol::gensym(), ref($class) || $class;
450b39c5158Smillert    tie *$obj, $obj if $] >= 5.005;
451b39c5158Smillert    *$obj->{Closed} = 1 ;
452b39c5158Smillert    $$error_ref = '';
453b39c5158Smillert    *$obj->{Error} = $error_ref ;
454b39c5158Smillert    my $errno = 0 ;
455b39c5158Smillert    *$obj->{ErrorNo} = \$errno ;
456b39c5158Smillert
457b39c5158Smillert    return $obj;
458b39c5158Smillert}
459b39c5158Smillert
460b39c5158Smillert
461b39c5158Smillert
462b39c5158Smillert#package Parse::Parameters ;
463b39c5158Smillert#
464b39c5158Smillert#
465b39c5158Smillert#require Exporter;
466b39c5158Smillert#our ($VERSION, @ISA, @EXPORT);
467b8851fccSafresh1#$VERSION = '2.000_08';
468b39c5158Smillert#@ISA = qw(Exporter);
469b39c5158Smillert
470b39c5158Smillert$EXPORT_TAGS{Parse} = [qw( ParseParameters
471b39c5158Smillert                           Parse_any Parse_unsigned Parse_signed
472898184e3Ssthen                           Parse_boolean Parse_string
473898184e3Ssthen                           Parse_code
47491f110e0Safresh1                           Parse_writable_scalar
475b39c5158Smillert                         )
476b39c5158Smillert                      ];
477b39c5158Smillert
478b39c5158Smillertpush @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
479b39c5158Smillert
480b39c5158Smillertuse constant Parse_any      => 0x01;
481b39c5158Smillertuse constant Parse_unsigned => 0x02;
482b39c5158Smillertuse constant Parse_signed   => 0x04;
483b39c5158Smillertuse constant Parse_boolean  => 0x08;
484b39c5158Smillertuse constant Parse_string   => 0x10;
485898184e3Ssthenuse constant Parse_code     => 0x20;
486b39c5158Smillert
487b39c5158Smillert#use constant Parse_store_ref        => 0x100 ;
48891f110e0Safresh1#use constant Parse_multiple         => 0x100 ;
489b39c5158Smillertuse constant Parse_writable         => 0x200 ;
490b39c5158Smillertuse constant Parse_writable_scalar  => 0x400 | Parse_writable ;
491b39c5158Smillert
492b39c5158Smillertuse constant OFF_PARSED     => 0 ;
493b39c5158Smillertuse constant OFF_TYPE       => 1 ;
494b39c5158Smillertuse constant OFF_DEFAULT    => 2 ;
495b39c5158Smillertuse constant OFF_FIXED      => 3 ;
49691f110e0Safresh1#use constant OFF_FIRST_ONLY => 4 ;
49791f110e0Safresh1#use constant OFF_STICKY     => 5 ;
498b39c5158Smillert
49991f110e0Safresh1use constant IxError => 0;
50091f110e0Safresh1use constant IxGot   => 1 ;
501b39c5158Smillert
502b39c5158Smillertsub ParseParameters
503b39c5158Smillert{
504b39c5158Smillert    my $level = shift || 0 ;
505b39c5158Smillert
506b39c5158Smillert    my $sub = (caller($level + 1))[3] ;
507b39c5158Smillert    local $Carp::CarpLevel = 1 ;
508b39c5158Smillert
509b39c5158Smillert    return $_[1]
510b39c5158Smillert        if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
511b39c5158Smillert
512eac174f2Safresh1    my $p = IO::Compress::Base::Parameters->new();
513b39c5158Smillert    $p->parse(@_)
51491f110e0Safresh1        or croak "$sub: $p->[IxError]" ;
515b39c5158Smillert
516b39c5158Smillert    return $p;
517b39c5158Smillert}
518b39c5158Smillert
519b39c5158Smillert
520b39c5158Smillertuse strict;
521898184e3Ssthen
522b39c5158Smillertuse warnings;
523b39c5158Smillertuse Carp;
524b39c5158Smillert
52591f110e0Safresh1
52691f110e0Safresh1sub Init
52791f110e0Safresh1{
52891f110e0Safresh1    my $default = shift ;
52991f110e0Safresh1    my %got ;
53091f110e0Safresh1
53191f110e0Safresh1    my $obj = IO::Compress::Base::Parameters::new();
53291f110e0Safresh1    while (my ($key, $v) = each %$default)
53391f110e0Safresh1    {
53491f110e0Safresh1        croak "need 2 params [@$v]"
53591f110e0Safresh1            if @$v != 2 ;
53691f110e0Safresh1
53791f110e0Safresh1        my ($type, $value) = @$v ;
53891f110e0Safresh1#        my ($first_only, $sticky, $type, $value) = @$v ;
53991f110e0Safresh1        my $sticky = 0;
54091f110e0Safresh1        my $x ;
54191f110e0Safresh1        $obj->_checkType($key, \$value, $type, 0, \$x)
54291f110e0Safresh1            or return undef ;
54391f110e0Safresh1
54491f110e0Safresh1        $key = lc $key;
54591f110e0Safresh1
54691f110e0Safresh1#        if (! $sticky) {
54791f110e0Safresh1#            $x = []
54891f110e0Safresh1#                if $type & Parse_multiple;
54991f110e0Safresh1
55091f110e0Safresh1#            $got{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
55191f110e0Safresh1            $got{$key} = [0, $type, $value, $x] ;
55291f110e0Safresh1#        }
55391f110e0Safresh1#
55491f110e0Safresh1#        $got{$key}[OFF_PARSED] = 0 ;
55591f110e0Safresh1    }
55691f110e0Safresh1
55791f110e0Safresh1    return bless \%got, "IO::Compress::Base::Parameters::Defaults" ;
55891f110e0Safresh1}
55991f110e0Safresh1
560b39c5158Smillertsub IO::Compress::Base::Parameters::new
561b39c5158Smillert{
56291f110e0Safresh1    #my $class = shift ;
563b39c5158Smillert
56491f110e0Safresh1    my $obj;
56591f110e0Safresh1    $obj->[IxError] = '';
56691f110e0Safresh1    $obj->[IxGot] = {} ;
567b39c5158Smillert
568b39c5158Smillert    return bless $obj, 'IO::Compress::Base::Parameters' ;
569b39c5158Smillert}
570b39c5158Smillert
571b39c5158Smillertsub IO::Compress::Base::Parameters::setError
572b39c5158Smillert{
573b39c5158Smillert    my $self = shift ;
574b39c5158Smillert    my $error = shift ;
575b39c5158Smillert    my $retval = @_ ? shift : undef ;
576b39c5158Smillert
57791f110e0Safresh1
57891f110e0Safresh1    $self->[IxError] = $error ;
579b39c5158Smillert    return $retval;
580b39c5158Smillert}
581b39c5158Smillert
58291f110e0Safresh1sub IO::Compress::Base::Parameters::getError
58391f110e0Safresh1{
58491f110e0Safresh1    my $self = shift ;
58591f110e0Safresh1    return $self->[IxError] ;
58691f110e0Safresh1}
587b39c5158Smillert
588b39c5158Smillertsub IO::Compress::Base::Parameters::parse
589b39c5158Smillert{
590b39c5158Smillert    my $self = shift ;
591b39c5158Smillert    my $default = shift ;
592b39c5158Smillert
59391f110e0Safresh1    my $got = $self->[IxGot] ;
594b39c5158Smillert    my $firstTime = keys %{ $got } == 0 ;
595b39c5158Smillert
596b39c5158Smillert    my (@Bad) ;
597b39c5158Smillert    my @entered = () ;
598b39c5158Smillert
599b39c5158Smillert    # Allow the options to be passed as a hash reference or
600b39c5158Smillert    # as the complete hash.
601b39c5158Smillert    if (@_ == 0) {
602b39c5158Smillert        @entered = () ;
603b39c5158Smillert    }
604b39c5158Smillert    elsif (@_ == 1) {
605b39c5158Smillert        my $href = $_[0] ;
606b39c5158Smillert
607b39c5158Smillert        return $self->setError("Expected even number of parameters, got 1")
608b39c5158Smillert            if ! defined $href or ! ref $href or ref $href ne "HASH" ;
609b39c5158Smillert
610b39c5158Smillert        foreach my $key (keys %$href) {
611b39c5158Smillert            push @entered, $key ;
612b39c5158Smillert            push @entered, \$href->{$key} ;
613b39c5158Smillert        }
614b39c5158Smillert    }
615b39c5158Smillert    else {
61691f110e0Safresh1
617b39c5158Smillert        my $count = @_;
618b39c5158Smillert        return $self->setError("Expected even number of parameters, got $count")
619b39c5158Smillert            if $count % 2 != 0 ;
620b39c5158Smillert
621b39c5158Smillert        for my $i (0.. $count / 2 - 1) {
622b39c5158Smillert            push @entered, $_[2 * $i] ;
623b39c5158Smillert            push @entered, \$_[2 * $i + 1] ;
624b39c5158Smillert        }
625b39c5158Smillert    }
626b39c5158Smillert
62791f110e0Safresh1        foreach my $key (keys %$default)
628b39c5158Smillert        {
629b39c5158Smillert
63091f110e0Safresh1            my ($type, $value) = @{ $default->{$key} } ;
631b39c5158Smillert
63291f110e0Safresh1            if ($firstTime) {
63391f110e0Safresh1                $got->{$key} = [0, $type, $value, $value] ;
634b39c5158Smillert            }
63591f110e0Safresh1            else
63691f110e0Safresh1            {
637b39c5158Smillert                $got->{$key}[OFF_PARSED] = 0 ;
638b39c5158Smillert            }
63991f110e0Safresh1        }
64091f110e0Safresh1
641b39c5158Smillert
642b39c5158Smillert    my %parsed = ();
643b39c5158Smillert
644b39c5158Smillert
645b39c5158Smillert    for my $i (0.. @entered / 2 - 1) {
646b39c5158Smillert        my $key = $entered[2* $i] ;
647b39c5158Smillert        my $value = $entered[2* $i+1] ;
648b39c5158Smillert
649b39c5158Smillert        #print "Key [$key] Value [$value]" ;
650b39c5158Smillert        #print defined $$value ? "[$$value]\n" : "[undef]\n";
651b39c5158Smillert
652b39c5158Smillert        $key =~ s/^-// ;
653b39c5158Smillert        my $canonkey = lc $key;
654b39c5158Smillert
65591f110e0Safresh1        if ($got->{$canonkey})
656b39c5158Smillert        {
657b39c5158Smillert            my $type = $got->{$canonkey}[OFF_TYPE] ;
658b39c5158Smillert            my $parsed = $parsed{$canonkey};
659b39c5158Smillert            ++ $parsed{$canonkey};
660b39c5158Smillert
661b39c5158Smillert            return $self->setError("Muliple instances of '$key' found")
66291f110e0Safresh1                if $parsed ;
663b39c5158Smillert
664b39c5158Smillert            my $s ;
665b39c5158Smillert            $self->_checkType($key, $value, $type, 1, \$s)
666b39c5158Smillert                or return undef ;
667b39c5158Smillert
668b39c5158Smillert            $value = $$value ;
669b39c5158Smillert            $got->{$canonkey} = [1, $type, $value, $s] ;
67091f110e0Safresh1
671b39c5158Smillert        }
672b39c5158Smillert        else
673b39c5158Smillert          { push (@Bad, $key) }
674b39c5158Smillert    }
675b39c5158Smillert
676b39c5158Smillert    if (@Bad) {
677b39c5158Smillert        my ($bad) = join(", ", @Bad) ;
678b39c5158Smillert        return $self->setError("unknown key value(s) $bad") ;
679b39c5158Smillert    }
680b39c5158Smillert
681b39c5158Smillert    return 1;
682b39c5158Smillert}
683b39c5158Smillert
684b39c5158Smillertsub IO::Compress::Base::Parameters::_checkType
685b39c5158Smillert{
686b39c5158Smillert    my $self = shift ;
687b39c5158Smillert
688b39c5158Smillert    my $key   = shift ;
689b39c5158Smillert    my $value = shift ;
690b39c5158Smillert    my $type  = shift ;
691b39c5158Smillert    my $validate  = shift ;
692b39c5158Smillert    my $output  = shift;
693b39c5158Smillert
694b39c5158Smillert    #local $Carp::CarpLevel = $level ;
695b39c5158Smillert    #print "PARSE $type $key $value $validate $sub\n" ;
696b39c5158Smillert
697b39c5158Smillert    if ($type & Parse_writable_scalar)
698b39c5158Smillert    {
699b39c5158Smillert        return $self->setError("Parameter '$key' not writable")
70091f110e0Safresh1            if  readonly $$value ;
701b39c5158Smillert
702b39c5158Smillert        if (ref $$value)
703b39c5158Smillert        {
704b39c5158Smillert            return $self->setError("Parameter '$key' not a scalar reference")
70591f110e0Safresh1                if ref $$value ne 'SCALAR' ;
706b39c5158Smillert
707b39c5158Smillert            $$output = $$value ;
708b39c5158Smillert        }
709b39c5158Smillert        else
710b39c5158Smillert        {
711b39c5158Smillert            return $self->setError("Parameter '$key' not a scalar")
71291f110e0Safresh1                if ref $value ne 'SCALAR' ;
713b39c5158Smillert
714b39c5158Smillert            $$output = $value ;
715b39c5158Smillert        }
716b39c5158Smillert
717b39c5158Smillert        return 1;
718b39c5158Smillert    }
719b39c5158Smillert
720b39c5158Smillert
721b39c5158Smillert    $value = $$value ;
722b39c5158Smillert
723b39c5158Smillert    if ($type & Parse_any)
724b39c5158Smillert    {
725b39c5158Smillert        $$output = $value ;
726b39c5158Smillert        return 1;
727b39c5158Smillert    }
728b39c5158Smillert    elsif ($type & Parse_unsigned)
729b39c5158Smillert    {
73091f110e0Safresh1
731b39c5158Smillert        return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
73291f110e0Safresh1            if ! defined $value ;
733b39c5158Smillert        return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
73491f110e0Safresh1            if $value !~ /^\d+$/;
735b39c5158Smillert
736b39c5158Smillert        $$output = defined $value ? $value : 0 ;
737b39c5158Smillert        return 1;
738b39c5158Smillert    }
739b39c5158Smillert    elsif ($type & Parse_signed)
740b39c5158Smillert    {
741b39c5158Smillert        return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
74291f110e0Safresh1            if ! defined $value ;
743b39c5158Smillert        return $self->setError("Parameter '$key' must be a signed int, got '$value'")
74491f110e0Safresh1            if $value !~ /^-?\d+$/;
745b39c5158Smillert
746b39c5158Smillert        $$output = defined $value ? $value : 0 ;
747b39c5158Smillert        return 1 ;
748b39c5158Smillert    }
749b39c5158Smillert    elsif ($type & Parse_boolean)
750b39c5158Smillert    {
751b39c5158Smillert        return $self->setError("Parameter '$key' must be an int, got '$value'")
75291f110e0Safresh1            if defined $value && $value !~ /^\d*$/;
75391f110e0Safresh1
75491f110e0Safresh1        $$output =  defined $value && $value != 0 ? 1 : 0 ;
75591f110e0Safresh1        return 1;
75691f110e0Safresh1    }
75791f110e0Safresh1
75891f110e0Safresh1    elsif ($type & Parse_string)
75991f110e0Safresh1    {
76091f110e0Safresh1        $$output = defined $value ? $value : "" ;
761b39c5158Smillert        return 1;
762b39c5158Smillert    }
763898184e3Ssthen    elsif ($type & Parse_code)
764898184e3Ssthen    {
765898184e3Ssthen        return $self->setError("Parameter '$key' must be a code reference, got '$value'")
76691f110e0Safresh1            if (! defined $value || ref $value ne 'CODE') ;
76791f110e0Safresh1
768b39c5158Smillert        $$output = defined $value ? $value : "" ;
769b39c5158Smillert        return 1;
770b39c5158Smillert    }
771b39c5158Smillert
772b39c5158Smillert    $$output = $value ;
773b39c5158Smillert    return 1;
774b39c5158Smillert}
775b39c5158Smillert
776b39c5158Smillertsub IO::Compress::Base::Parameters::parsed
777b39c5158Smillert{
77891f110e0Safresh1    return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
779b39c5158Smillert}
780b39c5158Smillert
781b39c5158Smillert
78291f110e0Safresh1sub IO::Compress::Base::Parameters::getValue
783b39c5158Smillert{
78491f110e0Safresh1    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
78591f110e0Safresh1}
78691f110e0Safresh1sub IO::Compress::Base::Parameters::setValue
78791f110e0Safresh1{
78891f110e0Safresh1    $_[0]->[IxGot]{$_[1]}[OFF_PARSED]  = 1;
78991f110e0Safresh1    $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
79091f110e0Safresh1    $_[0]->[IxGot]{$_[1]}[OFF_FIXED]   = $_[2] ;
791b39c5158Smillert}
792b39c5158Smillert
79391f110e0Safresh1sub IO::Compress::Base::Parameters::valueRef
79491f110e0Safresh1{
79591f110e0Safresh1    return  $_[0]->[IxGot]{$_[1]}[OFF_FIXED]  ;
796b39c5158Smillert}
797b39c5158Smillert
798b39c5158Smillertsub IO::Compress::Base::Parameters::valueOrDefault
799b39c5158Smillert{
800b39c5158Smillert    my $self = shift ;
801b39c5158Smillert    my $name = shift ;
802b39c5158Smillert    my $default = shift ;
803b39c5158Smillert
80491f110e0Safresh1    my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
805b39c5158Smillert
806b39c5158Smillert    return $value if defined $value ;
807b39c5158Smillert    return $default ;
808b39c5158Smillert}
809b39c5158Smillert
810b39c5158Smillertsub IO::Compress::Base::Parameters::wantValue
811b39c5158Smillert{
81291f110e0Safresh1    return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
813b39c5158Smillert}
814b39c5158Smillert
815b39c5158Smillertsub IO::Compress::Base::Parameters::clone
816b39c5158Smillert{
817b39c5158Smillert    my $self = shift ;
81891f110e0Safresh1    my $obj = [] ;
819b39c5158Smillert    my %got ;
820b39c5158Smillert
82191f110e0Safresh1    my $hash = $self->[IxGot] ;
82291f110e0Safresh1    for my $k (keys %{ $hash })
82391f110e0Safresh1    {
82491f110e0Safresh1        $got{$k} = [ @{ $hash->{$k} } ];
825b39c5158Smillert    }
826b39c5158Smillert
82791f110e0Safresh1    $obj->[IxError] = $self->[IxError];
82891f110e0Safresh1    $obj->[IxGot] = \%got ;
829b39c5158Smillert
830b39c5158Smillert    return bless $obj, 'IO::Compress::Base::Parameters' ;
831b39c5158Smillert}
832b39c5158Smillert
833b39c5158Smillertpackage U64;
834b39c5158Smillert
835b39c5158Smillertuse constant MAX32 => 0xFFFFFFFF ;
836b39c5158Smillertuse constant HI_1 => MAX32 + 1 ;
837b39c5158Smillertuse constant LOW   => 0 ;
838b39c5158Smillertuse constant HIGH  => 1;
839b39c5158Smillert
840b39c5158Smillertsub new
841b39c5158Smillert{
84291f110e0Safresh1    return bless [ 0, 0 ], $_[0]
84391f110e0Safresh1        if @_ == 1 ;
844b39c5158Smillert
84591f110e0Safresh1    return bless [ $_[1], 0 ], $_[0]
84691f110e0Safresh1        if @_ == 2 ;
847b39c5158Smillert
84891f110e0Safresh1    return bless [ $_[2], $_[1] ], $_[0]
84991f110e0Safresh1        if @_ == 3 ;
850b39c5158Smillert}
851b39c5158Smillert
852b39c5158Smillertsub newUnpack_V64
853b39c5158Smillert{
85491f110e0Safresh1    my ($low, $hi) = unpack "V V", $_[0] ;
855b39c5158Smillert    bless [ $low, $hi ], "U64";
856b39c5158Smillert}
857b39c5158Smillert
858b39c5158Smillertsub newUnpack_V32
859b39c5158Smillert{
860b39c5158Smillert    my $string = shift;
861b39c5158Smillert
862b39c5158Smillert    my $low = unpack "V", $string ;
863b39c5158Smillert    bless [ $low, 0 ], "U64";
864b39c5158Smillert}
865b39c5158Smillert
866b39c5158Smillertsub reset
867b39c5158Smillert{
86891f110e0Safresh1    $_[0]->[HIGH] = $_[0]->[LOW] = 0;
869b39c5158Smillert}
870b39c5158Smillert
871b39c5158Smillertsub clone
872b39c5158Smillert{
87391f110e0Safresh1    bless [ @{$_[0]}  ], ref $_[0] ;
874b39c5158Smillert}
875b39c5158Smillert
876b39c5158Smillertsub getHigh
877b39c5158Smillert{
87891f110e0Safresh1    return $_[0]->[HIGH];
879b39c5158Smillert}
880b39c5158Smillert
881b39c5158Smillertsub getLow
882b39c5158Smillert{
88391f110e0Safresh1    return $_[0]->[LOW];
884b39c5158Smillert}
885b39c5158Smillert
886b39c5158Smillertsub get32bit
887b39c5158Smillert{
88891f110e0Safresh1    return $_[0]->[LOW];
889b39c5158Smillert}
890b39c5158Smillert
891b39c5158Smillertsub get64bit
892b39c5158Smillert{
893b39c5158Smillert    # Not using << here because the result will still be
894b39c5158Smillert    # a 32-bit value on systems where int size is 32-bits
89591f110e0Safresh1    return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
896b39c5158Smillert}
897b39c5158Smillert
898b39c5158Smillertsub add
899b39c5158Smillert{
90091f110e0Safresh1#    my $self = shift;
90191f110e0Safresh1    my $value = $_[1];
902b39c5158Smillert
903b39c5158Smillert    if (ref $value eq 'U64') {
90491f110e0Safresh1        $_[0]->[HIGH] += $value->[HIGH] ;
905b39c5158Smillert        $value = $value->[LOW];
906b39c5158Smillert    }
907898184e3Ssthen    elsif ($value > MAX32) {
90891f110e0Safresh1        $_[0]->[HIGH] += int($value / HI_1) ;
909898184e3Ssthen        $value = $value % HI_1;
910898184e3Ssthen    }
911b39c5158Smillert
91291f110e0Safresh1    my $available = MAX32 - $_[0]->[LOW] ;
913b39c5158Smillert
914b39c5158Smillert    if ($value > $available) {
91591f110e0Safresh1       ++ $_[0]->[HIGH] ;
91691f110e0Safresh1       $_[0]->[LOW] = $value - $available - 1;
917b39c5158Smillert    }
918b39c5158Smillert    else {
91991f110e0Safresh1       $_[0]->[LOW] += $value ;
92091f110e0Safresh1    }
92191f110e0Safresh1}
92291f110e0Safresh1
92391f110e0Safresh1sub add32
92491f110e0Safresh1{
92591f110e0Safresh1#    my $self = shift;
92691f110e0Safresh1    my $value = $_[1];
92791f110e0Safresh1
92891f110e0Safresh1    if ($value > MAX32) {
92991f110e0Safresh1        $_[0]->[HIGH] += int($value / HI_1) ;
93091f110e0Safresh1        $value = $value % HI_1;
93191f110e0Safresh1    }
93291f110e0Safresh1
93391f110e0Safresh1    my $available = MAX32 - $_[0]->[LOW] ;
93491f110e0Safresh1
93591f110e0Safresh1    if ($value > $available) {
93691f110e0Safresh1       ++ $_[0]->[HIGH] ;
93791f110e0Safresh1       $_[0]->[LOW] = $value - $available - 1;
93891f110e0Safresh1    }
93991f110e0Safresh1    else {
94091f110e0Safresh1       $_[0]->[LOW] += $value ;
941b39c5158Smillert    }
942898184e3Ssthen}
943b39c5158Smillert
944898184e3Ssthensub subtract
945898184e3Ssthen{
946898184e3Ssthen    my $self = shift;
947898184e3Ssthen    my $value = shift;
948898184e3Ssthen
949898184e3Ssthen    if (ref $value eq 'U64') {
950898184e3Ssthen
951898184e3Ssthen        if ($value->[HIGH]) {
952898184e3Ssthen            die "bad"
953898184e3Ssthen                if $self->[HIGH] == 0 ||
954898184e3Ssthen                   $value->[HIGH] > $self->[HIGH] ;
955898184e3Ssthen
956898184e3Ssthen           $self->[HIGH] -= $value->[HIGH] ;
957898184e3Ssthen        }
958898184e3Ssthen
959898184e3Ssthen        $value = $value->[LOW] ;
960898184e3Ssthen    }
961898184e3Ssthen
962898184e3Ssthen    if ($value > $self->[LOW]) {
963898184e3Ssthen       -- $self->[HIGH] ;
964898184e3Ssthen       $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ;
965898184e3Ssthen    }
966898184e3Ssthen    else {
967898184e3Ssthen       $self->[LOW] -= $value;
968898184e3Ssthen    }
969b39c5158Smillert}
970b39c5158Smillert
971b39c5158Smillertsub equal
972b39c5158Smillert{
973b39c5158Smillert    my $self = shift;
974b39c5158Smillert    my $other = shift;
975b39c5158Smillert
976b39c5158Smillert    return $self->[LOW]  == $other->[LOW] &&
977b39c5158Smillert           $self->[HIGH] == $other->[HIGH] ;
978b39c5158Smillert}
979b39c5158Smillert
980b46d8ef2Safresh1sub isZero
981b46d8ef2Safresh1{
982b46d8ef2Safresh1    my $self = shift;
983b46d8ef2Safresh1
984b46d8ef2Safresh1    return $self->[LOW]  == 0 &&
985b46d8ef2Safresh1           $self->[HIGH] == 0 ;
986b46d8ef2Safresh1}
987b46d8ef2Safresh1
988898184e3Ssthensub gt
989898184e3Ssthen{
990898184e3Ssthen    my $self = shift;
991898184e3Ssthen    my $other = shift;
992898184e3Ssthen
993898184e3Ssthen    return $self->cmp($other) > 0 ;
994898184e3Ssthen}
995898184e3Ssthen
996898184e3Ssthensub cmp
997898184e3Ssthen{
998898184e3Ssthen    my $self = shift;
999898184e3Ssthen    my $other = shift ;
1000898184e3Ssthen
1001898184e3Ssthen    if ($self->[LOW] == $other->[LOW]) {
1002898184e3Ssthen        return $self->[HIGH] - $other->[HIGH] ;
1003898184e3Ssthen    }
1004898184e3Ssthen    else {
1005898184e3Ssthen        return $self->[LOW] - $other->[LOW] ;
1006898184e3Ssthen    }
1007898184e3Ssthen}
1008898184e3Ssthen
1009898184e3Ssthen
1010b39c5158Smillertsub is64bit
1011b39c5158Smillert{
101291f110e0Safresh1    return $_[0]->[HIGH] > 0 ;
1013b39c5158Smillert}
1014b39c5158Smillert
1015898184e3Ssthensub isAlmost64bit
1016898184e3Ssthen{
101791f110e0Safresh1    return $_[0]->[HIGH] > 0 ||  $_[0]->[LOW] == MAX32 ;
1018898184e3Ssthen}
1019898184e3Ssthen
1020b39c5158Smillertsub getPacked_V64
1021b39c5158Smillert{
102291f110e0Safresh1    return pack "V V", @{ $_[0] } ;
1023b39c5158Smillert}
1024b39c5158Smillert
1025b39c5158Smillertsub getPacked_V32
1026b39c5158Smillert{
102791f110e0Safresh1    return pack "V", $_[0]->[LOW] ;
1028b39c5158Smillert}
1029b39c5158Smillert
1030b39c5158Smillertsub pack_V64
1031b39c5158Smillert{
103291f110e0Safresh1    return pack "V V", $_[0], 0;
1033b39c5158Smillert}
1034b39c5158Smillert
1035b39c5158Smillert
1036898184e3Ssthensub full32
1037898184e3Ssthen{
1038898184e3Ssthen    return $_[0] == MAX32 ;
1039898184e3Ssthen}
1040898184e3Ssthen
1041898184e3Ssthensub Value_VV64
1042898184e3Ssthen{
1043898184e3Ssthen    my $buffer = shift;
1044898184e3Ssthen
1045898184e3Ssthen    my ($lo, $hi) = unpack ("V V" , $buffer);
1046898184e3Ssthen    no warnings 'uninitialized';
1047898184e3Ssthen    return $hi * HI_1 + $lo;
1048898184e3Ssthen}
1049898184e3Ssthen
1050898184e3Ssthen
1051b39c5158Smillertpackage IO::Compress::Base::Common;
1052b39c5158Smillert
1053b39c5158Smillert1;
1054