the latest changes in CMOP::Class->add_method to Moose::Meta::Role.
Now roles add methods via add_method, which clones method objects as
needed. Added tests for this cloning and making sure we can track the
history of a method through any roles it's been in.
sub wrap_method_body {
my ( $self, %args ) = @_;
- my $body = delete $args{body}; # delete is for compat
-
- ('CODE' eq ref($body))
+ ('CODE' eq ref $args{body})
|| Moose->throw_error("Your code block must be a CODE reference");
- $self->method_metaclass->wrap( $body => (
+ $self->method_metaclass->wrap(
package_name => $self->name,
%args,
- ));
+ );
}
sub add_method {
my $body;
if (blessed($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;
+ if ($method->package_name ne $self->name) {
$method = $method->clone(
package_name => $self->name,
- name => $method_name
+ name => $method_name
) if $method->can('clone');
}
}
}
sub alias_method {
- my ($self, $method_name, $method) = @_;
- (defined $method_name && $method_name)
- || Moose->throw_error("You must define a method name");
-
- my $body = (blessed($method) ? $method->body : $method);
- ('CODE' eq ref($body))
- || Moose->throw_error("Your code block must be a CODE reference");
+ my $self = shift;
- $self->add_package_symbol(
- { sigil => '&', type => 'CODE', name => $method_name },
- $body
- );
+ $self->add_method(@_);
}
## ------------------------------------------------------------------
$method_map{$method->{name}} = $method->{method};
}
- $c->alias_method($_ => $method_map{$_}) for keys %method_map;
+ $c->add_method($_ => $method_map{$_}) for keys %method_map;
}
sub apply_override_method_modifiers {
}
else {
# add it, although it could be overriden
- $class->alias_method(
+ $class->add_method(
$method_name,
$role->get_method($method_name)
);
$class->get_method($aliased_method_name)->body != $role->get_method($method_name)->body) {
$class->throw_error("Cannot create a method alias if a local method of the same name exists");
}
- $class->alias_method(
+ $class->add_method(
$aliased_method_name,
$role->get_method($method_name)
);
Moose->throw_error("Cannot create a method alias if a local method of the same name exists");
}
- $role2->alias_method(
+ $role2->add_method(
$aliased_method_name,
$role1->get_method($method_name)
);
}
else {
# add it, although it could be overriden
- $role2->alias_method(
+ $role2->add_method(
$method_name,
$role1->get_method($method_name)
);
$class->_new(\%params);
}
-# NOTE:
-# we need to override this cause
-# we dont have that package I was
-# talking about above.
-# - SL
-sub alias_method {
+# This is largely a cope of what's in Moose::Meta::Role (itself
+# largely a copy of Class::MOP::Class). However, we can't actually
+# call add_package_symbol, because there's no package to which which
+# add the symbol.
+sub add_method {
my ($self, $method_name, $method) = @_;
(defined $method_name && $method_name)
- || Moose->throw_error("You must define a method name");
-
- # make sure to bless the
- # method if nessecary
- $method = $self->method_metaclass->wrap(
- $method,
- package_name => $self->name,
- name => $method_name
- ) if !blessed($method);
+ || Moose->throw_error("You must define a method name");
+
+ my $body;
+ if (blessed($method)) {
+ $body = $method->body;
+ if ($method->package_name ne $self->name) {
+ $method = $method->clone(
+ package_name => $self->name,
+ name => $method_name
+ ) if $method->can('clone');
+ }
+ }
+ else {
+ $body = $method;
+ $method = $self->wrap_method_body( body => $body, name => $method_name );
+ }
$self->get_method_map->{$method_name} = $method;
}
=item B<get_method_map>
-=item B<alias_method>
+=item B<add_method>
=back
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+
+{
+ package Role::Foo;
+ use Moose::Role;
+
+ sub foo { }
+}
+
+{
+ package ClassA;
+ use Moose;
+
+ with 'Role::Foo';
+}
+
+{
+ my $meth = ClassA->meta->get_method('foo');
+ ok( $meth, 'ClassA has a foo method' );
+ isa_ok( $meth, 'Moose::Meta::Method' );
+ is( $meth->original_method, Role::Foo->meta->get_method('foo'),
+ 'ClassA->foo was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'ClassA::foo',
+ 'fq name is ClassA::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
+
+{
+ package Role::Bar;
+ use Moose::Role;
+ with 'Role::Foo';
+
+ sub bar { }
+}
+
+{
+ my $meth = Role::Bar->meta->get_method('foo');
+ ok( $meth, 'Role::Bar has a foo method' );
+ is( $meth->original_method, Role::Foo->meta->get_method('foo'),
+ 'Role::Bar->foo was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'Role::Bar::foo',
+ 'fq name is Role::Bar::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
+
+{
+ package ClassB;
+ use Moose;
+
+ with 'Role::Bar';
+}
+
+{
+ my $meth = ClassB->meta->get_method('foo');
+ ok( $meth, 'ClassB has a foo method' );
+ is( $meth->original_method, Role::Bar->meta->get_method('foo'),
+ 'ClassA->foo was cloned from Role::Bar->foo' );
+ is( $meth->original_method->original_method, Role::Foo->meta->get_method('foo'),
+ '... which in turn was cloned from Role::Foo->foo' );
+ is( $meth->fully_qualified_name, 'ClassB::foo',
+ 'fq name is ClassA::foo' );
+ is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
+ 'original fq name is Role::Foo::foo' );
+}
projects / gitmo/Moose.git / commitdiff