File Coverage

blib/lib/Params/Util/PP.pm
Criterion Covered Total %
statement 65 71 91.5
branch 67 72 93.0
condition 58 62 93.5
subroutine 31 32 96.8
pod n/a
total 221 237 93.2


line stmt bran cond sub pod time code
1             package Params::Util::PP;
2              
3 18     18   110 use strict;
  18         34  
  18         465  
4 18     18   77 use warnings;
  18         41  
  18         683  
5              
6             our $VERSION = '1.100';
7              
8             =pod
9              
10             =head1 NAME
11              
12             Params::Util::PP - PurePerl Params::Util routines
13              
14             =cut
15              
16 18     18   117 use Scalar::Util ();
  18         38  
  18         320  
17 18     18   20433 use overload ();
  18         14998  
  18         36014  
18              
19             Scalar::Util->can("looks_like_number") and Scalar::Util->import("looks_like_number");
20             # Use a private pure-perl copy of looks_like_number if the version of
21             # Scalar::Util is old (for whatever reason).
22             Params::Util::PP->can("looks_like_number") or *looks_like_number = sub {
23             local $_ = shift;
24              
25             # checks from perlfaq4
26             return 0 if !defined($_);
27             if (ref($_))
28             {
29             return overload::Overloaded($_) ? defined(0 + $_) : 0;
30             }
31             return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
32             ## no critic (RegularExpressions::ProhibitComplexRegexes)
33             return 1 if (/^(?:[+-]?)(?=[0-9]|\.[0-9])[0-9]*(?:\.[0-9]*)?(?:[Ee](?:[+-]?[0-9]+))?$/); # a C float
34             return 1 if ($] >= 5.008 and /^(?:Inf(?:inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
35              
36             0;
37             };
38              
39             ## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking)
40             ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
41              
42 0     0   0 sub _XScompiled { return 0; }
43              
44             sub _STRING ($)
45             {
46 50     50   12618 my $arg = $_[0];
47 50 100 100     435 return (defined $arg and not ref $arg and length($arg)) ? $arg : undef;
48             }
49              
50             sub _IDENTIFIER ($)
51             {
52 76     76   34938 my $arg = $_[0];
53 76 100 100     723 return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*\z/s) ? $arg : undef;
54             }
55              
56             sub _CLASS ($)
57             {
58 152     152   19482 my $arg = $_[0];
59 152 100 100     2591 return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $arg : undef;
60             }
61              
62             sub _CLASSISA ($$)
63             {
64 52 100 100 52   10996 return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef;
65             }
66              
67             sub _CLASSDOES ($$)
68             {
69 8 100 66 8   237 return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef;
70             }
71              
72             sub _SUBCLASS ($$)
73             {
74 52 100 100 52   693 return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1]))
75             ? $_[0]
76             : undef;
77             }
78              
79             sub _NUMBER ($)
80             {
81 62     62   14022 my $arg = $_[0];
82 62 100 100     656 return (defined $arg and not ref $arg and looks_like_number($arg)) ? $arg : undef;
83             }
84              
85             sub _POSINT ($)
86             {
87 84     84   40444 my $arg = $_[0];
88 84 100 100     824 return (defined $arg and not ref $arg and $arg =~ m/^[1-9]\d*$/) ? $arg : undef;
89             }
90              
91             sub _NONNEGINT ($)
92             {
93 88     88   16301 my $arg = $_[0];
94 88 100 100     821 return (defined $arg and not ref $arg and $arg =~ m/^(?:0|[1-9]\d*)$/) ? $arg : undef;
95             }
96              
97             sub _SCALAR ($)
98             {
99 24 100 100 24   1511 return (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef;
100             }
101              
102             sub _SCALAR0 ($)
103             {
104 28 100   28   168 return ref $_[0] eq 'SCALAR' ? $_[0] : undef;
105             }
106              
107             sub _ARRAY ($)
108             {
109 68 100 100 68   347 return (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef;
110             }
111              
112             sub _ARRAY0 ($)
113             {
114 68 100   68   437 return ref $_[0] eq 'ARRAY' ? $_[0] : undef;
115             }
116              
117             sub _ARRAYLIKE
118             {
119             return (
120 36 100 100 36   12264 defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'ARRAY')
121             or overload::Method($_[0], '@{}'))
122             ) ? $_[0] : undef;
123             }
124              
125             sub _HASH ($)
126             {
127 22 100 100 22   122 return (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef;
128             }
129              
130             sub _HASH0 ($)
131             {
132 22 100   22   125 return ref $_[0] eq 'HASH' ? $_[0] : undef;
133             }
134              
135             sub _HASHLIKE
136             {
137             return (
138 36 100 100 36   12955 defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'HASH')
139             or overload::Method($_[0], '%{}'))
140             ) ? $_[0] : undef;
141             }
142              
143             sub _CODE ($)
144             {
145 24 100   24   153 return ref $_[0] eq 'CODE' ? $_[0] : undef;
146             }
147              
148             sub _CODELIKE($)
149             {
150             return (
151 17 100 100 17   8020 (Scalar::Util::reftype($_[0]) || '') eq 'CODE'
152             or Scalar::Util::blessed($_[0]) and overload::Method($_[0], '&{}')
153             ) ? $_[0] : undef;
154             }
155              
156             sub _INVOCANT($)
157             {
158             return (
159 20 100 100 20   9464 defined $_[0]
160             and (
161             defined Scalar::Util::blessed($_[0])
162             or
163             # We used to check for stash definedness, but any class-like name is a
164             # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02
165             _CLASS($_[0])
166             )
167             ) ? $_[0] : undef;
168             }
169              
170             sub _INSTANCE ($$)
171             {
172 81 100 100 81   22861 return (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef;
173             }
174              
175             sub _INSTANCEDOES ($$)
176             {
177 38 100 66 38   126633 return (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef;
178             }
179              
180             sub _REGEX ($)
181             {
182 22 100 100 22   769 return (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef;
183             }
184              
185             sub _SET ($$)
186             {
187 44     44   11005 my $set_param = shift;
188 44 100       84 _ARRAY($set_param) or return undef;
189 12         26 foreach my $item (@$set_param)
190             {
191 12 100       27 _INSTANCE($item, $_[0]) or return undef;
192             }
193 4         16 return $set_param;
194             }
195              
196             sub _SET0 ($$)
197             {
198 44     44   86 my $set_param = shift;
199 44 100       82 _ARRAY0($set_param) or return undef;
200 16         36 foreach my $item (@$set_param)
201             {
202 12 100       28 _INSTANCE($item, $_[0]) or return undef;
203             }
204 8         33 return $set_param;
205             }
206              
207             # We're doing this longhand for now. Once everything is perfect,
208             # we'll compress this into something that compiles more efficiently.
209             # Further, testing file handles is not something that is generally
210             # done millions of times, so doing it slowly is not a big speed hit.
211             sub _HANDLE
212             {
213 30     30   33107 my $it = shift;
214              
215             # It has to be defined, of course
216 30 100       86 unless (defined $it)
217             {
218 2         6 return undef;
219             }
220              
221             # Normal globs are considered to be file handles
222 28 100       68 if (ref $it eq 'GLOB')
223             {
224 6         15 return $it;
225             }
226              
227             # Check for a normal tied filehandle
228             # Side Note: 5.5.4's tied() and can() doesn't like getting undef
229 22 50 33     49 if (tied($it) and tied($it)->can('TIEHANDLE'))
230             {
231 0         0 return $it;
232             }
233              
234             # There are no other non-object handles that we support
235 22 100       55 unless (Scalar::Util::blessed($it))
236             {
237 20         36 return undef;
238             }
239              
240             # Check for a common base classes for conventional IO::Handle object
241 2 50       33 if ($it->isa('IO::Handle'))
242             {
243 0         0 return $it;
244             }
245              
246             # Check for tied file handles using Tie::Handle
247 2 50       12 if ($it->isa('Tie::Handle'))
248             {
249 0         0 return $it;
250             }
251              
252             # IO::Scalar is not a proper seekable, but it is valid is a
253             # regular file handle
254 2 50       11 if ($it->isa('IO::Scalar'))
255             {
256 0         0 return $it;
257             }
258              
259             # Yet another special case for IO::String, which refuses (for now
260             # anyway) to become a subclass of IO::Handle.
261 2 50       8 if ($it->isa('IO::String'))
262             {
263 0         0 return $it;
264             }
265              
266             # This is not any sort of object we know about
267 2         6 return undef;
268             }
269              
270             sub _DRIVER ($$)
271             {
272             ## no critic (BuiltinFunctions::ProhibitStringyEval)
273 38 100 100 38   92 return (defined _CLASS($_[0]) and eval "require $_[0];" and not $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef;
274             }
275              
276             1;