Commit | Line | Data |
3fea05b9 |
1 | package Params::Util; |
2 | |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | Params::Util - Simple, compact and correct param-checking functions |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | # Import some functions |
12 | use Params::Util qw{_SCALAR _HASH _INSTANCE}; |
13 | |
14 | # If you are lazy, or need a lot of them... |
15 | use Params::Util ':ALL'; |
16 | |
17 | sub foo { |
18 | my $object = _INSTANCE(shift, 'Foo') or return undef; |
19 | my $image = _SCALAR(shift) or return undef; |
20 | my $options = _HASH(shift) or return undef; |
21 | # etc... |
22 | } |
23 | |
24 | =head1 DESCRIPTION |
25 | |
26 | C<Params::Util> provides a basic set of importable functions that makes |
27 | checking parameters a hell of a lot easier |
28 | |
29 | While they can be (and are) used in other contexts, the main point |
30 | behind this module is that the functions B<both> Do What You Mean, |
31 | and Do The Right Thing, so they are most useful when you are getting |
32 | params passed into your code from someone and/or somewhere else |
33 | and you can't really trust the quality. |
34 | |
35 | Thus, C<Params::Util> is of most use at the edges of your API, where |
36 | params and data are coming in from outside your code. |
37 | |
38 | The functions provided by C<Params::Util> check in the most strictly |
39 | correct manner known, are documented as thoroughly as possible so their |
40 | exact behaviour is clear, and heavily tested so make sure they are not |
41 | fooled by weird data and Really Bad Things. |
42 | |
43 | To use, simply load the module providing the functions you want to use |
44 | as arguments (as shown in the SYNOPSIS). |
45 | |
46 | To aid in maintainability, C<Params::Util> will B<never> export by |
47 | default. |
48 | |
49 | You must explicitly name the functions you want to export, or use the |
50 | C<:ALL> param to just have it export everything (although this is not |
51 | recommended if you have any _FOO functions yourself with which future |
52 | additions to C<Params::Util> may clash) |
53 | |
54 | =head1 FUNCTIONS |
55 | |
56 | =cut |
57 | |
58 | use 5.00503; |
59 | use strict; |
60 | require overload; |
61 | require Exporter; |
62 | require Scalar::Util; |
63 | require DynaLoader; |
64 | |
65 | use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS}; |
66 | |
67 | $VERSION = '1.00'; |
68 | @ISA = qw{ |
69 | Exporter |
70 | DynaLoader |
71 | }; |
72 | @EXPORT_OK = qw{ |
73 | _STRING _IDENTIFIER |
74 | _CLASS _CLASSISA _SUBCLASS _DRIVER |
75 | _NUMBER _POSINT _NONNEGINT |
76 | _SCALAR _SCALAR0 |
77 | _ARRAY _ARRAY0 _ARRAYLIKE |
78 | _HASH _HASH0 _HASHLIKE |
79 | _CODE _CODELIKE |
80 | _INVOCANT _REGEX _INSTANCE |
81 | _SET _SET0 |
82 | _HANDLE |
83 | }; |
84 | %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); |
85 | |
86 | eval { |
87 | local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; |
88 | bootstrap Params::Util $VERSION; |
89 | 1; |
90 | } unless $ENV{PERL_PARAMS_UTIL_PP}; |
91 | |
92 | |
93 | |
94 | |
95 | |
96 | ##################################################################### |
97 | # Param Checking Functions |
98 | |
99 | =pod |
100 | |
101 | =head2 _STRING $string |
102 | |
103 | The C<_STRING> function is intended to be imported into your |
104 | package, and provides a convenient way to test to see if a value is |
105 | a normal non-false string of non-zero length. |
106 | |
107 | Note that this will NOT do anything magic to deal with the special |
108 | C<'0'> false negative case, but will return it. |
109 | |
110 | # '0' not considered valid data |
111 | my $name = _STRING(shift) or die "Bad name"; |
112 | |
113 | # '0' is considered valid data |
114 | my $string = _STRING($_[0]) ? shift : die "Bad string"; |
115 | |
116 | Please also note that this function expects a normal string. It does |
117 | not support overloading or other magic techniques to get a string. |
118 | |
119 | Returns the string as a conveince if it is a valid string, or |
120 | C<undef> if not. |
121 | |
122 | =cut |
123 | |
124 | eval <<'END_PERL' unless defined &_STRING; |
125 | sub _STRING ($) { |
126 | (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef; |
127 | } |
128 | END_PERL |
129 | |
130 | =pod |
131 | |
132 | =head2 _IDENTIFIER $string |
133 | |
134 | The C<_IDENTIFIER> function is intended to be imported into your |
135 | package, and provides a convenient way to test to see if a value is |
136 | a string that is a valid Perl identifier. |
137 | |
138 | Returns the string as a convenience if it is a valid identifier, or |
139 | C<undef> if not. |
140 | |
141 | =cut |
142 | |
143 | eval <<'END_PERL' unless defined &_IDENTIFIER; |
144 | sub _IDENTIFIER ($) { |
145 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef; |
146 | } |
147 | END_PERL |
148 | |
149 | =pod |
150 | |
151 | =head2 _CLASS $string |
152 | |
153 | The C<_CLASS> function is intended to be imported into your |
154 | package, and provides a convenient way to test to see if a value is |
155 | a string that is a valid Perl class. |
156 | |
157 | This function only checks that the format is valid, not that the |
158 | class is actually loaded. It also assumes "normalised" form, and does |
159 | not accept class names such as C<::Foo> or C<D'Oh>. |
160 | |
161 | Returns the string as a convenience if it is a valid class name, or |
162 | C<undef> if not. |
163 | |
164 | =cut |
165 | |
166 | eval <<'END_PERL' unless defined &_CLASS; |
167 | sub _CLASS ($) { |
168 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; |
169 | } |
170 | END_PERL |
171 | |
172 | =pod |
173 | |
174 | =head2 _CLASSISA $string, $class |
175 | |
176 | The C<_CLASSISA> function is intended to be imported into your |
177 | package, and provides a convenient way to test to see if a value is |
178 | a string that is a particularly class, or a subclass of it. |
179 | |
180 | This function checks that the format is valid and calls the -E<gt>isa |
181 | method on the class name. It does not check that the class is actually |
182 | loaded. |
183 | |
184 | It also assumes "normalised" form, and does |
185 | not accept class names such as C<::Foo> or C<D'Oh>. |
186 | |
187 | Returns the string as a convenience if it is a valid class name, or |
188 | C<undef> if not. |
189 | |
190 | =cut |
191 | |
192 | eval <<'END_PERL' unless defined &_CLASSISA; |
193 | sub _CLASSISA ($$) { |
194 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef; |
195 | } |
196 | END_PERL |
197 | |
198 | =pod |
199 | |
200 | =head2 _SUBCLASS $string, $class |
201 | |
202 | The C<_SUBCLASS> function is intended to be imported into your |
203 | package, and provides a convenient way to test to see if a value is |
204 | a string that is a subclass of a specified class. |
205 | |
206 | This function checks that the format is valid and calls the -E<gt>isa |
207 | method on the class name. It does not check that the class is actually |
208 | loaded. |
209 | |
210 | It also assumes "normalised" form, and does |
211 | not accept class names such as C<::Foo> or C<D'Oh>. |
212 | |
213 | Returns the string as a convenience if it is a valid class name, or |
214 | C<undef> if not. |
215 | |
216 | =cut |
217 | |
218 | eval <<'END_PERL' unless defined &_SUBCLASS; |
219 | sub _SUBCLASS ($$) { |
220 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef; |
221 | } |
222 | END_PERL |
223 | |
224 | =pod |
225 | |
226 | =head2 _NUMBER $scalar |
227 | |
228 | The C<_NUMBER> function is intended to be imported into your |
229 | package, and provides a convenient way to test to see if a value is |
230 | a number. That is, it is defined and perl thinks it's a number. |
231 | |
232 | This function is basically a Params::Util-style wrapper around the |
233 | L<Scalar::Util> C<looks_like_number> function. |
234 | |
235 | Returns the value as a convience, or C<undef> if the value is not a |
236 | number. |
237 | |
238 | =cut |
239 | |
240 | eval <<'END_PERL' unless defined &_NUMBER; |
241 | sub _NUMBER ($) { |
242 | ( defined $_[0] and ! ref $_[0] and Scalar::Util::looks_like_number($_[0]) ) |
243 | ? $_[0] |
244 | : undef; |
245 | } |
246 | END_PERL |
247 | |
248 | =pod |
249 | |
250 | =head2 _POSINT $integer |
251 | |
252 | The C<_POSINT> function is intended to be imported into your |
253 | package, and provides a convenient way to test to see if a value is |
254 | a positive integer (of any length). |
255 | |
256 | Returns the value as a convience, or C<undef> if the value is not a |
257 | positive integer. |
258 | |
259 | The name itself is derived from the XML schema constraint of the same |
260 | name. |
261 | |
262 | =cut |
263 | |
264 | eval <<'END_PERL' unless defined &_POSINT; |
265 | sub _POSINT ($) { |
266 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef; |
267 | } |
268 | END_PERL |
269 | |
270 | =pod |
271 | |
272 | =head2 _NONNEGINT $integer |
273 | |
274 | The C<_NONNEGINT> function is intended to be imported into your |
275 | package, and provides a convenient way to test to see if a value is |
276 | a non-negative integer (of any length). That is, a positive integer, |
277 | or zero. |
278 | |
279 | Returns the value as a convience, or C<undef> if the value is not a |
280 | non-negative integer. |
281 | |
282 | As with other tests that may return false values, care should be taken |
283 | to test via "defined" in boolean validy contexts. |
284 | |
285 | unless ( defined _NONNEGINT($value) ) { |
286 | die "Invalid value"; |
287 | } |
288 | |
289 | The name itself is derived from the XML schema constraint of the same |
290 | name. |
291 | |
292 | =cut |
293 | |
294 | eval <<'END_PERL' unless defined &_NONNEGINT; |
295 | sub _NONNEGINT ($) { |
296 | (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef; |
297 | } |
298 | END_PERL |
299 | |
300 | =pod |
301 | |
302 | =head2 _SCALAR \$scalar |
303 | |
304 | The C<_SCALAR> function is intended to be imported into your package, |
305 | and provides a convenient way to test for a raw and unblessed |
306 | C<SCALAR> reference, with content of non-zero length. |
307 | |
308 | For a version that allows zero length C<SCALAR> references, see |
309 | the C<_SCALAR0> function. |
310 | |
311 | Returns the C<SCALAR> reference itself as a convenience, or C<undef> |
312 | if the value provided is not a C<SCALAR> reference. |
313 | |
314 | =cut |
315 | |
316 | eval <<'END_PERL' unless defined &_SCALAR; |
317 | sub _SCALAR ($) { |
318 | (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef; |
319 | } |
320 | END_PERL |
321 | |
322 | =pod |
323 | |
324 | =head2 _SCALAR0 \$scalar |
325 | |
326 | The C<_SCALAR0> function is intended to be imported into your package, |
327 | and provides a convenient way to test for a raw and unblessed |
328 | C<SCALAR0> reference, allowing content of zero-length. |
329 | |
330 | For a simpler "give me some content" version that requires non-zero |
331 | length, C<_SCALAR> function. |
332 | |
333 | Returns the C<SCALAR> reference itself as a convenience, or C<undef> |
334 | if the value provided is not a C<SCALAR> reference. |
335 | |
336 | =cut |
337 | |
338 | eval <<'END_PERL' unless defined &_SCALAR0; |
339 | sub _SCALAR0 ($) { |
340 | ref $_[0] eq 'SCALAR' ? $_[0] : undef; |
341 | } |
342 | END_PERL |
343 | |
344 | =pod |
345 | |
346 | =head2 _ARRAY $value |
347 | |
348 | The C<_ARRAY> function is intended to be imported into your package, |
349 | and provides a convenient way to test for a raw and unblessed |
350 | C<ARRAY> reference containing B<at least> one element of any kind. |
351 | |
352 | For a more basic form that allows zero length ARRAY references, see |
353 | the C<_ARRAY0> function. |
354 | |
355 | Returns the C<ARRAY> reference itself as a convenience, or C<undef> |
356 | if the value provided is not an C<ARRAY> reference. |
357 | |
358 | =cut |
359 | |
360 | eval <<'END_PERL' unless defined &_ARRAY; |
361 | sub _ARRAY ($) { |
362 | (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; |
363 | } |
364 | END_PERL |
365 | |
366 | =pod |
367 | |
368 | =head2 _ARRAY0 $value |
369 | |
370 | The C<_ARRAY0> function is intended to be imported into your package, |
371 | and provides a convenient way to test for a raw and unblessed |
372 | C<ARRAY> reference, allowing C<ARRAY> references that contain no |
373 | elements. |
374 | |
375 | For a more basic "An array of something" form that also requires at |
376 | least one element, see the C<_ARRAY> function. |
377 | |
378 | Returns the C<ARRAY> reference itself as a convenience, or C<undef> |
379 | if the value provided is not an C<ARRAY> reference. |
380 | |
381 | =cut |
382 | |
383 | eval <<'END_PERL' unless defined &_ARRAY0; |
384 | sub _ARRAY0 ($) { |
385 | ref $_[0] eq 'ARRAY' ? $_[0] : undef; |
386 | } |
387 | END_PERL |
388 | |
389 | =pod |
390 | |
391 | =head2 _ARRAYLIKE $value |
392 | |
393 | The C<_ARRAYLIKE> function tests whether a given scalar value can respond to |
394 | array dereferencing. If it can, the value is returned. If it cannot, |
395 | C<_ARRAYLIKE> returns C<undef>. |
396 | |
397 | =cut |
398 | |
399 | eval <<'END_PERL' unless defined &_ARRAYLIKE; |
400 | sub _ARRAYLIKE { |
401 | (defined $_[0] and ref $_[0] and ( |
402 | (Scalar::Util::reftype($_[0]) eq 'ARRAY') |
403 | or |
404 | overload::Method($_[0], '@{}') |
405 | )) ? $_[0] : undef; |
406 | } |
407 | END_PERL |
408 | |
409 | =pod |
410 | |
411 | =head2 _HASH $value |
412 | |
413 | The C<_HASH> function is intended to be imported into your package, |
414 | and provides a convenient way to test for a raw and unblessed |
415 | C<HASH> reference with at least one entry. |
416 | |
417 | For a version of this function that allows the C<HASH> to be empty, |
418 | see the C<_HASH0> function. |
419 | |
420 | Returns the C<HASH> reference itself as a convenience, or C<undef> |
421 | if the value provided is not an C<HASH> reference. |
422 | |
423 | =cut |
424 | |
425 | eval <<'END_PERL' unless defined &_HASH; |
426 | sub _HASH ($) { |
427 | (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef; |
428 | } |
429 | END_PERL |
430 | |
431 | =pod |
432 | |
433 | =head2 _HASH0 $value |
434 | |
435 | The C<_HASH0> function is intended to be imported into your package, |
436 | and provides a convenient way to test for a raw and unblessed |
437 | C<HASH> reference, regardless of the C<HASH> content. |
438 | |
439 | For a simpler "A hash of something" version that requires at least one |
440 | element, see the C<_HASH> function. |
441 | |
442 | Returns the C<HASH> reference itself as a convenience, or C<undef> |
443 | if the value provided is not an C<HASH> reference. |
444 | |
445 | =cut |
446 | |
447 | eval <<'END_PERL' unless defined &_HASH0; |
448 | sub _HASH0 ($) { |
449 | ref $_[0] eq 'HASH' ? $_[0] : undef; |
450 | } |
451 | END_PERL |
452 | |
453 | =pod |
454 | |
455 | =head2 _HASHLIKE $value |
456 | |
457 | The C<_HASHLIKE> function tests whether a given scalar value can respond to |
458 | hash dereferencing. If it can, the value is returned. If it cannot, |
459 | C<_HASHLIKE> returns C<undef>. |
460 | |
461 | =cut |
462 | |
463 | eval <<'END_PERL' unless defined &_HASHLIKE; |
464 | sub _HASHLIKE { |
465 | (defined $_[0] and ref $_[0] and ( |
466 | (Scalar::Util::reftype($_[0]) eq 'HASH') |
467 | or |
468 | overload::Method($_[0], '%{}') |
469 | )) ? $_[0] : undef; |
470 | } |
471 | END_PERL |
472 | |
473 | =pod |
474 | |
475 | =head2 _CODE $value |
476 | |
477 | The C<_CODE> function is intended to be imported into your package, |
478 | and provides a convenient way to test for a raw and unblessed |
479 | C<CODE> reference. |
480 | |
481 | Returns the C<CODE> reference itself as a convenience, or C<undef> |
482 | if the value provided is not an C<CODE> reference. |
483 | |
484 | =cut |
485 | |
486 | eval <<'END_PERL' unless defined &_CODE; |
487 | sub _CODE ($) { |
488 | ref $_[0] eq 'CODE' ? $_[0] : undef; |
489 | } |
490 | END_PERL |
491 | |
492 | =pod |
493 | |
494 | =head2 _CODELIKE $value |
495 | |
496 | The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>, |
497 | which checks for an explicit C<CODE> reference, the C<_CODELIKE> function |
498 | also includes things that act like them, such as blessed objects that |
499 | overload C<'&{}'>. |
500 | |
501 | Please note that in the case of objects overloaded with '&{}', you will |
502 | almost always end up also testing it in 'bool' context at some stage. |
503 | |
504 | For example: |
505 | |
506 | sub foo { |
507 | my $code1 = _CODELIKE(shift) or die "No code param provided"; |
508 | my $code2 = _CODELIKE(shift); |
509 | if ( $code2 ) { |
510 | print "Got optional second code param"; |
511 | } |
512 | } |
513 | |
514 | As such, you will most likely always want to make sure your class has |
515 | at least the following to allow it to evaluate to true in boolean |
516 | context. |
517 | |
518 | # Always evaluate to true in boolean context |
519 | use overload 'bool' => sub () { 1 }; |
520 | |
521 | Returns the callable value as a convenience, or C<undef> if the |
522 | value provided is not callable. |
523 | |
524 | Note - This function was formerly known as _CALLABLE but has been renamed |
525 | for greater symmetry with the other _XXXXLIKE functions. |
526 | |
527 | The use of _CALLABLE has been deprecated. It will continue to work, but |
528 | with a warning, until end-2006, then will be removed. |
529 | |
530 | I apologise for any inconvenience caused. |
531 | |
532 | =cut |
533 | |
534 | eval <<'END_PERL' unless defined &_CODELIKE; |
535 | sub _CODELIKE($) { |
536 | ( |
537 | (Scalar::Util::reftype($_[0])||'') eq 'CODE' |
538 | or |
539 | Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}') |
540 | ) |
541 | ? $_[0] : undef; |
542 | } |
543 | END_PERL |
544 | |
545 | =pod |
546 | |
547 | =head2 _INVOCANT $value |
548 | |
549 | This routine tests whether the given value is a valid method invocant. |
550 | This can be either an instance of an object, or a class name. |
551 | |
552 | If so, the value itself is returned. Otherwise, C<_INVOCANT> |
553 | returns C<undef>. |
554 | |
555 | =cut |
556 | |
557 | eval <<'END_PERL' unless defined &_INVOCANT; |
558 | sub _INVOCANT($) { |
559 | (defined $_[0] and |
560 | (defined Scalar::Util::blessed($_[0]) |
561 | or |
562 | # We used to check for stash definedness, but any class-like name is a |
563 | # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02 |
564 | Params::Util::_CLASS($_[0])) |
565 | ) ? $_[0] : undef; |
566 | } |
567 | END_PERL |
568 | |
569 | =pod |
570 | |
571 | =head2 _INSTANCE $object, $class |
572 | |
573 | The C<_INSTANCE> function is intended to be imported into your package, |
574 | and provides a convenient way to test for an object of a particular class |
575 | in a strictly correct manner. |
576 | |
577 | Returns the object itself as a convenience, or C<undef> if the value |
578 | provided is not an object of that type. |
579 | |
580 | =cut |
581 | |
582 | eval <<'END_PERL' unless defined &_INSTANCE; |
583 | sub _INSTANCE ($$) { |
584 | (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef; |
585 | } |
586 | END_PERL |
587 | |
588 | =pod |
589 | |
590 | =head2 _REGEX $value |
591 | |
592 | The C<_REGEX> function is intended to be imported into your package, |
593 | and provides a convenient way to test for a regular expression. |
594 | |
595 | Returns the value itself as a convenience, or C<undef> if the value |
596 | provided is not a regular expression. |
597 | |
598 | =cut |
599 | |
600 | eval <<'END_PERL' unless defined &_REGEX; |
601 | sub _REGEX ($) { |
602 | (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef; |
603 | } |
604 | END_PERL |
605 | |
606 | =pod |
607 | |
608 | =head2 _SET \@array, $class |
609 | |
610 | The C<_SET> function is intended to be imported into your package, |
611 | and provides a convenient way to test for set of at least one object of |
612 | a particular class in a strictly correct manner. |
613 | |
614 | The set is provided as a reference to an C<ARRAY> of objects of the |
615 | class provided. |
616 | |
617 | For an alternative function that allows zero-length sets, see the |
618 | C<_SET0> function. |
619 | |
620 | Returns the C<ARRAY> reference itself as a convenience, or C<undef> if |
621 | the value provided is not a set of that class. |
622 | |
623 | =cut |
624 | |
625 | eval <<'END_PERL' unless defined &_SET; |
626 | sub _SET ($$) { |
627 | my $set = shift; |
628 | _ARRAY($set) or return undef; |
629 | foreach my $item ( @$set ) { |
630 | _INSTANCE($item,$_[0]) or return undef; |
631 | } |
632 | $set; |
633 | } |
634 | END_PERL |
635 | |
636 | =pod |
637 | |
638 | =head2 _SET0 \@array, $class |
639 | |
640 | The C<_SET0> function is intended to be imported into your package, |
641 | and provides a convenient way to test for a set of objects of a |
642 | particular class in a strictly correct manner, allowing for zero objects. |
643 | |
644 | The set is provided as a reference to an C<ARRAY> of objects of the |
645 | class provided. |
646 | |
647 | For an alternative function that requires at least one object, see the |
648 | C<_SET> function. |
649 | |
650 | Returns the C<ARRAY> reference itself as a convenience, or C<undef> if |
651 | the value provided is not a set of that class. |
652 | |
653 | =cut |
654 | |
655 | eval <<'END_PERL' unless defined &_SET0; |
656 | sub _SET0 ($$) { |
657 | my $set = shift; |
658 | _ARRAY0($set) or return undef; |
659 | foreach my $item ( @$set ) { |
660 | _INSTANCE($item,$_[0]) or return undef; |
661 | } |
662 | $set; |
663 | } |
664 | END_PERL |
665 | |
666 | =pod |
667 | |
668 | =head2 _HANDLE |
669 | |
670 | The C<_HANDLE> function is intended to be imported into your package, |
671 | and provides a convenient way to test whether or not a single scalar |
672 | value is a file handle. |
673 | |
674 | Unfortunately, in Perl the definition of a file handle can be a little |
675 | bit fuzzy, so this function is likely to be somewhat imperfect (at first |
676 | anyway). |
677 | |
678 | That said, it is implement as well or better than the other file handle |
679 | detectors in existance (and we stole from the best of them). |
680 | |
681 | =cut |
682 | |
683 | # We're doing this longhand for now. Once everything is perfect, |
684 | # we'll compress this into something that compiles more efficiently. |
685 | # Further, testing file handles is not something that is generally |
686 | # done millions of times, so doing it slowly is not a big speed hit. |
687 | eval <<'END_PERL' unless defined &_HANDLE; |
688 | sub _HANDLE { |
689 | my $it = shift; |
690 | |
691 | # It has to be defined, of course |
692 | unless ( defined $it ) { |
693 | return undef; |
694 | } |
695 | |
696 | # Normal globs are considered to be file handles |
697 | if ( ref $it eq 'GLOB' ) { |
698 | return $it; |
699 | } |
700 | |
701 | # Check for a normal tied filehandle |
702 | # Side Note: 5.5.4's tied() and can() doesn't like getting undef |
703 | if ( tied($it) and tied($it)->can('TIEHANDLE') ) { |
704 | return $it; |
705 | } |
706 | |
707 | # There are no other non-object handles that we support |
708 | unless ( Scalar::Util::blessed($it) ) { |
709 | return undef; |
710 | } |
711 | |
712 | # Check for a common base classes for conventional IO::Handle object |
713 | if ( $it->isa('IO::Handle') ) { |
714 | return $it; |
715 | } |
716 | |
717 | |
718 | # Check for tied file handles using Tie::Handle |
719 | if ( $it->isa('Tie::Handle') ) { |
720 | return $it; |
721 | } |
722 | |
723 | # IO::Scalar is not a proper seekable, but it is valid is a |
724 | # regular file handle |
725 | if ( $it->isa('IO::Scalar') ) { |
726 | return $it; |
727 | } |
728 | |
729 | # Yet another special case for IO::String, which refuses (for now |
730 | # anyway) to become a subclass of IO::Handle. |
731 | if ( $it->isa('IO::String') ) { |
732 | return $it; |
733 | } |
734 | |
735 | # This is not any sort of object we know about |
736 | return undef; |
737 | } |
738 | END_PERL |
739 | |
740 | =pod |
741 | |
742 | =head2 _DRIVER $string |
743 | |
744 | sub foo { |
745 | my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver"; |
746 | ... |
747 | } |
748 | |
749 | The C<_DRIVER> function is intended to be imported into your |
750 | package, and provides a convenient way to load and validate |
751 | a driver class. |
752 | |
753 | The most common pattern when taking a driver class as a parameter |
754 | is to check that the name is a class (i.e. check against _CLASS) |
755 | and then to load the class (if it exists) and then ensure that |
756 | the class returns true for the isa method on some base driver name. |
757 | |
758 | Return the value as a convenience, or C<undef> if the value is not |
759 | a class name, the module does not exist, the module does not load, |
760 | or the class fails the isa test. |
761 | |
762 | =cut |
763 | |
764 | eval <<'END_PERL' unless defined &_DRIVER; |
765 | sub _DRIVER ($$) { |
766 | (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; |
767 | } |
768 | END_PERL |
769 | |
770 | 1; |
771 | |
772 | =pod |
773 | |
774 | =head1 TO DO |
775 | |
776 | - Add _CAN to help resolve the UNIVERSAL::can debacle |
777 | |
778 | - Would be even nicer if someone would demonstrate how the hell to |
779 | build a Module::Install dist of the ::Util dual Perl/XS type. :/ |
780 | |
781 | - Implement an assertion-like version of this module, that dies on |
782 | error. |
783 | |
784 | - Implement a Test:: version of this module, for use in testing |
785 | |
786 | =head1 SUPPORT |
787 | |
788 | Bugs should be reported via the CPAN bug tracker at |
789 | |
790 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util> |
791 | |
792 | For other issues, contact the author. |
793 | |
794 | =head1 AUTHOR |
795 | |
796 | Adam Kennedy E<lt>adamk@cpan.orgE<gt> |
797 | |
798 | =head1 SEE ALSO |
799 | |
800 | L<Params::Validate> |
801 | |
802 | =head1 COPYRIGHT |
803 | |
804 | Copyright 2005 - 2009 Adam Kennedy. |
805 | |
806 | This program is free software; you can redistribute |
807 | it and/or modify it under the same terms as Perl itself. |
808 | |
809 | The full text of the license can be found in the |
810 | LICENSE file included with this module. |
811 | |
812 | =cut |