Commit | Line | Data |
f4a2945e |
1 | # Scalar::Util.pm |
2 | # |
09c2a9b8 |
3 | # Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved. |
f4a2945e |
4 | # This program is free software; you can redistribute it and/or |
5 | # modify it under the same terms as Perl itself. |
6 | |
7 | package Scalar::Util; |
8 | |
9 | require Exporter; |
10 | require List::Util; # List::Util loads the XS |
11 | |
09c2a9b8 |
12 | @ISA = qw(Exporter); |
13 | @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); |
aaaf1885 |
14 | $VERSION = "1.13"; |
09c2a9b8 |
15 | $VERSION = eval $VERSION; |
16 | |
17 | sub export_fail { |
18 | if (grep { /^(weaken|isweak)$/ } @_ ) { |
19 | require Carp; |
20 | Carp::croak("Weak references are not implemented in the version of perl"); |
21 | } |
22 | if (grep { /^(isvstring)$/ } @_ ) { |
23 | require Carp; |
24 | Carp::croak("Vstrings are not implemented in the version of perl"); |
25 | } |
26 | if (grep { /^(dualvar|set_prototype)$/ } @_ ) { |
27 | require Carp; |
28 | Carp::croak("$1 is only avaliable with the XS version"); |
29 | } |
30 | |
31 | @_; |
32 | } |
f4a2945e |
33 | |
c0f790df |
34 | sub openhandle ($) { |
35 | my $fh = shift; |
36 | my $rt = reftype($fh) || ''; |
37 | |
38 | return defined(fileno($fh)) ? $fh : undef |
39 | if $rt eq 'IO'; |
40 | |
41 | if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) |
42 | $fh = \(my $tmp=$fh); |
43 | } |
44 | elsif ($rt ne 'GLOB') { |
45 | return undef; |
46 | } |
47 | |
48 | (tied(*$fh) or defined(fileno($fh))) |
49 | ? $fh : undef; |
50 | } |
51 | |
09c2a9b8 |
52 | eval <<'ESQ' unless defined &dualvar; |
53 | |
54 | push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); |
55 | |
56 | # The code beyond here is only used if the XS is not installed |
57 | |
58 | # Hope nobody defines a sub by this name |
59 | sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } |
60 | |
61 | sub blessed ($) { |
62 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
63 | length(ref($_[0])) |
64 | ? eval { $_[0]->a_sub_not_likely_to_be_here } |
65 | : undef |
66 | } |
67 | |
68 | sub refaddr($) { |
69 | my $pkg = ref($_[0]) or return undef; |
70 | bless $_[0], 'Scalar::Util::Fake'; |
71 | my $i = int($_[0]); |
72 | bless $_[0], $pkg; |
73 | $i; |
74 | } |
75 | |
76 | sub reftype ($) { |
77 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
78 | my $r = shift; |
79 | my $t; |
80 | |
81 | length($t = ref($r)) or return undef; |
82 | |
83 | # This eval will fail if the reference is not blessed |
84 | eval { $r->a_sub_not_likely_to_be_here; 1 } |
85 | ? do { |
86 | $t = eval { |
87 | # we have a GLOB or an IO. Stringify a GLOB gives it's name |
88 | my $q = *$r; |
89 | $q =~ /^\*/ ? "GLOB" : "IO"; |
90 | } |
91 | or do { |
92 | # OK, if we don't have a GLOB what parts of |
93 | # a glob will it populate. |
94 | # NOTE: A glob always has a SCALAR |
95 | local *glob = $r; |
96 | defined *glob{ARRAY} && "ARRAY" |
97 | or defined *glob{HASH} && "HASH" |
98 | or defined *glob{CODE} && "CODE" |
99 | or length(ref(${$r})) ? "REF" : "SCALAR"; |
100 | } |
101 | } |
102 | : $t |
103 | } |
104 | |
105 | sub tainted { |
106 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
107 | local $^W = 0; |
108 | eval { kill 0 * $_[0] }; |
109 | $@ =~ /^Insecure/; |
110 | } |
111 | |
112 | sub readonly { |
113 | return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); |
114 | |
115 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
116 | my $tmp = $_[0]; |
117 | |
118 | !eval { $_[0] = $tmp; 1 }; |
119 | } |
120 | |
121 | sub looks_like_number { |
122 | local $_ = shift; |
123 | |
124 | # checks from perlfaq4 |
125 | return 1 unless defined; |
126 | return 1 if (/^[+-]?\d+$/); # is a +/- integer |
127 | return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float |
128 | return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); |
129 | |
130 | 0; |
131 | } |
132 | |
133 | ESQ |
134 | |
f4a2945e |
135 | 1; |
136 | |
137 | __END__ |
138 | |
139 | =head1 NAME |
140 | |
141 | Scalar::Util - A selection of general-utility scalar subroutines |
142 | |
143 | =head1 SYNOPSIS |
144 | |
97605c51 |
145 | use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype); |
f4a2945e |
146 | |
147 | =head1 DESCRIPTION |
148 | |
149 | C<Scalar::Util> contains a selection of subroutines that people have |
150 | expressed would be nice to have in the perl core, but the usage would |
151 | not really be high enough to warrant the use of a keyword, and the size |
152 | so small such that being individual extensions would be wasteful. |
153 | |
154 | By default C<Scalar::Util> does not export any subroutines. The |
155 | subroutines defined are |
156 | |
157 | =over 4 |
158 | |
159 | =item blessed EXPR |
160 | |
161 | If EXPR evaluates to a blessed reference the name of the package |
162 | that it is blessed into is returned. Otherwise C<undef> is returned. |
163 | |
c29e891d |
164 | $scalar = "foo"; |
165 | $class = blessed $scalar; # undef |
166 | |
167 | $ref = []; |
168 | $class = blessed $ref; # undef |
169 | |
170 | $obj = bless [], "Foo"; |
171 | $class = blessed $obj; # "Foo" |
172 | |
f4a2945e |
173 | =item dualvar NUM, STRING |
174 | |
175 | Returns a scalar that has the value NUM in a numeric context and the |
176 | value STRING in a string context. |
177 | |
178 | $foo = dualvar 10, "Hello"; |
c29e891d |
179 | $num = $foo + 2; # 12 |
180 | $str = $foo . " world"; # Hello world |
f4a2945e |
181 | |
60f3865b |
182 | =item isvstring EXPR |
183 | |
184 | If EXPR is a scalar which was coded as a vstring the result is true. |
185 | |
186 | $vs = v49.46.48; |
187 | $fmt = isvstring($vs) ? "%vd" : "%s"; #true |
188 | printf($fmt,$vs); |
189 | |
f4a2945e |
190 | =item isweak EXPR |
191 | |
192 | If EXPR is a scalar which is a weak reference the result is true. |
193 | |
c29e891d |
194 | $ref = \$foo; |
195 | $weak = isweak($ref); # false |
196 | weaken($ref); |
197 | $weak = isweak($ref); # true |
198 | |
9e7deb6c |
199 | =item looks_like_number EXPR |
200 | |
201 | Returns true if perl thinks EXPR is a number. See |
202 | L<perlapi/looks_like_number>. |
203 | |
c0f790df |
204 | =item openhandle FH |
205 | |
206 | Returns FH if FH may be used as a filehandle and is open, or FH is a tied |
207 | handle. Otherwise C<undef> is returned. |
208 | |
209 | $fh = openhandle(*STDIN); # \*STDIN |
210 | $fh = openhandle(\*STDIN); # \*STDIN |
211 | $fh = openhandle(*NOTOPEN); # undef |
212 | $fh = openhandle("scalar"); # undef |
213 | |
ee4ffb48 |
214 | =item readonly SCALAR |
215 | |
216 | Returns true if SCALAR is readonly. |
217 | |
c29e891d |
218 | sub foo { readonly($_[0]) } |
219 | |
220 | $readonly = foo($bar); # false |
221 | $readonly = foo(0); # true |
222 | |
60f3865b |
223 | =item refaddr EXPR |
224 | |
225 | If EXPR evaluates to a reference the internal memory address of |
226 | the referenced value is returned. Otherwise C<undef> is returned. |
227 | |
228 | $addr = refaddr "string"; # undef |
229 | $addr = refaddr \$var; # eg 12345678 |
230 | $addr = refaddr []; # eg 23456784 |
231 | |
232 | $obj = bless {}, "Foo"; |
233 | $addr = refaddr $obj; # eg 88123488 |
234 | |
f4a2945e |
235 | =item reftype EXPR |
236 | |
237 | If EXPR evaluates to a reference the type of the variable referenced |
238 | is returned. Otherwise C<undef> is returned. |
239 | |
c29e891d |
240 | $type = reftype "string"; # undef |
241 | $type = reftype \$var; # SCALAR |
242 | $type = reftype []; # ARRAY |
243 | |
244 | $obj = bless {}, "Foo"; |
245 | $type = reftype $obj; # HASH |
246 | |
97605c51 |
247 | =item set_prototype CODEREF, PROTOTYPE |
248 | |
249 | Sets the prototype of the given function, or deletes it if PROTOTYPE is |
250 | undef. Returns the CODEREF. |
251 | |
252 | set_prototype \&foo, '$$'; |
253 | |
ee4ffb48 |
254 | =item tainted EXPR |
255 | |
256 | Return true if the result of EXPR is tainted |
257 | |
c29e891d |
258 | $taint = tainted("constant"); # false |
259 | $taint = tainted($ENV{PWD}); # true if running under -T |
260 | |
f4a2945e |
261 | =item weaken REF |
262 | |
263 | REF will be turned into a weak reference. This means that it will not |
264 | hold a reference count on the object it references. Also when the reference |
265 | count on that object reaches zero, REF will be set to undef. |
266 | |
267 | This is useful for keeping copies of references , but you don't want to |
022735b4 |
268 | prevent the object being DESTROY-ed at its usual time. |
f4a2945e |
269 | |
c29e891d |
270 | { |
271 | my $var; |
272 | $ref = \$var; |
273 | weaken($ref); # Make $ref a weak reference |
274 | } |
275 | # $ref is now undef |
276 | |
f4a2945e |
277 | =back |
278 | |
9c3c560b |
279 | =head1 KNOWN BUGS |
280 | |
281 | There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will |
282 | show up as tests 8 and 9 of dualvar.t failing |
283 | |
f4a2945e |
284 | =head1 COPYRIGHT |
285 | |
09c2a9b8 |
286 | Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved. |
c29e891d |
287 | This program is free software; you can redistribute it and/or modify it |
f4a2945e |
288 | under the same terms as Perl itself. |
289 | |
c29e891d |
290 | Except weaken and isweak which are |
f4a2945e |
291 | |
292 | Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved. |
293 | This program is free software; you can redistribute it and/or modify it |
294 | under the same terms as perl itself. |
295 | |
296 | =head1 BLATANT PLUG |
297 | |
298 | The weaken and isweak subroutines in this module and the patch to the core Perl |
299 | were written in connection with the APress book `Tuomas J. Lukka's Definitive |
300 | Guide to Object-Oriented Programming in Perl', to avoid explaining why certain |
301 | things would have to be done in cumbersome ways. |
302 | |
303 | =cut |