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 84     84   596 use strict ;
  84         166  
  84         2424  
4 84     84   412 use warnings;
  84         175  
  84         1948  
5 84     84   1035 use bytes;
  84         196  
  84         1994  
6              
7 84     84   1963 use Carp;
  84         166  
  84         8274  
8 84     84   567 use Scalar::Util qw(blessed readonly);
  84         228  
  84         9446  
9 84     84   42050 use File::GlobMapper;
  84         235  
  84         11081  
10              
11             require Exporter;
12             our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13             @ISA = qw(Exporter);
14             $VERSION = '2.205';
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 84     84   954 use constant STATUS_OK => 0;
  84         240  
  84         10047  
46 84     84   627 use constant STATUS_ENDSTREAM => 1;
  84         192  
  84         4828  
47 84     84   527 use constant STATUS_EOF => 2;
  84         1054  
  84         5382  
48 84     84   576 use constant STATUS_ERROR => -1;
  84         219  
  84         4803  
49 84     84   541 use constant MAX16 => 0xFFFF ;
  84         203  
  84         4979  
50 84     84   547 use constant MAX32 => 0xFFFFFFFF ;
  84         206  
  84         4888  
51 84     84   521 use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
  84         200  
  84         34098  
52              
53              
54             sub isGeMax32
55             {
56 184     184 0 634 return $_[0] >= MAX32cmp ;
57             }
58              
59             sub hasEncode()
60             {
61 20 100   20 0 61 if (! defined $HAS_ENCODE) {
62             eval
63 5         10 {
64 5         44 require Encode;
65 5         354 Encode->import();
66             };
67              
68 5 50       30 $HAS_ENCODE = $@ ? 0 : 1 ;
69             }
70              
71 20         49 return $HAS_ENCODE;
72             }
73              
74             sub getEncoding($$$)
75             {
76 20     20 0 35 my $obj = shift;
77 20         34 my $class = shift ;
78 20         33 my $want_encoding = shift ;
79              
80 20 50       50 $obj->croakError("$class: Encode module needed to use -Encode")
81             if ! hasEncode();
82              
83 20         58 my $encoding = Encode::find_encoding($want_encoding);
84              
85 20 100       4527 $obj->croakError("$class: Encoding '$want_encoding' is not available")
86             if ! $encoding;
87              
88 15         58 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 2170     2170 0 4075 my $handle = shift ;
99              
100 2170 50       9281 binmode $handle
101             if $needBinmode;
102             }
103              
104             sub setBinModeOutput($)
105             {
106 1018     1018 0 2513 my $handle = shift ;
107              
108 1018 50       5256 binmode $handle
109             if $needBinmode;
110             }
111              
112             sub isaFilehandle($)
113             {
114 84     84   52005 use utf8; # Pragma needed to keep Perl 5.6.0 happy
  84         1299  
  84         496  
115 16424   66 16424 0 4385625 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 1018   100 1018 0 5779 return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
125             }
126              
127             sub isaFilename($)
128             {
129 1458   100 1458 0 11640 return (defined $_[0] and
130             ! ref $_[0] and
131             UNIVERSAL::isa(\$_[0], 'SCALAR'));
132             }
133              
134             sub isaFileGlobString
135             {
136 947   100 947 0 6622 return defined $_[0] && $_[0] =~ /^<.*>$/;
137             }
138              
139             sub cleanFileGlobString
140             {
141 110     110 0 202 my $string = shift ;
142              
143 110         872 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
144              
145 110         340 return $string;
146             }
147              
148 84     84   22732 use constant WANT_CODE => 1 ;
  84         204  
  84         5031  
149 84     84   545 use constant WANT_EXT => 2 ;
  84         181  
  84         4542  
150 84     84   566 use constant WANT_UNDEF => 4 ;
  84         172  
  84         5250  
151             #use constant WANT_HASH => 8 ;
152 84     84   592 use constant WANT_HASH => 0 ;
  84         215  
  84         145325  
153              
154             sub whatIsInput($;$)
155             {
156 9039     9039 0 18981 my $got = whatIs(@_);
157              
158 9039 100 66     41148 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      100        
      100        
159             {
160             #use IO::File;
161 67         181 $got = 'handle';
162 67         271 $_[0] = *STDIN;
163             #$_[0] = IO::File->new("<-");
164             }
165              
166 9039         20147 return $got;
167             }
168              
169             sub whatIsOutput($;$)
170             {
171 5251     5251 0 10813 my $got = whatIs(@_);
172              
173 5251 100 66     24417 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      66        
      100        
174             {
175 7         19 $got = 'handle';
176 7         38 $_[0] = *STDOUT;
177             #$_[0] = IO::File->new(">-");
178             }
179              
180 5251         11854 return $got;
181             }
182              
183             sub whatIs ($;$)
184             {
185 14290 100   14290 0 26757 return 'handle' if isaFilehandle($_[0]);
186              
187 12498   100     38602 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
188 12498   100     30703 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
189 12498   66     29239 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
190 12498   66     29079 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
191              
192 12498 50 66     26628 return 'undef' if ! defined $_[0] && $undef ;
193              
194 12498 100       24412 if (ref $_[0]) {
195 6193 100       16187 return '' if blessed($_[0]); # is an object
196             #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
197 6133 100       18160 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
198 334 100 100     1702 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
199 44 50 33     177 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
200 44 100 100     167 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
201 42         95 return '';
202             }
203              
204 6305 100 100     15683 return 'fileglob' if $extended && isaFileGlobString($_[0]);
205 6110         11526 return 'filename';
206             }
207              
208             sub oneTarget
209             {
210 3026     3026 0 12881 return $_[0] =~ /^(code|handle|buffer|filename)$/;
211             }
212              
213             sub IO::Compress::Base::Validator::new
214             {
215 1513     1513   3175 my $class = shift ;
216              
217 1513         2352 my $Class = shift ;
218 1513         2241 my $error_ref = shift ;
219 1513         2402 my $reportClass = shift ;
220              
221 1513         5902 my %data = (Class => $Class,
222             Error => $error_ref,
223             reportClass => $reportClass,
224             ) ;
225              
226 1513         3353 my $obj = bless \%data, $class ;
227              
228 1513         3001 local $Carp::CarpLevel = 1;
229              
230 1513         3717 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
231 1513         3617 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
232              
233 1513         3294 my $oneInput = $data{oneInput} = oneTarget($inType);
234 1513         3225 my $oneOutput = $data{oneOutput} = oneTarget($outType);
235              
236 1513 100       3679 if (! $inType)
237             {
238 30         111 $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 1483 100       3072 if (! $outType)
250             {
251 30         122 $obj->croakError("$reportClass: illegal output parameter") ;
252             #return undef ;
253             }
254              
255              
256 1453 100 100     5348 if ($inType ne 'fileglob' && $outType eq 'fileglob')
257             {
258 15         54 $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 1438 100 100     3707 if ($inType eq 'fileglob' && $outType eq 'fileglob')
267             {
268 35         144 $data{GlobMap} = 1 ;
269 35         111 $data{inType} = $data{outType} = 'filename';
270 35         311 my $mapper = File::GlobMapper->new($_[0], $_[1]);
271 35 100       117 if ( ! $mapper )
272             {
273 15         40 return $obj->saveErrorString($File::GlobMapper::Error) ;
274             }
275 20         93 $data{Pairs} = $mapper->getFileMap();
276              
277 20         148 return $obj;
278             }
279              
280 1403 100 100     4723 $obj->croakError("$reportClass: input and output $inType are identical")
      66        
281             if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
282              
283 1358 100       4461 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
    100          
    100          
284             {
285 110         325 my $glob = cleanFileGlobString($_[0]);
286 110         8327 my @inputs = glob($glob);
287              
288 110 50       722 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       126 $obj->validateInputFilenames($inputs[0])
296             or return undef;
297 35         98 $_[0] = $inputs[0] ;
298 35         83 $data{inType} = 'filename' ;
299 35         83 $data{oneInput} = 1;
300             }
301             else
302             {
303 75 50       279 $obj->validateInputFilenames(@inputs)
304             or return undef;
305 75         333 $_[0] = [ @inputs ] ;
306 75         245 $data{inType} = 'filenames' ;
307             }
308             }
309             elsif ($inType eq 'filename')
310             {
311 341 100       1061 $obj->validateInputFilenames($_[0])
312             or return undef;
313             }
314             elsif ($inType eq 'array')
315             {
316 175         464 $data{inType} = 'filenames' ;
317 175 100       559 $obj->validateInputArray($_[0])
318             or return undef ;
319             }
320              
321             return $obj->saveErrorString("$reportClass: output buffer is read-only")
322 1243 100 100     3704 if $outType eq 'buffer' && readonly(${ $_[1] });
  597         2834  
323              
324 1228 100       3174 if ($outType eq 'filename' )
325             {
326 321 50 33     1415 $obj->croakError("$reportClass: output filename is undef or null string")
327             if ! defined $_[1] || $_[1] eq '' ;
328              
329 321 100       3966 if (-e $_[1])
330             {
331 156 100       658 if (-d _ )
332             {
333 15         86 return $obj->saveErrorString("output file '$_[1]' is a directory");
334             }
335             }
336             }
337              
338 1213         6298 return $obj ;
339             }
340              
341             sub IO::Compress::Base::Validator::saveErrorString
342             {
343 280     280   463 my $self = shift ;
344 280         410 ${ $self->{Error} } = shift ;
  280         624  
345 280         1111 return undef;
346              
347             }
348              
349             sub IO::Compress::Base::Validator::croakError
350             {
351 200     200   336 my $self = shift ;
352 200         492 $self->saveErrorString($_[0]);
353 200         35114 croak $_[0];
354             }
355              
356              
357              
358             sub IO::Compress::Base::Validator::validateInputFilenames
359             {
360 671     671   1166 my $self = shift ;
361              
362 671         1653 foreach my $filename (@_)
363             {
364 821 100 100     3217 $self->croakError("$self->{reportClass}: input filename is undef or null string")
365             if ! defined $filename || $filename eq '' ;
366              
367 781 50       1898 next if $filename eq '-';
368              
369 781 100       10729 if (! -e $filename )
370             {
371 15         98 return $self->saveErrorString("input file '$filename' does not exist");
372             }
373              
374 766 100       3061 if (-d _ )
375             {
376 15         88 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         2316 return 1 ;
386             }
387              
388             sub IO::Compress::Base::Validator::validateInputArray
389             {
390 175     175   315 my $self = shift ;
391              
392 175 100       273 if ( @{ $_[0] } == 0 )
  175         573  
393             {
394 5         24 return $self->saveErrorString("empty array reference") ;
395             }
396              
397 170         312 foreach my $element ( @{ $_[0] } )
  170         464  
398             {
399 260         525 my $inType = whatIsInput($element);
400              
401 260 100       861 if (! $inType)
    100          
402             {
403 20         61 $self->croakError("unknown input parameter") ;
404             }
405             elsif($inType eq 'filename')
406             {
407 220 50       548 $self->validateInputFilenames($element)
408             or return undef ;
409             }
410             else
411             {
412 20         51 $self->croakError("not a filename") ;
413             }
414             }
415              
416 120         385 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 6381   66 6381 0 24835 my $class = shift || (caller)[0] ;
447 6381         11790 my $error_ref = shift ;
448              
449 6381   33     17364 my $obj = bless Symbol::gensym(), ref($class) || $class;
450 6381 50       151250 tie *$obj, $obj if $] >= 5.005;
451 6381         19996 *$obj->{Closed} = 1 ;
452 6381         12619 $$error_ref = '';
453 6381         12145 *$obj->{Error} = $error_ref ;
454 6381         9765 my $errno = 0 ;
455 6381         11968 *$obj->{ErrorNo} = \$errno ;
456              
457 6381         16100 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 84     84   735 use constant Parse_any => 0x01;
  84         201  
  84         10405  
481 84     84   2391 use constant Parse_unsigned => 0x02;
  84         3876  
  84         6102  
482 84     84   562 use constant Parse_signed => 0x04;
  84         207  
  84         4314  
483 84     84   3932 use constant Parse_boolean => 0x08;
  84         1944  
  84         11124  
484 84     84   2240 use constant Parse_string => 0x10;
  84         190  
  84         12460  
485 84     84   537 use constant Parse_code => 0x20;
  84         1873  
  84         10767  
486              
487             #use constant Parse_store_ref => 0x100 ;
488             #use constant Parse_multiple => 0x100 ;
489 84     84   604 use constant Parse_writable => 0x200 ;
  84         181  
  84         10163  
490 84     84   2196 use constant Parse_writable_scalar => 0x400 | Parse_writable ;
  84         1912  
  84         5936  
491              
492 84     84   2328 use constant OFF_PARSED => 0 ;
  84         3594  
  84         7301  
493 84     84   2290 use constant OFF_TYPE => 1 ;
  84         167  
  84         6986  
494 84     84   500 use constant OFF_DEFAULT => 2 ;
  84         217  
  84         5291  
495 84     84   2396 use constant OFF_FIXED => 3 ;
  84         176  
  84         7343  
496             #use constant OFF_FIRST_ONLY => 4 ;
497             #use constant OFF_STICKY => 5 ;
498              
499 84     84   501 use constant IxError => 0;
  84         1720  
  84         5591  
500 84     84   519 use constant IxGot => 1 ;
  84         177  
  84         14970  
501              
502             sub ParseParameters
503             {
504 55   100 55 0 10113 my $level = shift || 0 ;
505              
506 55         327 my $sub = (caller($level + 1))[3] ;
507 55         116 local $Carp::CarpLevel = 1 ;
508              
509 55 100 100     215 return $_[1]
      100        
510             if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
511              
512 54         154 my $p = IO::Compress::Base::Parameters->new();
513 54 100       141 $p->parse(@_)
514             or croak "$sub: $p->[IxError]" ;
515              
516 34         93 return $p;
517             }
518              
519              
520 84     84   591 use strict;
  84         1916  
  84         2377  
521              
522 84     84   1938 use warnings;
  84         178  
  84         6588  
523 84     84   550 use Carp;
  84         180  
  84         152838  
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 5453     5453   8692 my $obj;
565 5453         13052 $obj->[IxError] = '';
566 5453         10675 $obj->[IxGot] = {} ;
567              
568 5453         29527 return bless $obj, 'IO::Compress::Base::Parameters' ;
569             }
570              
571             sub IO::Compress::Base::Parameters::setError
572             {
573 77     77   150 my $self = shift ;
574 77         123 my $error = shift ;
575 77 50       201 my $retval = @_ ? shift : undef ;
576              
577              
578 77         151 $self->[IxError] = $error ;
579 77         3205 return $retval;
580             }
581              
582             sub IO::Compress::Base::Parameters::getError
583             {
584 57     57   268 my $self = shift ;
585 57         368 return $self->[IxError] ;
586             }
587              
588             sub IO::Compress::Base::Parameters::parse
589             {
590 5629     5629   9872 my $self = shift ;
591 5629         8268 my $default = shift ;
592              
593 5629         9257 my $got = $self->[IxGot] ;
594 5629         8511 my $firstTime = keys %{ $got } == 0 ;
  5629         15892  
595              
596 5629         9593 my (@Bad) ;
597 5629         9570 my @entered = () ;
598              
599             # Allow the options to be passed as a hash reference or
600             # as the complete hash.
601 5629 100       15408 if (@_ == 0) {
    100          
602 1197         2192 @entered = () ;
603             }
604             elsif (@_ == 1) {
605 20         38 my $href = $_[0] ;
606              
607 20 100 100     146 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         16 foreach my $key (keys %$href) {
611 6         8 push @entered, $key ;
612 6         14 push @entered, \$href->{$key} ;
613             }
614             }
615             else {
616              
617 4412         7279 my $count = @_;
618 4412 50       11509 return $self->setError("Expected even number of parameters, got $count")
619             if $count % 2 != 0 ;
620              
621 4412         15909 for my $i (0.. $count / 2 - 1) {
622 12480         22470 push @entered, $_[2 * $i] ;
623 12480         25064 push @entered, \$_[2 * $i + 1] ;
624             }
625             }
626              
627 5614         25124 foreach my $key (keys %$default)
628             {
629              
630 77967         100133 my ($type, $value) = @{ $default->{$key} } ;
  77967         130858  
631              
632 77967 100       119270 if ($firstTime) {
633 74146         159353 $got->{$key} = [0, $type, $value, $value] ;
634             }
635             else
636             {
637 3821         6135 $got->{$key}[OFF_PARSED] = 0 ;
638             }
639             }
640              
641              
642 5614         14022 my %parsed = ();
643              
644              
645 5614         16435 for my $i (0.. @entered / 2 - 1) {
646 12486         22598 my $key = $entered[2* $i] ;
647 12486         19618 my $value = $entered[2* $i+1] ;
648              
649             #print "Key [$key] Value [$value]" ;
650             #print defined $$value ? "[$$value]\n" : "[undef]\n";
651              
652 12486         25470 $key =~ s/^-// ;
653 12486         22480 my $canonkey = lc $key;
654              
655 12486 100       25136 if ($got->{$canonkey})
656             {
657 12459         20013 my $type = $got->{$canonkey}[OFF_TYPE] ;
658 12459         19457 my $parsed = $parsed{$canonkey};
659 12459         21414 ++ $parsed{$canonkey};
660              
661 12459 100       23394 return $self->setError("Muliple instances of '$key' found")
662             if $parsed ;
663              
664 12458         16273 my $s ;
665 12458 100       26199 $self->_checkType($key, $value, $type, 1, \$s)
666             or return undef ;
667              
668 12424         20397 $value = $$value ;
669 12424         38985 $got->{$canonkey} = [1, $type, $value, $s] ;
670              
671             }
672             else
673 27         76 { push (@Bad, $key) }
674             }
675              
676 5579 100       13750 if (@Bad) {
677 27         88 my ($bad) = join(", ", @Bad) ;
678 27         719 return $self->setError("unknown key value(s) $bad") ;
679             }
680              
681 5552         22731 return 1;
682             }
683              
684             sub IO::Compress::Base::Parameters::_checkType
685             {
686 12458     12458   18025 my $self = shift ;
687              
688 12458         17205 my $key = shift ;
689 12458         16659 my $value = shift ;
690 12458         16562 my $type = shift ;
691 12458         16654 my $validate = shift ;
692 12458         16702 my $output = shift;
693              
694             #local $Carp::CarpLevel = $level ;
695             #print "PARSE $type $key $value $validate $sub\n" ;
696              
697 12458 100       24514 if ($type & Parse_writable_scalar)
698             {
699 25 100       115 return $self->setError("Parameter '$key' not writable")
700             if readonly $$value ;
701              
702 24 100       109 if (ref $$value)
703             {
704 12 100       81 return $self->setError("Parameter '$key' not a scalar reference")
705             if ref $$value ne 'SCALAR' ;
706              
707 1         3 $$output = $$value ;
708             }
709             else
710             {
711 12 100       55 return $self->setError("Parameter '$key' not a scalar")
712             if ref $value ne 'SCALAR' ;
713              
714 11         28 $$output = $value ;
715             }
716              
717 12         40 return 1;
718             }
719              
720              
721 12433         18829 $value = $$value ;
722              
723 12433 100       34400 if ($type & Parse_any)
    100          
    100          
    100          
    100          
    100          
724             {
725 2455         4096 $$output = $value ;
726 2455         6516 return 1;
727             }
728             elsif ($type & Parse_unsigned)
729             {
730              
731 447 100       1103 return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
732             if ! defined $value ;
733 443 100       2481 return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
734             if $value !~ /^\d+$/;
735              
736 432 50       1033 $$output = defined $value ? $value : 0 ;
737 432         1322 return 1;
738             }
739             elsif ($type & Parse_signed)
740             {
741 77 100       188 return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
742             if ! defined $value ;
743 76 100       320 return $self->setError("Parameter '$key' must be a signed int, got '$value'")
744             if $value !~ /^-?\d+$/;
745              
746 75 50       211 $$output = defined $value ? $value : 0 ;
747 75         172 return 1 ;
748             }
749             elsif ($type & Parse_boolean)
750             {
751 9448 100 66     48628 return $self->setError("Parameter '$key' must be an int, got '$value'")
752             if defined $value && $value !~ /^\d*$/;
753              
754 9445 100 66     30240 $$output = defined $value && $value != 0 ? 1 : 0 ;
755 9445         24509 return 1;
756             }
757              
758             elsif ($type & Parse_string)
759             {
760 1 50       12 $$output = defined $value ? $value : "" ;
761 1         4 return 1;
762             }
763             elsif ($type & Parse_code)
764             {
765 4 100 66     29 return $self->setError("Parameter '$key' must be a code reference, got '$value'")
766             if (! defined $value || ref $value ne 'CODE') ;
767              
768 3 50       9 $$output = defined $value ? $value : "" ;
769 3         10 return 1;
770             }
771              
772 1         3 $$output = $value ;
773 1         3 return 1;
774             }
775              
776             sub IO::Compress::Base::Parameters::parsed
777             {
778 11721     11721   46136 return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
779             }
780              
781              
782             sub IO::Compress::Base::Parameters::getValue
783             {
784 89003     89003   260694 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
785             }
786             sub IO::Compress::Base::Parameters::setValue
787             {
788 7971     7971   19831 $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1;
789 7971         14047 $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
790 7971         15485 $_[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 2300     2300   4504 my $self = shift ;
801 2300         3181 my $name = shift ;
802 2300         3236 my $default = shift ;
803              
804 2300         4099 my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
805              
806 2300 100       6290 return $value if defined $value ;
807 389         890 return $default ;
808             }
809              
810             sub IO::Compress::Base::Parameters::wantValue
811             {
812 1149     1149   3544 return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
813             }
814              
815             sub IO::Compress::Base::Parameters::clone
816             {
817 255     255   457 my $self = shift ;
818 255         526 my $obj = [] ;
819 255         419 my %got ;
820              
821 255         494 my $hash = $self->[IxGot] ;
822 255         559 for my $k (keys %{ $hash })
  255         1414  
823             {
824 5616         7235 $got{$k} = [ @{ $hash->{$k} } ];
  5616         12558  
825             }
826              
827 255         853 $obj->[IxError] = $self->[IxError];
828 255         509 $obj->[IxGot] = \%got ;
829              
830 255         1966 return bless $obj, 'IO::Compress::Base::Parameters' ;
831             }
832              
833             package U64;
834              
835 84     84   787 use constant MAX32 => 0xFFFFFFFF ;
  84         236  
  84         5561  
836 84     84   592 use constant HI_1 => MAX32 + 1 ;
  84         188  
  84         4769  
837 84     84   562 use constant LOW => 0 ;
  84         176  
  84         4242  
838 84     84   512 use constant HIGH => 1;
  84         174  
  84         100739  
839              
840             sub new
841             {
842 11150 100   11150   41783 return bless [ 0, 0 ], $_[0]
843             if @_ == 1 ;
844              
845 20 100       56 return bless [ $_[1], 0 ], $_[0]
846             if @_ == 2 ;
847              
848 17 50       94 return bless [ $_[2], $_[1] ], $_[0]
849             if @_ == 3 ;
850             }
851              
852             sub newUnpack_V64
853             {
854 118     118   386 my ($low, $hi) = unpack "V V", $_[0] ;
855 118         364 bless [ $low, $hi ], "U64";
856             }
857              
858             sub newUnpack_V32
859             {
860 3948     3948   8831 my $string = shift;
861              
862 3948         7117 my $low = unpack "V", $string ;
863 3948         10590 bless [ $low, 0 ], "U64";
864             }
865              
866             sub reset
867             {
868 3907     3907   7624 $_[0]->[HIGH] = $_[0]->[LOW] = 0;
869             }
870              
871             sub clone
872             {
873 530     530   838 bless [ @{$_[0]} ], ref $_[0] ;
  530         2702  
874             }
875              
876             sub getHigh
877             {
878 23     23   196 return $_[0]->[HIGH];
879             }
880              
881             sub getLow
882             {
883 23     23   118 return $_[0]->[LOW];
884             }
885              
886             sub get32bit
887             {
888 1436     1436   5353 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 2653     2653   8311 return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
896             }
897              
898             sub add
899             {
900             # my $self = shift;
901 15857     15857   23137 my $value = $_[1];
902              
903 15857 100       39150 if (ref $value eq 'U64') {
    50          
904 384         667 $_[0]->[HIGH] += $value->[HIGH] ;
905 384         644 $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 15857         26554 my $available = MAX32 - $_[0]->[LOW] ;
913              
914 15857 100       27792 if ($value > $available) {
915 2         5 ++ $_[0]->[HIGH] ;
916 2         8 $_[0]->[LOW] = $value - $available - 1;
917             }
918             else {
919 15855         29302 $_[0]->[LOW] += $value ;
920             }
921             }
922              
923             sub add32
924             {
925             # my $self = shift;
926 787     787   1284 my $value = $_[1];
927              
928 787 50       1726 if ($value > MAX32) {
929 0         0 $_[0]->[HIGH] += int($value / HI_1) ;
930 0         0 $value = $value % HI_1;
931             }
932              
933 787         1391 my $available = MAX32 - $_[0]->[LOW] ;
934              
935 787 50       1520 if ($value > $available) {
936 0         0 ++ $_[0]->[HIGH] ;
937 0         0 $_[0]->[LOW] = $value - $available - 1;
938             }
939             else {
940 787         1675 $_[0]->[LOW] += $value ;
941             }
942             }
943              
944             sub subtract
945             {
946 4     4   12 my $self = shift;
947 4         8 my $value = shift;
948              
949 4 100       12 if (ref $value eq 'U64') {
950              
951 2 50       7 if ($value->[HIGH]) {
952 2 50 33     12 die "bad"
953             if $self->[HIGH] == 0 ||
954             $value->[HIGH] > $self->[HIGH] ;
955              
956 2         4 $self->[HIGH] -= $value->[HIGH] ;
957             }
958              
959 2         4 $value = $value->[LOW] ;
960             }
961              
962 4 100       13 if ($value > $self->[LOW]) {
963 3         4 -- $self->[HIGH] ;
964 3         8 $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ;
965             }
966             else {
967 1         3 $self->[LOW] -= $value;
968             }
969             }
970              
971             sub equal
972             {
973 1030     1030   1499 my $self = shift;
974 1030         1328 my $other = shift;
975              
976 1030   66     4351 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   2 my $self = shift;
991 1         3 my $other = shift;
992              
993 1         3 return $self->cmp($other) > 0 ;
994             }
995              
996             sub cmp
997             {
998 3     3   14 my $self = shift;
999 3         4 my $other = shift ;
1000              
1001 3 50       11 if ($self->[LOW] == $other->[LOW]) {
1002 0         0 return $self->[HIGH] - $other->[HIGH] ;
1003             }
1004             else {
1005 3         21 return $self->[LOW] - $other->[LOW] ;
1006             }
1007             }
1008              
1009              
1010             sub is64bit
1011             {
1012 1105     1105   3938 return $_[0]->[HIGH] > 0 ;
1013             }
1014              
1015             sub isAlmost64bit
1016             {
1017 766   33 766   3470 return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ;
1018             }
1019              
1020             sub getPacked_V64
1021             {
1022 860     860   1310 return pack "V V", @{ $_[0] } ;
  860         2292  
1023             }
1024              
1025             sub getPacked_V32
1026             {
1027 1863     1863   5053 return pack "V", $_[0]->[LOW] ;
1028             }
1029              
1030             sub pack_V64
1031             {
1032 84     84   214 return pack "V V", $_[0], 0;
1033             }
1034              
1035              
1036             sub full32
1037             {
1038 32     32   118 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 84     84   713 no warnings 'uninitialized';
  84         241  
  84         8086  
1047 0           return $hi * HI_1 + $lo;
1048             }
1049              
1050              
1051             package IO::Compress::Base::Common;
1052              
1053             1;