| 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 | Params::Util::BEGIN |
| 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 | 1 | 2µs | 2µs | eval { |
| 87 | 1 | 700ns | 700ns | local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; |
| 88 | 1 | 11µs | 11µs | bootstrap Params::Util $VERSION; # spent 306µs making 1 call to DynaLoader::bootstrap |
| 89 | 1 | 500ns | 500ns | 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 |