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