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 (file)
--- 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 (file)
--- 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 (file)
--- 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<original_method>
+
+If this method object was created as a clone of some other method
+object, this returns the object that was cloned.
+
+=item B<original_name>
+
+This returns the original name of the CODE reference, wherever it was
+first defined.
+
+=item B<original_package_name>
+
+This returns the original package name that the CODE reference is
+attached to, wherever it was first defined.
+
+=item B<original_fully_qualified_name>
+
+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 (file)
--- 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');