From: gfx 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?a=commitdiff_plain;h=01afd8ffba9b9783e84c6cfc8ba45e11a0f5d8f4;p=gitmo%2FMouse.git 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)