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.15";
  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 Note that if you take a copy of a scalar with a weakened reference,
 278 the copy will be a strong reference.
 279
 280     my $var;
 281     my $foo = \$var;
 282     weaken($foo);                       # Make $foo a weak reference
 283     my $bar = $foo;                     # $bar is now a strong reference
 284
 285 This may be less obvious in other situations, such as C<grep()>, for instance
 286 when grepping through a list of weakened references to objects that may have
 287 been destroyed already:
 288
 289     @object = grep { defined } @object;
 290
 291 This will indeed remove all references to destroyed objects, but the remaining
 292 references to objects will be strong, causing the remaining objects to never
 293 be destroyed because there is now always a strong reference to them in the
 294 @object array.
 295
 296 =back
 297
 298 =head1 KNOWN BUGS
 299
 300 There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will
 301 show up as tests 8 and 9 of dualvar.t failing
 302
 303 =head1 COPYRIGHT
 304
 305 Copyright (c) 1997-2005 Graham Barr <gbarr@pobox.com>. All rights reserved.
 306 This program is free software; you can redistribute it and/or modify it
 307 under the same terms as Perl itself.
 308
 309 Except weaken and isweak which are
 310
 311 Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
 312 This program is free software; you can redistribute it and/or modify it
 313 under the same terms as perl itself.
 314
 315 =head1 BLATANT PLUG
 316
 317 The weaken and isweak subroutines in this module and the patch to the core Perl
 318 were written in connection  with the APress book `Tuomas J. Lukka's Definitive
 319 Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
 320 things would have to be done in cumbersome ways.
 321
 322 =cut