From: gfx <gfuji@cpan.org>
Date: Mon, 28 Sep 2009 00:31:08 +0000 (+0900)
Subject: Fix has_method() for backward compatibility
X-Git-Tag: 0.37~8
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=01afd8ffba9b9783e84c6cfc8ba45e11a0f5d8f4;hp=134daa672a270f9144185a6d245085558fceb210

Fix has_method() for backward compatibility
---

diff --git a/lib/Mouse.pm b/lib/Mouse.pm
index 4f2345d..7eec152 100644
--- a/lib/Mouse.pm
+++ b/lib/Mouse.pm
@@ -11,7 +11,7 @@ use Exporter;
 use Carp 'confess';
 use Scalar::Util 'blessed';
 
-use Mouse::Util qw(load_class is_class_loaded not_supported);
+use Mouse::Util qw(load_class is_class_loaded get_code_package not_supported);
 
 use Mouse::Meta::Module;
 use Mouse::Meta::Class;
@@ -190,7 +190,7 @@ sub unimport {
         my $code;
         if(exists $is_removable{$keyword}
             && ($code = $caller->can($keyword))
-            && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){
+            && get_code_package($code) eq __PACKAGE__){
 
             delete $stash->{$keyword};
         }
diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index 0545f36..c102596 100755
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -5,7 +5,7 @@ use warnings;
 use Carp ();
 use Scalar::Util qw/blessed weaken/;
 
-use Mouse::Util qw/:meta get_code_info not_supported load_class/;
+use Mouse::Util qw/:meta get_code_package not_supported load_class/;
 
 {
     my %METACLASS_CACHE;
@@ -97,13 +97,17 @@ sub add_method {
     *{ $pkg . '::' . $name } = $code;
 }
 
-sub _code_is_mine { # taken from Class::MOP::Class
-    my ( $self, $code ) = @_;
+# XXX: for backward compatibility
+my %foreign = map{ $_ => undef } qw(
+    Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
+    Carp Scalar::Util
+);
+sub _code_is_mine{
+    my($self, $code) = @_;
 
-    my ( $code_package, $code_name ) = get_code_info($code);
+    my $package = get_code_package($code);
 
-    return $code_package && $code_package eq $self->{package}
-        || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
+    return !exists $foreign{$package};
 }
 
 sub has_method {
@@ -111,7 +115,7 @@ sub has_method {
 
     return 1 if $self->{methods}->{$method_name};
 
-    my $code = $self->{package}->can($method_name);
+    my $code = do{ no strict 'refs'; *{$self->{package} . '::' . $method_name}{CODE} };
 
     return $code && $self->_code_is_mine($code);
 }
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index 87aaa8e..ec08a5b 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -8,17 +8,6 @@ our @ISA = qw(Mouse::Meta::Module);
 
 sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
 
-# XXX: for backward compatibility
-my %foreign = map{ $_ => undef } qw(Mouse::Role Carp Scalar::Util UNIVERSAL);
-sub _code_is_mine{
-    my($self, $code) = @_;
-
-    my($package, $name) = get_code_info($code);
-
-    return $package && !exists $foreign{$package};
-}
-
-
 sub _construct_meta {
     my $class = shift;
 
diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm
index 3e86088..bc32665 100644
--- a/lib/Mouse/Role.pm
+++ b/lib/Mouse/Role.pm
@@ -7,7 +7,7 @@ use Exporter;
 use Carp 'confess';
 use Scalar::Util 'blessed';
 
-use Mouse::Util qw(load_class not_supported);
+use Mouse::Util qw(load_class get_code_package not_supported);
 use Mouse ();
 
 our @ISA = qw(Exporter);
@@ -150,7 +150,7 @@ sub unimport {
         my $code;
         if(exists $is_removable{$keyword}
             && ($code = $caller->can($keyword))
-            && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){
+            && get_code_package($code) eq __PACKAGE__){
 
             delete $stash->{$keyword};
         }
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index e86da70..254ddbc 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -5,6 +5,7 @@ use warnings;
 use Exporter;
 
 use Carp qw(confess);
+use B ();
 
 use constant _MOUSE_VERBOSE => !!$ENV{MOUSE_VERBOSE};
 
@@ -22,6 +23,8 @@ our @EXPORT_OK = qw(
     get_linear_isa
     get_code_info
 
+    get_code_package
+
     not_supported
 
     does meta dump
@@ -99,8 +102,6 @@ BEGIN {
         my ($coderef) = @_;
         ref($coderef) or return;
 
-        require B;
-
         my $cv = B::svref_2object($coderef);
         $cv->isa('B::CV') or return;
 
@@ -109,6 +110,18 @@ BEGIN {
 
         return ($gv->STASH->NAME, $gv->NAME);
     }
+
+    sub get_code_package{
+        my($coderef) = @_;
+
+        my $cv = B::svref_2object($coderef);
+        $cv->isa('B::CV') or return '';
+
+        my $gv = $cv->GV;
+        $gv->isa('B::GV') or return '';
+
+        return $gv->STASH->NAME;
+    }
 }
 
 # taken from Mouse::Util (0.90)