1# Scalar::Util.pm
2#
3# Copyright (c) 1997-2005 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
7package Scalar::Util;
8
9use strict;
10use vars qw(@ISA @EXPORT_OK $VERSION);
11require Exporter;
12require 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.18";
17$VERSION   = eval $VERSION;
18
19sub 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
36sub 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
54eval <<'ESQ' unless defined &dualvar;
55
56use vars qw(@EXPORT_FAIL);
57push @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
62sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
63
64sub 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
71sub 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
85sub 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
114sub tainted {
115  local($@, $SIG{__DIE__}, $SIG{__WARN__});
116  local $^W = 0;
117  eval { kill 0 * $_[0] };
118  $@ =~ /^Insecure/;
119}
120
121sub 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
130sub 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
142ESQ
143
1441;
145
146__END__
147
148=head1 NAME
149
150Scalar::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
159C<Scalar::Util> contains a selection of subroutines that people have
160expressed would be nice to have in the perl core, but the usage would
161not really be high enough to warrant the use of a keyword, and the size
162so small such that being individual extensions would be wasteful.
163
164By default C<Scalar::Util> does not export any subroutines. The
165subroutines defined are
166
167=over 4
168
169=item blessed EXPR
170
171If EXPR evaluates to a blessed reference the name of the package
172that 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
185Returns a scalar that has the value NUM in a numeric context and the
186value 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
194If 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
202If 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
209B<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
216Returns true if perl thinks EXPR is a number. See
217L<perlapi/looks_like_number>.
218
219=item openhandle FH
220
221Returns FH if FH may be used as a filehandle and is open, or FH is a tied
222handle. 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
231Returns 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
240If EXPR evaluates to a reference the internal memory address of
241the 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
252If EXPR evaluates to a reference the type of the variable referenced
253is 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
264Sets the prototype of the given function, or deletes it if PROTOTYPE is
265undef. Returns the CODEREF.
266
267    set_prototype \&foo, '$$';
268
269=item tainted EXPR
270
271Return 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
278REF will be turned into a weak reference. This means that it will not
279hold a reference count on the object it references. Also when the reference
280count on that object reaches zero, REF will be set to undef.
281
282This is useful for keeping copies of references , but you don't want to
283prevent 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
292Note that if you take a copy of a scalar with a weakened reference,
293the 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
300This may be less obvious in other situations, such as C<grep()>, for instance
301when grepping through a list of weakened references to objects that may have
302been destroyed already:
303
304    @object = grep { defined } @object;
305
306This will indeed remove all references to destroyed objects, but the remaining
307references to objects will be strong, causing the remaining objects to never
308be 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
315There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
316show up as tests 8 and 9 of dualvar.t failing
317
318=head1 COPYRIGHT
319
320Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
321This program is free software; you can redistribute it and/or modify it
322under the same terms as Perl itself.
323
324Except weaken and isweak which are
325
326Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
327This program is free software; you can redistribute it and/or modify it
328under the same terms as perl itself.
329
330=head1 BLATANT PLUG
331
332The weaken and isweak subroutines in this module and the patch to the core Perl
333were written in connection  with the APress book `Tuomas J. Lukka's Definitive
334Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
335things would have to be done in cumbersome ways.
336
337=cut
338