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 =cut