1 package Compress::Zlib::Common;
8 use Scalar::Util qw(blessed readonly);
12 our ($VERSION, @ISA, @EXPORT);
14 $VERSION = '2.000_05';
16 @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam
17 isaFileGlobString cleanFileGlobString oneTarget
18 setBinModeInput setBinModeOutput
19 ckOutputParam ckInOutParams
26 sub setBinModeInput($)
30 binmode $handle unless $^O eq 'MSWin32' ;
31 #binmode $handle if $] == 5.008 ;
32 #binmode $handle unless isSTDIN($handle) ;
35 sub setBinModeOutput($)
39 #binmode $handle if $] == 5.008;
40 #binmode $handle unless isSTDOUT($handle) ;
45 # my $handle = shift ;
47 # return 0 unless isaFilehandle($handle);
48 # return fileno $handle == fileno STDIN || fileno $handle == fileno STDOUT;
53 # my $handle = shift ;
55 # return 0 unless isaFilehandle($handle);
56 # return fileno $handle == fileno STDIN;
61 # my $handle = shift ;
63 # return 0 unless isaFilehandle($handle);
64 # return fileno $handle == fileno STDOUT;
69 use utf8; # Pragma needed to keep Perl 5.6.0 happy
70 return (defined $_[0] and
71 (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB'))
72 and defined fileno($_[0]) )
77 return (defined $_[0] and
79 UNIVERSAL::isa(\$_[0], 'SCALAR'));
84 return defined $_[0] && $_[0] =~ /^<.*>$/;
87 sub cleanFileGlobString
91 $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/;
96 use constant WANT_CODE => 1 ;
97 use constant WANT_EXT => 2 ;
98 use constant WANT_UNDEF => 4 ;
99 use constant WANT_HASH => 8 ;
103 my $got = whatIs(@_);
105 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
110 $_[0] = new IO::File("<-");
116 sub whatIsOutput($;$)
118 my $got = whatIs(@_);
120 if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-')
124 $_[0] = new IO::File(">-");
132 return 'handle' if isaFilehandle($_[0]);
134 my $wantCode = defined $_[1] && $_[1] & WANT_CODE ;
135 my $extended = defined $_[1] && $_[1] & WANT_EXT ;
136 my $undef = defined $_[1] && $_[1] & WANT_UNDEF ;
137 my $hash = defined $_[1] && $_[1] & WANT_HASH ;
139 return 'undef' if ! defined $_[0] && $undef ;
142 return '' if blessed($_[0]); # is an object
143 #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object
144 return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR');
145 return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ;
146 return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ;
147 return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ;
151 return 'fileglob' if $extended && isaFileGlobString($_[0]);
157 return $_[0] =~ /^(code|handle|buffer|filename)$/;
160 sub ckInputParam ($$$;$)
163 my $inType = whatIsInput($_[0], $_[2]);
164 local $Carp::CarpLevel = 1;
166 croak "$from: input parameter not a filename, filehandle, array ref or scalar ref"
169 if ($inType eq 'filename' )
171 croak "$from: input filename is undef or null string"
172 if ! defined $_[0] || $_[0] eq '' ;
174 if ($_[0] ne '-' && ! -e $_[0] )
176 ${$_[1]} = "input file '$_[0]' does not exist";
184 sub ckOutputParam ($$$)
187 my $outType = whatIsOutput($_[0]);
188 local $Carp::CarpLevel = 1;
190 croak "$from: output parameter not a filename, filehandle or scalar ref"
193 croak "$from: output filename is undef or null string"
194 if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ;
196 croak("$from: output buffer is read-only")
197 if $outType eq 'buffer' && readonly(${ $_[0] });
202 #sub ckInOutParams($$$$)
206 # ckInputParam($from, $_[0], $_[2])
208 # ckOutputParam($from, $_[1], $_[2])
211 # my $inType = whatIs($_[0]);
212 # my $outType = whatIs($_[1]);
214 # # Check that input != output
215 # if ($inType eq $outType && $_[0] eq $_[1])
217 # local $Carp::CarpLevel = 1;
218 # croak("$from: input and output $inType are identical");
231 my $error_ref = shift ;
232 my $reportClass = shift ;
234 my %data = (Class => $Class,
237 reportClass => $reportClass,
240 my $obj = bless \%data, $class ;
242 local $Carp::CarpLevel = 1;
244 my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH);
245 my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH);
247 my $oneInput = $data{oneInput} = oneTarget($inType);
248 my $oneOutput = $data{oneOutput} = oneTarget($outType);
252 croak "$reportClass: illegal input parameter" ;
256 if ($inType eq 'hash')
259 $obj->{oneInput} = 1 ;
260 return $obj->validateHash($_[0]);
265 croak "$reportClass: illegal output parameter" ;
270 if ($inType ne 'fileglob' && $outType eq 'fileglob')
272 ${ $data{Error} } = "Need input fileglob for outout fileglob";
276 if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' )
278 ${ $data{Error} } = "input must ne filename or fileglob when output is a hash";
282 if ($inType eq 'fileglob' && $outType eq 'fileglob')
285 $data{inType} = $data{outType} = 'filename';
286 my $mapper = new File::GlobMapper($_[0], $_[1]);
289 ${ $data{Error} } = $File::GlobMapper::Error ;
292 $data{Pairs} = $mapper->getFileMap();
297 croak("$reportClass: input and output $inType are identical")
298 if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ;
300 if ($inType eq 'fileglob') # && $outType ne 'fileglob'
302 my $glob = cleanFileGlobString($_[0]);
303 my @inputs = glob($glob);
308 die "legal or die???" ;
312 $obj->validateInputFilenames($inputs[0])
315 $data{inType} = 'filename' ;
320 $obj->validateInputFilenames(@inputs)
322 $_[0] = [ @inputs ] ;
323 $data{inType} = 'filenames' ;
326 elsif ($inType eq 'filename')
328 $obj->validateInputFilenames($_[0])
331 elsif ($inType eq 'array')
333 $obj->validateInputArray($_[0])
337 croak("$reportClass: output buffer is read-only")
338 if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]);
340 if ($outType eq 'filename' )
342 croak "$reportClass: output filename is undef or null string"
343 if ! defined $_[1] || $_[1] eq '' ;
350 sub Validator::validateInputFilenames
354 foreach my $filename (@_)
356 croak "$self->{reportClass}: input filename is undef or null string"
357 if ! defined $filename || $filename eq '' ;
359 next if $filename eq '-';
363 ${ $self->{Error} } = "input file '$filename' does not exist";
369 ${ $self->{Error} } = "cannot open file '$filename': $!";
377 sub Validator::validateInputArray
381 foreach my $element ( @{ $_[0] } )
383 my $inType = whatIsInput($element);
387 ${ $self->{Error} } = "unknown input parameter" ;
395 sub Validator::validateHash
400 while (my($k, $v) = each %$href)
402 my $ktype = whatIsInput($k);
403 my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ;
405 if ($ktype ne 'filename')
407 ${ $self->{Error} } = "hash key not filename" ;
411 my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ;
412 if (! $valid{$vtype})
414 ${ $self->{Error} } = "hash value not ok" ;