@@ -37,7 +37,7 @@ WriteMakefile( : ( INSTALLDIRS => q[perl], PREREQ_PM => {'Test::More' => 0,}, - (eval { ExtUtils::MakeMaker->VERSION(6.21) } ? (LICENSE => 'perl') : ()), + (eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()), ($do_xs ? () : (XS => {}, C => [])), ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { Makefile.PL @@ -12,6 +12,7 @@ use strict; use warnings; use vars qw(@ISA @EXPORT $VERSION $recurse); require Exporter; +use B qw(svref_2object); @ISA = qw(Exporter); @EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number); @@ -19,12 +20,11 @@ $VERSION = "1.20"; $VERSION = eval $VERSION; sub blessed ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - return ref($_[0]) if $recurse; - local $recurse = 1; # protect against recursion if user has used UNIVERSAL::can from CPAN - length(ref($_[0])) - ? eval { $_[0]->UNIVERSAL::can('can') && ref($_[0]) } - : undef; + return undef unless length(ref($_[0])); + my $b = svref_2object($_[0]); + return undef unless $b->isa('B::PVMG'); + my $s = $b->SvSTASH; + return $s->isa('B::HV') ? $s->NAME : undef; } sub refaddr($) { @@ -44,33 +44,32 @@ sub refaddr($) { hex($1); } -sub reftype ($) { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $r = shift; - my $t; - - length($t = ref($r)) or return undef; - - # This eval will fail if the reference is not blessed - eval { $r->UNIVERSAL::can('can') } - ? do { - $t = eval { - # we have a GLOB or an IO. Stringify a GLOB gives it's name - my $q = *$r; - (defined($q) && $q =~ /^\*/) ? "GLOB" : "IO"; - } - or do { - # OK, if we don't have a GLOB what parts of - # a glob will it populate. - # NOTE: A glob always has a SCALAR - local *glob = $r; - defined *glob{ARRAY} && "ARRAY" - or defined *glob{HASH} && "HASH" - or defined *glob{CODE} && "CODE" - or length(ref(${$r})) ? "REF" : "SCALAR"; - } - } - : $t +{ + my %tmap = qw( + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::NULL SCALAR + B::NV SCALAR + B::PV SCALAR + B::GV GLOB + B::RV REF + B::REGEXP REGEXP + ); + + sub reftype ($) { + my $r = shift; + + return undef unless length(ref($r)); + + my $t = ref(svref_2object($r)); + + return + exists $tmap{$t} ? $tmap{$t} + : length(ref($$r)) ? 'REF' + : 'SCALAR'; + } } sub tainted { lib/Scalar/Util/PP.pm @@ -13,7 +13,7 @@ BEGIN { } } -use Test::More tests => 23; +use Test::More tests => 29; use Scalar::Util qw(reftype); use vars qw($t $y $x *F); @@ -21,6 +21,7 @@ use Symbol qw(gensym); # Ensure we do not trigger and tied methods tie *F, 'MyTie'; +my $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP'; @test = ( [ undef, 1, 'number' ], @@ -32,7 +33,8 @@ tie *F, 'MyTie'; [ GLOB => \*F, 'tied GLOB ref' ], [ GLOB => gensym, 'GLOB ref' ], [ CODE => sub {}, 'CODE ref' ], -# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN + [ IO => *STDIN{IO},'IO ref' ], + [ $RE => qr/x/, 'REGEEXP' ], ); foreach $test (@test) { t/reftype.t 6b60a9e8c2c20cbb3982ae57034214edf08551f2 Graham Barr gbarr@pobox.com http://github.com/gbarr/Scalar-List-Utils/commit/eddddcccda4fe0e3484378850b345c60fbcab010 eddddcccda4fe0e3484378850b345c60fbcab010 2009-05-13T14:41:25-07:00 2009-05-13T12:49:04-07:00 Reimplement perl version of reftype and blessed using B While not pure perl as B is an XS extension. B is part of core perl so users should have it available. the PP versions are only meant as a fallback for users who do not have compiler access c5f0b6626926ebc7983a30b381b2ec8b44dfa2c1 Graham Barr gbarr@pobox.com