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