ext/List/Util/lib/Scalar/Util.pm

   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
   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.17";
  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   "$_[0]" =~ /0x(\w+)/;
  72   my $i = do { local $^W; hex $1 };
  73   bless $_[0], $pkg;
  74   $i;
  75 }
  76
  77 sub reftype ($) {
  78   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  79   my $r = shift;
  80   my $t;
  81
  82   length($t = ref($r)) or return undef;
  83
  84   # This eval will fail if the reference is not blessed
  85   eval { $r->a_sub_not_likely_to_be_here; 1 }
  86     ? do {
  87       $t = eval {
  88           # we have a GLOB or an IO. Stringify a GLOB gives it's name
  89           my $q = *$r;
  90           $q =~ /^\*/ ? "GLOB" : "IO";
  91         }
  92         or do {
  93           # OK, if we don't have a GLOB what parts of
  94           # a glob will it populate.
  95           # NOTE: A glob always has a SCALAR
  96           local *glob = $r;
  97           defined *glob{ARRAY} && "ARRAY"
  98           or defined *glob{HASH} && "HASH"
  99           or defined *glob{CODE} && "CODE"
 100           or length(ref(${$r})) ? "REF" : "SCALAR";
 101         }
 102     }
 103     : $t
 104 }
 105
 106 sub tainted {
 107   local($@, $SIG{__DIE__}, $SIG{__WARN__});
 108   local $^W = 0;
 109   eval { kill 0 * $_[0] };
 110   $@ =~ /^Insecure/;
 111 }
 112
 113 sub readonly {
 114   return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
 115
 116   local($@, $SIG{__DIE__}, $SIG{__WARN__});
 117   my $tmp = $_[0];
 118
 119   !eval { $_[0] = $tmp; 1 };
 120 }
 121
 122 sub looks_like_number {
 123   local $_ = shift;
 124
 125   # checks from perlfaq4
 126   return $] < 5.008005 unless defined;
 127   return 1 if (/^[+-]?\d+$/); # is a +/- integer
 128   return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
 129   return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
 130
 131   0;
 132 }
 133
 134 ESQ
 135
 136 1;
 137
 138 __END__
 139
 140 =head1 NAME
 141
 142 Scalar::Util - A selection of general-utility scalar subroutines
 143
 144 =head1 SYNOPSIS
 145
 146     use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted weaken isvstring looks_like_number set_prototype);
 147
 148 =head1 DESCRIPTION
 149
 150 C<Scalar::Util> contains a selection of subroutines that people have
 151 expressed would be nice to have in the perl core, but the usage would
 152 not really be high enough to warrant the use of a keyword, and the size
 153 so small such that being individual extensions would be wasteful.
 154
 155 By default C<Scalar::Util> does not export any subroutines. The
 156 subroutines defined are
 157
 158 =over 4
 159
 160 =item blessed EXPR
 161
 162 If EXPR evaluates to a blessed reference the name of the package
 163 that it is blessed into is returned. Otherwise C<undef> is returned.
 164
 165    $scalar = "foo";
 166    $class  = blessed $scalar;           # undef
 167
 168    $ref    = [];
 169    $class  = blessed $ref;              # undef
 170
 171    $obj    = bless [], "Foo";
 172    $class  = blessed $obj;              # "Foo"
 173
 174 =item dualvar NUM, STRING
 175
 176 Returns a scalar that has the value NUM in a numeric context and the
 177 value STRING in a string context.
 178
 179     $foo = dualvar 10, "Hello";
 180     $num = $foo + 2;                    # 12
 181     $str = $foo . " world";             # Hello world
 182
 183 =item isvstring EXPR
 184
 185 If EXPR is a scalar which was coded as a vstring the result is true.
 186
 187     $vs   = v49.46.48;
 188     $fmt  = isvstring($vs) ? "%vd" : "%s"; #true
 189     printf($fmt,$vs);
 190
 191 =item isweak EXPR
 192
 193 If EXPR is a scalar which is a weak reference the result is true.
 194
 195     $ref  = \$foo;
 196     $weak = isweak($ref);               # false
 197     weaken($ref);
 198     $weak = isweak($ref);               # true
 199
 200 =item looks_like_number EXPR
 201
 202 Returns true if perl thinks EXPR is a number. See
 203 L<perlapi/looks_like_number>.
 204
 205 =item openhandle FH
 206
 207 Returns FH if FH may be used as a filehandle and is open, or FH is a tied
 208 handle. Otherwise C<undef> is returned.
 209
 210     $fh = openhandle(*STDIN);           # \*STDIN
 211     $fh = openhandle(\*STDIN);          # \*STDIN
 212     $fh = openhandle(*NOTOPEN);         # undef
 213     $fh = openhandle("scalar");         # undef
 214
 215 =item readonly SCALAR
 216
 217 Returns true if SCALAR is readonly.
 218
 219     sub foo { readonly($_[0]) }
 220
 221     $readonly = foo($bar);              # false
 222     $readonly = foo(0);                 # true
 223
 224 =item refaddr EXPR
 225
 226 If EXPR evaluates to a reference the internal memory address of
 227 the referenced value is returned. Otherwise C<undef> is returned.
 228
 229     $addr = refaddr "string";           # undef
 230     $addr = refaddr \$var;              # eg 12345678
 231     $addr = refaddr [];                 # eg 23456784
 232
 233     $obj  = bless {}, "Foo";
 234     $addr = refaddr $obj;               # eg 88123488
 235
 236 =item reftype EXPR
 237
 238 If EXPR evaluates to a reference the type of the variable referenced
 239 is returned. Otherwise C<undef> is returned.
 240
 241     $type = reftype "string";           # undef
 242     $type = reftype \$var;              # SCALAR
 243     $type = reftype [];                 # ARRAY
 244
 245     $obj  = bless {}, "Foo";
 246     $type = reftype $obj;               # HASH
 247
 248 =item set_prototype CODEREF, PROTOTYPE
 249
 250 Sets the prototype of the given function, or deletes it if PROTOTYPE is
 251 undef. Returns the CODEREF.
 252
 253     set_prototype \&foo, '$$';
 254
 255 =item tainted EXPR
 256
 257 Return true if the result of EXPR is tainted
 258
 259     $taint = tainted("constant");       # false
 260     $taint = tainted($ENV{PWD});        # true if running under -T
 261
 262 =item weaken REF
 263
 264 REF will be turned into a weak reference. This means that it will not
 265 hold a reference count on the object it references. Also when the reference
 266 count on that object reaches zero, REF will be set to undef.
 267
 268 This is useful for keeping copies of references , but you don't want to
 269 prevent the object being DESTROY-ed at its usual time.
 270
 271     {
 272       my $var;
 273       $ref = \$var;
 274       weaken($ref);                     # Make $ref a weak reference
 275     }
 276     # $ref is now undef
 277
 278 Note that if you take a copy of a scalar with a weakened reference,
 279 the copy will be a strong reference.
 280
 281     my $var;
 282     my $foo = \$var;
 283     weaken($foo);                       # Make $foo a weak reference
 284     my $bar = $foo;                     # $bar is now a strong reference
 285
 286 This may be less obvious in other situations, such as C<grep()>, for instance
 287 when grepping through a list of weakened references to objects that may have
 288 been destroyed already:
 289
 290     @object = grep { defined } @object;
 291
 292 This will indeed remove all references to destroyed objects, but the remaining
 293 references to objects will be strong, causing the remaining objects to never
 294 be destroyed because there is now always a strong reference to them in the
 295 @object array.
 296
 297 =back
 298
 299 =head1 KNOWN BUGS
 300
 301 There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
 302 show up as tests 8 and 9 of dualvar.t failing
 303
 304 =head1 COPYRIGHT
 305
 306 Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
 307 This program is free software; you can redistribute it and/or modify it
 308 under the same terms as Perl itself.
 309
 310 Except weaken and isweak which are
 311
 312 Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
 313 This program is free software; you can redistribute it and/or modify it
 314 under the same terms as perl itself.
 315
 316 =head1 BLATANT PLUG
 317
 318 The weaken and isweak subroutines in this module and the patch to the core Perl
 319 were written in connection  with the APress book `Tuomas J. Lukka's Definitive
 320 Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
 321 things would have to be done in cumbersome ways.
 322
 323 =cut