From: Dave Rolsky Date: Thu, 11 Sep 2008 20:19:12 +0000 (+0000) Subject: No more alias_method for roles either. This meant more or less copying X-Git-Tag: 0.58~34^2~21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=87e636262bb48cefaaa4f30504deec928fd38513;p=gitmo%2FMoose.git No more alias_method for roles either. This meant more or less copying 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. --- diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index d872f79..701f117 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -371,15 +371,13 @@ sub has_method { 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 { @@ -390,14 +388,10 @@ 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'); } } @@ -427,18 +421,9 @@ sub get_method_list { } 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(@_); } ## ------------------------------------------------------------------ diff --git a/lib/Moose/Meta/Role/Application/RoleSummation.pm b/lib/Moose/Meta/Role/Application/RoleSummation.pm index c07d000..7487d82 100644 --- a/lib/Moose/Meta/Role/Application/RoleSummation.pm +++ b/lib/Moose/Meta/Role/Application/RoleSummation.pm @@ -170,7 +170,7 @@ sub apply_methods { $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 { diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm index 8342bea..f320e55 100644 --- a/lib/Moose/Meta/Role/Application/ToClass.pm +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -110,7 +110,7 @@ sub apply_methods { } else { # add it, although it could be overriden - $class->alias_method( + $class->add_method( $method_name, $role->get_method($method_name) ); @@ -124,7 +124,7 @@ sub apply_methods { $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) ); diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm index 0a9e3b6..1723929 100644 --- a/lib/Moose/Meta/Role/Application/ToRole.pm +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -78,7 +78,7 @@ sub apply_methods { 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) ); @@ -100,7 +100,7 @@ sub apply_methods { } else { # add it, although it could be overriden - $role2->alias_method( + $role2->add_method( $method_name, $role1->get_method($method_name) ); diff --git a/lib/Moose/Meta/Role/Composite.pm b/lib/Moose/Meta/Role/Composite.pm index bdfc8ba..2399967 100644 --- a/lib/Moose/Meta/Role/Composite.pm +++ b/lib/Moose/Meta/Role/Composite.pm @@ -42,23 +42,29 @@ sub new { $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; } @@ -87,7 +93,7 @@ Moose::Meta::Role::Composite - An object to represent the set of roles =item B -=item B +=item B =back diff --git a/t/030_roles/032_roles_and_method_cloning.t b/t/030_roles/032_roles_and_method_cloning.t new file mode 100644 index 0000000..d167ec1 --- /dev/null +++ b/t/030_roles/032_roles_and_method_cloning.t @@ -0,0 +1,72 @@ +#!/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' ); +}