File | /usr/local/lib/perl/5.10.0/Params/Util.pm |
Statements Executed | 47 |
Total Time | 0.0017352 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | Params::Util::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
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 | 3 | 42µs | 14µs | use 5.00503; |
59 | 3 | 43µs | 14µs | use strict; # spent 8µs making 1 call to strict::import |
60 | 1 | 600ns | 600ns | require overload; |
61 | 1 | 500ns | 500ns | require Exporter; |
62 | 1 | 400ns | 400ns | require Scalar::Util; |
63 | 1 | 101µs | 101µs | require DynaLoader; |
64 | ||||
65 | 3 | 571µs | 190µs | use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS}; # spent 58µs making 1 call to vars::import |
66 | ||||
67 | 1 | 700ns | 700ns | $VERSION = '1.00'; |
68 | 1 | 14µs | 14µs | @ISA = qw{ |
69 | Exporter | |||
70 | DynaLoader | |||
71 | }; | |||
72 | 1 | 9µs | 9µs | @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 | 1 | 4µs | 4µs | %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); |
85 | ||||
86 | 4 | 14µs | 3µs | eval { |
87 | local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; | |||
88 | bootstrap Params::Util $VERSION; # spent 306µs making 1 call to DynaLoader::bootstrap | |||
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 | 1 | 6µs | 6µs | 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 | 1 | 95µs | 95µs | 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 | 1 | 68µs | 68µs | 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 | 1 | 77µs | 77µs | 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 | 1 | 96µs | 96µs | 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 | 1 | 5µs | 5µs | 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 | 1 | 54µs | 54µs | 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 | 1 | 59µs | 59µs | 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 | 1 | 500ns | 500ns | 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 | 1 | 400ns | 400ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 500ns | 500ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 500ns | 500ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 200ns | 200ns | 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 | 1 | 61µs | 61µs | 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 | 1 | 500ns | 500ns | 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 | 1 | 300ns | 300ns | 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 | 1 | 74µs | 74µs | 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 | 1 | 74µs | 74µs | 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 | 1 | 144µs | 144µs | 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 | 1 | 75µs | 75µs | 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 | 44µs | 44µs | 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 |