Util.pm
Go to the documentation of this file.
00001 # Original package Params::Util downloaded from CPAN on 6/15/2012. This module 00002 # has been modified by Andreas Schuh on 6/15/2012 to make it part of BASIS. 00003 00004 package BASIS::Params::Util; 00005 00006 =pod 00007 00008 =head1 NAME 00009 00010 BASIS::Params::Util - Simple, compact and correct param-checking functions 00011 00012 =head1 SYNOPSIS 00013 00014 # Import some functions 00015 use BASIS::Params::Util qw{_SCALAR _HASH _INSTANCE}; 00016 00017 # If you are lazy, or need a lot of them... 00018 use BASIS::Params::Util ':ALL'; 00019 00020 sub foo { 00021 my $object = _INSTANCE(shift, 'Foo') or return undef; 00022 my $image = _SCALAR(shift) or return undef; 00023 my $options = _HASH(shift) or return undef; 00024 # etc... 00025 } 00026 00027 =head1 DESCRIPTION 00028 00029 C<BASIS::Params::Util> provides a basic set of importable functions that makes 00030 checking parameters a hell of a lot easier 00031 00032 While they can be (and are) used in other contexts, the main point 00033 behind this module is that the functions B<both> Do What You Mean, 00034 and Do The Right Thing, so they are most useful when you are getting 00035 params passed into your code from someone and/or somewhere else 00036 and you can't really trust the quality. 00037 00038 Thus, C<BASIS::Params::Util> is of most use at the edges of your API, where 00039 params and data are coming in from outside your code. 00040 00041 The functions provided by C<BASIS::Params::Util> check in the most strictly 00042 correct manner known, are documented as thoroughly as possible so their 00043 exact behaviour is clear, and heavily tested so make sure they are not 00044 fooled by weird data and Really Bad Things. 00045 00046 To use, simply load the module providing the functions you want to use 00047 as arguments (as shown in the SYNOPSIS). 00048 00049 To aid in maintainability, C<BASIS::Params::Util> will B<never> export by 00050 default. 00051 00052 You must explicitly name the functions you want to export, or use the 00053 C<:ALL> param to just have it export everything (although this is not 00054 recommended if you have any _FOO functions yourself with which future 00055 additions to C<BASIS::Params::Util> may clash) 00056 00057 =head1 FUNCTIONS 00058 00059 =cut 00060 00061 use 5.00503; 00062 use strict; 00063 require overload; 00064 require Exporter; 00065 require Scalar::Util; 00066 require DynaLoader; 00067 00068 use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS}; 00069 00070 $VERSION = '1.07'; 00071 @ISA = qw{ 00072 Exporter 00073 DynaLoader 00074 }; 00075 @EXPORT_OK = qw{ 00076 _STRING _IDENTIFIER 00077 _CLASS _CLASSISA _SUBCLASS _DRIVER _CLASSDOES 00078 _NUMBER _POSINT _NONNEGINT 00079 _SCALAR _SCALAR0 00080 _ARRAY _ARRAY0 _ARRAYLIKE 00081 _HASH _HASH0 _HASHLIKE 00082 _CODE _CODELIKE 00083 _INVOCANT _REGEX _INSTANCE _INSTANCEDOES 00084 _SET _SET0 00085 _HANDLE 00086 }; 00087 %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); 00088 00089 eval { 00090 local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; 00091 bootstrap BASIS::Params::Util $VERSION; 00092 1; 00093 } unless $ENV{PERL_PARAMS_UTIL_PP}; 00094 00095 # Use a private pure-perl copy of looks_like_number if the version of 00096 # Scalar::Util is old (for whatever reason). 00097 my $SU = eval "$Scalar::Util::VERSION" || 0; 00098 if ( $SU >= 1.18 ) { 00099 Scalar::Util->import('looks_like_number'); 00100 } else { 00101 eval <<'END_PERL'; 00102 sub looks_like_number { 00103 local $_ = shift; 00104 00105 # checks from perlfaq4 00106 return 0 if !defined($_); 00107 if (ref($_)) { 00108 return overload::Overloaded($_) ? defined(0 + $_) : 0; 00109 } 00110 return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer 00111 return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float 00112 return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); 00113 00114 0; 00115 } 00116 END_PERL 00117 } 00118 00119 00120 00121 00122 00123 ##################################################################### 00124 # Param Checking Functions 00125 00126 =pod 00127 00128 =head2 _STRING $string 00129 00130 The C<_STRING> function is intended to be imported into your 00131 package, and provides a convenient way to test to see if a value is 00132 a normal non-false string of non-zero length. 00133 00134 Note that this will NOT do anything magic to deal with the special 00135 C<'0'> false negative case, but will return it. 00136 00137 # '0' not considered valid data 00138 my $name = _STRING(shift) or die "Bad name"; 00139 00140 # '0' is considered valid data 00141 my $string = _STRING($_[0]) ? shift : die "Bad string"; 00142 00143 Please also note that this function expects a normal string. It does 00144 not support overloading or other magic techniques to get a string. 00145 00146 Returns the string as a conveince if it is a valid string, or 00147 C<undef> if not. 00148 00149 =cut 00150 00151 eval <<'END_PERL' unless defined &_STRING; 00152 sub _STRING ($) { 00153 (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef; 00154 } 00155 END_PERL 00156 00157 =pod 00158 00159 =head2 _IDENTIFIER $string 00160 00161 The C<_IDENTIFIER> function is intended to be imported into your 00162 package, and provides a convenient way to test to see if a value is 00163 a string that is a valid Perl identifier. 00164 00165 Returns the string as a convenience if it is a valid identifier, or 00166 C<undef> if not. 00167 00168 =cut 00169 00170 eval <<'END_PERL' unless defined &_IDENTIFIER; 00171 sub _IDENTIFIER ($) { 00172 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*\z/s) ? $_[0] : undef; 00173 } 00174 END_PERL 00175 00176 =pod 00177 00178 =head2 _CLASS $string 00179 00180 The C<_CLASS> function is intended to be imported into your 00181 package, and provides a convenient way to test to see if a value is 00182 a string that is a valid Perl class. 00183 00184 This function only checks that the format is valid, not that the 00185 class is actually loaded. It also assumes "normalised" form, and does 00186 not accept class names such as C<::Foo> or C<D'Oh>. 00187 00188 Returns the string as a convenience if it is a valid class name, or 00189 C<undef> if not. 00190 00191 =cut 00192 00193 eval <<'END_PERL' unless defined &_CLASS; 00194 sub _CLASS ($) { 00195 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; 00196 } 00197 END_PERL 00198 00199 =pod 00200 00201 =head2 _CLASSISA $string, $class 00202 00203 The C<_CLASSISA> function is intended to be imported into your 00204 package, and provides a convenient way to test to see if a value is 00205 a string that is a particularly class, or a subclass of it. 00206 00207 This function checks that the format is valid and calls the -E<gt>isa 00208 method on the class name. It does not check that the class is actually 00209 loaded. 00210 00211 It also assumes "normalised" form, and does 00212 not accept class names such as C<::Foo> or C<D'Oh>. 00213 00214 Returns the string as a convenience if it is a valid class name, or 00215 C<undef> if not. 00216 00217 =cut 00218 00219 eval <<'END_PERL' unless defined &_CLASSISA; 00220 sub _CLASSISA ($$) { 00221 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef; 00222 } 00223 END_PERL 00224 00225 =head2 _CLASSDOES $string, $role 00226 00227 This routine behaves exactly like C<L</_CLASSISA>>, but checks with C<< ->DOES 00228 >> rather than C<< ->isa >>. This is probably only a good idea to use on Perl 00229 5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been 00230 implemented. 00231 00232 =cut 00233 00234 eval <<'END_PERL' unless defined &_CLASSDOES; 00235 sub _CLASSDOES ($$) { 00236 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef; 00237 } 00238 END_PERL 00239 00240 =pod 00241 00242 =head2 _SUBCLASS $string, $class 00243 00244 The C<_SUBCLASS> function is intended to be imported into your 00245 package, and provides a convenient way to test to see if a value is 00246 a string that is a subclass of a specified class. 00247 00248 This function checks that the format is valid and calls the -E<gt>isa 00249 method on the class name. It does not check that the class is actually 00250 loaded. 00251 00252 It also assumes "normalised" form, and does 00253 not accept class names such as C<::Foo> or C<D'Oh>. 00254 00255 Returns the string as a convenience if it is a valid class name, or 00256 C<undef> if not. 00257 00258 =cut 00259 00260 eval <<'END_PERL' unless defined &_SUBCLASS; 00261 sub _SUBCLASS ($$) { 00262 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) ? $_[0] : undef; 00263 } 00264 END_PERL 00265 00266 =pod 00267 00268 =head2 _NUMBER $scalar 00269 00270 The C<_NUMBER> function is intended to be imported into your 00271 package, and provides a convenient way to test to see if a value is 00272 a number. That is, it is defined and perl thinks it's a number. 00273 00274 This function is basically a BASIS::Params::Util-style wrapper around the 00275 L<Scalar::Util> C<looks_like_number> function. 00276 00277 Returns the value as a convience, or C<undef> if the value is not a 00278 number. 00279 00280 =cut 00281 00282 eval <<'END_PERL' unless defined &_NUMBER; 00283 sub _NUMBER ($) { 00284 ( defined $_[0] and ! ref $_[0] and looks_like_number($_[0]) ) 00285 ? $_[0] 00286 : undef; 00287 } 00288 END_PERL 00289 00290 =pod 00291 00292 =head2 _POSINT $integer 00293 00294 The C<_POSINT> function is intended to be imported into your 00295 package, and provides a convenient way to test to see if a value is 00296 a positive integer (of any length). 00297 00298 Returns the value as a convience, or C<undef> if the value is not a 00299 positive integer. 00300 00301 The name itself is derived from the XML schema constraint of the same 00302 name. 00303 00304 =cut 00305 00306 eval <<'END_PERL' unless defined &_POSINT; 00307 sub _POSINT ($) { 00308 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[1-9]\d*$/) ? $_[0] : undef; 00309 } 00310 END_PERL 00311 00312 =pod 00313 00314 =head2 _NONNEGINT $integer 00315 00316 The C<_NONNEGINT> function is intended to be imported into your 00317 package, and provides a convenient way to test to see if a value is 00318 a non-negative integer (of any length). That is, a positive integer, 00319 or zero. 00320 00321 Returns the value as a convience, or C<undef> if the value is not a 00322 non-negative integer. 00323 00324 As with other tests that may return false values, care should be taken 00325 to test via "defined" in boolean validy contexts. 00326 00327 unless ( defined _NONNEGINT($value) ) { 00328 die "Invalid value"; 00329 } 00330 00331 The name itself is derived from the XML schema constraint of the same 00332 name. 00333 00334 =cut 00335 00336 eval <<'END_PERL' unless defined &_NONNEGINT; 00337 sub _NONNEGINT ($) { 00338 (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^(?:0|[1-9]\d*)$/) ? $_[0] : undef; 00339 } 00340 END_PERL 00341 00342 =pod 00343 00344 =head2 _SCALAR \$scalar 00345 00346 The C<_SCALAR> function is intended to be imported into your package, 00347 and provides a convenient way to test for a raw and unblessed 00348 C<SCALAR> reference, with content of non-zero length. 00349 00350 For a version that allows zero length C<SCALAR> references, see 00351 the C<_SCALAR0> function. 00352 00353 Returns the C<SCALAR> reference itself as a convenience, or C<undef> 00354 if the value provided is not a C<SCALAR> reference. 00355 00356 =cut 00357 00358 eval <<'END_PERL' unless defined &_SCALAR; 00359 sub _SCALAR ($) { 00360 (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef; 00361 } 00362 END_PERL 00363 00364 =pod 00365 00366 =head2 _SCALAR0 \$scalar 00367 00368 The C<_SCALAR0> function is intended to be imported into your package, 00369 and provides a convenient way to test for a raw and unblessed 00370 C<SCALAR0> reference, allowing content of zero-length. 00371 00372 For a simpler "give me some content" version that requires non-zero 00373 length, C<_SCALAR> function. 00374 00375 Returns the C<SCALAR> reference itself as a convenience, or C<undef> 00376 if the value provided is not a C<SCALAR> reference. 00377 00378 =cut 00379 00380 eval <<'END_PERL' unless defined &_SCALAR0; 00381 sub _SCALAR0 ($) { 00382 ref $_[0] eq 'SCALAR' ? $_[0] : undef; 00383 } 00384 END_PERL 00385 00386 =pod 00387 00388 =head2 _ARRAY $value 00389 00390 The C<_ARRAY> function is intended to be imported into your package, 00391 and provides a convenient way to test for a raw and unblessed 00392 C<ARRAY> reference containing B<at least> one element of any kind. 00393 00394 For a more basic form that allows zero length ARRAY references, see 00395 the C<_ARRAY0> function. 00396 00397 Returns the C<ARRAY> reference itself as a convenience, or C<undef> 00398 if the value provided is not an C<ARRAY> reference. 00399 00400 =cut 00401 00402 eval <<'END_PERL' unless defined &_ARRAY; 00403 sub _ARRAY ($) { 00404 (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; 00405 } 00406 END_PERL 00407 00408 =pod 00409 00410 =head2 _ARRAY0 $value 00411 00412 The C<_ARRAY0> function is intended to be imported into your package, 00413 and provides a convenient way to test for a raw and unblessed 00414 C<ARRAY> reference, allowing C<ARRAY> references that contain no 00415 elements. 00416 00417 For a more basic "An array of something" form that also requires at 00418 least one element, see the C<_ARRAY> function. 00419 00420 Returns the C<ARRAY> reference itself as a convenience, or C<undef> 00421 if the value provided is not an C<ARRAY> reference. 00422 00423 =cut 00424 00425 eval <<'END_PERL' unless defined &_ARRAY0; 00426 sub _ARRAY0 ($) { 00427 ref $_[0] eq 'ARRAY' ? $_[0] : undef; 00428 } 00429 END_PERL 00430 00431 =pod 00432 00433 =head2 _ARRAYLIKE $value 00434 00435 The C<_ARRAYLIKE> function tests whether a given scalar value can respond to 00436 array dereferencing. If it can, the value is returned. If it cannot, 00437 C<_ARRAYLIKE> returns C<undef>. 00438 00439 =cut 00440 00441 eval <<'END_PERL' unless defined &_ARRAYLIKE; 00442 sub _ARRAYLIKE { 00443 (defined $_[0] and ref $_[0] and ( 00444 (Scalar::Util::reftype($_[0]) eq 'ARRAY') 00445 or 00446 overload::Method($_[0], '@{}') 00447 )) ? $_[0] : undef; 00448 } 00449 END_PERL 00450 00451 =pod 00452 00453 =head2 _HASH $value 00454 00455 The C<_HASH> function is intended to be imported into your package, 00456 and provides a convenient way to test for a raw and unblessed 00457 C<HASH> reference with at least one entry. 00458 00459 For a version of this function that allows the C<HASH> to be empty, 00460 see the C<_HASH0> function. 00461 00462 Returns the C<HASH> reference itself as a convenience, or C<undef> 00463 if the value provided is not an C<HASH> reference. 00464 00465 =cut 00466 00467 eval <<'END_PERL' unless defined &_HASH; 00468 sub _HASH ($) { 00469 (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef; 00470 } 00471 END_PERL 00472 00473 =pod 00474 00475 =head2 _HASH0 $value 00476 00477 The C<_HASH0> function is intended to be imported into your package, 00478 and provides a convenient way to test for a raw and unblessed 00479 C<HASH> reference, regardless of the C<HASH> content. 00480 00481 For a simpler "A hash of something" version that requires at least one 00482 element, see the C<_HASH> function. 00483 00484 Returns the C<HASH> reference itself as a convenience, or C<undef> 00485 if the value provided is not an C<HASH> reference. 00486 00487 =cut 00488 00489 eval <<'END_PERL' unless defined &_HASH0; 00490 sub _HASH0 ($) { 00491 ref $_[0] eq 'HASH' ? $_[0] : undef; 00492 } 00493 END_PERL 00494 00495 =pod 00496 00497 =head2 _HASHLIKE $value 00498 00499 The C<_HASHLIKE> function tests whether a given scalar value can respond to 00500 hash dereferencing. If it can, the value is returned. If it cannot, 00501 C<_HASHLIKE> returns C<undef>. 00502 00503 =cut 00504 00505 eval <<'END_PERL' unless defined &_HASHLIKE; 00506 sub _HASHLIKE { 00507 (defined $_[0] and ref $_[0] and ( 00508 (Scalar::Util::reftype($_[0]) eq 'HASH') 00509 or 00510 overload::Method($_[0], '%{}') 00511 )) ? $_[0] : undef; 00512 } 00513 END_PERL 00514 00515 =pod 00516 00517 =head2 _CODE $value 00518 00519 The C<_CODE> function is intended to be imported into your package, 00520 and provides a convenient way to test for a raw and unblessed 00521 C<CODE> reference. 00522 00523 Returns the C<CODE> reference itself as a convenience, or C<undef> 00524 if the value provided is not an C<CODE> reference. 00525 00526 =cut 00527 00528 eval <<'END_PERL' unless defined &_CODE; 00529 sub _CODE ($) { 00530 ref $_[0] eq 'CODE' ? $_[0] : undef; 00531 } 00532 END_PERL 00533 00534 =pod 00535 00536 =head2 _CODELIKE $value 00537 00538 The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>, 00539 which checks for an explicit C<CODE> reference, the C<_CODELIKE> function 00540 also includes things that act like them, such as blessed objects that 00541 overload C<'&{}'>. 00542 00543 Please note that in the case of objects overloaded with '&{}', you will 00544 almost always end up also testing it in 'bool' context at some stage. 00545 00546 For example: 00547 00548 sub foo { 00549 my $code1 = _CODELIKE(shift) or die "No code param provided"; 00550 my $code2 = _CODELIKE(shift); 00551 if ( $code2 ) { 00552 print "Got optional second code param"; 00553 } 00554 } 00555 00556 As such, you will most likely always want to make sure your class has 00557 at least the following to allow it to evaluate to true in boolean 00558 context. 00559 00560 # Always evaluate to true in boolean context 00561 use overload 'bool' => sub () { 1 }; 00562 00563 Returns the callable value as a convenience, or C<undef> if the 00564 value provided is not callable. 00565 00566 Note - This function was formerly known as _CALLABLE but has been renamed 00567 for greater symmetry with the other _XXXXLIKE functions. 00568 00569 The use of _CALLABLE has been deprecated. It will continue to work, but 00570 with a warning, until end-2006, then will be removed. 00571 00572 I apologise for any inconvenience caused. 00573 00574 =cut 00575 00576 eval <<'END_PERL' unless defined &_CODELIKE; 00577 sub _CODELIKE($) { 00578 ( 00579 (Scalar::Util::reftype($_[0])||'') eq 'CODE' 00580 or 00581 Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}') 00582 ) 00583 ? $_[0] : undef; 00584 } 00585 END_PERL 00586 00587 =pod 00588 00589 =head2 _INVOCANT $value 00590 00591 This routine tests whether the given value is a valid method invocant. 00592 This can be either an instance of an object, or a class name. 00593 00594 If so, the value itself is returned. Otherwise, C<_INVOCANT> 00595 returns C<undef>. 00596 00597 =cut 00598 00599 eval <<'END_PERL' unless defined &_INVOCANT; 00600 sub _INVOCANT($) { 00601 (defined $_[0] and 00602 (defined Scalar::Util::blessed($_[0]) 00603 or 00604 # We used to check for stash definedness, but any class-like name is a 00605 # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02 00606 BASIS::Params::Util::_CLASS($_[0])) 00607 ) ? $_[0] : undef; 00608 } 00609 END_PERL 00610 00611 =pod 00612 00613 =head2 _INSTANCE $object, $class 00614 00615 The C<_INSTANCE> function is intended to be imported into your package, 00616 and provides a convenient way to test for an object of a particular class 00617 in a strictly correct manner. 00618 00619 Returns the object itself as a convenience, or C<undef> if the value 00620 provided is not an object of that type. 00621 00622 =cut 00623 00624 eval <<'END_PERL' unless defined &_INSTANCE; 00625 sub _INSTANCE ($$) { 00626 (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef; 00627 } 00628 END_PERL 00629 00630 =head2 _INSTANCEDOES $object, $role 00631 00632 This routine behaves exactly like C<L</_INSTANCE>>, but checks with C<< ->DOES 00633 >> rather than C<< ->isa >>. This is probably only a good idea to use on Perl 00634 5.10 or later, when L<UNIVERSAL::DOES|UNIVERSAL::DOES/DOES> has been 00635 implemented. 00636 00637 =cut 00638 00639 eval <<'END_PERL' unless defined &_INSTANCEDOES; 00640 sub _INSTANCEDOES ($$) { 00641 (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef; 00642 } 00643 END_PERL 00644 00645 =pod 00646 00647 =head2 _REGEX $value 00648 00649 The C<_REGEX> function is intended to be imported into your package, 00650 and provides a convenient way to test for a regular expression. 00651 00652 Returns the value itself as a convenience, or C<undef> if the value 00653 provided is not a regular expression. 00654 00655 =cut 00656 00657 eval <<'END_PERL' unless defined &_REGEX; 00658 sub _REGEX ($) { 00659 (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef; 00660 } 00661 END_PERL 00662 00663 =pod 00664 00665 =head2 _SET \@array, $class 00666 00667 The C<_SET> function is intended to be imported into your package, 00668 and provides a convenient way to test for set of at least one object of 00669 a particular class in a strictly correct manner. 00670 00671 The set is provided as a reference to an C<ARRAY> of objects of the 00672 class provided. 00673 00674 For an alternative function that allows zero-length sets, see the 00675 C<_SET0> function. 00676 00677 Returns the C<ARRAY> reference itself as a convenience, or C<undef> if 00678 the value provided is not a set of that class. 00679 00680 =cut 00681 00682 eval <<'END_PERL' unless defined &_SET; 00683 sub _SET ($$) { 00684 my $set = shift; 00685 _ARRAY($set) or return undef; 00686 foreach my $item ( @$set ) { 00687 _INSTANCE($item,$_[0]) or return undef; 00688 } 00689 $set; 00690 } 00691 END_PERL 00692 00693 =pod 00694 00695 =head2 _SET0 \@array, $class 00696 00697 The C<_SET0> function is intended to be imported into your package, 00698 and provides a convenient way to test for a set of objects of a 00699 particular class in a strictly correct manner, allowing for zero objects. 00700 00701 The set is provided as a reference to an C<ARRAY> of objects of the 00702 class provided. 00703 00704 For an alternative function that requires at least one object, see the 00705 C<_SET> function. 00706 00707 Returns the C<ARRAY> reference itself as a convenience, or C<undef> if 00708 the value provided is not a set of that class. 00709 00710 =cut 00711 00712 eval <<'END_PERL' unless defined &_SET0; 00713 sub _SET0 ($$) { 00714 my $set = shift; 00715 _ARRAY0($set) or return undef; 00716 foreach my $item ( @$set ) { 00717 _INSTANCE($item,$_[0]) or return undef; 00718 } 00719 $set; 00720 } 00721 END_PERL 00722 00723 =pod 00724 00725 =head2 _HANDLE 00726 00727 The C<_HANDLE> function is intended to be imported into your package, 00728 and provides a convenient way to test whether or not a single scalar 00729 value is a file handle. 00730 00731 Unfortunately, in Perl the definition of a file handle can be a little 00732 bit fuzzy, so this function is likely to be somewhat imperfect (at first 00733 anyway). 00734 00735 That said, it is implement as well or better than the other file handle 00736 detectors in existance (and we stole from the best of them). 00737 00738 =cut 00739 00740 # We're doing this longhand for now. Once everything is perfect, 00741 # we'll compress this into something that compiles more efficiently. 00742 # Further, testing file handles is not something that is generally 00743 # done millions of times, so doing it slowly is not a big speed hit. 00744 eval <<'END_PERL' unless defined &_HANDLE; 00745 sub _HANDLE { 00746 my $it = shift; 00747 00748 # It has to be defined, of course 00749 unless ( defined $it ) { 00750 return undef; 00751 } 00752 00753 # Normal globs are considered to be file handles 00754 if ( ref $it eq 'GLOB' ) { 00755 return $it; 00756 } 00757 00758 # Check for a normal tied filehandle 00759 # Side Note: 5.5.4's tied() and can() doesn't like getting undef 00760 if ( tied($it) and tied($it)->can('TIEHANDLE') ) { 00761 return $it; 00762 } 00763 00764 # There are no other non-object handles that we support 00765 unless ( Scalar::Util::blessed($it) ) { 00766 return undef; 00767 } 00768 00769 # Check for a common base classes for conventional IO::Handle object 00770 if ( $it->isa('IO::Handle') ) { 00771 return $it; 00772 } 00773 00774 00775 # Check for tied file handles using Tie::Handle 00776 if ( $it->isa('Tie::Handle') ) { 00777 return $it; 00778 } 00779 00780 # IO::Scalar is not a proper seekable, but it is valid is a 00781 # regular file handle 00782 if ( $it->isa('IO::Scalar') ) { 00783 return $it; 00784 } 00785 00786 # Yet another special case for IO::String, which refuses (for now 00787 # anyway) to become a subclass of IO::Handle. 00788 if ( $it->isa('IO::String') ) { 00789 return $it; 00790 } 00791 00792 # This is not any sort of object we know about 00793 return undef; 00794 } 00795 END_PERL 00796 00797 =pod 00798 00799 =head2 _DRIVER $string 00800 00801 sub foo { 00802 my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver"; 00803 ... 00804 } 00805 00806 The C<_DRIVER> function is intended to be imported into your 00807 package, and provides a convenient way to load and validate 00808 a driver class. 00809 00810 The most common pattern when taking a driver class as a parameter 00811 is to check that the name is a class (i.e. check against _CLASS) 00812 and then to load the class (if it exists) and then ensure that 00813 the class returns true for the isa method on some base driver name. 00814 00815 Return the value as a convenience, or C<undef> if the value is not 00816 a class name, the module does not exist, the module does not load, 00817 or the class fails the isa test. 00818 00819 =cut 00820 00821 eval <<'END_PERL' unless defined &_DRIVER; 00822 sub _DRIVER ($$) { 00823 (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; 00824 } 00825 END_PERL 00826 00827 1; 00828 00829 =pod 00830 00831 =head1 TO DO 00832 00833 - Add _CAN to help resolve the UNIVERSAL::can debacle 00834 00835 - Would be even nicer if someone would demonstrate how the hell to 00836 build a Module::Install dist of the ::Util dual Perl/XS type. :/ 00837 00838 - Implement an assertion-like version of this module, that dies on 00839 error. 00840 00841 - Implement a Test:: version of this module, for use in testing 00842 00843 =head1 SUPPORT 00844 00845 Bugs should be reported via the CPAN bug tracker at 00846 00847 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Params-Util> 00848 00849 For other issues, contact the author. 00850 00851 =head1 AUTHOR 00852 00853 Adam Kennedy E<lt>adamk@cpan.orgE<gt> 00854 00855 Modified by Andreas Schuh on 6/15/2012 in order to make it a subpackage 00856 of the SBIA namespace for inclusion with the BASIS package. 00857 00858 =head1 SEE ALSO 00859 00860 L<Params::Validate> 00861 00862 =head1 COPYRIGHT 00863 00864 Copyright 2005 - 2012 Adam Kennedy. 00865 00866 This program is free software; you can redistribute 00867 it and/or modify it under the same terms as Perl itself. 00868 00869 The full text of the license can be found in the 00870 LICENSE file included with this module. 00871 00872 =cut