adding method exclusion

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 9b74bec..16e9b9f 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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<meta>
 
+=item B<get_method_exclusions>
+
+=item B<is_method_excluded>
+
 =item B<apply>
 
 =item B<check_role_exclusions>

diff --git a/lib/Moose/Meta/Role/Application/ToClass.pm b/lib/Moose/Meta/Role/Application/ToClass.pm
index 3f757d9..ffb4673 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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