[Summary view] [Print] [Text view]

   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  =head1 BLATANT PLUG
 335  
 336  The weaken and isweak subroutines in this module and the patch to the core Perl
 337  were written in connection  with the APress book `Tuomas J. Lukka's Definitive
 338  Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
 339  things would have to be done in cumbersome ways.
 340  
 341  =cut