This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update to Scalar-List-Utils-1.14
[perl5.git] / ext / List / Util / lib / Scalar / Util.pm
1 # Scalar::Util.pm
2 #
3 # Copyright (c) 1997-2004 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 require Exporter;
10 require List::Util; # List::Util loads the XS
11
12 @ISA       = qw(Exporter);
13 @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
14 $VERSION    = "1.14";
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 }
33
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
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 $] < 5.009002 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
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
145     use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype);
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
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
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";
179     $num = $foo + 2;                    # 12
180     $str = $foo . " world";             # Hello world
181
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
190 =item isweak EXPR
191
192 If EXPR is a scalar which is a weak reference the result is true.
193
194     $ref  = \$foo;
195     $weak = isweak($ref);               # false
196     weaken($ref);
197     $weak = isweak($ref);               # true
198
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
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     
214 =item readonly SCALAR
215
216 Returns true if SCALAR is readonly.
217
218     sub foo { readonly($_[0]) }
219
220     $readonly = foo($bar);              # false
221     $readonly = foo(0);                 # true
222
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
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
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
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
254 =item tainted EXPR
255
256 Return true if the result of EXPR is tainted
257
258     $taint = tainted("constant");       # false
259     $taint = tainted($ENV{PWD});        # true if running under -T
260
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
268 prevent the object being DESTROY-ed at its usual time.
269
270     {
271       my $var;
272       $ref = \$var;
273       weaken($ref);                     # Make $ref a weak reference
274     }
275     # $ref is now undef
276
277 =back
278
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
284 =head1 COPYRIGHT
285
286 Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
287 This program is free software; you can redistribute it and/or modify it
288 under the same terms as Perl itself.
289
290 Except weaken and isweak which are
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