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.
))
);
+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;
});
## --------------------------------------------------------
$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
$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
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
use strict;
use warnings;
-use Test::More tests => 27;
+use Test::More tests => 39;
use Test::Exception;
use Class::MOP;
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};
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');