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   718 use strict ;
  130         218  
  130         3880  
4 130     130   452 use warnings;
  130         250  
  130         4191  
5 130     130   3652 use bytes;
  130         3812  
  130         569  
6              
7 130     130   2619 use Carp;
  130         215  
  130         9768  
8 130     130   775 use Scalar::Util qw(blessed readonly);
  130         229  
  130         11349  
9 130     130   64629 use File::GlobMapper;
  130         333  
  130         15538  
10              
11             require Exporter;
12             our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE);
13             @ISA = qw(Exporter);
14             $VERSION = '2.222';
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   943 use constant STATUS_OK => 0;
  130         285  
  130         11248  
46 130     130   584 use constant STATUS_ENDSTREAM => 1;
  130         222  
  130         5846  
47 130     130   534 use constant STATUS_EOF => 2;
  130         241  
  130         5242  
48 130     130   612 use constant STATUS_ERROR => -1;
  130         312  
  130         5012  
49 130     130   536 use constant MAX16 => 0xFFFF ;
  130         196  
  130         4516  
50 130     130   526 use constant MAX32 => 0xFFFFFFFF ;
  130         247  
  130         5423  
51 130     130   857 use constant MAX32cmp => 0xFFFFFFFF + 1 - 1; # for 5.6.x on 32-bit need to force an non-IV value
  130         494  
  130         43350  
52              
53              
54             sub isGeMax32
55             {
56 184     184 0 490 return $_[0] >= MAX32cmp ;
57             }
58              
59             sub hasEncode()
60             {
61 20 100   20 0 38 if (! defined $HAS_ENCODE) {
62             eval
63 5         8 {
64 5         28 require Encode;
65 5         253 Encode->import();
66             };
67              
68 5 50       18 $HAS_ENCODE = $@ ? 0 : 1 ;
69             }
70              
71 20         33 return $HAS_ENCODE;
72             }
73              
74             sub getEncoding($$$)
75             {
76 20     20 0 27 my $obj = shift;
77 20         23 my $class = shift ;
78 20         25 my $want_encoding = shift ;
79              
80 20 50       35 $obj->croakError("$class: Encode module needed to use -Encode")
81             if ! hasEncode();
82              
83 20         61 my $encoding = Encode::find_encoding($want_encoding);
84              
85 20 100       3237 $obj->croakError("$class: Encoding '$want_encoding' is not available")
86             if ! $encoding;
87              
88 15         35 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 3388 my $handle = shift ;
99              
100 2190 50       6572 binmode $handle
101             if $needBinmode;
102             }
103              
104             sub setBinModeOutput($)
105             {
106 1049     1049 0 1797 my $handle = shift ;
107              
108 1049 50       4537 binmode $handle
109             if $needBinmode;
110             }
111              
112             sub isaFilehandle($)
113             {
114 130     130   54071 use utf8; # Pragma needed to keep Perl 5.6.0 happy
  130         28861  
  130         673  
115 16623   66 16623 0 80879337 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 4698 return ( defined($_[0]) and ref($_[0]) eq 'SCALAR' and defined ${ $_[0] } ) ;
125             }
126              
127             sub isaFilename($)
128             {
129 1495   100 1495 0 9855 return (defined $_[0] and
130             ! ref $_[0] and
131             UNIVERSAL::isa(\$_[0], 'SCALAR'));
132             }
133              
134             sub isaFileGlobString
135             {
136 1007   100 1007 0 5704 return defined $_[0] && $_[0] =~ /^<.*>$/;
137             }
138              
139             sub cleanFileGlobString
140             {
141 110     110 0 170 my $string = shift ;
142              
143 110         822 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
144              
145 110         276 return $string;
146             }
147              
148 130     130   37108 use constant WANT_CODE => 1 ;
  130         617  
  130         7978  
149 130     130   574 use constant WANT_EXT => 2 ;
  130         273  
  130         7125  
150 130     130   664 use constant WANT_UNDEF => 4 ;
  130         341  
  130         5318  
151             #use constant WANT_HASH => 8 ;
152 130     130   509 use constant WANT_HASH => 0 ;
  130         199  
  130         181102  
153              
154             sub whatIsInput($;$)
155             {
156 9109     9109 0 16204 my $got = whatIs(@_);
157              
158 9109 100 66     32582 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      100        
      100        
159             {
160             #use IO::File;
161 100         231 $got = 'handle';
162 100         337 $_[0] = *STDIN;
163             #$_[0] = IO::File->new("<-");
164             }
165              
166 9109         15140 return $got;
167             }
168              
169             sub whatIsOutput($;$)
170             {
171 5343     5343 0 9422 my $got = whatIs(@_);
172              
173 5343 100 66     19117 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
      66        
      100        
174             {
175 24         39 $got = 'handle';
176 24         83 $_[0] = *STDOUT;
177             #$_[0] = IO::File->new(">-");
178             }
179              
180 5343         9003 return $got;
181             }
182              
183             sub whatIs ($;$)
184             {
185 14452 100   14452 0 23789 return 'handle' if isaFilehandle($_[0]);
186              
187 12624   100     28440 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
188 12624   100     24184 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
189 12624   66     23037 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
190 12624   66     23110 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
191              
192 12624 50 66     21599 return 'undef' if ! defined $_[0] && $undef ;
193              
194 12624 100       18541 if (ref $_[0]) {
195 6193 100       9677 return '' if blessed($_[0]); # is an object
196             #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
197 6133 100       14973 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
198 334 100 100     1558 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
199 44 50 33     129 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
200 44 100 100     147 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
201 42         84 return '';
202             }
203              
204 6431 100 100     12546 return 'fileglob' if $extended && isaFileGlobString($_[0]);
205 6236         9798 return 'filename';
206             }
207              
208             sub oneTarget
209             {
210 3086     3086 0 12994 return $_[0] =~ /^(code|handle|buffer|filename)$/;
211             }
212              
213             sub IO::Compress::Base::Validator::new
214             {
215 1543     1543   2234 my $class = shift ;
216              
217 1543         2035 my $Class = shift ;
218 1543         2016 my $error_ref = shift ;
219 1543         2161 my $reportClass = shift ;
220              
221 1543         6078 my %data = (Class => $Class,
222             Error => $error_ref,
223             reportClass => $reportClass,
224             ) ;
225              
226 1543         2972 my $obj = bless \%data, $class ;
227              
228 1543         2663 local $Carp::CarpLevel = 1;
229              
230 1543         3565 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
231 1543         3261 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
232              
233 1543         2765 my $oneInput = $data{oneInput} = oneTarget($inType);
234 1543         2596 my $oneOutput = $data{oneOutput} = oneTarget($outType);
235              
236 1543 100       3501 if (! $inType)
237             {
238 30         87 $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       2733 if (! $outType)
250             {
251 30         86 $obj->croakError("$reportClass: illegal output parameter") ;
252             #return undef ;
253             }
254              
255              
256 1483 100 100     4405 if ($inType ne 'fileglob' && $outType eq 'fileglob')
257             {
258 15         38 $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     3490 if ($inType eq 'fileglob' && $outType eq 'fileglob')
267             {
268 35         95 $data{GlobMap} = 1 ;
269 35         91 $data{inType} = $data{outType} = 'filename';
270 35         327 my $mapper = File::GlobMapper->new($_[0], $_[1]);
271 35 100       88 if ( ! $mapper )
272             {
273 15         184 return $obj->saveErrorString($File::GlobMapper::Error) ;
274             }
275 20         57 $data{Pairs} = $mapper->getFileMap();
276              
277 20         157 return $obj;
278             }
279              
280 1433 100 100     4416 $obj->croakError("$reportClass: input and output $inType are identical")
      66        
281             if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
282              
283 1388 100       4464 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
    100          
    100          
284             {
285 110         288 my $glob = cleanFileGlobString($_[0]);
286 110         9344 my @inputs = glob($glob);
287              
288 110 50       505 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       178 $obj->validateInputFilenames($inputs[0])
296             or return undef;
297 35         93 $_[0] = $inputs[0] ;
298 35         68 $data{inType} = 'filename' ;
299 35         75 $data{oneInput} = 1;
300             }
301             else
302             {
303 75 50       324 $obj->validateInputFilenames(@inputs)
304             or return undef;
305 75         246 $_[0] = [ @inputs ] ;
306 75         178 $data{inType} = 'filenames' ;
307             }
308             }
309             elsif ($inType eq 'filename')
310             {
311 341 100       1041 $obj->validateInputFilenames($_[0])
312             or return undef;
313             }
314             elsif ($inType eq 'array')
315             {
316 175         379 $data{inType} = 'filenames' ;
317 175 100       523 $obj->validateInputArray($_[0])
318             or return undef ;
319             }
320              
321             return $obj->saveErrorString("$reportClass: output buffer is read-only")
322 1273 100 100     3145 if $outType eq 'buffer' && readonly(${ $_[1] });
  597         2737  
323              
324 1258 100       2383 if ($outType eq 'filename' )
325             {
326 335 50 33     1286 $obj->croakError("$reportClass: output filename is undef or null string")
327             if ! defined $_[1] || $_[1] eq '' ;
328              
329 335 100       4074 if (-e $_[1])
330             {
331 156 100       420 if (-d _ )
332             {
333 15         60 return $obj->saveErrorString("output file '$_[1]' is a directory");
334             }
335             }
336             }
337              
338 1243         5450 return $obj ;
339             }
340              
341             sub IO::Compress::Base::Validator::saveErrorString
342             {
343 280     280   369 my $self = shift ;
344 280         329 ${ $self->{Error} } = shift ;
  280         546  
345 280         1043 return undef;
346              
347             }
348              
349             sub IO::Compress::Base::Validator::croakError
350             {
351 200     200   242 my $self = shift ;
352 200         409 $self->saveErrorString($_[0]);
353 200         34226 croak $_[0];
354             }
355              
356              
357              
358             sub IO::Compress::Base::Validator::validateInputFilenames
359             {
360 671     671   907 my $self = shift ;
361              
362 671         1233 foreach my $filename (@_)
363             {
364 821 100 100     2661 $self->croakError("$self->{reportClass}: input filename is undef or null string")
365             if ! defined $filename || $filename eq '' ;
366              
367 781 50       1531 next if $filename eq '-';
368              
369 781 100       11013 if (! -e $filename )
370             {
371 15         54 return $self->saveErrorString("input file '$filename' does not exist");
372             }
373              
374 766 100       2058 if (-d _ )
375             {
376 15         87 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         1632 return 1 ;
386             }
387              
388             sub IO::Compress::Base::Validator::validateInputArray
389             {
390 175     175   240 my $self = shift ;
391              
392 175 100       219 if ( @{ $_[0] } == 0 )
  175         478  
393             {
394 5         17 return $self->saveErrorString("empty array reference") ;
395             }
396              
397 170         251 foreach my $element ( @{ $_[0] } )
  170         430  
398             {
399 260         430 my $inType = whatIsInput($element);
400              
401 260 100       628 if (! $inType)
    100          
402             {
403 20         49 $self->croakError("unknown input parameter") ;
404             }
405             elsif($inType eq 'filename')
406             {
407 220 50       443 $self->validateInputFilenames($element)
408             or return undef ;
409             }
410             else
411             {
412 20         61 $self->croakError("not a filename") ;
413             }
414             }
415              
416 120         319 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 22768 my $class = shift || (caller)[0] ;
447 6432         9358 my $error_ref = shift ;
448              
449 6432   33     17747 my $obj = bless Symbol::gensym(), ref($class) || $class;
450 6432 50       139871 tie *$obj, $obj if $] >= 5.005;
451 6432         19066 *$obj->{Closed} = 1 ;
452 6432         13368 $$error_ref = '';
453 6432         11330 *$obj->{Error} = $error_ref ;
454 6432         8819 my $errno = 0 ;
455 6432         11279 *$obj->{ErrorNo} = \$errno ;
456              
457 6432         14136 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   936 use constant Parse_any => 0x01;
  130         172  
  130         7782  
481 130     130   585 use constant Parse_unsigned => 0x02;
  130         239  
  130         5614  
482 130     130   534 use constant Parse_signed => 0x04;
  130         261  
  130         5081  
483 130     130   524 use constant Parse_boolean => 0x08;
  130         174  
  130         4683  
484 130     130   1132 use constant Parse_string => 0x10;
  130         214  
  130         4985  
485 130     130   536 use constant Parse_code => 0x20;
  130         162  
  130         4680  
486              
487             #use constant Parse_store_ref => 0x100 ;
488             #use constant Parse_multiple => 0x100 ;
489 130     130   517 use constant Parse_writable => 0x200 ;
  130         224  
  130         5454  
490 130     130   600 use constant Parse_writable_scalar => 0x400 | Parse_writable ;
  130         258  
  130         5040  
491              
492 130     130   520 use constant OFF_PARSED => 0 ;
  130         187  
  130         4470  
493 130     130   559 use constant OFF_TYPE => 1 ;
  130         192  
  130         4407  
494 130     130   456 use constant OFF_DEFAULT => 2 ;
  130         199  
  130         4497  
495 130     130   476 use constant OFF_FIXED => 3 ;
  130         226  
  130         4238  
496             #use constant OFF_FIRST_ONLY => 4 ;
497             #use constant OFF_STICKY => 5 ;
498              
499 130     130   496 use constant IxError => 0;
  130         230  
  130         4240  
500 130     130   509 use constant IxGot => 1 ;
  130         244  
  130         20940  
501              
502             sub ParseParameters
503             {
504 58   100 58 0 136155 my $level = shift || 0 ;
505              
506 58         343 my $sub = (caller($level + 1))[3] ;
507 58         119 local $Carp::CarpLevel = 1 ;
508              
509 58 100 100     270 return $_[1]
      100        
510             if @_ == 2 && defined $_[1] && UNIVERSAL::isa($_[1], "IO::Compress::Base::Parameters");
511              
512 57         291 my $p = IO::Compress::Base::Parameters->new();
513 57 100       147 $p->parse(@_)
514             or croak "$sub: $p->[IxError]" ;
515              
516 37         110 return $p;
517             }
518              
519              
520 130     130   678 use strict;
  130         295  
  130         3364  
521              
522 130     130   458 use warnings;
  130         170  
  130         5507  
523 130     130   540 use Carp;
  130         214  
  130         197112  
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   7331 my $obj;
565 5507         12289 $obj->[IxError] = '';
566 5507         9274 $obj->[IxGot] = {} ;
567              
568 5507         27454 return bless $obj, 'IO::Compress::Base::Parameters' ;
569             }
570              
571             sub IO::Compress::Base::Parameters::setError
572             {
573 77     77   132 my $self = shift ;
574 77         111 my $error = shift ;
575 77 50       177 my $retval = @_ ? shift : undef ;
576              
577              
578 77         131 $self->[IxError] = $error ;
579 77         4718 return $retval;
580             }
581              
582             sub IO::Compress::Base::Parameters::getError
583             {
584 57     57   78 my $self = shift ;
585 57         339 return $self->[IxError] ;
586             }
587              
588             sub IO::Compress::Base::Parameters::parse
589             {
590 5683     5683   7739 my $self = shift ;
591 5683         6949 my $default = shift ;
592              
593 5683         8030 my $got = $self->[IxGot] ;
594 5683         6746 my $firstTime = keys %{ $got } == 0 ;
  5683         12831  
595              
596 5683         7472 my (@Bad) ;
597 5683         8475 my @entered = () ;
598              
599             # Allow the options to be passed as a hash reference or
600             # as the complete hash.
601 5683 100       13347 if (@_ == 0) {
    100          
602 1215         1769 @entered = () ;
603             }
604             elsif (@_ == 1) {
605 20         31 my $href = $_[0] ;
606              
607 20 100 100     113 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         11 foreach my $key (keys %$href) {
611 6         7 push @entered, $key ;
612 6         14 push @entered, \$href->{$key} ;
613             }
614             }
615             else {
616              
617 4448         6426 my $count = @_;
618 4448 50       10709 return $self->setError("Expected even number of parameters, got $count")
619             if $count % 2 != 0 ;
620              
621 4448         14544 for my $i (0.. $count / 2 - 1) {
622 12647         19573 push @entered, $_[2 * $i] ;
623 12647         22084 push @entered, \$_[2 * $i + 1] ;
624             }
625             }
626              
627 5668         20222 foreach my $key (keys %$default)
628             {
629              
630 79329         79507 my ($type, $value) = @{ $default->{$key} } ;
  79329         111356  
631              
632 79329 100       95959 if ($firstTime) {
633 75508         136723 $got->{$key} = [0, $type, $value, $value] ;
634             }
635             else
636             {
637 3821         4904 $got->{$key}[OFF_PARSED] = 0 ;
638             }
639             }
640              
641              
642 5668         13686 my %parsed = ();
643              
644              
645 5668         13901 for my $i (0.. @entered / 2 - 1) {
646 12653         17173 my $key = $entered[2* $i] ;
647 12653         15715 my $value = $entered[2* $i+1] ;
648              
649             #print "Key [$key] Value [$value]" ;
650             #print defined $$value ? "[$$value]\n" : "[undef]\n";
651              
652 12653         19367 $key =~ s/^-// ;
653 12653         17555 my $canonkey = lc $key;
654              
655 12653 100       20561 if ($got->{$canonkey})
656             {
657 12626         16735 my $type = $got->{$canonkey}[OFF_TYPE] ;
658 12626         15532 my $parsed = $parsed{$canonkey};
659 12626         17586 ++ $parsed{$canonkey};
660              
661 12626 100       18936 return $self->setError("Muliple instances of '$key' found")
662             if $parsed ;
663              
664 12625         12773 my $s ;
665 12625 100       24624 $self->_checkType($key, $value, $type, 1, \$s)
666             or return undef ;
667              
668 12591         15606 $value = $$value ;
669 12591         31478 $got->{$canonkey} = [1, $type, $value, $s] ;
670              
671             }
672             else
673 27         61 { push (@Bad, $key) }
674             }
675              
676 5633 100       10215 if (@Bad) {
677 27         70 my ($bad) = join(", ", @Bad) ;
678 27         84 return $self->setError("unknown key value(s) $bad") ;
679             }
680              
681 5606         19041 return 1;
682             }
683              
684             sub IO::Compress::Base::Parameters::_checkType
685             {
686 12625     12625   14113 my $self = shift ;
687              
688 12625         13979 my $key = shift ;
689 12625         14359 my $value = shift ;
690 12625         12937 my $type = shift ;
691 12625         13090 my $validate = shift ;
692 12625         12788 my $output = shift;
693              
694             #local $Carp::CarpLevel = $level ;
695             #print "PARSE $type $key $value $validate $sub\n" ;
696              
697 12625 100       19796 if ($type & Parse_writable_scalar)
698             {
699 25 100       98 return $self->setError("Parameter '$key' not writable")
700             if readonly $$value ;
701              
702 24 100       57 if (ref $$value)
703             {
704 12 100       66 return $self->setError("Parameter '$key' not a scalar reference")
705             if ref $$value ne 'SCALAR' ;
706              
707 1         4 $$output = $$value ;
708             }
709             else
710             {
711 12 100       44 return $self->setError("Parameter '$key' not a scalar")
712             if ref $value ne 'SCALAR' ;
713              
714 11         20 $$output = $value ;
715             }
716              
717 12         41 return 1;
718             }
719              
720              
721 12600         15806 $value = $$value ;
722              
723 12600 100       28526 if ($type & Parse_any)
    100          
    100          
    100          
    100          
    100          
724             {
725 2489         3445 $$output = $value ;
726 2489         4842 return 1;
727             }
728             elsif ($type & Parse_unsigned)
729             {
730              
731 475 100       968 return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
732             if ! defined $value ;
733 471 100       2152 return $self->setError("Parameter '$key' must be an unsigned int, got '$value'")
734             if $value !~ /^\d+$/;
735              
736 460 50       1060 $$output = defined $value ? $value : 0 ;
737 460         1085 return 1;
738             }
739             elsif ($type & Parse_signed)
740             {
741 99 100       202 return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
742             if ! defined $value ;
743 98 100       359 return $self->setError("Parameter '$key' must be a signed int, got '$value'")
744             if $value !~ /^-?\d+$/;
745              
746 97 50       205 $$output = defined $value ? $value : 0 ;
747 97         195 return 1 ;
748             }
749             elsif ($type & Parse_boolean)
750             {
751 9531 100 66     38274 return $self->setError("Parameter '$key' must be an int, got '$value'")
752             if defined $value && $value !~ /^\d*$/;
753              
754 9528 100 66     22712 $$output = defined $value && $value != 0 ? 1 : 0 ;
755 9528         18972 return 1;
756             }
757              
758             elsif ($type & Parse_string)
759             {
760 1 50       5 $$output = defined $value ? $value : "" ;
761 1         5 return 1;
762             }
763             elsif ($type & Parse_code)
764             {
765 4 100 66     27 return $self->setError("Parameter '$key' must be a code reference, got '$value'")
766             if (! defined $value || ref $value ne 'CODE') ;
767              
768 3 50       8 $$output = defined $value ? $value : "" ;
769 3         6 return 1;
770             }
771              
772 1         2 $$output = $value ;
773 1         4 return 1;
774             }
775              
776             sub IO::Compress::Base::Parameters::parsed
777             {
778 12005     12005   37926 return $_[0]->[IxGot]{$_[1]}[OFF_PARSED] ;
779             }
780              
781              
782             sub IO::Compress::Base::Parameters::getValue
783             {
784 90350     90350   211626 return $_[0]->[IxGot]{$_[1]}[OFF_FIXED] ;
785             }
786             sub IO::Compress::Base::Parameters::setValue
787             {
788 8047     8047   18417 $_[0]->[IxGot]{$_[1]}[OFF_PARSED] = 1;
789 8047         11655 $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] = $_[2] ;
790 8047         12398 $_[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   2677 my $self = shift ;
801 2356         2592 my $name = shift ;
802 2356         2544 my $default = shift ;
803              
804 2356         3543 my $value = $self->[IxGot]{$name}[OFF_DEFAULT] ;
805              
806 2356 100       4812 return $value if defined $value ;
807 389         600 return $default ;
808             }
809              
810             sub IO::Compress::Base::Parameters::wantValue
811             {
812 1149     1149   2513 return defined $_[0]->[IxGot]{$_[1]}[OFF_DEFAULT] ;
813             }
814              
815             sub IO::Compress::Base::Parameters::clone
816             {
817 255     255   308 my $self = shift ;
818 255         391 my $obj = [] ;
819 255         330 my %got ;
820              
821 255         339 my $hash = $self->[IxGot] ;
822 255         299 for my $k (keys %{ $hash })
  255         1249  
823             {
824 5616         5152 $got{$k} = [ @{ $hash->{$k} } ];
  5616         10399  
825             }
826              
827 255         750 $obj->[IxError] = $self->[IxError];
828 255         347 $obj->[IxGot] = \%got ;
829              
830 255         1811 return bless $obj, 'IO::Compress::Base::Parameters' ;
831             }
832              
833             package U64;
834              
835 130     130   1007 use constant MAX32 => 0xFFFFFFFF ;
  130         267  
  130         8409  
836 130     130   606 use constant HI_1 => MAX32 + 1 ;
  130         227  
  130         6233  
837 130     130   789 use constant LOW => 0 ;
  130         384  
  130         5003  
838 130     130   585 use constant HIGH => 1;
  130         233  
  130         113315  
839              
840             sub new
841             {
842 11282 100   11282   34851 return bless [ 0, 0 ], $_[0]
843             if @_ == 1 ;
844              
845 20 100       33 return bless [ $_[1], 0 ], $_[0]
846             if @_ == 2 ;
847              
848 17 50       57 return bless [ $_[2], $_[1] ], $_[0]
849             if @_ == 3 ;
850             }
851              
852             sub newUnpack_V64
853             {
854 118     118   232 my ($low, $hi) = unpack "V V", $_[0] ;
855 118         256 bless [ $low, $hi ], "U64";
856             }
857              
858             sub newUnpack_V32
859             {
860 3952     3952   6574 my $string = shift;
861              
862 3952         4832 my $low = unpack "V", $string ;
863 3952         8377 bless [ $low, 0 ], "U64";
864             }
865              
866             sub reset
867             {
868 3907     3907   6427 $_[0]->[HIGH] = $_[0]->[LOW] = 0;
869             }
870              
871             sub clone
872             {
873 558     558   641 bless [ @{$_[0]} ], ref $_[0] ;
  558         2566  
874             }
875              
876             sub getHigh
877             {
878 23     23   88 return $_[0]->[HIGH];
879             }
880              
881             sub getLow
882             {
883 23     23   63 return $_[0]->[LOW];
884             }
885              
886             sub get32bit
887             {
888 1466     1466   3661 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   6908 return $_[0]->[HIGH] * HI_1 + $_[0]->[LOW];
896             }
897              
898             sub add
899             {
900             # my $self = shift;
901 16032     16032   17775 my $value = $_[1];
902              
903 16032 100       30202 if (ref $value eq 'U64') {
    50          
904 412         583 $_[0]->[HIGH] += $value->[HIGH] ;
905 412         599 $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         20633 my $available = MAX32 - $_[0]->[LOW] ;
913              
914 16032 100       20621 if ($value > $available) {
915 2         3 ++ $_[0]->[HIGH] ;
916 2         4 $_[0]->[LOW] = $value - $available - 1;
917             }
918             else {
919 16030         22671 $_[0]->[LOW] += $value ;
920             }
921             }
922              
923             sub add32
924             {
925             # my $self = shift;
926 843     843   1052 my $value = $_[1];
927              
928 843 50       1472 if ($value > MAX32) {
929 0         0 $_[0]->[HIGH] += int($value / HI_1) ;
930 0         0 $value = $value % HI_1;
931             }
932              
933 843         1095 my $available = MAX32 - $_[0]->[LOW] ;
934              
935 843 50       1309 if ($value > $available) {
936 0         0 ++ $_[0]->[HIGH] ;
937 0         0 $_[0]->[LOW] = $value - $available - 1;
938             }
939             else {
940 843         1353 $_[0]->[LOW] += $value ;
941             }
942             }
943              
944             sub subtract
945             {
946 4     4   10 my $self = shift;
947 4         4 my $value = shift;
948              
949 4 100       10 if (ref $value eq 'U64') {
950              
951 2 50       6 if ($value->[HIGH]) {
952 2 50 33     11 die "bad"
953             if $self->[HIGH] == 0 ||
954             $value->[HIGH] > $self->[HIGH] ;
955              
956 2         4 $self->[HIGH] -= $value->[HIGH] ;
957             }
958              
959 2         2 $value = $value->[LOW] ;
960             }
961              
962 4 100       7 if ($value > $self->[LOW]) {
963 3         4 -- $self->[HIGH] ;
964 3         7 $self->[LOW] = MAX32 - $value + $self->[LOW] + 1 ;
965             }
966             else {
967 1         2 $self->[LOW] -= $value;
968             }
969             }
970              
971             sub equal
972             {
973 1030     1030   1037 my $self = shift;
974 1030         1048 my $other = shift;
975              
976 1030   66     3127 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         2 my $other = shift;
992              
993 1         2 return $self->cmp($other) > 0 ;
994             }
995              
996             sub cmp
997             {
998 3     3   6 my $self = shift;
999 3         4 my $other = shift ;
1000              
1001 3 50       8 if ($self->[LOW] == $other->[LOW]) {
1002 0         0 return $self->[HIGH] - $other->[HIGH] ;
1003             }
1004             else {
1005 3         13 return $self->[LOW] - $other->[LOW] ;
1006             }
1007             }
1008              
1009              
1010             sub is64bit
1011             {
1012 1189     1189   3480 return $_[0]->[HIGH] > 0 ;
1013             }
1014              
1015             sub isAlmost64bit
1016             {
1017 822   33 822   2990 return $_[0]->[HIGH] > 0 || $_[0]->[LOW] == MAX32 ;
1018             }
1019              
1020             sub getPacked_V64
1021             {
1022 916     916   1045 return pack "V V", @{ $_[0] } ;
  916         2287  
1023             }
1024              
1025             sub getPacked_V32
1026             {
1027 2003     2003   4429 return pack "V", $_[0]->[LOW] ;
1028             }
1029              
1030             sub pack_V64
1031             {
1032 84     84   143 return pack "V V", $_[0], 0;
1033             }
1034              
1035              
1036             sub full32
1037             {
1038 32     32   61 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   891 no warnings 'uninitialized';
  130         218  
  130         12788  
1047 0           return $hi * HI_1 + $lo;
1048             }
1049              
1050              
1051             package IO::Compress::Base::Common;
1052              
1053             1;