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