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