File Coverage

blib/lib/IO/Compress/Base/Common.pm
Criterion Covered Total %
statement 436 462 94.3
branch 162 192 84.3
condition 93 119 78.1
subroutine 93 97 95.8
pod 0 17 0.0
total 784 887 88.3


line stmt bran cond sub pod time code
1             package IO::Compress::Base::Common;
2              
3 130     130   997 use strict ;
  130         297  
  130         5183  
4 130     130   663 use warnings;
  130         302  
  130         6906  
5 130     130   9889 use bytes;
  130         6195  
  130         872  
6              
7 130     130   4104 use Carp;
  130         321  
  130         13711  
8 130     130   970 use Scalar::Util qw(blessed readonly);
  130         282  
  130         18231  
9 130     130   79010 use File::GlobMapper;
  130         437  
  130         21707  
10              
11             require Exporter;
12             our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13             @ISA = qw(Exporter);
14             $VERSION = '2.219';
15              
16             @EXPORT = qw( isaFilehandle isaFilename isaScalar
17             whatIsInput whatIsOutput
18             isaFileGlobString cleanFileGlobString oneTarget
19             setBinModeInput setBinModeOutput
20             ckInOutParams
21             createSelfTiedObject
22              
23             isGeMax32
24              
25             MAX32
26              
27             WANT_CODE
28             WANT_EXT
29             WANT_UNDEF
30             WANT_HASH
31              
32             STATUS_OK
33             STATUS_ENDSTREAM
34             STATUS_EOF
35             STATUS_ERROR
36             );
37              
38             %EXPORT_TAGS = ( Status => [qw( STATUS_OK
39             STATUS_ENDSTREAM
40             STATUS_EOF
41             STATUS_ERROR
42             )]);
43              
44              
45 130     130   1120 use constant STATUS_OK => 0;
  130         337  
  130         18175  
46 130     130   1197 use constant STATUS_ENDSTREAM => 1;
  130         368  
  130         7987  
47 130     130   1056 use constant STATUS_EOF => 2;
  130         378  
  130         7729  
48 130     130   750 use constant STATUS_ERROR => -1;
  130         423  
  130         7150  
49 130     130   807 use constant MAX16 => 0xFFFF ;
  130         425  
  130         7826  
50 130     130   900 use constant MAX32 => 0xFFFFFFFF ;
  130         271  
  130         7814  
51 130     130   755 use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
  130         292  
  130         68623  
52              
53              
54             sub isGeMax32
55             {
56 184     184 0 891 return $_[0] >= MAX32cmp ;
57             }
58              
59             sub hasEncode()
60             {
61 20 100   20 0 62 if (! defined $HAS_ENCODE) {
62             eval
63 5         10 {
64 5         47 require Encode;
65 5         416 Encode->import();
66             };
67              
68 5 50       26 $HAS_ENCODE = $@ ? 0 : 1 ;
69             }
70              
71 20         57 return $HAS_ENCODE;
72             }
73              
74             sub getEncoding($$$)
75             {
76 20     20 0 38 my $obj = shift;
77 20         41 my $class = shift ;
78 20         39 my $want_encoding = shift ;
79              
80 20 50       57 $obj->croakError("$class: Encode module needed to use -Encode")
81             if ! hasEncode();
82              
83 20         133 my $encoding = Encode::find_encoding($want_encoding);
84              
85 20 100       6043 $obj->croakError("$class: Encoding '$want_encoding' is not available")
86             if ! $encoding;
87              
88 15         88 return $encoding;
89             }
90              
91             our ($needBinmode);
92             $needBinmode = ($^O eq 'MSWin32' ||
93             ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
94             ? 1 : 1 ;
95              
96             sub setBinModeInput($)
97             {
98 2190     2190 0 4468 my $handle = shift ;
99              
100 2190 50       10286 binmode $handle
101             if $needBinmode;
102             }
103              
104             sub setBinModeOutput($)
105             {
106 1049     1049 0 5420 my $handle = shift ;
107              
108 1049 50       7865 binmode $handle
109             if $needBinmode;
110             }
111              
112             sub isaFilehandle($)
113             {
114 130     130   85989 use utf8; # Pragma needed to keep Perl 5.6.0 happy
  130         41043  
  130         993  
115 16623   66 16623 0 134282267 return (defined $_[0] and
116             (UNIVERSAL::isa($_[0],'GLOB') or
117             UNIVERSAL::isa($_[0],'IO::Handle') or
118             UNIVERSAL::isa(\$_[0],'GLOB'))
119             )
120             }
121              
122             sub isaScalar
123             {
124 1048   100 1048 0 16700 return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
125             }
126              
127             sub isaFilename($)
128             {
129 1495   100 1495 0 16597 return (defined $_[0] and
130             ! ref $_[0] and
131             UNIVERSAL::isa(\$_[0], 'SCALAR'));
132             }
133              
134             sub isaFileGlobString
135             {
136 1007   100 1007 0 12174 return defined $_[0] && $_[0] =~ /^<.*>$/;
137             }
138              
139             sub cleanFileGlobString
140             {
141 110     110 0 272 my $string = shift ;
142              
143 110         1188 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
144              
145 110         392 return $string;
146             }
147              
148 130     130   58757 use constant WANT_CODE => 1 ;
  130         390  
  130         10560  
149 130     130   1547 use constant WANT_EXT => 2 ;
  130         526  
  130         26962  
150 130     130   865 use constant WANT_UNDEF => 4 ;
  130         316  
  130         7596  
151             #use constant WANT_HASH => 8 ;
152 130     130   750 use constant WANT_HASH => 0 ;
  130         521  
  130         278697  
153              
154             sub whatIsInput($;$)
155             {
156 9109     9109 0 28962 my $got = whatIs(@_);
157              
158 9109 100 66     58550 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      100        
      100        
159             {
160             #use IO::File;
161 100         337 $got = 'handle';
162 100         471 $_[0] = *STDIN;
163             #$_[0] = IO::File->new("<-");
164             }
165              
166 9109         25781 return $got;
167             }
168              
169             sub whatIsOutput($;$)
170             {
171 5343     5343 0 13351 my $got = whatIs(@_);
172              
173 5343 100 66     31164 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      66        
      100        
174             {
175 24         88 $got = 'handle';
176 24         102 $_[0] = *STDOUT;
177             #$_[0] = IO::File->new(">-");
178             }
179              
180 5343         13683 return $got;
181             }
182              
183             sub whatIs ($;$)
184             {
185 14452 100   14452 0 42806 return 'handle' if isaFilehandle($_[0]);
186              
187 12624   100     44205 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
188 12624   100     42841 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
189 12624   66     34208 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
190 12624   66     35503 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
191              
192 12624 50 66     35122 return 'undef' if ! defined $_[0] && $undef ;
193              
194 12624 100       32763 if (ref $_[0]) {
195 6193 100       15804 return '' if blessed($_[0]); # is an object
196             #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
197 6133 100       24719 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
198 334 100 100     2156 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
199 44 50 33     265 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
200 44 100 100     198 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
201 42         169 return '';
202             }
203              
204 6431 100 100     18236 return 'fileglob' if $extended && isaFileGlobString($_[0]);
205 6236         14112 return 'filename';
206             }
207              
208             sub oneTarget
209             {
210 3086     3086 0 17501 return $_[0] =~ /^(code|handle|buffer|filename)$/;
211             }
212              
213             sub IO::Compress::Base::Validator::new
214             {
215 1543     1543   3503 my $class = shift ;
216              
217 1543         4150 my $Class = shift ;
218 1543         6229 my $error_ref = shift ;
219 1543         3078 my $reportClass = shift ;
220              
221 1543         9816 my %data = (Class => $Class,
222             Error => $error_ref,
223             reportClass => $reportClass,
224             ) ;
225              
226 1543         4382 my $obj = bless \%data, $class ;
227              
228 1543         3902 local $Carp::CarpLevel = 1;
229              
230 1543         5384 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
231 1543         5190 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
232              
233 1543         6750 my $oneInput = $data{oneInput} = oneTarget($inType);
234 1543         3860 my $oneOutput = $data{oneOutput} = oneTarget($outType);
235              
236 1543 100       4748 if (! $inType)
237             {
238 30         139 $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 1513 100       4369 if (! $outType)
250             {
251 30         127 $obj->croakError("$reportClass: illegal output parameter") ;
252             #return undef ;
253             }
254              
255              
256 1483 100 100     7538 if ($inType ne 'fileglob' && $outType eq 'fileglob')
257             {
258 15         53 $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 1468 100 100     5105 if ($inType eq 'fileglob' && $outType eq 'fileglob')
267             {
268 35         105 $data{GlobMap} = 1 ;
269 35         107 $data{inType} = $data{outType} = 'filename';
270 35         477 my $mapper = File::GlobMapper->new($_[0], $_[1]);
271 35 100       159 if ( ! $mapper )
272             {
273 15         342 return $obj->saveErrorString($File::GlobMapper::Error) ;
274             }
275 20         96 $data{Pairs} = $mapper->getFileMap();
276              
277 20         287 return $obj;
278             }
279              
280 1433 100 100     7051 $obj->croakError("$reportClass: input and output $inType are identical")
      66        
281             if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
282              
283 1388 100       15134 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
    100          
    100          
284             {
285 110         475 my $glob = cleanFileGlobString($_[0]);
286 110         25482 my @inputs = glob($glob);
287              
288 110 50       867 if (@inputs == 0)
    100          
289             {
290             # TODO -- legal or die?
291 0         0 die "globmap matched zero file -- legal or die???" ;
292             }
293             elsif (@inputs == 1)
294             {
295 35 50       303 $obj->validateInputFilenames($inputs[0])
296             or return undef;
297 35         100 $_[0] = $inputs[0] ;
298 35         118 $data{inType} = 'filename' ;
299 35         159 $data{oneInput} = 1;
300             }
301             else
302             {
303 75 50       432 $obj->validateInputFilenames(@inputs)
304             or return undef;
305 75         416 $_[0] = [ @inputs ] ;
306 75         340 $data{inType} = 'filenames' ;
307             }
308             }
309             elsif ($inType eq 'filename')
310             {
311 341 100       1507 $obj->validateInputFilenames($_[0])
312             or return undef;
313             }
314             elsif ($inType eq 'array')
315             {
316 175         454 $data{inType} = 'filenames' ;
317 175 100       683 $obj->validateInputArray($_[0])
318             or return undef ;
319             }
320              
321             return $obj->saveErrorString("$reportClass: output buffer is read-only")
322 1273 100 100     5062 if $outType eq 'buffer' && readonly(${ $_[1] });
  597         3595  
323              
324 1258 100       3901 if ($outType eq 'filename' )
325             {
326 335 50 33     2040 $obj->croakError("$reportClass: output filename is undef or null string")
327             if ! defined $_[1] || $_[1] eq '' ;
328              
329 335 100       5192 if (-e $_[1])
330             {
331 156 100       654 if (-d _ )
332             {
333 15         90 return $obj->saveErrorString("output file '$_[1]' is a directory");
334             }
335             }
336             }
337              
338 1243         8265 return $obj ;
339             }
340              
341             sub IO::Compress::Base::Validator::saveErrorString
342             {
343 280     280   543 my $self = shift ;
344 280         525 ${ $self->{Error} } = shift ;
  280         920  
345 280         1881 return undef;
346              
347             }
348              
349             sub IO::Compress::Base::Validator::croakError
350             {
351 200     200   383 my $self = shift ;
352 200         605 $self->saveErrorString($_[0]);
353 200         61540 croak $_[0];
354             }
355              
356              
357              
358             sub IO::Compress::Base::Validator::validateInputFilenames
359             {
360 671     671   1489 my $self = shift ;
361              
362 671         2005 foreach my $filename (@_)
363             {
364 821 100 100     4494 $self->croakError("$self->{reportClass}: input filename is undef or null string")
365             if ! defined $filename || $filename eq '' ;
366              
367 781 50       2319 next if $filename eq '-';
368              
369 781 100       15272 if (! -e $filename )
370             {
371 15         87 return $self->saveErrorString("input file '$filename' does not exist");
372             }
373              
374 766 100       3111 if (-d _ )
375             {
376 15         82 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 601         2547 return 1 ;
386             }
387              
388             sub IO::Compress::Base::Validator::validateInputArray
389             {
390 175     175   346 my $self = shift ;
391              
392 175 100       307 if ( @{ $_[0] } == 0 )
  175         738  
393             {
394 5         30 return $self->saveErrorString("empty array reference") ;
395             }
396              
397 170         359 foreach my $element ( @{ $_[0] } )
  170         557  
398             {
399 260         637 my $inType = whatIsInput($element);
400              
401 260 100       894 if (! $inType)
    100          
402             {
403 20         66 $self->croakError("unknown input parameter") ;
404             }
405             elsif($inType eq 'filename')
406             {
407 220 50       670 $self->validateInputFilenames($element)
408             or return undef ;
409             }
410             else
411             {
412 20         67 $self->croakError("not a filename") ;
413             }
414             }
415              
416 120         397 return 1 ;
417             }
418              
419             #sub IO::Compress::Base::Validator::validateHash
420             #{
421             # my $self = shift ;
422             # my $href = shift ;
423             #
424             # while (my($k, $v) = each %$href)
425             # {
426             # my $ktype = whatIsInput($k);
427             # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
428             #
429             # if ($ktype ne 'filename')
430             # {
431             # return $self->saveErrorString("hash key not filename") ;
432             # }
433             #
434             # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
435             # if (! $valid{$vtype})
436             # {
437             # return $self->saveErrorString("hash value not ok") ;
438             # }
439             # }
440             #
441             # return $self ;
442             #}
443              
444             sub createSelfTiedObject
445             {
446 6432   66 6432 0 35185 my $class = shift || (caller)[0] ;
447 6432         14771 my $error_ref = shift ;
448              
449 6432   33     25290 my $obj = bless Symbol::gensym(), ref($class) || $class;
450 6432 50       239802 tie *$obj, $obj if $] >= 5.005;
451 6432         32093 *$obj->{Closed} = 1 ;
452 6432         20348 $$error_ref = '';
453 6432         18756 *$obj->{Error} = $error_ref ;
454 6432         11845 my $errno = 0 ;
455 6432         16084 *$obj->{ErrorNo} = \$errno ;
456              
457 6432         19551 return $obj;
458             }
459              
460              
461              
462             #package Parse::Parameters ;
463             #
464             #
465             #require Exporter;
466             #our ($VERSION, @ISA, @EXPORT);
467             #$VERSION = '2.000_08';
468             #@ISA = qw(Exporter);
469              
470             $EXPORT_TAGS{Parse} = [qw( ParseParameters
471             Parse_any Parse_unsigned Parse_signed
472             Parse_boolean Parse_string
473             Parse_code
474             Parse_writable_scalar
475             )
476             ];
477              
478             push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
479              
480 130     130   1143 use constant Parse_any => 0x01;
  130         251  
  130         10173  
481 130     130   810 use constant Parse_unsigned => 0x02;
  130         312  
  130         8247  
482 130     130   863 use constant Parse_signed => 0x04;
  130         340  
  130         9220  
483 130     130   802 use constant Parse_boolean => 0x08;
  130         298  
  130         7174  
484 130     130   743 use constant Parse_string => 0x10;
  130         276  
  130         7332  
485 130     130   725 use constant Parse_code => 0x20;
  130         242  
  130         6745  
486              
487             #use constant Parse_store_ref => 0x100 ;
488             #use constant Parse_multiple => 0x100 ;
489 130     130   715 use constant Parse_writable => 0x200 ;
  130         289  
  130         7890  
490 130     130   803 use constant Parse_writable_scalar => 0x400 | Parse_writable ;
  130         337  
  130         6806  
491              
492 130     130   754 use constant OFF_PARSED => 0 ;
  130         406  
  130         6798  
493 130     130   720 use constant OFF_TYPE => 1 ;
  130         233  
  130         6779  
494 130     130   753 use constant OFF_DEFAULT => 2 ;
  130         380  
  130         7042  
495 130     130   680 use constant OFF_FIXED => 3 ;
  130         314  
  130         6805  
496             #use constant OFF_FIRST_ONLY => 4 ;
497             #use constant OFF_STICKY => 5 ;
498              
499 130     130   742 use constant IxError => 0;
  130         329  
  130         6261  
500 130     130   755 use constant IxGot => 1 ;
  130         311  
  130         29253  
501              
502             sub ParseParameters
503             {
504 58   100 58 0 214467 my $level = shift || 0 ;
505              
506 58         406 my $sub = (caller($level + 1))[3] ;
507 58         160 local $Carp::CarpLevel = 1 ;
508              
509 58 100 100     361 return $_[1]
      100        
510             if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
511              
512 57         302 my $p = IO::Compress::Base::Parameters->new();
513 57 100       341 $p->parse(@_)
514             or croak "$sub: $p->[IxError]" ;
515              
516 37         216 return $p;
517             }
518              
519              
520 130     130   1013 use strict;
  130         324  
  130         4526  
521              
522 130     130   698 use warnings;
  130         254  
  130         9055  
523 130     130   780 use Carp;
  130         265  
  130         307061  
524              
525              
526             sub Init
527             {
528 0     0 0 0 my $default = shift ;
529 0         0 my %got ;
530              
531 0         0 my $obj = IO::Compress::Base::Parameters::new();
532 0         0 while (my ($key, $v) = each %$default)
533             {
534 0 0       0 croak "need 2 params [@$v]"
535             if @$v != 2 ;
536              
537 0         0 my ($type, $value) = @$v ;
538             # my ($first_only, $sticky, $type, $value) = @$v ;
539 0         0 my $sticky = 0;
540 0         0 my $x ;
541 0 0       0 $obj->_checkType($key, \$value, $type, 0, \$x)
542             or return undef ;
543              
544 0         0 $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 0         0 $got{$key} = [0, $type, $value, $x] ;
552             # }
553             #
554             # $got{$key}[OFF_PARSED] = 0 ;
555             }
556              
557 0         0 return bless \%got, "IO::Compress::Base::Parameters::Defaults" ;
558             }
559              
560             sub IO::Compress::Base::Parameters::new
561             {
562             #my $class = shift ;
563              
564 5507     5507   10462 my $obj;
565 5507         20010 $obj->[IxError] = '';
566 5507         16618 $obj->[IxGot] = {} ;
567              
568 5507         46663 return bless $obj, 'IO::Compress::Base::Parameters' ;
569             }
570              
571             sub IO::Compress::Base::Parameters::setError
572             {
573 77     77   2404 my $self = shift ;
574 77         172 my $error = shift ;
575 77 50       236 my $retval = @_ ? shift : undef ;
576              
577              
578 77         194 $self->[IxError] = $error ;
579 77         6040 return $retval;
580             }
581              
582             sub IO::Compress::Base::Parameters::getError
583             {
584 57     57   117 my $self = shift ;
585 57         514 return $self->[IxError] ;
586             }
587              
588             sub IO::Compress::Base::Parameters::parse
589             {
590 5683     5683   11754 my $self = shift ;
591 5683         9919 my $default = shift ;
592              
593 5683         13818 my $got = $self->[IxGot] ;
594 5683         14267 my $firstTime = keys %{ $got } == 0 ;
  5683         18294  
595              
596 5683         11115 my (@Bad) ;
597 5683         12315 my @entered = () ;
598              
599             # Allow the options to be passed as a hash reference or
600             # as the complete hash.
601 5683 100       26835 if (@_ == 0) {
    100          
602 1215         2650 @entered = () ;
603             }
604             elsif (@_ == 1) {
605 20         88 my $href = $_[0] ;
606              
607 20 100 100     193 return $self->setError("Expected even number of parameters, got 1")
      100        
608             if ! defined $href or ! ref $href or ref $href ne "HASH" ;
609              
610 5         18 foreach my $key (keys %$href) {
611 6         11 push @entered, $key ;
612 6         18 push @entered, \$href->{$key} ;
613             }
614             }
615             else {
616              
617 4448         9428 my $count = @_;
618 4448 50       17696 return $self->setError("Expected even number of parameters, got $count")
619             if $count % 2 != 0 ;
620              
621 4448         19975 for my $i (0.. $count / 2 - 1) {
622 12647         28924 push @entered, $_[2 * $i] ;
623 12647         33401 push @entered, \$_[2 * $i + 1] ;
624             }
625             }
626              
627 5668         30296 foreach my $key (keys %$default)
628             {
629              
630 79329         117552 my ($type, $value) = @{ $default->{$key} } ;
  79329         165331  
631              
632 79329 100       139499 if ($firstTime) {
633 75508         216123 $got->{$key} = [0, $type, $value, $value] ;
634             }
635             else
636             {
637 3821         11066 $got->{$key}[OFF_PARSED] = 0 ;
638             }
639             }
640              
641              
642 5668         19595 my %parsed = ();
643              
644              
645 5668         23625 for my $i (0.. @entered / 2 - 1) {
646 12653         47337 my $key = $entered[2* $i] ;
647 12653         24393 my $value = $entered[2* $i+1] ;
648              
649             #print "Key [$key] Value [$value]" ;
650             #print defined $$value ? "[$$value]\n" : "[undef]\n";
651              
652 12653         27990 $key =~ s/^-// ;
653 12653         25225 my $canonkey = lc $key;
654              
655 12653 100       43349 if ($got->{$canonkey})
656             {
657 12626         27322 my $type = $got->{$canonkey}[OFF_TYPE] ;
658 12626         43614 my $parsed = $parsed{$canonkey};
659 12626         25637 ++ $parsed{$canonkey};
660              
661 12626 100       48516 return $self->setError("Muliple instances of '$key' found")
662             if $parsed ;
663              
664 12625         18459 my $s ;
665 12625 100       41737 $self->_checkType($key, $value, $type, 1, \$s)
666             or return undef ;
667              
668 12591         23525 $value = $$value ;
669 12591         48553 $got->{$canonkey} = [1, $type, $value, $s] ;
670              
671             }
672             else
673 27         92 { push (@Bad, $key) }
674             }
675              
676 5633 100       17224 if (@Bad) {
677 27         101 my ($bad) = join(", ", @Bad) ;
678 27         233 return $self->setError("unknown key value(s) $bad") ;
679             }
680              
681 5606         31205 return 1;
682             }
683              
684             sub IO::Compress::Base::Parameters::_checkType
685             {
686 12625     12625   20754 my $self = shift ;
687              
688 12625         21837 my $key = shift ;
689 12625         24950 my $value = shift ;
690 12625         19011 my $type = shift ;
691 12625         18393 my $validate = shift ;
692 12625         18867 my $output = shift;
693              
694             #local $Carp::CarpLevel = $level ;
695             #print "PARSE $type $key $value $validate $sub\n" ;
696              
697 12625 100       35508 if ($type & Parse_writable_scalar)
698             {
699 25 100       136 return $self->setError("Parameter '$key' not writable")
700             if readonly $$value ;
701              
702 24 100       80 if (ref $$value)
703             {
704 12 100       80 return $self->setError("Parameter '$key' not a scalar reference")
705             if ref $$value ne 'SCALAR' ;
706              
707 1         5 $$output = $$value ;
708             }
709             else
710             {
711 12 100       60 return $self->setError("Parameter '$key' not a scalar")
712             if ref $value ne 'SCALAR' ;
713              
714 11         34 $$output = $value ;
715             }
716              
717 12         54 return 1;
718             }
719              
720              
721 12600         24800 $value = $$value ;
722              
723 12600 100       46328 if ($type & Parse_any)
    100          
    100          
    100          
    100          
    100          
724             {
725 2489         5729 $$output = $value ;
726 2489         7333 return 1;
727             }
728             elsif ($type & Parse_unsigned)
729             {
730              
731 475 100       1411 return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
732             if ! defined $value ;
733 471 100       3004 return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
734             if $value !~ /^\d+$/;
735              
736 460 50       1412 $$output = defined $value ? $value : 0 ;
737 460         1748 return 1;
738             }
739             elsif ($type & Parse_signed)
740             {
741 99 100       312 return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
742             if ! defined $value ;
743 98 100       628 return $self->setError("Parameter '$key' must be a signed int, got '$value'")
744             if $value !~ /^-?\d+$/;
745              
746 97 50       342 $$output = defined $value ? $value : 0 ;
747 97         345 return 1 ;
748             }
749             elsif ($type & Parse_boolean)
750             {
751 9531 100 66     59016 return $self->setError("Parameter '$key' must be an int, got '$value'")
752             if defined $value && $value !~ /^\d*$/;
753              
754 9528 100 66     35762 $$output = defined $value && $value != 0 ? 1 : 0 ;
755 9528         29823 return 1;
756             }
757              
758             elsif ($type & Parse_string)
759             {
760 1 50       8 $$output = defined $value ? $value : "" ;
761 1         4 return 1;
762             }
763             elsif ($type & Parse_code)
764             {
765 4 100 66     25 return $self->setError("Parameter '$key' must be a code reference, got '$value'")
766             if (! defined $value || ref $value ne 'CODE') ;
767              
768 3 50       6 $$output = defined $value ? $value : "" ;
769 3         7 return 1;
770             }
771              
772 1         4 $$output = $value ;
773 1         4 return 1;
774             }
775              
776             sub IO::Compress::Base::Parameters::parsed
777             {
778 12005     12005   63745 return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
779             }
780              
781              
782             sub IO::Compress::Base::Parameters::getValue
783             {
784 90314     90314   370520 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
785             }
786             sub IO::Compress::Base::Parameters::setValue
787             {
788 8047     8047   30151 $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1;
789 8047         17198 $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
790 8047         22176 $_[0]->[IxGot]{$_[1]}[OFF_FIXED] = $_[2] ;
791             }
792              
793             sub IO::Compress::Base::Parameters::valueRef
794             {
795 0     0   0 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
796             }
797              
798             sub IO::Compress::Base::Parameters::valueOrDefault
799             {
800 2356     2356   3583 my $self = shift ;
801 2356         3939 my $name = shift ;
802 2356         3946 my $default = shift ;
803              
804 2356         5213 my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
805              
806 2356 100       7059 return $value if defined $value ;
807 389         939 return $default ;
808             }
809              
810             sub IO::Compress::Base::Parameters::wantValue
811             {
812 1149     1149   3673 return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
813             }
814              
815             sub IO::Compress::Base::Parameters::clone
816             {
817 255     255   568 my $self = shift ;
818 255         524 my $obj = [] ;
819 255         3064 my %got ;
820              
821 255         521 my $hash = $self->[IxGot] ;
822 255         466 for my $k (keys %{ $hash })
  255         1770  
823             {
824 5616         7859 $got{$k} = [ @{ $hash->{$k} } ];
  5616         16802  
825             }
826              
827 255         1130 $obj->[IxError] = $self->[IxError];
828 255         603 $obj->[IxGot] = \%got ;
829              
830 255         2951 return bless $obj, 'IO::Compress::Base::Parameters' ;
831             }
832              
833             package U64;
834              
835 130     130   1354 use constant MAX32 => 0xFFFFFFFF ;
  130         308  
  130         10786  
836 130     130   961 use constant HI_1 => MAX32 + 1 ;
  130         384  
  130         8932  
837 130     130   757 use constant LOW => 0 ;
  130         304  
  130         7833  
838 130     130   851 use constant HIGH => 1;
  130         346  
  130         172436  
839              
840             sub new
841             {
842 11282 100   11282   65284 return bless [ 0, 0 ], $_[0]
843             if @_ == 1 ;
844              
845 20 100       62 return bless [ $_[1], 0 ], $_[0]
846             if @_ == 2 ;
847              
848 17 50       87 return bless [ $_[2], $_[1] ], $_[0]
849             if @_ == 3 ;
850             }
851              
852             sub newUnpack_V64
853             {
854 118     118   439 my ($low, $hi) = unpack "V V", $_[0] ;
855 118         431 bless [ $low, $hi ], "U64";
856             }
857              
858             sub newUnpack_V32
859             {
860 3952     3952   11201 my $string = shift;
861              
862 3952         8170 my $low = unpack "V", $string ;
863 3952         14498 bless [ $low, 0 ], "U64";
864             }
865              
866             sub reset
867             {
868 3907     3907   12506 $_[0]->[HIGH] = $_[0]->[LOW] = 0;
869             }
870              
871             sub clone
872             {
873 558     558   1117 bless [ @{$_[0]} ], ref $_[0] ;
  558         3572  
874             }
875              
876             sub getHigh
877             {
878 23     23   170 return $_[0]->[HIGH];
879             }
880              
881             sub getLow
882             {
883 23     23   141 return $_[0]->[LOW];
884             }
885              
886             sub get32bit
887             {
888 1466     1466   5259 return $_[0]->[LOW];
889             }
890              
891             sub get64bit
892             {
893             # Not using << here because the result will still be
894             # a 32-bit value on systems where int size is 32-bits
895 2697     2697   10652 return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
896             }
897              
898             sub add
899             {
900             # my $self = shift;
901 16032     16032   25536 my $value = $_[1];
902              
903 16032 100       49890 if (ref $value eq 'U64') {
    50          
904 412         1068 $_[0]->[HIGH] += $value->[HIGH] ;
905 412         813 $value = $value->[LOW];
906             }
907             elsif ($value > MAX32) {
908 0         0 $_[0]->[HIGH] += int($value / HI_1) ;
909 0         0 $value = $value % HI_1;
910             }
911              
912 16032         31966 my $available = MAX32 - $_[0]->[LOW] ;
913              
914 16032 100       38191 if ($value > $available) {
915 2         35 ++ $_[0]->[HIGH] ;
916 2         8 $_[0]->[LOW] = $value - $available - 1;
917             }
918             else {
919 16030         38688 $_[0]->[LOW] += $value ;
920             }
921             }
922              
923             sub add32
924             {
925             # my $self = shift;
926 843     843   1570 my $value = $_[1];
927              
928 843 50       2300 if ($value > MAX32) {
929 0         0 $_[0]->[HIGH] += int($value / HI_1) ;
930 0         0 $value = $value % HI_1;
931             }
932              
933 843         1647 my $available = MAX32 - $_[0]->[LOW] ;
934              
935 843 50       1989 if ($value > $available) {
936 0         0 ++ $_[0]->[HIGH] ;
937 0         0 $_[0]->[LOW] = $value - $available - 1;
938             }
939             else {
940 843         2028 $_[0]->[LOW] += $value ;
941             }
942             }
943              
944             sub subtract
945             {
946 4     4   14 my $self = shift;
947 4         9 my $value = shift;
948              
949 4 100       17 if (ref $value eq 'U64') {
950              
951 2 50       10 if ($value->[HIGH]) {
952 2 50 33     17 die "bad"
953             if $self->[HIGH] == 0 ||
954             $value->[HIGH] > $self->[HIGH] ;
955              
956 2         5 $self->[HIGH] -= $value->[HIGH] ;
957             }
958              
959 2         4 $value = $value->[LOW] ;
960             }
961              
962 4 100       12 if ($value > $self->[LOW]) {
963 3         5 -- $self->[HIGH] ;
964 3         12 $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ;
965             }
966             else {
967 1         4 $self->[LOW] -= $value;
968             }
969             }
970              
971             sub equal
972             {
973 1030     1030   1645 my $self = shift;
974 1030         1555 my $other = shift;
975              
976 1030   66     5334 return $self->[LOW] == $other->[LOW] &&
977             $self->[HIGH] == $other->[HIGH] ;
978             }
979              
980             sub isZero
981             {
982 0     0   0 my $self = shift;
983              
984 0   0     0 return $self->[LOW] == 0 &&
985             $self->[HIGH] == 0 ;
986             }
987              
988             sub gt
989             {
990 1     1   3 my $self = shift;
991 1         2 my $other = shift;
992              
993 1         5 return $self->cmp($other) > 0 ;
994             }
995              
996             sub cmp
997             {
998 3     3   11 my $self = shift;
999 3         7 my $other = shift ;
1000              
1001 3 50       9 if ($self->[LOW] == $other->[LOW]) {
1002 0         0 return $self->[HIGH] - $other->[HIGH] ;
1003             }
1004             else {
1005 3         22 return $self->[LOW] - $other->[LOW] ;
1006             }
1007             }
1008              
1009              
1010             sub is64bit
1011             {
1012 1189     1189   13539 return $_[0]->[HIGH] > 0 ;
1013             }
1014              
1015             sub isAlmost64bit
1016             {
1017 822   33 822   4602 return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ;
1018             }
1019              
1020             sub getPacked_V64
1021             {
1022 916     916   1567 return pack "V V", @{ $_[0] } ;
  916         3414  
1023             }
1024              
1025             sub getPacked_V32
1026             {
1027 2003     2003   6892 return pack "V", $_[0]->[LOW] ;
1028             }
1029              
1030             sub pack_V64
1031             {
1032 84     84   275 return pack "V V", $_[0], 0;
1033             }
1034              
1035              
1036             sub full32
1037             {
1038 32     32   114 return $_[0] == MAX32 ;
1039             }
1040              
1041             sub Value_VV64
1042             {
1043 0     0     my $buffer = shift;
1044              
1045 0           my ($lo, $hi) = unpack ("V V" , $buffer);
1046 130     130   1245 no warnings 'uninitialized';
  130         304  
  130         22807  
1047 0           return $hi * HI_1 + $lo;
1048             }
1049              
1050              
1051             package IO::Compress::Base::Common;
1052              
1053             1;