1 package IO::Compress::Base::Common;
8 use Scalar::Util qw(blessed readonly);
12 our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS);
14 $VERSION = '2.000_10';
16 @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
17 isaFileGlobString cleanFileGlobString oneTarget
18 setBinModeInput setBinModeOutput
33 %EXPORT_TAGS = ( Status => [qw( STATUS_OK
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;
50 $needBinmode = ($^O eq 'MSWin32' ||
51 ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
54 sub setBinModeInput($)
62 sub setBinModeOutput($)
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]) )
80 return (defined $_[0] and
82 UNIVERSAL::isa(\$_[0], 'SCALAR'));
87 return defined $_[0] && $_[0] =~ /^<.*>$/;
90 sub cleanFileGlobString
94 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
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 ;
107 my $got = whatIs(@_);
109 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
114 $_[0] = new IO::File("<-");
120 sub whatIsOutput($;$)
122 my $got = whatIs(@_);
124 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
128 $_[0] = new IO::File(">-");
136 return 'handle' if isaFilehandle($_[0]);
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 ;
143 return 'undef' if ! defined $_[0] && $undef ;
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 ;
155 return 'fileglob' if $extended && isaFileGlobString($_[0]);
161 return $_[0] =~ /^(code|handle|buffer|filename)$/;
169 my $error_ref = shift ;
170 my $reportClass = shift ;
172 my %data = (Class => $Class,
174 reportClass => $reportClass,
177 my $obj = bless \%data, $class ;
179 local $Carp::CarpLevel = 1;
181 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
182 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
184 my $oneInput = $data{oneInput} = oneTarget($inType);
185 my $oneOutput = $data{oneOutput} = oneTarget($outType);
189 $obj->croakError("$reportClass: illegal input parameter") ;
193 # if ($inType eq 'hash')
196 # $obj->{oneInput} = 1 ;
197 # return $obj->validateHash($_[0]);
202 $obj->croakError("$reportClass: illegal output parameter") ;
207 if ($inType ne 'fileglob' && $outType eq 'fileglob')
209 $obj->croakError("Need input fileglob for outout fileglob");
212 # if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
214 # $obj->croakError("input must ne filename or fileglob when output is a hash");
217 if ($inType eq 'fileglob' && $outType eq 'fileglob')
220 $data{inType} = $data{outType} = 'filename';
221 my $mapper = new File::GlobMapper($_[0], $_[1]);
224 return $obj->saveErrorString($File::GlobMapper::Error) ;
226 $data{Pairs} = $mapper->getFileMap();
231 $obj->croakError("$reportClass: input and output $inType are identical")
232 if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
234 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
236 my $glob = cleanFileGlobString($_[0]);
237 my @inputs = glob($glob);
241 # TODO -- legal or die?
242 die "globmap matched zero file -- legal or die???" ;
246 $obj->validateInputFilenames($inputs[0])
249 $data{inType} = 'filename' ;
254 $obj->validateInputFilenames(@inputs)
256 $_[0] = [ @inputs ] ;
257 $data{inType} = 'filenames' ;
260 elsif ($inType eq 'filename')
262 $obj->validateInputFilenames($_[0])
265 elsif ($inType eq 'array')
267 $data{inType} = 'filenames' ;
268 $obj->validateInputArray($_[0])
272 return $obj->saveErrorString("$reportClass: output buffer is read-only")
273 if $outType eq 'buffer' && readonly(${ $_[1] });
275 if ($outType eq 'filename' )
277 $obj->croakError("$reportClass: output filename is undef or null string")
278 if ! defined $_[1] || $_[1] eq '' ;
284 sub Validator::saveErrorString
287 ${ $self->{Error} } = shift ;
292 sub Validator::croakError
295 $self->saveErrorString($_[0]);
301 sub Validator::validateInputFilenames
305 foreach my $filename (@_)
307 $self->croakError("$self->{reportClass}: input filename is undef or null string")
308 if ! defined $filename || $filename eq '' ;
310 next if $filename eq '-';
314 return $self->saveErrorString("input file '$filename' does not exist");
319 return $self->saveErrorString("cannot open file '$filename': $!");
326 sub Validator::validateInputArray
330 if ( @{ $_[0] } == 0 )
332 return $self->saveErrorString("empty array reference") ;
335 foreach my $element ( @{ $_[0] } )
337 my $inType = whatIsInput($element);
341 $self->croakError("unknown input parameter") ;
343 elsif($inType eq 'filename')
345 $self->validateInputFilenames($element)
350 $self->croakError("not a filename") ;
357 #sub Validator::validateHash
362 # while (my($k, $v) = each %$href)
364 # my $ktype = whatIsInput($k);
365 # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
367 # if ($ktype ne 'filename')
369 # return $self->saveErrorString("hash key not filename") ;
372 # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
373 # if (! $valid{$vtype})
375 # return $self->saveErrorString("hash value not ok") ;
382 sub createSelfTiedObject
384 my $class = shift || (caller)[0] ;
385 my $error_ref = shift ;
387 my $obj = bless Symbol::gensym(), ref($class) || $class;
388 tie *$obj, $obj if $] >= 5.005;
389 *$obj->{Closed} = 1 ;
391 *$obj->{Error} = $error_ref ;
393 *$obj->{ErrorNo} = \$errno ;
400 #package Parse::Parameters ;
404 #our ($VERSION, @ISA, @EXPORT);
405 #$VERSION = '2.000_08';
406 #@ISA = qw(Exporter);
408 $EXPORT_TAGS{Parse} = [qw( ParseParameters
409 Parse_any Parse_unsigned Parse_signed
410 Parse_boolean Parse_custom Parse_string
415 push @EXPORT, @{ $EXPORT_TAGS{Parse} } ;
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;
424 use constant Parse_store_ref => 0x100 ;
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 ;
437 my $level = shift || 0 ;
439 my $sub = (caller($level + 1))[3] ;
440 local $Carp::CarpLevel = 1 ;
441 my $p = new IO::Compress::Base::Parameters() ;
443 or croak "$sub: $p->{Error}" ;
448 #package IO::Compress::Base::Parameters;
454 sub IO::Compress::Base::Parameters::new
458 my $obj = { Error => '',
462 #return bless $obj, ref($class) || $class || __PACKAGE__ ;
463 return bless $obj, 'IO::Compress::Base::Parameters' ;
466 sub IO::Compress::Base::Parameters::setError
470 my $retval = @_ ? shift : undef ;
472 $self->{Error} = $error ;
479 # return $self->{Error} ;
482 sub IO::Compress::Base::Parameters::parse
486 my $default = shift ;
488 my $got = $self->{Got} ;
489 my $firstTime = keys %{ $got } == 0 ;
494 # Allow the options to be passed as a hash reference or
495 # as the complete hash.
501 return $self->setError("Expected even number of parameters, got 1")
502 if ! defined $href or ! ref $href or ref $href ne "HASH" ;
504 foreach my $key (keys %$href) {
505 push @entered, $key ;
506 push @entered, \$href->{$key} ;
511 return $self->setError("Expected even number of parameters, got $count")
514 for my $i (0.. $count / 2 - 1) {
515 push @entered, $_[2* $i] ;
516 push @entered, \$_[2* $i+1] ;
521 while (my ($key, $v) = each %$default)
523 croak "need 4 params [@$v]"
526 my ($first_only, $sticky, $type, $value) = @$v ;
528 $self->_checkType($key, \$value, $type, 0, \$x)
533 if ($firstTime || ! $sticky) {
534 $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ;
537 $got->{$key}[OFF_PARSED] = 0 ;
540 for my $i (0.. @entered / 2 - 1) {
541 my $key = $entered[2* $i] ;
542 my $value = $entered[2* $i+1] ;
544 #print "Key [$key] Value [$value]" ;
545 #print defined $$value ? "[$$value]\n" : "[undef]\n";
548 my $canonkey = lc $key;
550 if ($got->{$canonkey} && ($firstTime ||
551 ! $got->{$canonkey}[OFF_FIRST_ONLY] ))
553 my $type = $got->{$canonkey}[OFF_TYPE] ;
555 $self->_checkType($key, $value, $type, 1, \$s)
557 #$value = $$value unless $type & Parse_store_ref ;
559 $got->{$canonkey} = [1, $type, $value, $s] ;
562 { push (@Bad, $key) }
566 my ($bad) = join(", ", @Bad) ;
567 return $self->setError("unknown key value(s) @Bad") ;
573 sub IO::Compress::Base::Parameters::_checkType
580 my $validate = shift ;
583 #local $Carp::CarpLevel = $level ;
584 #print "PARSE $type $key $value $validate $sub\n" ;
585 if ( $type & Parse_store_ref)
588 # if ref ${ $value } ;
596 if ($type & Parse_any)
601 elsif ($type & Parse_unsigned)
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+$/;
608 $$output = defined $value ? $value : 0 ;
611 elsif ($type & Parse_signed)
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+$/;
618 $$output = defined $value ? $value : 0 ;
621 elsif ($type & Parse_boolean)
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 ;
628 elsif ($type & Parse_string)
630 $$output = defined $value ? $value : "" ;
640 sub IO::Compress::Base::Parameters::parsed
645 return $self->{Got}{lc $name}[OFF_PARSED] ;
648 sub IO::Compress::Base::Parameters::value
655 $self->{Got}{lc $name}[OFF_PARSED] = 1;
656 $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ;
657 $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ;
660 return $self->{Got}{lc $name}[OFF_FIXED] ;
663 sub IO::Compress::Base::Parameters::valueOrDefault
667 my $default = shift ;
669 my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ;
671 return $value if defined $value ;
675 sub IO::Compress::Base::Parameters::wantValue
680 return defined $self->{Got}{lc $name}[OFF_DEFAULT] ;
684 sub IO::Compress::Base::Parameters::clone
690 while (my ($k, $v) = each %{ $self->{Got} }) {
694 $obj->{Error} = $self->{Error};
695 $obj->{Got} = \%got ;
697 return bless $obj, 'IO::Compress::Base::Parameters' ;
700 package IO::Compress::Base::Common;