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
CommitLineData
f4a2945e
JH
1# Scalar::Util.pm
2#
42975ef9 3# Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
f4a2945e
JH
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7package Scalar::Util;
8
9require Exporter;
10require List::Util; # List::Util loads the XS
11
09c2a9b8
GB
12@ISA = qw(Exporter);
13@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
42975ef9 14$VERSION = "1.14";
09c2a9b8
GB
15$VERSION = eval $VERSION;
16
17sub 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
GB
34sub 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
GB
52eval <<'ESQ' unless defined &dualvar;
53
54push @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
59sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
60
61sub 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
68sub 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
76sub 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
105sub tainted {
106 local($@, $SIG{__DIE__}, $SIG{__WARN__});
107 local $^W = 0;
108 eval { kill 0 * $_[0] };
109 $@ =~ /^Insecure/;
110}
111
112sub 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
121sub looks_like_number {
122 local $_ = shift;
123
124 # checks from perlfaq4
4579700c 125 return $] < 5.009002 unless defined;
09c2a9b8
GB
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
133ESQ
134
f4a2945e
JH
1351;
136
137__END__
138
139=head1 NAME
140
141Scalar::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
JH
146
147=head1 DESCRIPTION
148
149C<Scalar::Util> contains a selection of subroutines that people have
150expressed would be nice to have in the perl core, but the usage would
151not really be high enough to warrant the use of a keyword, and the size
152so small such that being individual extensions would be wasteful.
153
154By default C<Scalar::Util> does not export any subroutines. The
155subroutines defined are
156
157=over 4
158
159=item blessed EXPR
160
161If EXPR evaluates to a blessed reference the name of the package
162that it is blessed into is returned. Otherwise C<undef> is returned.
163
c29e891d
GB
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
JH
173=item dualvar NUM, STRING
174
175Returns a scalar that has the value NUM in a numeric context and the
176value STRING in a string context.
177
178 $foo = dualvar 10, "Hello";
c29e891d
GB
179 $num = $foo + 2; # 12
180 $str = $foo . " world"; # Hello world
f4a2945e 181
60f3865b
GB
182=item isvstring EXPR
183
184If 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
JH
190=item isweak EXPR
191
192If EXPR is a scalar which is a weak reference the result is true.
193
c29e891d
GB
194 $ref = \$foo;
195 $weak = isweak($ref); # false
196 weaken($ref);
197 $weak = isweak($ref); # true
198
9e7deb6c
GB
199=item looks_like_number EXPR
200
201Returns true if perl thinks EXPR is a number. See
202L<perlapi/looks_like_number>.
203
c0f790df
GB
204=item openhandle FH
205
206Returns FH if FH may be used as a filehandle and is open, or FH is a tied
207handle. 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
JH
214=item readonly SCALAR
215
216Returns true if SCALAR is readonly.
217
c29e891d
GB
218 sub foo { readonly($_[0]) }
219
220 $readonly = foo($bar); # false
221 $readonly = foo(0); # true
222
60f3865b
GB
223=item refaddr EXPR
224
225If EXPR evaluates to a reference the internal memory address of
226the 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
JH
235=item reftype EXPR
236
237If EXPR evaluates to a reference the type of the variable referenced
238is returned. Otherwise C<undef> is returned.
239
c29e891d
GB
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
GB
247=item set_prototype CODEREF, PROTOTYPE
248
249Sets the prototype of the given function, or deletes it if PROTOTYPE is
250undef. Returns the CODEREF.
251
252 set_prototype \&foo, '$$';
253
ee4ffb48
JH
254=item tainted EXPR
255
256Return true if the result of EXPR is tainted
257
c29e891d
GB
258 $taint = tainted("constant"); # false
259 $taint = tainted($ENV{PWD}); # true if running under -T
260
f4a2945e
JH
261=item weaken REF
262
263REF will be turned into a weak reference. This means that it will not
264hold a reference count on the object it references. Also when the reference
265count on that object reaches zero, REF will be set to undef.
266
267This is useful for keeping copies of references , but you don't want to
022735b4 268prevent the object being DESTROY-ed at its usual time.
f4a2945e 269
c29e891d
GB
270 {
271 my $var;
272 $ref = \$var;
273 weaken($ref); # Make $ref a weak reference
274 }
275 # $ref is now undef
276
f4a2945e
JH
277=back
278
9c3c560b
JH
279=head1 KNOWN BUGS
280
281There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
282show up as tests 8 and 9 of dualvar.t failing
283
f4a2945e
JH
284=head1 COPYRIGHT
285
42975ef9 286Copyright (c) 1997-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
c29e891d 287This program is free software; you can redistribute it and/or modify it
f4a2945e
JH
288under the same terms as Perl itself.
289
c29e891d 290Except weaken and isweak which are
f4a2945e
JH
291
292Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
293This program is free software; you can redistribute it and/or modify it
294under the same terms as perl itself.
295
296=head1 BLATANT PLUG
297
298The weaken and isweak subroutines in this module and the patch to the core Perl
299were written in connection with the APress book `Tuomas J. Lukka's Definitive
300Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
301things would have to be done in cumbersome ways.
302
303=cut