1 package Compress::Zlib::Common;
8 use Scalar::Util qw(blessed readonly);
12 our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS);
14 $VERSION = '2.000_07';
16 @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput
17 isaFileGlobString cleanFileGlobString oneTarget
18 setBinModeInput setBinModeOutput
32 %EXPORT_TAGS = ( Status => [qw( STATUS_OK
38 use constant STATUS_OK => 0;
39 use constant STATUS_ENDSTREAM => 1;
40 use constant STATUS_ERROR => 2;
43 $needBinmode = ($^O eq 'MSWin32' ||
44 ($] >= 5.006 && eval ' ${^UNICODE} || ${^UTF8LOCALE} '))
47 sub setBinModeInput($)
55 sub setBinModeOutput($)
65 use utf8; # Pragma needed to keep Perl 5.6.0 happy
66 return (defined $_[0] and
67 (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB'))
68 and defined fileno($_[0]) )
73 return (defined $_[0] and
75 UNIVERSAL::isa(\$_[0], 'SCALAR'));
80 return defined $_[0] && $_[0] =~ /^<.*>$/;
83 sub cleanFileGlobString
87 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
92 use constant WANT_CODE => 1 ;
93 use constant WANT_EXT => 2 ;
94 use constant WANT_UNDEF => 4 ;
95 #use constant WANT_HASH => 8 ;
96 use constant WANT_HASH => 0 ;
100 my $got = whatIs(@_);
102 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
107 $_[0] = new IO::File("<-");
113 sub whatIsOutput($;$)
115 my $got = whatIs(@_);
117 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
121 $_[0] = new IO::File(">-");
129 return 'handle' if isaFilehandle($_[0]);
131 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
132 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
133 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
134 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
136 return 'undef' if ! defined $_[0] && $undef ;
139 return '' if blessed($_[0]); # is an object
140 #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
141 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
142 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
143 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
144 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
148 return 'fileglob' if $extended && isaFileGlobString($_[0]);
154 return $_[0] =~ /^(code|handle|buffer|filename)$/;
162 my $error_ref = shift ;
163 my $reportClass = shift ;
165 my %data = (Class => $Class,
167 reportClass => $reportClass,
170 my $obj = bless \%data, $class ;
172 local $Carp::CarpLevel = 1;
174 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
175 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
177 my $oneInput = $data{oneInput} = oneTarget($inType);
178 my $oneOutput = $data{oneOutput} = oneTarget($outType);
182 $obj->croakError("$reportClass: illegal input parameter") ;
186 # if ($inType eq 'hash')
189 # $obj->{oneInput} = 1 ;
190 # return $obj->validateHash($_[0]);
195 $obj->croakError("$reportClass: illegal output parameter") ;
200 if ($inType ne 'fileglob' && $outType eq 'fileglob')
202 $obj->croakError("Need input fileglob for outout fileglob");
205 # if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
207 # $obj->croakError("input must ne filename or fileglob when output is a hash");
210 if ($inType eq 'fileglob' && $outType eq 'fileglob')
213 $data{inType} = $data{outType} = 'filename';
214 my $mapper = new File::GlobMapper($_[0], $_[1]);
217 return $obj->saveErrorString($File::GlobMapper::Error) ;
219 $data{Pairs} = $mapper->getFileMap();
224 $obj->croakError("$reportClass: input and output $inType are identical")
225 if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
227 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
229 my $glob = cleanFileGlobString($_[0]);
230 my @inputs = glob($glob);
234 # TODO -- legal or die?
235 die "globmap matched zero file -- legal or die???" ;
239 $obj->validateInputFilenames($inputs[0])
242 $data{inType} = 'filename' ;
247 $obj->validateInputFilenames(@inputs)
249 $_[0] = [ @inputs ] ;
250 $data{inType} = 'filenames' ;
253 elsif ($inType eq 'filename')
255 $obj->validateInputFilenames($_[0])
258 elsif ($inType eq 'array')
260 $data{inType} = 'filenames' ;
261 $obj->validateInputArray($_[0])
265 return $obj->saveErrorString("$reportClass: output buffer is read-only")
266 if $outType eq 'buffer' && readonly(${ $_[1] });
268 if ($outType eq 'filename' )
270 $obj->croakError("$reportClass: output filename is undef or null string")
271 if ! defined $_[1] || $_[1] eq '' ;
277 sub Validator::saveErrorString
280 ${ $self->{Error} } = shift ;
285 sub Validator::croakError
288 $self->saveErrorString($_[0]);
294 sub Validator::validateInputFilenames
298 foreach my $filename (@_)
300 $self->croakError("$self->{reportClass}: input filename is undef or null string")
301 if ! defined $filename || $filename eq '' ;
303 next if $filename eq '-';
307 return $self->saveErrorString("input file '$filename' does not exist");
312 return $self->saveErrorString("cannot open file '$filename': $!");
319 sub Validator::validateInputArray
323 if ( @{ $_[0] } == 0 )
325 return $self->saveErrorString("empty array reference") ;
328 foreach my $element ( @{ $_[0] } )
330 my $inType = whatIsInput($element);
334 $self->croakError("unknown input parameter") ;
336 elsif($inType eq 'filename')
338 $self->validateInputFilenames($element)
343 $self->croakError("not a filename") ;
350 #sub Validator::validateHash
355 # while (my($k, $v) = each %$href)
357 # my $ktype = whatIsInput($k);
358 # my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
360 # if ($ktype ne 'filename')
362 # return $self->saveErrorString("hash key not filename") ;
365 # my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
366 # if (! $valid{$vtype})
368 # return $self->saveErrorString("hash value not ok") ;
375 sub createSelfTiedObject
377 my $class = shift || (caller)[0] ;
378 my $error_ref = shift ;
380 my $obj = bless Symbol::gensym(), ref($class) || $class;
381 tie *$obj, $obj if $] >= 5.005;
382 *$obj->{Closed} = 1 ;
384 *$obj->{Error} = $error_ref ;
386 *$obj->{ErrorNo} = \$errno ;