local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Scalar/Util/PP.pm

   1 # Scalar::Util::PP.pm
   2 #
   3 # Copyright (c) 1997-2009 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 # This module is normally only loaded if the XS module is not available
   8
   9 package Scalar::Util::PP;
  10
  11 use strict;
  12 use warnings;
  13 use vars qw(@ISA @EXPORT $VERSION $recurse);
  14 require Exporter;
  15 use B qw(svref_2object);
  16
  17 @ISA     = qw(Exporter);
  18 @EXPORT  = qw(blessed reftype tainted readonly refaddr looks_like_number);
  19 $VERSION = "1.22";
  20 $VERSION = eval $VERSION;
  21
  22 sub blessed ($) {
  23   return undef unless length(ref($_[0]));
  24   my $b = svref_2object($_[0]);
  25   return undef unless $b->isa('B::PVMG');
  26   my $s = $b->SvSTASH;
  27   return $s->isa('B::HV') ? $s->NAME : undef;
  28 }
  29
  30 sub refaddr($) {
  31   return undef unless length(ref($_[0]));
  32
  33   my $addr;
  34   if(defined(my $pkg = blessed($_[0]))) {
  35     $addr .= bless $_[0], 'Scalar::Util::Fake';
  36     bless $_[0], $pkg;
  37   }
  38   else {
  39     $addr .= $_[0]
  40   }
  41
  42   $addr =~ /0x(\w+)/;
  43   local $^W;
  44   hex($1);
  45 }
  46
  47 {
  48   my %tmap = qw(
  49     B::HV HASH
  50     B::AV ARRAY
  51     B::CV CODE
  52     B::IO IO
  53     B::NULL SCALAR
  54     B::NV SCALAR
  55     B::PV SCALAR
  56     B::GV GLOB
  57     B::RV REF
  58     B::REGEXP REGEXP
  59   );
  60
  61   sub reftype ($) {
  62     my $r = shift;
  63
  64     return undef unless length(ref($r));
  65
  66     my $t = ref(svref_2object($r));
  67
  68     return
  69         exists $tmap{$t} ? $tmap{$t}
  70       : length(ref($$r)) ? 'REF'
  71       :                    'SCALAR';
  72   }
  73 }
  74
  75 sub tainted {
  76   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  77   local $^W = 0;
  78   no warnings;
  79   eval { kill 0 * $_[0] };
  80   $@ =~ /^Insecure/;
  81 }
  82
  83 sub readonly {
  84   return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
  85
  86   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  87   my $tmp = $_[0];
  88
  89   !eval { $_[0] = $tmp; 1 };
  90 }
  91
  92 sub looks_like_number {
  93   local $_ = shift;
  94
  95   # checks from perlfaq4
  96   return 0 if !defined($_);
  97   if (ref($_)) {
  98     require overload;
  99     return overload::Overloaded($_) ? defined(0 + $_) : 0;
 100   }
 101   return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
 102   return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
 103   return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
 104
 105   0;
 106 }
 107
 108
 109 1;