home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / lib / perl / 5.10.0 / Scalar / Util.pm
Encoding:
Perl POD Document  |  2009-06-26  |  3.3 KB  |  148 lines
  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.