cpan/List-Util/lib/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.23";
  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   no warnings 'portable';
  45   hex($1);
  46 }
  47
  48 {
  49   my %tmap = qw(
  50     B::NULL   SCALAR
  51
  52     B::HV     HASH
  53     B::AV     ARRAY
  54     B::CV     CODE
  55     B::IO     IO
  56     B::GV     GLOB
  57     B::REGEXP REGEXP
  58   );
  59
  60   sub reftype ($) {
  61     my $r = shift;
  62
  63     return undef unless length(ref($r));
  64
  65     my $t = ref(svref_2object($r));
  66
  67     return
  68         exists $tmap{$t} ? $tmap{$t}
  69       : length(ref($$r)) ? 'REF'
  70       :                    'SCALAR';
  71   }
  72 }
  73
  74 sub tainted {
  75   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  76   local $^W = 0;
  77   no warnings;
  78   eval { kill 0 * $_[0] };
  79   $@ =~ /^Insecure/;
  80 }
  81
  82 sub readonly {
  83   return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
  84
  85   local($@, $SIG{__DIE__}, $SIG{__WARN__});
  86   my $tmp = $_[0];
  87
  88   !eval { $_[0] = $tmp; 1 };
  89 }
  90
  91 sub looks_like_number {
  92   local $_ = shift;
  93
  94   # checks from perlfaq4
  95   return 0 if !defined($_);
  96   if (ref($_)) {
  97     require overload;
  98     return overload::Overloaded($_) ? defined(0 + $_) : 0;
  99   }
 100   return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
 101   return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
 102   return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
 103
 104   0;
 105 }
 106
 107
 108 1;