This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Scalar-List-Utils-1.19
[perl5.git] / ext / List / Util / lib / Scalar / Util.pm
1 # Scalar::Util.pm
2 #
3 # Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
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 use strict;
10 use vars qw(@ISA @EXPORT_OK $VERSION);
11 require Exporter;
12 require List::Util; # List::Util loads the XS
13
14 @ISA       = qw(Exporter);
15 @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
16 $VERSION    = "1.19";
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 }
35
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
54 eval <<'ESQ' unless defined &dualvar;
55
56 use vars qw(@EXPORT_FAIL);
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;
73   if (blessed($_[0])) {
74     bless $_[0], 'Scalar::Util::Fake';
75   }
76   else {
77     $pkg = undef;
78   }
79   "$_[0]" =~ /0x(\w+)/;
80   my $i = do { local $^W; hex $1 };
81   bless $_[0], $pkg if defined $pkg;
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
134   return 0 if !defined($_) or ref($_);
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
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
154     use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted
155                         weaken isvstring looks_like_number set_prototype);
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
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
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";
189     $num = $foo + 2;                    # 12
190     $str = $foo . " world";             # Hello world
191
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
200 =item isweak EXPR
201
202 If EXPR is a scalar which is a weak reference the result is true.
203
204     $ref  = \$foo;
205     $weak = isweak($ref);               # false
206     weaken($ref);
207     $weak = isweak($ref);               # true
208
209 B<NOTE>: Copying a weak reference creates a normal, strong, reference.
210
211     $copy = $ref;
212     $weak = isweak($ref);               # false
213
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
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     
229 =item readonly SCALAR
230
231 Returns true if SCALAR is readonly.
232
233     sub foo { readonly($_[0]) }
234
235     $readonly = foo($bar);              # false
236     $readonly = foo(0);                 # true
237
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
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
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
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
269 =item tainted EXPR
270
271 Return true if the result of EXPR is tainted
272
273     $taint = tainted("constant");       # false
274     $taint = tainted($ENV{PWD});        # true if running under -T
275
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
283 prevent the object being DESTROY-ed at its usual time.
284
285     {
286       my $var;
287       $ref = \$var;
288       weaken($ref);                     # Make $ref a weak reference
289     }
290     # $ref is now undef
291
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
311 =back
312
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
318 =head1 SEE ALSO
319
320 L<List::Util>
321
322 =head1 COPYRIGHT
323
324 Copyright (c) 1997-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
325 This program is free software; you can redistribute it and/or modify it
326 under the same terms as Perl itself.
327
328 Except weaken and isweak which are
329
330 Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
331 This program is free software; you can redistribute it and/or modify it
332 under the same terms as perl itself.
333
334 =head1 BLATANT PLUG
335
336 The weaken and isweak subroutines in this module and the patch to the core Perl
337 were written in connection  with the APress book `Tuomas J. Lukka's Definitive
338 Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
339 things would have to be done in cumbersome ways.
340
341 =cut