Commit | Line | Data |
642e522c |
1 | package Compress::Zlib::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); |
13 | @ISA = qw(Exporter); |
14 | $VERSION = '2.000_05'; |
15 | |
16 | @EXPORT = qw( isaFilehandle isaFilename whatIsInput whatIsOutput ckInputParam |
17 | isaFileGlobString cleanFileGlobString oneTarget |
18 | setBinModeInput setBinModeOutput |
19 | ckOutputParam ckInOutParams |
20 | WANT_CODE |
21 | WANT_EXT |
22 | WANT_UNDEF |
23 | WANT_HASH |
24 | ); |
25 | |
26 | sub setBinModeInput($) |
27 | { |
28 | my $handle = shift ; |
29 | |
0e28d6a3 |
30 | binmode $handle |
31 | unless $^O eq 'MSWin32' && ! ( ${^UNICODE} || ${^UTF8LOCALE} ); |
642e522c |
32 | } |
33 | |
34 | sub setBinModeOutput($) |
35 | { |
36 | my $handle = shift ; |
37 | |
0e28d6a3 |
38 | binmode $handle |
39 | unless $^O eq 'MSWin32' && ! ( ${^UNICODE} || ${^UTF8LOCALE} ); |
642e522c |
40 | } |
41 | |
642e522c |
42 | sub isaFilehandle($) |
43 | { |
44 | use utf8; # Pragma needed to keep Perl 5.6.0 happy |
45 | return (defined $_[0] and |
46 | (UNIVERSAL::isa($_[0],'GLOB') or UNIVERSAL::isa(\$_[0],'GLOB')) |
47 | and defined fileno($_[0]) ) |
48 | } |
49 | |
50 | sub isaFilename($) |
51 | { |
52 | return (defined $_[0] and |
53 | ! ref $_[0] and |
54 | UNIVERSAL::isa(\$_[0], 'SCALAR')); |
55 | } |
56 | |
57 | sub isaFileGlobString |
58 | { |
59 | return defined $_[0] && $_[0] =~ /^<.*>$/; |
60 | } |
61 | |
62 | sub cleanFileGlobString |
63 | { |
64 | my $string = shift ; |
65 | |
66 | $string =~ s/^\s*<\s*(.*)\s*>\s*$/$1/; |
67 | |
68 | return $string; |
69 | } |
70 | |
71 | use constant WANT_CODE => 1 ; |
72 | use constant WANT_EXT => 2 ; |
73 | use constant WANT_UNDEF => 4 ; |
74 | use constant WANT_HASH => 8 ; |
75 | |
76 | sub whatIsInput($;$) |
77 | { |
78 | my $got = whatIs(@_); |
79 | #return $got; |
80 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') |
81 | { |
82 | use IO::File; |
83 | $got = 'handle'; |
84 | #$_[0] = \*STDIN; |
85 | $_[0] = new IO::File("<-"); |
86 | } |
87 | |
88 | return $got; |
89 | } |
90 | |
91 | sub whatIsOutput($;$) |
92 | { |
93 | my $got = whatIs(@_); |
94 | #return $got; |
95 | if (defined $got && $got eq 'filename' && defined $_[0] && $_[0] eq '-') |
96 | { |
97 | $got = 'handle'; |
98 | #$_[0] = \*STDOUT; |
99 | $_[0] = new IO::File(">-"); |
100 | } |
101 | |
102 | return $got; |
103 | } |
104 | |
105 | sub whatIs ($;$) |
106 | { |
107 | return 'handle' if isaFilehandle($_[0]); |
108 | |
109 | my $wantCode = defined $_[1] && $_[1] & WANT_CODE ; |
110 | my $extended = defined $_[1] && $_[1] & WANT_EXT ; |
111 | my $undef = defined $_[1] && $_[1] & WANT_UNDEF ; |
112 | my $hash = defined $_[1] && $_[1] & WANT_HASH ; |
113 | |
114 | return 'undef' if ! defined $_[0] && $undef ; |
115 | |
116 | if (ref $_[0]) { |
117 | return '' if blessed($_[0]); # is an object |
118 | #return '' if UNIVERSAL::isa($_[0], 'UNIVERSAL'); # is an object |
119 | return 'buffer' if UNIVERSAL::isa($_[0], 'SCALAR'); |
120 | return 'array' if UNIVERSAL::isa($_[0], 'ARRAY') && $extended ; |
121 | return 'hash' if UNIVERSAL::isa($_[0], 'HASH') && $hash ; |
122 | return 'code' if UNIVERSAL::isa($_[0], 'CODE') && $wantCode ; |
123 | return ''; |
124 | } |
125 | |
126 | return 'fileglob' if $extended && isaFileGlobString($_[0]); |
127 | return 'filename'; |
128 | } |
129 | |
130 | sub oneTarget |
131 | { |
132 | return $_[0] =~ /^(code|handle|buffer|filename)$/; |
133 | } |
134 | |
135 | sub ckInputParam ($$$;$) |
136 | { |
137 | my $from = shift ; |
138 | my $inType = whatIsInput($_[0], $_[2]); |
139 | local $Carp::CarpLevel = 1; |
140 | |
141 | croak "$from: input parameter not a filename, filehandle, array ref or scalar ref" |
142 | if ! $inType ; |
143 | |
144 | if ($inType eq 'filename' ) |
145 | { |
146 | croak "$from: input filename is undef or null string" |
147 | if ! defined $_[0] || $_[0] eq '' ; |
148 | |
149 | if ($_[0] ne '-' && ! -e $_[0] ) |
150 | { |
151 | ${$_[1]} = "input file '$_[0]' does not exist"; |
152 | return undef; |
153 | } |
154 | } |
155 | |
156 | return 1; |
157 | } |
158 | |
159 | sub ckOutputParam ($$$) |
160 | { |
161 | my $from = shift ; |
162 | my $outType = whatIsOutput($_[0]); |
163 | local $Carp::CarpLevel = 1; |
164 | |
165 | croak "$from: output parameter not a filename, filehandle or scalar ref" |
166 | if ! $outType ; |
167 | |
168 | croak "$from: output filename is undef or null string" |
169 | if $outType eq 'filename' && (! defined $_[0] || $_[0] eq '') ; |
170 | |
171 | croak("$from: output buffer is read-only") |
172 | if $outType eq 'buffer' && readonly(${ $_[0] }); |
173 | |
174 | return 1; |
175 | } |
176 | |
642e522c |
177 | sub Validator::new |
178 | { |
179 | my $class = shift ; |
180 | |
181 | my $Class = shift ; |
182 | my $type = shift ; |
183 | my $error_ref = shift ; |
184 | my $reportClass = shift ; |
185 | |
186 | my %data = (Class => $Class, |
187 | Type => $type, |
188 | Error => $error_ref, |
189 | reportClass => $reportClass, |
190 | ) ; |
191 | |
192 | my $obj = bless \%data, $class ; |
193 | |
194 | local $Carp::CarpLevel = 1; |
195 | |
196 | my $inType = $data{inType} = whatIsInput($_[0], WANT_EXT|WANT_HASH); |
197 | my $outType = $data{outType} = whatIsOutput($_[1], WANT_EXT|WANT_HASH); |
198 | |
199 | my $oneInput = $data{oneInput} = oneTarget($inType); |
200 | my $oneOutput = $data{oneOutput} = oneTarget($outType); |
201 | |
202 | if (! $inType) |
203 | { |
204 | croak "$reportClass: illegal input parameter" ; |
205 | #return undef ; |
206 | } |
207 | |
208 | if ($inType eq 'hash') |
209 | { |
210 | $obj->{Hash} = 1 ; |
211 | $obj->{oneInput} = 1 ; |
212 | return $obj->validateHash($_[0]); |
213 | } |
214 | |
215 | if (! $outType) |
216 | { |
217 | croak "$reportClass: illegal output parameter" ; |
218 | #return undef ; |
219 | } |
220 | |
221 | |
222 | if ($inType ne 'fileglob' && $outType eq 'fileglob') |
223 | { |
224 | ${ $data{Error} } = "Need input fileglob for outout fileglob"; |
225 | return undef ; |
226 | } |
227 | |
228 | if ($inType ne 'fileglob' && $outType eq 'hash' && $inType ne 'filename' ) |
229 | { |
230 | ${ $data{Error} } = "input must ne filename or fileglob when output is a hash"; |
231 | return undef ; |
232 | } |
233 | |
234 | if ($inType eq 'fileglob' && $outType eq 'fileglob') |
235 | { |
236 | $data{GlobMap} = 1 ; |
237 | $data{inType} = $data{outType} = 'filename'; |
238 | my $mapper = new File::GlobMapper($_[0], $_[1]); |
239 | if ( ! $mapper ) |
240 | { |
241 | ${ $data{Error} } = $File::GlobMapper::Error ; |
242 | return undef ; |
243 | } |
244 | $data{Pairs} = $mapper->getFileMap(); |
245 | |
246 | return $obj; |
247 | } |
248 | |
249 | croak("$reportClass: input and output $inType are identical") |
250 | if $inType eq $outType && $_[0] eq $_[1] && $_[0] ne '-' ; |
251 | |
252 | if ($inType eq 'fileglob') # && $outType ne 'fileglob' |
253 | { |
254 | my $glob = cleanFileGlobString($_[0]); |
255 | my @inputs = glob($glob); |
256 | |
257 | if (@inputs == 0) |
258 | { |
259 | # legal or die? |
260 | die "legal or die???" ; |
261 | } |
262 | elsif (@inputs == 1) |
263 | { |
264 | $obj->validateInputFilenames($inputs[0]) |
265 | or return undef; |
266 | $_[0] = $inputs[0] ; |
267 | $data{inType} = 'filename' ; |
268 | $data{oneInput} = 1; |
269 | } |
270 | else |
271 | { |
272 | $obj->validateInputFilenames(@inputs) |
273 | or return undef; |
274 | $_[0] = [ @inputs ] ; |
275 | $data{inType} = 'filenames' ; |
276 | } |
277 | } |
278 | elsif ($inType eq 'filename') |
279 | { |
280 | $obj->validateInputFilenames($_[0]) |
281 | or return undef; |
282 | } |
283 | elsif ($inType eq 'array') |
284 | { |
285 | $obj->validateInputArray($_[0]) |
286 | or return undef ; |
287 | } |
288 | |
289 | croak("$reportClass: output buffer is read-only") |
290 | if $outType eq 'buffer' && Compress::Zlib::_readonly_ref($_[1]); |
291 | |
292 | if ($outType eq 'filename' ) |
293 | { |
294 | croak "$reportClass: output filename is undef or null string" |
295 | if ! defined $_[1] || $_[1] eq '' ; |
296 | } |
297 | |
298 | return $obj ; |
299 | } |
300 | |
301 | |
302 | sub Validator::validateInputFilenames |
303 | { |
304 | my $self = shift ; |
305 | |
306 | foreach my $filename (@_) |
307 | { |
308 | croak "$self->{reportClass}: input filename is undef or null string" |
309 | if ! defined $filename || $filename eq '' ; |
310 | |
311 | next if $filename eq '-'; |
312 | |
313 | if (! -e $filename ) |
314 | { |
315 | ${ $self->{Error} } = "input file '$filename' does not exist"; |
316 | return undef; |
317 | } |
318 | |
319 | if (! -r $filename ) |
320 | { |
321 | ${ $self->{Error} } = "cannot open file '$filename': $!"; |
322 | return undef; |
323 | } |
324 | } |
325 | |
326 | return 1 ; |
327 | } |
328 | |
329 | sub Validator::validateInputArray |
330 | { |
331 | my $self = shift ; |
332 | |
333 | foreach my $element ( @{ $_[0] } ) |
334 | { |
335 | my $inType = whatIsInput($element); |
336 | |
337 | if (! $inType) |
338 | { |
339 | ${ $self->{Error} } = "unknown input parameter" ; |
340 | return undef ; |
341 | } |
342 | } |
343 | |
344 | return 1 ; |
345 | } |
346 | |
347 | sub Validator::validateHash |
348 | { |
349 | my $self = shift ; |
350 | my $href = shift ; |
351 | |
352 | while (my($k, $v) = each %$href) |
353 | { |
354 | my $ktype = whatIsInput($k); |
355 | my $vtype = whatIsOutput($v, WANT_EXT|WANT_UNDEF) ; |
356 | |
357 | if ($ktype ne 'filename') |
358 | { |
359 | ${ $self->{Error} } = "hash key not filename" ; |
360 | return undef ; |
361 | } |
362 | |
363 | my %valid = map { $_ => 1 } qw(filename buffer array undef handle) ; |
364 | if (! $valid{$vtype}) |
365 | { |
366 | ${ $self->{Error} } = "hash value not ok" ; |
367 | return undef ; |
368 | } |
369 | } |
370 | |
371 | return $self ; |
372 | } |
373 | |
374 | 1; |