File Coverage

blib/lib/Params/SomeUtil.pm
Criterion Covered Total %
statement 60 65 92.3
branch 42 46 91.3
condition 38 39 97.4
subroutine 21 21 100.0
pod n/a
total 161 171 94.1


line stmt bran cond sub pod time code
1             package Params::SomeUtil;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Params::SomeUtil - Simple, compact and correct param-checking functions
8              
9             =head1 SYNOPSIS
10              
11             # Import some functions
12             use Params::SomeUtil qw{_SCALAR _HASH _INSTANCE};
13            
14             # If you are lazy, or need a lot of them...
15             use Params::SomeUtil ':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 provides a basic set of importable functions that makes
27             checking parameters a hell of a lot easier. This module is a fork
28             of version 1.07 of L with some additional bug fixes, see L
29             below.
30              
31             While they can be (and are) used in other contexts, the main point
32             behind this module is that the functions B Do What You Mean,
33             and Do The Right Thing, so they are most useful when you are getting
34             params passed into your code from someone and/or somewhere else
35             and you can't really trust the quality.
36              
37             Thus, C is of most use at the edges of your API, where
38             params and data are coming in from outside your code.
39              
40             The functions provided by C check in the most strictly
41             correct manner known, are documented as thoroughly as possible so their
42             exact behaviour is clear, and heavily tested so make sure they are not
43             fooled by weird data and Really Bad Things.
44              
45             To use, simply load the module providing the functions you want to use
46             as arguments (as shown in the SYNOPSIS).
47              
48             To aid in maintainability, C will B export by
49             default.
50              
51             You must explicitly name the functions you want to export, or use the
52             C<:ALL> param to just have it export everything (although this is not
53             recommended if you have any _FOO functions yourself with which future
54             additions to C may clash)
55              
56             =head1 WHY
57              
58             L already exists and has for some time. Unfortunately,
59             while the current maintainer has accepted patches to the project's
60             git repostiroy, he refuses to make new releases of the module. I
61             offered to help cut a new release but refused citing "quality" as an
62             issue without elaborating, thus this fork. This module includes
63             the following changes that were applied after 1.07:
64              
65             =over 4
66              
67             =item Fix for L
68             and L
69              
70             These are for _CLASS and _POSINT, with similar fixes for _STRING,
71             _IDENTIFIER, _NUMBER and _NONNEGINT.
72              
73             =item Fix for L
74              
75             But without the Americanised "corrections".
76              
77             =back
78              
79             These are the intentional differences from L:
80              
81             =over 4
82              
83             =item XS build is unchanged from 1.07
84              
85             Although some improvements can likely be made here (patches welcome), the changes made
86             since 1.07 have broken the ability to install this module without a compiler.
87              
88             =item PP versions of functions are not in a separate module
89              
90             There us currently no C. There probably should be, and may
91             later be, but for now I wanted to make the minimum changes to make this viable.
92             (patches welcome)
93              
94             =item Fix for L
95              
96             The XS versions of _ARRAY, _ARRAY0, _HASH and _HASH0 were inconsistent with the pure-perl
97             versions, and the documentation. The suggested fixes in the ticket were applied for
98             _ARRAY and _HASH. It was clear to me from reading the documentation that _ARRAY0 and
99             _HASH0 also had the same bug so they have also been corrected.
100              
101             =back
102              
103             This is as of L version 1.102, which is the current version as of this writing.
104             If there is a release of L I will endevour to update this list.
105              
106             My preference would be for releases of L resume and for it to be
107             maintained by someone responsive to tickets. I am not a direct user of L,
108             or L and I do not particularly want to maintain this module,
109             but given the way the CPAN ecosystem works this seems to strangely be the "easiest"
110             way to work around the challenge that I have.
111              
112             I would love to retire this module and make it a compatibility layer if it becomes unnecessary.
113              
114             =head1 FUNCTIONS
115              
116             =cut
117              
118 19     19   3043819 use 5.00503;
  19         80  
119 19     19   161 use strict;
  19         79  
  19         1429  
120             require overload;
121             require Exporter;
122             require Scalar::Util;
123             require DynaLoader;
124              
125 19     19   170 use vars qw{$VERSION @ISA @EXPORT_OK %EXPORT_TAGS};
  19         41  
  19         17370  
126              
127             $VERSION = '1.08';
128             @ISA = qw{
129             Exporter
130             DynaLoader
131             };
132             @EXPORT_OK = qw{
133             _STRING _IDENTIFIER
134             _CLASS _CLASSISA _SUBCLASS _DRIVER _CLASSDOES
135             _NUMBER _POSINT _NONNEGINT
136             _SCALAR _SCALAR0
137             _ARRAY _ARRAY0 _ARRAYLIKE
138             _HASH _HASH0 _HASHLIKE
139             _CODE _CODELIKE
140             _INVOCANT _REGEX _INSTANCE _INSTANCEDOES
141             _SET _SET0
142             _HANDLE
143             };
144             %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
145              
146             eval {
147             local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
148             bootstrap Params::SomeUtil $VERSION;
149             1;
150             } unless $ENV{PERL_PARAMS_UTIL_PP} || $ENV{PERL_PARAMS_SOMEUTIL_PP};
151              
152             # Use a private pure-perl copy of looks_like_number if the version of
153             # Scalar::Util is old (for whatever reason).
154             my $SU = eval "$Scalar::Util::VERSION" || 0;
155             if ( $SU >= 1.18 ) {
156             Scalar::Util->import('looks_like_number');
157             } else {
158             eval <<'END_PERL';
159             sub looks_like_number {
160             local $_ = shift;
161              
162             # checks from perlfaq4
163             return 0 if !defined($_);
164             if (ref($_)) {
165             return overload::Overloaded($_) ? defined(0 + $_) : 0;
166             }
167             return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
168             return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
169             return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
170              
171             0;
172             }
173             END_PERL
174             }
175              
176              
177              
178              
179              
180             #####################################################################
181             # Param Checking Functions
182              
183             =pod
184              
185             =head2 _STRING $string
186              
187             The C<_STRING> function is intended to be imported into your
188             package, and provides a convenient way to test to see if a value is
189             a normal non-false string of non-zero length.
190              
191             Note that this will NOT do anything magic to deal with the special
192             C<'0'> false negative case, but will return it.
193              
194             # '0' not considered valid data
195             my $name = _STRING(shift) or die "Bad name";
196            
197             # '0' is considered valid data
198             my $string = _STRING($_[0]) ? shift : die "Bad string";
199              
200             Please also note that this function expects a normal string. It does
201             not support overloading or other magic techniques to get a string.
202              
203             Returns the string as a convenience if it is a valid string, or
204             C if not.
205              
206             =cut
207              
208 50 100 100 86   254791 eval <<'END_PERL' unless defined &_STRING;
209             sub _STRING ($) {
210             (defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
211             }
212             END_PERL
213              
214             =pod
215              
216             =head2 _IDENTIFIER $string
217              
218             The C<_IDENTIFIER> function is intended to be imported into your
219             package, and provides a convenient way to test to see if a value is
220             a string that is a valid Perl identifier.
221              
222             Returns the string as a convenience if it is a valid identifier, or
223             C if not.
224              
225             =cut
226              
227 76 100 100 76   275884 eval <<'END_PERL' unless defined &_IDENTIFIER;
  76         981  
228             sub _IDENTIFIER ($) {
229             my $arg = shift;
230             (defined $arg and ! ref $arg and $arg =~ m/^[^\W\d]\w*\z/s) ? $arg : undef;
231             }
232             END_PERL
233              
234             =pod
235              
236             =head2 _CLASS $string
237              
238             The C<_CLASS> function is intended to be imported into your
239             package, and provides a convenient way to test to see if a value is
240             a string that is a valid Perl class.
241              
242             This function only checks that the format is valid, not that the
243             class is actually loaded. It also assumes "normalised" form, and does
244             not accept class names such as C<::Foo> or C.
245              
246             Returns the string as a convenience if it is a valid class name, or
247             C if not.
248              
249             =cut
250              
251 152 100 100 152   34554 eval <<'END_PERL' unless defined &_CLASS;
  152         4091  
252             sub _CLASS ($) {
253             my $arg = shift;
254             (defined $arg and ! ref $arg and $arg =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $arg : undef;
255             }
256             END_PERL
257              
258             =pod
259              
260             =head2 _CLASSISA $string, $class
261              
262             The C<_CLASSISA> function is intended to be imported into your
263             package, and provides a convenient way to test to see if a value is
264             a string that is a particularly class, or a subclass of it.
265              
266             This function checks that the format is valid and calls the -Eisa
267             method on the class name. It does not check that the class is actually
268             loaded.
269              
270             It also assumes "normalised" form, and does
271             not accept class names such as C<::Foo> or C.
272              
273             Returns the string as a convenience if it is a valid class name, or
274             C if not.
275              
276             =cut
277              
278 52 100 100 52   385996 eval <<'END_PERL' unless defined &_CLASSISA;
  52         760  
279             sub _CLASSISA ($$) {
280             my($string, $class) = @_;
281             (defined $string and ! ref $string and $string =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $string->isa($class)) ? $string : undef;
282             }
283             END_PERL
284              
285             =head2 _CLASSDOES $string, $role
286              
287             This routine behaves exactly like C>, but checks with C<< ->DOES
288             >> rather than C<< ->isa >>. This is probably only a good idea to use on Perl
289             5.10 or later, when L has been
290             implemented.
291              
292             =cut
293              
294 8 100 66 8   25 eval <<'END_PERL' unless defined &_CLASSDOES;
  8         3049  
295             sub _CLASSDOES ($$) {
296             my($string, $role) = @_;
297             (defined $string and ! ref $string and $string =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $string->DOES($role)) ? $string : undef;
298             }
299             END_PERL
300              
301             =pod
302              
303             =head2 _SUBCLASS $string, $class
304              
305             The C<_SUBCLASS> function is intended to be imported into your
306             package, and provides a convenient way to test to see if a value is
307             a string that is a subclass of a specified class.
308              
309             This function checks that the format is valid and calls the -Eisa
310             method on the class name. It does not check that the class is actually
311             loaded.
312              
313             It also assumes "normalised" form, and does
314             not accept class names such as C<::Foo> or C.
315              
316             Returns the string as a convenience if it is a valid class name, or
317             C if not.
318              
319             =cut
320              
321 52 100 100 52   153 eval <<'END_PERL' unless defined &_SUBCLASS;
  52         672  
322             sub _SUBCLASS ($$) {
323             my($string, $class) = @_;
324             (defined $string and ! ref $string and $string =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $string ne $class and $string->isa($class)) ? $string : undef;
325             }
326             END_PERL
327              
328             =pod
329              
330             =head2 _NUMBER $scalar
331              
332             The C<_NUMBER> function is intended to be imported into your
333             package, and provides a convenient way to test to see if a value is
334             a number. That is, it is defined and perl thinks it's a number.
335              
336             This function is basically a Params::SomeUtil-style wrapper around the
337             L C function.
338              
339             Returns the value as a convenience, or C if the value is not a
340             number.
341              
342             =cut
343              
344     100 24     eval <<'END_PERL' unless defined &_NUMBER;
345             sub _NUMBER ($) {
346             ( defined $_[0] and ! ref $_[0] and looks_like_number($_[0]) )
347             ? $_[0]
348             : undef;
349             }
350             END_PERL
351              
352             =pod
353              
354             =head2 _POSINT $integer
355              
356             The C<_POSINT> function is intended to be imported into your
357             package, and provides a convenient way to test to see if a value is
358             a positive integer (of any length).
359              
360             Returns the value as a convenience, or C if the value is not a
361             positive integer.
362              
363             The name itself is derived from the XML schema constraint of the same
364             name.
365              
366             =cut
367              
368 136 100 100 136   109020 eval <<'END_PERL' unless defined &_POSINT;
  74         888  
369             sub _POSINT ($) {
370             my $arg = shift;
371             (defined $arg and ! ref $arg and $arg =~ m/^[1-9]\d*$/) ? $arg : undef;
372             }
373             END_PERL
374              
375             =pod
376              
377             =head2 _NONNEGINT $integer
378              
379             The C<_NONNEGINT> function is intended to be imported into your
380             package, and provides a convenient way to test to see if a value is
381             a non-negative integer (of any length). That is, a positive integer,
382             or zero.
383              
384             Returns the value as a convenience, or C if the value is not a
385             non-negative integer.
386              
387             As with other tests that may return false values, care should be taken
388             to test via "defined" in valid boolean contexts.
389              
390             unless ( defined _NONNEGINT($value) ) {
391             die "Invalid value";
392             }
393              
394             The name itself is derived from the XML schema constraint of the same
395             name.
396              
397             =cut
398              
399 88 100 100 88   22150 eval <<'END_PERL' unless defined &_NONNEGINT;
  88         971  
400             sub _NONNEGINT ($) {
401             my $arg = shift;
402             (defined $arg and ! ref $arg and $arg =~ m/^(?:0|[1-9]\d*)$/) ? $arg : undef;
403             }
404             END_PERL
405              
406             =pod
407              
408             =head2 _SCALAR \$scalar
409              
410             The C<_SCALAR> function is intended to be imported into your package,
411             and provides a convenient way to test for a raw and unblessed
412             C reference, with content of non-zero length.
413              
414             For a version that allows zero length C references, see
415             the C<_SCALAR0> function.
416              
417             Returns the C reference itself as a convenience, or C
418             if the value provided is not a C reference.
419              
420             =cut
421              
422       17     eval <<'END_PERL' unless defined &_SCALAR;
423             sub _SCALAR ($) {
424             (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
425             }
426             END_PERL
427              
428             =pod
429              
430             =head2 _SCALAR0 \$scalar
431              
432             The C<_SCALAR0> function is intended to be imported into your package,
433             and provides a convenient way to test for a raw and unblessed
434             C reference, allowing content of zero-length.
435              
436             For a simpler "give me some content" version that requires non-zero
437             length, C<_SCALAR> function.
438              
439             Returns the C reference itself as a convenience, or C
440             if the value provided is not a C reference.
441              
442             =cut
443              
444             eval <<'END_PERL' unless defined &_SCALAR0;
445             sub _SCALAR0 ($) {
446             ref $_[0] eq 'SCALAR' ? $_[0] : undef;
447             }
448             END_PERL
449              
450             =pod
451              
452             =head2 _ARRAY $value
453              
454             The C<_ARRAY> function is intended to be imported into your package,
455             and provides a convenient way to test for a raw and unblessed
456             C reference containing B one element of any kind.
457              
458             For a more basic form that allows zero length ARRAY references, see
459             the C<_ARRAY0> function.
460              
461             Returns the C reference itself as a convenience, or C
462             if the value provided is not an C reference.
463              
464             =cut
465              
466             eval <<'END_PERL' unless defined &_ARRAY;
467             sub _ARRAY ($) {
468             (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
469             }
470             END_PERL
471              
472             =pod
473              
474             =head2 _ARRAY0 $value
475              
476             The C<_ARRAY0> function is intended to be imported into your package,
477             and provides a convenient way to test for a raw and unblessed
478             C reference, allowing C references that contain no
479             elements.
480              
481             For a more basic "An array of something" form that also requires at
482             least one element, see the C<_ARRAY> function.
483              
484             Returns the C reference itself as a convenience, or C
485             if the value provided is not an C reference.
486              
487             =cut
488              
489             eval <<'END_PERL' unless defined &_ARRAY0;
490             sub _ARRAY0 ($) {
491             ref $_[0] eq 'ARRAY' ? $_[0] : undef;
492             }
493             END_PERL
494              
495             =pod
496              
497             =head2 _ARRAYLIKE $value
498              
499             The C<_ARRAYLIKE> function tests whether a given scalar value can respond to
500             array dereferencing. If it can, the value is returned. If it cannot,
501             C<_ARRAYLIKE> returns C.
502              
503             =cut
504              
505             eval <<'END_PERL' unless defined &_ARRAYLIKE;
506             sub _ARRAYLIKE {
507             (defined $_[0] and ref $_[0] and (
508             (Scalar::Util::reftype($_[0]) eq 'ARRAY')
509             or
510             overload::Method($_[0], '@{}')
511             )) ? $_[0] : undef;
512             }
513             END_PERL
514              
515             =pod
516              
517             =head2 _HASH $value
518              
519             The C<_HASH> function is intended to be imported into your package,
520             and provides a convenient way to test for a raw and unblessed
521             C reference with at least one entry.
522              
523             For a version of this function that allows the C to be empty,
524             see the C<_HASH0> function.
525              
526             Returns the C reference itself as a convenience, or C
527             if the value provided is not an C reference.
528              
529             =cut
530              
531             eval <<'END_PERL' unless defined &_HASH;
532             sub _HASH ($) {
533             (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
534             }
535             END_PERL
536              
537             =pod
538              
539             =head2 _HASH0 $value
540              
541             The C<_HASH0> function is intended to be imported into your package,
542             and provides a convenient way to test for a raw and unblessed
543             C reference, regardless of the C content.
544              
545             For a simpler "A hash of something" version that requires at least one
546             element, see the C<_HASH> function.
547              
548             Returns the C reference itself as a convenience, or C
549             if the value provided is not an C reference.
550              
551             =cut
552              
553             eval <<'END_PERL' unless defined &_HASH0;
554             sub _HASH0 ($) {
555             ref $_[0] eq 'HASH' ? $_[0] : undef;
556             }
557             END_PERL
558              
559             =pod
560              
561             =head2 _HASHLIKE $value
562              
563             The C<_HASHLIKE> function tests whether a given scalar value can respond to
564             hash dereferencing. If it can, the value is returned. If it cannot,
565             C<_HASHLIKE> returns C.
566              
567             =cut
568              
569             eval <<'END_PERL' unless defined &_HASHLIKE;
570             sub _HASHLIKE {
571             (defined $_[0] and ref $_[0] and (
572             (Scalar::Util::reftype($_[0]) eq 'HASH')
573             or
574             overload::Method($_[0], '%{}')
575             )) ? $_[0] : undef;
576             }
577             END_PERL
578              
579             =pod
580              
581             =head2 _CODE $value
582              
583             The C<_CODE> function is intended to be imported into your package,
584             and provides a convenient way to test for a raw and unblessed
585             C reference.
586              
587             Returns the C reference itself as a convenience, or C
588             if the value provided is not an C reference.
589              
590             =cut
591              
592             eval <<'END_PERL' unless defined &_CODE;
593             sub _CODE ($) {
594             ref $_[0] eq 'CODE' ? $_[0] : undef;
595             }
596             END_PERL
597              
598             =pod
599              
600             =head2 _CODELIKE $value
601              
602             The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>,
603             which checks for an explicit C reference, the C<_CODELIKE> function
604             also includes things that act like them, such as blessed objects that
605             overload C<'&{}'>.
606              
607             Please note that in the case of objects overloaded with '&{}', you will
608             almost always end up also testing it in 'bool' context at some stage.
609              
610             For example:
611              
612             sub foo {
613             my $code1 = _CODELIKE(shift) or die "No code param provided";
614             my $code2 = _CODELIKE(shift);
615             if ( $code2 ) {
616             print "Got optional second code param";
617             }
618             }
619              
620             As such, you will most likely always want to make sure your class has
621             at least the following to allow it to evaluate to true in boolean
622             context.
623              
624             # Always evaluate to true in boolean context
625             use overload 'bool' => sub () { 1 };
626              
627             Returns the callable value as a convenience, or C if the
628             value provided is not callable.
629              
630             Note - This function was formerly known as _CALLABLE but has been renamed
631             for greater symmetry with the other _XXXXLIKE functions.
632              
633             The use of _CALLABLE has been deprecated. It will continue to work, but
634             with a warning, until end-2006, then will be removed.
635              
636             I apologise for any inconvenience caused.
637              
638             =cut
639              
640             eval <<'END_PERL' unless defined &_CODELIKE;
641             sub _CODELIKE($) {
642             (
643             (Scalar::Util::reftype($_[0])||'') eq 'CODE'
644             or
645             Scalar::Util::blessed($_[0]) and overload::Method($_[0],'&{}')
646             )
647             ? $_[0] : undef;
648             }
649             END_PERL
650              
651             =pod
652              
653             =head2 _INVOCANT $value
654              
655             This routine tests whether the given value is a valid method invocant.
656             This can be either an instance of an object, or a class name.
657              
658             If so, the value itself is returned. Otherwise, C<_INVOCANT>
659             returns C.
660              
661             =cut
662              
663 44 100 100 44   451788 eval <<'END_PERL' unless defined &_INVOCANT;
664             sub _INVOCANT($) {
665             (defined $_[0] and
666             (defined Scalar::Util::blessed($_[0])
667             or
668             # We used to check for stash definedness, but any class-like name is a
669             # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
670             Params::SomeUtil::_CLASS($_[0]))
671             ) ? $_[0] : undef;
672             }
673             END_PERL
674              
675             =pod
676              
677             =head2 _INSTANCE $object, $class
678              
679             The C<_INSTANCE> function is intended to be imported into your package,
680             and provides a convenient way to test for an object of a particular class
681             in a strictly correct manner.
682              
683             Returns the object itself as a convenience, or C if the value
684             provided is not an object of that type.
685              
686             =cut
687              
688             eval <<'END_PERL' unless defined &_INSTANCE;
689             sub _INSTANCE ($$) {
690             (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
691             }
692             END_PERL
693              
694             =head2 _INSTANCEDOES $object, $role
695              
696             This routine behaves exactly like C>, but checks with C<< ->DOES
697             >> rather than C<< ->isa >>. This is probably only a good idea to use on Perl
698             5.10 or later, when L has been
699             implemented.
700              
701             =cut
702              
703 135 100 100 135   406459 eval <<'END_PERL' unless defined &_INSTANCEDOES;
704             sub _INSTANCEDOES ($$) {
705             (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef;
706             }
707             END_PERL
708              
709             =pod
710              
711             =head2 _REGEX $value
712              
713             The C<_REGEX> function is intended to be imported into your package,
714             and provides a convenient way to test for a regular expression.
715              
716             Returns the value itself as a convenience, or C if the value
717             provided is not a regular expression.
718              
719             =cut
720              
721             eval <<'END_PERL' unless defined &_REGEX;
722             sub _REGEX ($) {
723             (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
724             }
725             END_PERL
726              
727             =pod
728              
729             =head2 _SET \@array, $class
730              
731             The C<_SET> function is intended to be imported into your package,
732             and provides a convenient way to test for set of at least one object of
733             a particular class in a strictly correct manner.
734              
735             The set is provided as a reference to an C of objects of the
736             class provided.
737              
738             For an alternative function that allows zero-length sets, see the
739             C<_SET0> function.
740              
741             Returns the C reference itself as a convenience, or C if
742             the value provided is not a set of that class.
743              
744             =cut
745              
746 114 100   114   32407 eval <<'END_PERL' unless defined &_SET;
  92 100       1301  
  48         217895  
  36         356  
  28         211  
747             sub _SET ($$) {
748             my $set = shift;
749             _ARRAY($set) or return undef;
750             foreach my $item ( @$set ) {
751             _INSTANCE($item,$_[0]) or return undef;
752             }
753             $set;
754             }
755             END_PERL
756              
757             =pod
758              
759             =head2 _SET0 \@array, $class
760              
761             The C<_SET0> function is intended to be imported into your package,
762             and provides a convenient way to test for a set of objects of a
763             particular class in a strictly correct manner, allowing for zero objects.
764              
765             The set is provided as a reference to an C of objects of the
766             class provided.
767              
768             For an alternative function that requires at least one object, see the
769             C<_SET> function.
770              
771             Returns the C reference itself as a convenience, or C if
772             the value provided is not a set of that class.
773              
774             =cut
775              
776 80 100   92   27256 eval <<'END_PERL' unless defined &_SET0;
  68 100       886  
  33         11792  
  12         204  
  8         36  
777             sub _SET0 ($$) {
778             my $set = shift;
779             _ARRAY0($set) or return undef;
780             foreach my $item ( @$set ) {
781             _INSTANCE($item,$_[0]) or return undef;
782             }
783             $set;
784             }
785             END_PERL
786              
787             =pod
788              
789             =head2 _HANDLE
790              
791             The C<_HANDLE> function is intended to be imported into your package,
792             and provides a convenient way to test whether or not a single scalar
793             value is a file handle.
794              
795             Unfortunately, in Perl the definition of a file handle can be a little
796             bit fuzzy, so this function is likely to be somewhat imperfect (at first
797             anyway).
798              
799             That said, it is implement as well or better than the other file handle
800             detectors in existence (and we stole from the best of them).
801              
802             =cut
803              
804             # We're doing this longhand for now. Once everything is perfect,
805             # we'll compress this into something that compiles more efficiently.
806             # Further, testing file handles is not something that is generally
807             # done millions of times, so doing it slowly is not a big speed hit.
808 30 100 100 66   465771 eval <<'END_PERL' unless defined &_HANDLE;
  30 100       91  
  2 100       7  
  28 100       106  
  6 50       18  
  22 50       62  
  0 50       0  
  22 50       51  
  20         44  
  2         29  
  0         0  
  2         16  
  0         0  
  2         13  
  0         0  
  2         29  
  0         0  
  2         7  
809             sub _HANDLE {
810             my $it = shift;
811              
812             # It has to be defined, of course
813             unless ( defined $it ) {
814             return undef;
815             }
816              
817             # Normal globs are considered to be file handles
818             if ( ref $it eq 'GLOB' ) {
819             return $it;
820             }
821              
822             # Check for a normal tied filehandle
823             # Side Note: 5.5.4's tied() and can() doesn't like getting undef
824             if ( tied($it) and tied($it)->can('TIEHANDLE') ) {
825             return $it;
826             }
827              
828             # There are no other non-object handles that we support
829             unless ( Scalar::Util::blessed($it) ) {
830             return undef;
831             }
832              
833             # Check for a common base classes for conventional IO::Handle object
834             if ( $it->isa('IO::Handle') ) {
835             return $it;
836             }
837              
838              
839             # Check for tied file handles using Tie::Handle
840             if ( $it->isa('Tie::Handle') ) {
841             return $it;
842             }
843              
844             # IO::Scalar is not a proper seekable, but it is valid is a
845             # regular file handle
846             if ( $it->isa('IO::Scalar') ) {
847             return $it;
848             }
849              
850             # Yet another special case for IO::String, which refuses (for now
851             # anyway) to become a subclass of IO::Handle.
852             if ( $it->isa('IO::String') ) {
853             return $it;
854             }
855              
856             # This is not any sort of object we know about
857             return undef;
858             }
859             END_PERL
860              
861             =pod
862              
863             =head2 _DRIVER $string
864              
865             sub foo {
866             my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver";
867             ...
868             }
869              
870             The C<_DRIVER> function is intended to be imported into your
871             package, and provides a convenient way to load and validate
872             a driver class.
873              
874             The most common pattern when taking a driver class as a parameter
875             is to check that the name is a class (i.e. check against _CLASS)
876             and then to load the class (if it exists) and then ensure that
877             the class returns true for the isa method on some base driver name.
878              
879             Return the value as a convenience, or C if the value is not
880             a class name, the module does not exist, the module does not load,
881             or the class fails the isa test.
882              
883             =cut
884              
885 38 100 100 62   778 eval <<'END_PERL' unless defined &_DRIVER;
886             sub _DRIVER ($$) {
887             (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
888             }
889             END_PERL
890              
891             sub _alt_hook {
892             package
893             Params::Util;
894              
895 1     25   375591 our @EXPORT_OK = @Params::SomeUtil::EXPORT_OK;
896 1         27 our @ISA = @Params::SomeUtil::ISA;
897 1         7 our %EXPORT_TAGS = %Params::SomeUtil::EXPORT_TAGS;
898 1         3 our $VERSION = 1.07;
899              
900 1         4 foreach my $sub (@EXPORT_OK) {
901 19     19   153 no strict 'refs';
  19         83  
  19         3423  
902 27         40 *{$sub} = \&{"Params::SomeUtil::$sub"};
  27         104  
  27         72  
903             }
904             }
905              
906             1;
907              
908             =pod
909              
910             =head1 TO DO
911              
912             - Add _CAN to help resolve the UNIVERSAL::can debacle
913              
914             - Implement an assertion-like version of this module, that dies on
915             error.
916              
917             - Implement a Test:: version of this module, for use in testing
918              
919             =head1 SUPPORT
920              
921             Bugs should be reported on the GitHub for this repository
922              
923             L
924              
925             For other issues, contact the author.
926              
927             =head1 AUTHOR
928              
929             Adam Kennedy Eadamk@cpan.orgE
930              
931             Maintained by
932              
933             Graham Ollis (PLICEASE)
934              
935             Contributors
936              
937             Paul Cochrane (PTC)
938              
939             Ricardo Signes (RGBS)
940              
941             RAFL
942              
943             Andrew Main (ZEFRAM)
944              
945             David Golden (DAGOLDEN)
946              
947             Tatsuhiko Miyagawa (MIYAGAWA)
948              
949             Peter Rabbitson (RIBASUSHI)
950              
951             =head1 SEE ALSO
952              
953             L
954              
955             =head1 COPYRIGHT
956              
957             Copyright 2005 - 2012 Adam Kennedy.
958              
959             This program is free software; you can redistribute
960             it and/or modify it under the same terms as Perl itself.
961              
962             The full text of the license can be found in the
963             LICENSE file included with this module.
964              
965             =cut