From: Dave Rolsky Date: Thu, 11 Sep 2008 16:13:55 +0000 (+0000) Subject: Part 1 of the great clone plan. X-Git-Tag: 0.66~3^2~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2226a8b07473ebde21f32a77683a2f3192f41b99;hp=91b73829b31b4035fa1b4a6ad7587a4861961a5d;p=gitmo%2FClass-MOP.git Part 1 of the great clone plan. When add_method is called with a method object, it calls clone on that method. To facilitate tracking the source of a method, we save the original method (the clone source) in the newly cloned method. I also added a bunch of convenience methods for getting various original names out of said original method. Eventually this will be used in Moose to determine whether a method originally came from a role. --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index e173d1c..d2f7270 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -488,9 +488,18 @@ Class::MOP::Method->meta->add_attribute( )) ); +Class::MOP::Method->meta->add_attribute( + Class::MOP::Attribute->new('original_method' => ( + reader => { 'original_method' => \&Class::MOP::Method::original_method }, + writer => { '_set_original_method' => \&Class::MOP::Method::_set_original_method }, + )) +); + Class::MOP::Method->meta->add_method('clone' => sub { my $self = shift; - $self->meta->clone_object($self, @_); + my $clone = $self->meta->clone_object($self, @_); + $clone->_set_original_method($self); + return $clone; }); ## -------------------------------------------------------- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index c8962f2..56e3e94 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -612,9 +612,7 @@ sub add_method { $body = $method->body; if ($method->package_name ne $self->name && $method->name ne $method_name) { - warn "Hello there, got something for you." - . " Method says " . $method->package_name . " " . $method->name - . " Class says " . $self->name . " " . $method_name; + warn "CLONING method\n"; $method = $method->clone( package_name => $self->name, name => $method_name diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 37af5a1..729d0aa 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -88,6 +88,39 @@ sub fully_qualified_name { $self->package_name . '::' . $self->name; } +sub original_method { (shift)->{'original_method'} } + +sub _set_original_method { $_[0]->{'original_method'} = $_[1] } + +# It's possible that this could cause a loop if there is a circular +# reference in here. That shouldn't ever happen in normal +# circumstances, since original method only gets set when clone is +# called. We _could_ check for such a loop, but it'd involve some sort +# of package-lexical variable, and wouldn't be terribly subclassable. +sub original_package_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_package_name + : $self->package_name; +} + +sub original_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_name + : $self->name; +} + +sub original_fully_qualified_name { + my $self = shift; + + $self->original_method + ? $self->original_method->original_fully_qualified_name + : $self->fully_qualified_name; +} + # NOTE: # the Class::MOP bootstrap # will create this for us @@ -166,6 +199,26 @@ This returns the package name that the CODE reference is attached to. This returns the fully qualified name of the CODE reference. +=item B + +If this method object was created as a clone of some other method +object, this returns the object that was cloned. + +=item B + +This returns the original name of the CODE reference, wherever it was +first defined. + +=item B + +This returns the original package name that the CODE reference is +attached to, wherever it was first defined. + +=item B + +This returns the original fully qualified name of the CODE reference, +wherever it was first defined. + =back =head2 Metaclass diff --git a/t/030_method.t b/t/030_method.t index b481a5c..4813b82 100644 --- a/t/030_method.t +++ b/t/030_method.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 27; +use Test::More tests => 39; use Test::Exception; use Class::MOP; @@ -20,6 +20,10 @@ is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to is($method->package_name, 'main', '... our package is main::'); is($method->name, '__ANON__', '... our sub name is __ANON__'); is($method->fully_qualified_name, 'main::__ANON__', '... our subs full name is main::__ANON__'); +is($method->original_method, undef, '... no original_method '); +is($method->original_package_name, 'main', '... the original_package_name is the same as package_name'); +is($method->original_name, '__ANON__', '... the original_name is the same as name'); +is($method->original_fully_qualified_name, 'main::__ANON__', '... the original_fully_qualified_name is the same as fully_qualified_name'); dies_ok { Class::MOP::Method->wrap } q{... can't call wrap() without some code}; dies_ok { Class::MOP::Method->wrap([]) } q{... can't call wrap() without some code}; @@ -68,7 +72,16 @@ dies_ok { Class::MOP::Method->wrap(sub { 'FAIL' }, name => '__ANON__') } '... bad args for &wrap'; +my $clone = $method->clone( + package_name => 'NewPackage', + name => 'new_name', +); - - - +isa_ok($clone, 'Class::MOP::Method'); +is($clone->package_name, 'NewPackage', '... cloned method has new pckage name'); +is($clone->name, 'new_name', '... cloned method has new sub name'); +is($clone->fully_qualified_name, 'NewPackage::new_name', '... cloned method has new fq name'); +is($clone->original_method, $method, '... cloned method has correct original_method'); +is($clone->original_package_name, 'main', '... cloned method has correct original_package_name'); +is($clone->original_name, '__ANON__', '... cloned method has correct original_name'); +is($clone->original_fully_qualified_name, 'main::__ANON__', '... cloned method has correct original_fully_qualified_name');