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; |
12 | our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS); |
13 | @ISA = qw(Exporter); |
2b4e0969 |
14 | $VERSION = '2.000_11'; |
25f0751f |
15 | |
16 | @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput |
17 | isaFileGlobString cleanFileGlobString oneTarget |
18 | setBinModeInput setBinModeOutput |
19 | ckInOutParams |
20 | createSelfTiedObject |
21 | |
22 | WANT_CODE |
23 | WANT_EXT |
24 | WANT_UNDEF |
25 | WANT_HASH |
26 | |
27 | STATUS_OK |
28 | STATUS_ENDSTREAM |
29 | STATUS_EOF |
30 | STATUS_ERROR |
31 | ); |
32 | |
33 | %EXPORT_TAGS = ( Status => [qw( STATUS_OK |
34 | STATUS_ENDSTREAM |
35 | STATUS_EOF |
36 | STATUS_ERROR |
37 | )]); |
38 | |
39 | |
40 | use constant STATUS_OK => 0; |
41 | use constant STATUS_ENDSTREAM => 1; |
42 | use constant STATUS_EOF => 2; |
43 | use constant STATUS_ERROR => -1; |
44 | #use constant STATUS_OK => 0; |
45 | #use constant STATUS_ENDSTREAM => 1; |
46 | #use constant STATUS_ERROR => 2; |
47 | #use constant STATUS_EOF => 3; |
48 | |
49 | our ($needBinmode); |
50 | $needBinmode = ($^O eq 'MSWin32' || |
51 | ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} ')) |
52 | ? 1 : 1 ; |
53 | |
54 | sub setBinModeInput($) |
55 | { |
56 | my $handle = shift ; |
57 | |
58 | binmode $handle |
59 | if $needBinmode; |
60 | } |
61 | |
62 | sub setBinModeOutput($) |
63 | { |
64 | my $handle = shift ; |
65 | |
66 | binmode $handle |
67 | if $needBinmode; |
68 | } |
69 | |
70 | sub isaFilehandle($) |
71 | { |
72 | use utf8; # Pragma needed to keep Perl 5.6.0 happy |
73 | return (defined $_[0] and |
74 | (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB')) |
75 | and defined fileno($_[0]) ) |
76 | } |
77 | |
78 | sub isaFilename($) |
79 | { |
80 | return (defined $_[0] and |
81 | ! ref $_[0] and |
82 | UNIVERSAL::isa(\$_[0], 'SCALAR')); |
83 | } |
84 | |
85 | sub isaFileGlobString |
86 | { |
87 | return defined $_[0] && $_[0] =~ /^<.*>$/; |
88 | } |
89 | |
90 | sub cleanFileGlobString |
91 | { |
92 | my $string = shift ; |
93 | |
94 | $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; |
95 | |
96 | return $string; |
97 | } |
98 | |
99 | use constant WANT_CODE => 1 ; |
100 | use constant WANT_EXT => 2 ; |
101 | use constant WANT_UNDEF => 4 ; |
102 | #use constant WANT_HASH => 8 ; |
103 | use constant WANT_HASH => 0 ; |
104 | |
105 | sub whatIsInput($;$) |
106 | { |
107 | my $got = whatIs(@_); |
108 | |
109 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') |
110 | { |
111 | use IO::File; |
112 | $got = 'handle'; |
113 | #$_[0] = \*STDIN; |
114 | $_[0] = new IO::File("<-"); |
115 | } |
116 | |
117 | return $got; |
118 | } |
119 | |
120 | sub whatIsOutput($;$) |
121 | { |
122 | my $got = whatIs(@_); |
123 | |
124 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') |
125 | { |
126 | $got = 'handle'; |
127 | #$_[0] = \*STDOUT; |
128 | $_[0] = new IO::File(">-"); |
129 | } |
130 | |
131 | return $got; |
132 | } |
133 | |
134 | sub whatIs ($;$) |
135 | { |
136 | return 'handle' if isaFilehandle($_[0]); |
137 | |
138 | my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; |
139 | my $extended = defined $_[1] && $_[1] & WANT_EXT ; |
140 | my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; |
141 | my $hash = defined $_[1] && $_[1] & WANT_HASH ; |
142 | |
143 | return 'undef' if ! defined $_[0] && $undef ; |
144 | |
145 | if (ref $_[0]) { |
146 | return '' if blessed($_[0]); # is an object |
147 | #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object |
148 | return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); |
149 | return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; |
150 | return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; |
151 | return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; |
152 | return ''; |
153 | } |
154 | |
155 | return 'fileglob' if $extended && isaFileGlobString($_[0]); |
156 | return 'filename'; |
157 | } |
158 | |
159 | sub oneTarget |
160 | { |
161 | return $_[0] =~ /^(code|handle|buffer|filename)$/; |
162 | } |
163 | |
164 | sub Validator::new |
165 | { |
166 | my $class = shift ; |
167 | |
168 | my $Class = shift ; |
169 | my $error_ref = shift ; |
170 | my $reportClass = shift ; |
171 | |
172 | my %data = (Class => $Class, |
173 | Error => $error_ref, |
174 | reportClass => $reportClass, |
175 | ) ; |
176 | |
177 | my $obj = bless \%data, $class ; |
178 | |
179 | local $Carp::CarpLevel = 1; |
180 | |
181 | my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); |
182 | my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); |
183 | |
184 | my $oneInput = $data{oneInput} = oneTarget($inType); |
185 | my $oneOutput = $data{oneOutput} = oneTarget($outType); |
186 | |
187 | if (! $inType) |
188 | { |
189 | $obj->croakError("$reportClass: illegal input parameter") ; |
190 | #return undef ; |
191 | } |
192 | |
193 | # if ($inType eq 'hash') |
194 | # { |
195 | # $obj->{Hash} = 1 ; |
196 | # $obj->{oneInput} = 1 ; |
197 | # return $obj->validateHash($_[0]); |
198 | # } |
199 | |
200 | if (! $outType) |
201 | { |
202 | $obj->croakError("$reportClass: illegal output parameter") ; |
203 | #return undef ; |
204 | } |
205 | |
206 | |
207 | if ($inType ne 'fileglob' && $outType eq 'fileglob') |
208 | { |
209 | $obj->croakError("Need input fileglob for outout fileglob"); |
210 | } |
211 | |
212 | # if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) |
213 | # { |
214 | # $obj->croakError("input must ne filename or fileglob when output is a hash"); |
215 | # } |
216 | |
217 | if ($inType eq 'fileglob' && $outType eq 'fileglob') |
218 | { |
219 | $data{GlobMap} = 1 ; |
220 | $data{inType} = $data{outType} = 'filename'; |
221 | my $mapper = new File::GlobMapper($_[0], $_[1]); |
222 | if ( ! $mapper ) |
223 | { |
224 | return $obj->saveErrorString($File::GlobMapper::Error) ; |
225 | } |
226 | $data{Pairs} = $mapper->getFileMap(); |
227 | |
228 | return $obj; |
229 | } |
230 | |
231 | $obj->croakError("$reportClass: input and output $inType are identical") |
232 | if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; |
233 | |
234 | if ($inType eq 'fileglob') # && $outType ne 'fileglob' |
235 | { |
236 | my $glob = cleanFileGlobString($_[0]); |
237 | my @inputs = glob($glob); |
238 | |
239 | if (@inputs == 0) |
240 | { |
241 | # TODO -- legal or die? |
242 | die "globmap matched zero file -- legal or die???" ; |
243 | } |
244 | elsif (@inputs == 1) |
245 | { |
246 | $obj->validateInputFilenames($inputs[0]) |
247 | or return undef; |
248 | $_[0] = $inputs[0] ; |
249 | $data{inType} = 'filename' ; |
250 | $data{oneInput} = 1; |
251 | } |
252 | else |
253 | { |
254 | $obj->validateInputFilenames(@inputs) |
255 | or return undef; |
256 | $_[0] = [ @inputs ] ; |
257 | $data{inType} = 'filenames' ; |
258 | } |
259 | } |
260 | elsif ($inType eq 'filename') |
261 | { |
262 | $obj->validateInputFilenames($_[0]) |
263 | or return undef; |
264 | } |
265 | elsif ($inType eq 'array') |
266 | { |
267 | $data{inType} = 'filenames' ; |
268 | $obj->validateInputArray($_[0]) |
269 | or return undef ; |
270 | } |
271 | |
272 | return $obj->saveErrorString("$reportClass: output buffer is read-only") |
273 | if $outType eq 'buffer' && readonly(${ $_[1] }); |
274 | |
275 | if ($outType eq 'filename' ) |
276 | { |
277 | $obj->croakError("$reportClass: output filename is undef or null string") |
278 | if ! defined $_[1] || $_[1] eq '' ; |
279 | } |
280 | |
281 | return $obj ; |
282 | } |
283 | |
284 | sub Validator::saveErrorString |
285 | { |
286 | my $self = shift ; |
287 | ${ $self->{Error} } = shift ; |
288 | return undef; |
289 | |
290 | } |
291 | |
292 | sub Validator::croakError |
293 | { |
294 | my $self = shift ; |
295 | $self->saveErrorString($_[0]); |
296 | croak $_[0]; |
297 | } |
298 | |
299 | |
300 | |
301 | sub Validator::validateInputFilenames |
302 | { |
303 | my $self = shift ; |
304 | |
305 | foreach my $filename (@_) |
306 | { |
307 | $self->croakError("$self->{reportClass}: input filename is undef or null string") |
308 | if ! defined $filename || $filename eq '' ; |
309 | |
310 | next if $filename eq '-'; |
311 | |
312 | if (! -e $filename ) |
313 | { |
314 | return $self->saveErrorString("input file '$filename' does not exist"); |
315 | } |
316 | |
317 | if (! -r $filename ) |
318 | { |
319 | return $self->saveErrorString("cannot open file '$filename': $!"); |
320 | } |
321 | } |
322 | |
323 | return 1 ; |
324 | } |
325 | |
326 | sub Validator::validateInputArray |
327 | { |
328 | my $self = shift ; |
329 | |
330 | if ( @{ $_[0] } == 0 ) |
331 | { |
332 | return $self->saveErrorString("empty array reference") ; |
333 | } |
334 | |
335 | foreach my $element ( @{ $_[0] } ) |
336 | { |
337 | my $inType = whatIsInput($element); |
338 | |
339 | if (! $inType) |
340 | { |
341 | $self->croakError("unknown input parameter") ; |
342 | } |
343 | elsif($inType eq 'filename') |
344 | { |
345 | $self->validateInputFilenames($element) |
346 | or return undef ; |
347 | } |
348 | else |
349 | { |
350 | $self->croakError("not a filename") ; |
351 | } |
352 | } |
353 | |
354 | return 1 ; |
355 | } |
356 | |
357 | #sub Validator::validateHash |
358 | #{ |
359 | # my $self = shift ; |
360 | # my $href = shift ; |
361 | # |
362 | # while (my($k, $v) = each %$href) |
363 | # { |
364 | # my $ktype = whatIsInput($k); |
365 | # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; |
366 | # |
367 | # if ($ktype ne 'filename') |
368 | # { |
369 | # return $self->saveErrorString("hash key not filename") ; |
370 | # } |
371 | # |
372 | # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; |
373 | # if (! $valid{$vtype}) |
374 | # { |
375 | # return $self->saveErrorString("hash value not ok") ; |
376 | # } |
377 | # } |
378 | # |
379 | # return $self ; |
380 | #} |
381 | |
382 | sub createSelfTiedObject |
383 | { |
384 | my $class = shift || (caller)[0] ; |
385 | my $error_ref = shift ; |
386 | |
387 | my $obj = bless Symbol::gensym(), ref($class) || $class; |
388 | tie *$obj, $obj if $] >= 5.005; |
389 | *$obj->{Closed} = 1 ; |
390 | $$error_ref = ''; |
391 | *$obj->{Error} = $error_ref ; |
392 | my $errno = 0 ; |
393 | *$obj->{ErrorNo} = \$errno ; |
394 | |
395 | return $obj; |
396 | } |
397 | |
398 | |
399 | |
400 | #package Parse::Parameters ; |
401 | # |
402 | # |
403 | #require Exporter; |
404 | #our ($VERSION, @ISA, @EXPORT); |
405 | #$VERSION = '2.000_08'; |
406 | #@ISA = qw(Exporter); |
407 | |
408 | $EXPORT_TAGS{Parse} = [qw( ParseParameters |
409 | Parse_any Parse_unsigned Parse_signed |
410 | Parse_boolean Parse_custom Parse_string |
411 | Parse_store_ref |
412 | ) |
413 | ]; |
414 | |
415 | push @EXPORT, @{ $EXPORT_TAGS{Parse} } ; |
416 | |
417 | use constant Parse_any => 0x01; |
418 | use constant Parse_unsigned => 0x02; |
419 | use constant Parse_signed => 0x04; |
420 | use constant Parse_boolean => 0x08; |
421 | use constant Parse_string => 0x10; |
422 | use constant Parse_custom => 0x12; |
423 | |
424 | use constant Parse_store_ref => 0x100 ; |
425 | |
426 | use constant OFF_PARSED => 0 ; |
427 | use constant OFF_TYPE => 1 ; |
428 | use constant OFF_DEFAULT => 2 ; |
429 | use constant OFF_FIXED => 3 ; |
430 | use constant OFF_FIRST_ONLY => 4 ; |
431 | use constant OFF_STICKY => 5 ; |
432 | |
433 | |
434 | |
435 | sub ParseParameters |
436 | { |
437 | my $level = shift || 0 ; |
438 | |
439 | my $sub = (caller($level + 1))[3] ; |
440 | local $Carp::CarpLevel = 1 ; |
441 | my $p = new IO::Compress::Base::Parameters() ; |
442 | $p->parse(@_) |
443 | or croak "$sub: $p->{Error}" ; |
444 | |
445 | return $p; |
446 | } |
447 | |
448 | #package IO::Compress::Base::Parameters; |
449 | |
450 | use strict; |
451 | use warnings; |
452 | use Carp; |
453 | |
454 | sub IO::Compress::Base::Parameters::new |
455 | { |
456 | my $class = shift ; |
457 | |
458 | my $obj = { Error => '', |
459 | Got => {}, |
460 | } ; |
461 | |
462 | #return bless $obj, ref($class) || $class || __PACKAGE__ ; |
463 | return bless $obj, 'IO::Compress::Base::Parameters' ; |
464 | } |
465 | |
466 | sub IO::Compress::Base::Parameters::setError |
467 | { |
468 | my $self = shift ; |
469 | my $error = shift ; |
470 | my $retval = @_ ? shift : undef ; |
471 | |
472 | $self->{Error} = $error ; |
473 | return $retval; |
474 | } |
475 | |
476 | #sub getError |
477 | #{ |
478 | # my $self = shift ; |
479 | # return $self->{Error} ; |
480 | #} |
481 | |
482 | sub IO::Compress::Base::Parameters::parse |
483 | { |
484 | my $self = shift ; |
485 | |
486 | my $default = shift ; |
487 | |
488 | my $got = $self->{Got} ; |
489 | my $firstTime = keys %{ $got } == 0 ; |
490 | |
491 | my (@Bad) ; |
492 | my @entered = () ; |
493 | |
494 | # Allow the options to be passed as a hash reference or |
495 | # as the complete hash. |
496 | if (@_ == 0) { |
497 | @entered = () ; |
498 | } |
499 | elsif (@_ == 1) { |
500 | my $href = $_[0] ; |
501 | return $self->setError("Expected even number of parameters, got 1") |
502 | if ! defined $href or ! ref $href or ref $href ne "HASH" ; |
503 | |
504 | foreach my $key (keys %$href) { |
505 | push @entered, $key ; |
506 | push @entered, \$href->{$key} ; |
507 | } |
508 | } |
509 | else { |
510 | my $count = @_; |
511 | return $self->setError("Expected even number of parameters, got $count") |
512 | if $count % 2 != 0 ; |
513 | |
514 | for my $i (0.. $count / 2 - 1) { |
515 | push @entered, $_[2* $i] ; |
516 | push @entered, \$_[2* $i+1] ; |
517 | } |
518 | } |
519 | |
520 | |
521 | while (my ($key, $v) = each %$default) |
522 | { |
523 | croak "need 4 params [@$v]" |
524 | if @$v != 4 ; |
525 | |
526 | my ($first_only, $sticky, $type, $value) = @$v ; |
527 | my $x ; |
528 | $self->_checkType($key, \$value, $type, 0, \$x) |
529 | or return undef ; |
530 | |
531 | $key = lc $key; |
532 | |
533 | if ($firstTime || ! $sticky) { |
534 | $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; |
535 | } |
536 | |
537 | $got->{$key}[OFF_PARSED] = 0 ; |
538 | } |
539 | |
540 | for my $i (0.. @entered / 2 - 1) { |
541 | my $key = $entered[2* $i] ; |
542 | my $value = $entered[2* $i+1] ; |
543 | |
544 | #print "Key [$key] Value [$value]" ; |
545 | #print defined $$value ? "[$$value]\n" : "[undef]\n"; |
546 | |
547 | $key =~ s/^-// ; |
548 | my $canonkey = lc $key; |
549 | |
550 | if ($got->{$canonkey} && ($firstTime || |
551 | ! $got->{$canonkey}[OFF_FIRST_ONLY] )) |
552 | { |
553 | my $type = $got->{$canonkey}[OFF_TYPE] ; |
554 | my $s ; |
555 | $self->_checkType($key, $value, $type, 1, \$s) |
556 | or return undef ; |
557 | #$value = $$value unless $type & Parse_store_ref ; |
558 | $value = $$value ; |
559 | $got->{$canonkey} = [1, $type, $value, $s] ; |
560 | } |
561 | else |
562 | { push (@Bad, $key) } |
563 | } |
564 | |
565 | if (@Bad) { |
566 | my ($bad) = join(", ", @Bad) ; |
567 | return $self->setError("unknown key value(s) @Bad") ; |
568 | } |
569 | |
570 | return 1; |
571 | } |
572 | |
573 | sub IO::Compress::Base::Parameters::_checkType |
574 | { |
575 | my $self = shift ; |
576 | |
577 | my $key = shift ; |
578 | my $value = shift ; |
579 | my $type = shift ; |
580 | my $validate = shift ; |
581 | my $output = shift; |
582 | |
583 | #local $Carp::CarpLevel = $level ; |
584 | #print "PARSE $type $key $value $validate $sub\n" ; |
585 | if ( $type & Parse_store_ref) |
586 | { |
587 | #$value = $$value |
588 | # if ref ${ $value } ; |
589 | |
590 | $$output = $value ; |
591 | return 1; |
592 | } |
593 | |
594 | $value = $$value ; |
595 | |
596 | if ($type & Parse_any) |
597 | { |
598 | $$output = $value ; |
599 | return 1; |
600 | } |
601 | elsif ($type & Parse_unsigned) |
602 | { |
603 | return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") |
604 | if $validate && ! defined $value ; |
605 | return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") |
606 | if $validate && $value !~ /^\d+$/; |
607 | |
608 | $$output = defined $value ? $value : 0 ; |
609 | return 1; |
610 | } |
611 | elsif ($type & Parse_signed) |
612 | { |
613 | return $self->setError("Parameter '$key' must be a signed int, got 'undef'") |
614 | if $validate && ! defined $value ; |
615 | return $self->setError("Parameter '$key' must be a signed int, got '$value'") |
616 | if $validate && $value !~ /^-?\d+$/; |
617 | |
618 | $$output = defined $value ? $value : 0 ; |
619 | return 1 ; |
620 | } |
621 | elsif ($type & Parse_boolean) |
622 | { |
623 | return $self->setError("Parameter '$key' must be an int, got '$value'") |
624 | if $validate && defined $value && $value !~ /^\d*$/; |
625 | $$output = defined $value ? $value != 0 : 0 ; |
626 | return 1; |
627 | } |
628 | elsif ($type & Parse_string) |
629 | { |
630 | $$output = defined $value ? $value : "" ; |
631 | return 1; |
632 | } |
633 | |
634 | $$output = $value ; |
635 | return 1; |
636 | } |
637 | |
638 | |
639 | |
640 | sub IO::Compress::Base::Parameters::parsed |
641 | { |
642 | my $self = shift ; |
643 | my $name = shift ; |
644 | |
645 | return $self->{Got}{lc $name}[OFF_PARSED] ; |
646 | } |
647 | |
648 | sub IO::Compress::Base::Parameters::value |
649 | { |
650 | my $self = shift ; |
651 | my $name = shift ; |
652 | |
653 | if (@_) |
654 | { |
655 | $self->{Got}{lc $name}[OFF_PARSED] = 1; |
656 | $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ; |
657 | $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ; |
658 | } |
659 | |
660 | return $self->{Got}{lc $name}[OFF_FIXED] ; |
661 | } |
662 | |
663 | sub IO::Compress::Base::Parameters::valueOrDefault |
664 | { |
665 | my $self = shift ; |
666 | my $name = shift ; |
667 | my $default = shift ; |
668 | |
669 | my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ; |
670 | |
671 | return $value if defined $value ; |
672 | return $default ; |
673 | } |
674 | |
675 | sub IO::Compress::Base::Parameters::wantValue |
676 | { |
677 | my $self = shift ; |
678 | my $name = shift ; |
679 | |
680 | return defined $self->{Got}{lc $name}[OFF_DEFAULT] ; |
681 | |
682 | } |
683 | |
684 | sub IO::Compress::Base::Parameters::clone |
685 | { |
686 | my $self = shift ; |
687 | my $obj = { }; |
688 | my %got ; |
689 | |
690 | while (my ($k, $v) = each %{ $self->{Got} }) { |
691 | $got{$k} = [ @$v ]; |
692 | } |
693 | |
694 | $obj->{Error} = $self->{Error}; |
695 | $obj->{Got} = \%got ; |
696 | |
697 | return bless $obj, 'IO::Compress::Base::Parameters' ; |
698 | } |
699 | |
700 | package IO::Compress::Base::Common; |
701 | |
702 | 1; |