From: Stevan Little Date: Tue, 1 Jan 2008 20:28:05 +0000 (+0000) Subject: adding method exclusion X-Git-Tag: 0_35~38 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c45384475d0d20e835d5666615ce15b17e79ff4b;p=gitmo%2FMoose.git adding method exclusion --- diff --git a/lib/Moose.pm b/lib/Moose.pm index 9b74bec..16e9b9f 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -92,10 +92,33 @@ use Moose::Util::TypeConstraints; with => sub { my $class = $CALLER; return subname 'Moose::with' => sub (@) { - my (@roles) = @_; - confess "Must specify at least one role" unless @roles; - Class::MOP::load_class($_) for @roles; - $class->meta->_apply_all_roles(@roles); + my (@args) = @_; + confess "Must specify at least one role" unless @args; + + my $roles = Data::OptList::mkopt(\@args); + + #use Data::Dumper; + #warn Dumper $roles; + + Class::MOP::load_class($_->[0]) for @$roles; + + ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role')) + || confess "You can only consume roles, " . $_->[0] . " is not a Moose role" + foreach @$roles; + + my $meta = $class->meta; + + if (scalar @$roles == 1) { + my ($role, $params) = @{$roles->[0]}; + $role->meta->apply($meta, (defined $params ? %$params : ())); + } + else { + Moose::Meta::Role->combine( + map { $_->[0]->meta } @$roles + )->apply($meta); + } + + #$class->meta->_apply_all_roles(@roles); }; }, has => sub { diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index bd3e691..34668f1 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -314,7 +314,7 @@ sub get_method_map { next if ($pkg || '') ne $role_name && ($name || '') ne '__ANON__'; } - + $map->{$symbol} = $method_metaclass->wrap($code); } @@ -323,7 +323,7 @@ sub get_method_map { sub get_method { my ($self, $name) = @_; - $self->get_method_map->{$name} + $self->get_method_map->{$name}; } sub has_method { diff --git a/lib/Moose/Meta/Role/Application.pm b/lib/Moose/Meta/Role/Application.pm index a71f65c..13da2c9 100644 --- a/lib/Moose/Meta/Role/Application.pm +++ b/lib/Moose/Meta/Role/Application.pm @@ -7,7 +7,32 @@ use metaclass; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; -sub new { (shift)->meta->new_object(@_) } +__PACKAGE__->meta->add_attribute('method_exclusions' => ( + init_arg => 'excludes', + reader => 'get_method_exclusions', + default => sub { [] } +)); + +sub new { + my ($class, %params) = @_; + + if (exists $params{excludes}) { + # I wish we had coercion here :) + $params{excludes} = (ref $params{excludes} eq 'ARRAY' + ? $params{excludes} + : [ $params{excludes} ]); + } + + $class->meta->new_object(%params); +} + +sub is_method_excluded { + my ($self, $method_name) = @_; + foreach (@{$self->get_method_exclusions}) { + return 1 if $_ eq $method_name; + } + return 0; +} sub apply { my $self = shift; @@ -61,6 +86,10 @@ This is the abstract base class for role applications. =item B +=item B + +=item B + =item B =item B diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm index 3f757d9..ffb4673 100644 --- a/lib/Moose/Meta/Role/Application/ToClass.pm +++ b/lib/Moose/Meta/Role/Application/ToClass.pm @@ -15,9 +15,9 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Role::Application'; sub apply { - my ($self, $role, $class) = @_; + my ($self, $role, $class) = @_; $self->SUPER::apply($role, $class); - $class->add_role($role); + $class->add_role($role); } sub check_role_exclusions { @@ -108,6 +108,9 @@ sub apply_attributes { sub apply_methods { my ($self, $role, $class) = @_; foreach my $method_name ($role->get_method_list) { + + next if $self->is_method_excluded($method_name); + # it if it has one already if ($class->has_method($method_name) && # and if they are not the same thing ... diff --git a/lib/Moose/Meta/Role/Application/ToRole.pm b/lib/Moose/Meta/Role/Application/ToRole.pm index 13fff10..23cfd38 100644 --- a/lib/Moose/Meta/Role/Application/ToRole.pm +++ b/lib/Moose/Meta/Role/Application/ToRole.pm @@ -15,9 +15,9 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Moose::Meta::Role::Application'; sub apply { - my ($self, $role1, $role2) = @_; - $self->SUPER::apply($role1, $role2); - $role2->add_role($role1); + my ($self, $role1, $role2) = @_; + $self->SUPER::apply($role1, $role2); + $role2->add_role($role1); } sub check_role_exclusions { @@ -65,6 +65,9 @@ sub apply_attributes { sub apply_methods { my ($self, $role1, $role2) = @_; foreach my $method_name ($role1->get_method_list) { + + next if $self->is_method_excluded($method_name); + # it if it has one already if ($role2->has_method($method_name) && # and if they are not the same thing ... diff --git a/lib/Moose/Meta/Role/Composite.pm b/lib/Moose/Meta/Role/Composite.pm index 5f2bd08..3461e84 100644 --- a/lib/Moose/Meta/Role/Composite.pm +++ b/lib/Moose/Meta/Role/Composite.pm @@ -54,11 +54,12 @@ sub alias_method { (defined $method_name && $method_name) || confess "You must define a method name"; - my $body = (blessed($method) ? $method->body : $method); - ('CODE' eq (reftype($body) || '')) - || confess "Your code block must be a CODE reference"; + # make sure to bless the + # method if nessecary + $method = $self->method_metaclass->wrap($method) + if !blessed($method); - $self->get_method_map->{$method_name} = $body; + $self->get_method_map->{$method_name} = $method; } 1; diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 0aeb2f4..4be9f77 100644 --- a/lib/Moose/Role.pm +++ b/lib/Moose/Role.pm @@ -8,6 +8,7 @@ use Scalar::Util 'blessed'; use Carp 'confess'; use Sub::Name 'subname'; +use Data::OptList; use Sub::Exporter; our $VERSION = '0.07'; @@ -58,18 +59,27 @@ use Moose::Util::TypeConstraints; with => sub { my $meta = _find_meta(); return subname 'Moose::Role::with' => sub (@) { - my (@roles) = @_; - confess "Must specify at least one role" unless @roles; - Class::MOP::load_class($_) for @roles; - ($_->can('meta') && $_->meta->isa('Moose::Meta::Role')) - || confess "You can only consume roles, $_ is not a Moose role" - foreach @roles; - if (scalar @roles == 1) { - $roles[0]->meta->apply($meta); + my (@args) = @_; + confess "Must specify at least one role" unless @args; + + my $roles = Data::OptList::mkopt(\@args); + + #use Data::Dumper; + #warn Dumper $roles; + + Class::MOP::load_class($_->[0]) for @$roles; + + ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role')) + || confess "You can only consume roles, " . $_->[0] . " is not a Moose role" + foreach @$roles; + + if (scalar @$roles == 1) { + my ($role, $params) = @{$roles->[0]}; + $role->meta->apply($meta, (defined $params ? %$params : ())); } else { Moose::Meta::Role->combine( - map { $_->meta } @roles + map { $_->[0]->meta } @$roles )->apply($meta); } }; diff --git a/t/030_roles/011_overriding.t b/t/030_roles/011_overriding.t index 5c9565e..10c149f 100644 --- a/t/030_roles/011_overriding.t +++ b/t/030_roles/011_overriding.t @@ -3,161 +3,213 @@ use strict; use warnings; -use Test::More no_plan => 1; #skip_all => "provisional test"; +use Test::More no_plan => 1; use Test::Exception; BEGIN { use_ok('Moose'); } -{ - # no conflicts, this doesn't actually test the new behavior, it's just an example - - lives_ok { - package Role::A; - use Moose::Role; - - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(bar) }; - } "define role A"; +{ + # test no conflicts here + package Role::A; + use Moose::Role; - lives_ok { - package Role::B; - use Moose::Role; + sub bar { 'Role::A::bar' } - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(xxy) }; - } "define role B"; + package Role::B; + use Moose::Role; - lives_ok { - package Role::C; - use Moose::Role; + sub xxy { 'Role::B::xxy' } - with qw(Role::A Role::B); # conflict between 'foo's here - - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo zot) }; + package Role::C; + use Moose::Role; + + ::lives_ok { + with qw(Role::A Role::B); # no conflict here } "define role C"; - lives_ok { - package Class::A; - use Moose; + sub foo { 'Role::C::foo' } + sub zot { 'Role::C::zot' } - with qw(Role::C); + package Class::A; + use Moose; - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) }; + ::lives_ok { + with qw(Role::C); } "define class A"; + + sub zot { 'Class::A::zot' } +} - can_ok( Class::A->new, qw(foo bar xxy zot) ); - - is( eval { Class::A->new->foo }, "Role::C::foo", "foo" ); - is( eval { Class::A->new->zot }, "Class::A::zot", "zot" ); - is( eval { Class::A->new->bar }, "Role::A::bar", "bar" ); - is( eval { Class::A->new->xxy }, "Role::B::xxy", "xxy" ); +can_ok( Class::A->new, qw(foo bar xxy zot) ); -} +is( Class::A->new->foo, "Role::C::foo", "... got the right foo method" ); +is( Class::A->new->zot, "Class::A::zot", "... got the right zot method" ); +is( Class::A->new->bar, "Role::A::bar", "... got the right bar method" ); +is( Class::A->new->xxy, "Role::B::xxy", "... got the right xxy method" ); { - # conflict resolved by role, same result as prev + # check that when a role is added to another role + # and they conflict and the method they conflicted + # with is then required. + + package Role::A::Conflict; + use Moose::Role; + + with 'Role::A'; + + sub bar { 'Role::A::Conflict::bar' } + + package Class::A::Conflict; + use Moose; + + ::throws_ok { + with 'Role::A::Conflict'; + } qr/requires.*'bar'/, '... did not fufill the requirement of &bar method'; + + package Class::A::Resolved; + use Moose; + + ::lives_ok { + with 'Role::A::Conflict'; + } '... did fufill the requirement of &bar method'; + + sub bar { 'Class::A::Resolved::bar' } +} - lives_ok { - package Role::D; - use Moose::Role; +ok(Role::A::Conflict->meta->requires_method('bar'), '... Role::A::Conflict created the bar requirement'); - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo bar) }; - } "define role Role::D"; +can_ok( Class::A::Resolved->new, qw(bar) ); - lives_ok { - package Role::E; - use Moose::Role; +is( Class::A::Resolved->new->bar, 'Class::A::Resolved::bar', "... got the right bar method" ); - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo xxy) }; - } "define role Role::E"; +{ + # check that when two roles are composed, they conflict + # but the composing role can resolve that conflict + + package Role::D; + use Moose::Role; - lives_ok { - package Role::F; - use Moose::Role; + sub foo { 'Role::D::foo' } + sub bar { 'Role::D::bar' } - with qw(Role::D Role::E); # conflict between 'foo's here + package Role::E; + use Moose::Role; - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo zot) }; - } "define role Role::F"; + sub foo { 'Role::E::foo' } + sub xxy { 'Role::E::xxy' } - lives_ok { - package Class::B; - use Moose; + package Role::F; + use Moose::Role; + ::lives_ok { + with qw(Role::D Role::E); # conflict between 'foo's here + } "define role Role::F"; + + sub foo { 'Role::F::foo' } + sub zot { 'Role::F::zot' } + + package Class::B; + use Moose; + + ::lives_ok { with qw(Role::F); - - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) }; } "define class Class::B"; + + sub zot { 'Class::B::zot' } +} - can_ok( Class::B->new, qw(foo bar xxy zot) ); +can_ok( Class::B->new, qw(foo bar xxy zot) ); - is( eval { Class::B->new->foo }, "Role::F::foo", "foo" ); - is( eval { Class::B->new->zot }, "Class::B::zot", "zot" ); - is( eval { Class::B->new->bar }, "Role::D::bar", "bar" ); - is( eval { Class::B->new->xxy }, "Role::E::xxy", "xxy" ); +is( Class::B->new->foo, "Role::F::foo", "... got the &foo method okay" ); +is( Class::B->new->zot, "Class::B::zot", "... got the &zot method okay" ); +is( Class::B->new->bar, "Role::D::bar", "... got the &bar method okay" ); +is( Class::B->new->xxy, "Role::E::xxy", "... got the &xxy method okay" ); + +ok(!Role::F->meta->requires_method('foo'), '... Role::F fufilled the &foo requirement'); + +{ + # check that a conflict can be resolved + # by a role, but also new ones can be + # created just as easily ... + + package Role::D::And::E::Conflict; + use Moose::Role; + + ::lives_ok { + with qw(Role::D Role::E); # conflict between 'foo's here + } "... define role Role::D::And::E::Conflict"; + + sub foo { 'Role::D::And::E::Conflict::foo' } # this overrides ... + + # but these conflict + sub xxy { 'Role::D::And::E::Conflict::xxy' } + sub bar { 'Role::D::And::E::Conflict::bar' } } +ok(!Role::D::And::E::Conflict->meta->requires_method('foo'), '... Role::D::And::E::Conflict fufilled the &foo requirement'); +ok(Role::D::And::E::Conflict->meta->requires_method('xxy'), '... Role::D::And::E::Conflict adds the &xxy requirement'); +ok(Role::D::And::E::Conflict->meta->requires_method('bar'), '... Role::D::And::E::Conflict adds the &bar requirement'); + { # conflict propagation + + package Role::H; + use Moose::Role; - lives_ok { - package Role::H; - use Moose::Role; + sub foo { 'Role::H::foo' } + sub bar { 'Role::H::bar' } - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo bar) }; - } "define role Role::H"; + package Role::J; + use Moose::Role; - lives_ok { - package Role::J; - use Moose::Role; + sub foo { 'Role::J::foo' } + sub xxy { 'Role::J::xxy' } - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo xxy) }; - } "define role Role::J"; - - lives_ok { - package Role::I; - use Moose::Role; + package Role::I; + use Moose::Role; + ::lives_ok { with qw(Role::J Role::H); # conflict between 'foo's here - - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) }; } "define role Role::I"; + + sub zot { 'Role::I::zot' } - throws_ok { - package Class::C; - use Moose; - + package Class::C; + use Moose; + + ::throws_ok { with qw(Role::I); - - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) }; } qr/requires.*'foo'/, "defining class Class::C fails"; - lives_ok { - package Class::E; - use Moose; + sub zot { 'Class::C::zot' } + package Class::E; + use Moose; + + ::lives_ok { with qw(Role::I); + } "resolved with method"; + + sub foo { 'Class::E::foo' } + sub zot { 'Class::E::zot' } +} + +can_ok( Class::E->new, qw(foo bar xxy zot) ); - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(foo zot) }; - } "resolved with method"; +is( Class::E->new->foo, "Class::E::foo", "... got the right &foo method" ); +is( Class::E->new->zot, "Class::E::zot", "... got the right &zot method" ); +is( Class::E->new->bar, "Role::H::bar", "... got the right &bar method" ); +is( Class::E->new->xxy, "Role::J::xxy", "... got the right &xxy method" ); +ok(Role::I->meta->requires_method('foo'), '... Role::I still have the &foo requirement'); + +{ # fix these later ... TODO: { - local $TODO = "TODO: add support for attribute methods fufilling reqs"; + local $TODO = "add support for attribute methods fufilling reqs"; lives_ok { package Class::D; @@ -165,10 +217,10 @@ BEGIN { has foo => ( default => __PACKAGE__ . "::foo", is => "rw" ); - use constant; - BEGIN { constant->import($_ => __PACKAGE__ . "::$_") for qw(zot) }; + sub zot { 'Class::D::zot' } with qw(Role::I); + } "resolved with attr"; can_ok( Class::D->new, qw(foo bar xxy zot) ); @@ -179,12 +231,5 @@ BEGIN { is( eval { Class::D->new->foo }, "Class::D::foo", "foo" ); is( eval { Class::D->new->zot }, "Class::D::zot", "zot" ); - can_ok( Class::E->new, qw(foo bar xxy zot) ); - - is( eval { Class::E->new->foo }, "Class::E::foo", "foo" ); - is( eval { Class::E->new->zot }, "Class::E::zot", "zot" ); - is( eval { Class::E->new->bar }, "Role::H::bar", "bar" ); - is( eval { Class::E->new->xxy }, "Role::J::xxy", "xxy" ); - } diff --git a/t/030_roles/012_method_exclusion_during_composition.t b/t/030_roles/012_method_exclusion_during_composition.t new file mode 100644 index 0000000..7275d37 --- /dev/null +++ b/t/030_roles/012_method_exclusion_during_composition.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package My::Role; + use Moose::Role; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package My::Class; + use Moose; + + with 'My::Role' => { excludes => 'bar' }; +} + +ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz); +ok(!My::Class->meta->has_method('bar'), '... but we excluded bar'); + +{ + package My::OtherRole; + use Moose::Role; + + with 'My::Role' => { excludes => 'foo' }; + + sub foo { 'My::OtherRole::foo' } + sub bar { 'My::OtherRole::bar' } +} + +ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar baz); + +ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); +ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required'); + + + + + diff --git a/t/030_roles/020_role_composite.t b/t/030_roles/020_role_composite.t index 38e8307..ae6d88c 100644 --- a/t/030_roles/020_role_composite.t +++ b/t/030_roles/020_role_composite.t @@ -41,6 +41,13 @@ BEGIN { Role::Baz->meta, ], '... got the right roles'); + ok($c->does_role($_), '... our composite does the role ' . $_) + for qw( + Role::Foo + Role::Bar + Role::Baz + ); + lives_ok { Moose::Meta::Role::Application::RoleSummation->new->apply($c); } '... this composed okay'; diff --git a/t/030_roles/021_role_composite_exlcusion.t b/t/030_roles/021_role_composite_exclusion.t similarity index 100% rename from t/030_roles/021_role_composite_exlcusion.t rename to t/030_roles/021_role_composite_exclusion.t