role-exclusion

diff --git a/TODO b/TODO
index 3fde938..6393ccb 100644 (file)
--- a/TODO
+++ b/TODO
@@ -115,7 +115,7 @@ and that if this usage style is used nothing is exported to the namespace.
 [17:02]        stevan  would fail
 [17:02]        stevan  because OrganicMolecule, InorganicMolocule can never be used together
 [17:03]        stevan  I am thinking this is quite sane 
-
+ 
 -------------------------------------------------------------------------------
 TO PONDER
 -------------------------------------------------------------------------------

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index b6928e7..2690bf1 100644 (file)
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -44,6 +44,16 @@ sub does_role {
     return 0;
 }
 
+sub excludes_role {
+    my ($self, $role_name) = @_;
+    (defined $role_name)
+        || confess "You must supply a role name to look for";
+    foreach my $role (@{$self->roles}) {
+        return 1 if $role->excludes_role($role_name);
+    }
+    return 0;
+}
+
 sub new_object {
     my ($class, %params) = @_;
     my $self = $class->SUPER::new_object(%params);
@@ -218,6 +228,12 @@ This will test if this class C<does> a given C<$role_name>. It will
 not only check it's local roles, but ask them as well in order to 
 cascade down the role hierarchy.
 
+=item B<excludes_role ($role_name)>
+
+This will test if this class C<excludes> a given C<$role_name>. It will 
+not only check it's local roles, but ask them as well in order to 
+cascade down the role hierarchy.
+
 =item B<add_attribute $attr_name, %params>
 
 This method does the same thing as L<Class::MOP::Class/add_attribute>, but adds

diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 5f66c67..3eb9ef3 100644 (file)
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -28,6 +28,13 @@ __PACKAGE__->meta->add_attribute('roles' => (
     default => sub { [] }
 ));
 
+## excluded roles
+
+__PACKAGE__->meta->add_attribute('excluded_roles_map' => (
+    reader  => 'get_excluded_roles_map',
+    default => sub { {} }
+));
+
 ## attributes
 
 __PACKAGE__->meta->add_attribute('attribute_map' => (
@@ -100,6 +107,23 @@ sub does_role {
     return 0;
 }
 
+## excluded roles
+
+sub add_excluded_roles {
+    my ($self, @excluded_role_names) = @_;
+    $self->get_excluded_roles_map->{$_} = undef foreach @excluded_role_names;
+}
+
+sub get_excluded_roles_list {
+    my ($self) = @_;
+    keys %{$self->get_excluded_roles_map};
+}
+
+sub excludes_role {
+    my ($self, $role_name) = @_;
+    exists $self->get_excluded_roles_map->{$role_name} ? 1 : 0;
+}
+
 ## required methods
 
 sub add_required_methods {
@@ -244,6 +268,28 @@ sub get_method_modifier_list {
 sub apply {
     my ($self, $other) = @_;
     
+    if ($other->excludes_role($self->name)) {
+        confess "Conflict detected: " . $other->name . " excludes role '" . $self->name . "'";
+    }
+    
+#    warn "... Checking " . $self->name . " for excluded methods";
+    foreach my $excluded_role_name ($self->get_excluded_roles_list) {
+#        warn "... Checking if '$excluded_role_name' is done by " . $other->name . " for " . $self->name;
+        if ($other->does_role($excluded_role_name)) { # || $self->does_role($excluded_role_name) 
+            confess "The class " . $other->name . " does the excluded role '$excluded_role_name'";
+        }
+        else {
+            if ($other->isa('Moose::Meta::Role')) {
+#                warn ">>> The role " . $other->name . " does not do the excluded role '$excluded_role_name', so we are adding it in";
+                $other->add_excluded_roles($excluded_role_name);
+            }
+            else {
+#                warn ">>> The class " . $other->name . " does not do the excluded role '$excluded_role_name', so we can just go about our business";                
+            }
+        }
+    }    
+    
+    
     # NOTE:
     # we might need to move this down below the 
     # the attributes so that we can require any 
@@ -260,7 +306,7 @@ sub apply {
                         "to be implemented by '" . $other->name . "'";
             }
         }
-    }    
+    }       
     
     foreach my $attribute_name ($self->get_attribute_list) {
         # it if it has one already
@@ -479,6 +525,18 @@ probably not that much really).
 
 =over 4
 
+=item B<add_excluded_roles>
+
+=item B<excludes_role>
+
+=item B<get_excluded_roles_list>
+
+=item B<get_excluded_roles_map>
+
+=back
+
+=over 4
+
 =item B<get_method>
 
 =item B<has_method>

diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm
index 3fd2649..2d6b8d3 100644 (file)
--- a/lib/Moose/Role.pm
+++ b/lib/Moose/Role.pm
@@ -75,6 +75,12 @@ use Moose::Util::TypeConstraints;
                 $meta->add_required_methods(@_);
                };
            },  
+        excludes => sub {
+            my $meta = _find_meta();
+            return subname 'Moose::Role::excludes' => sub { 
+                $meta->add_excluded_roles(@_);
+               };
+           },      
         has => sub {
             my $meta = _find_meta();
             return subname 'Moose::Role::has' => sub { 

diff --git a/t/044_basic_role_composition.t b/t/044_basic_role_composition.t
index 80516ef..d209244 100644 (file)
--- a/t/044_basic_role_composition.t
+++ b/t/044_basic_role_composition.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 62;
+use Test::More tests => 90;
 use Test::Exception;
 
 BEGIN {
@@ -158,6 +158,15 @@ ok(My::Test4->meta->has_method('bling'), '... we did get the method when manuall
 ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with');
 ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with');
 
+ok(!My::Test3->does('Role::Bling'), '... our class does() the correct roles');
+ok(!My::Test3->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test4->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test4->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test5->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test5->does('Role::Bling::Bling'), '... our class does() the correct roles');
+ok(My::Test6->does('Role::Bling'), '... our class does() the correct roles');
+ok(My::Test6->does('Role::Bling::Bling'), '... our class does() the correct roles');
+
 is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added');
 is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added');
 is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method');
@@ -176,6 +185,7 @@ is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method');
 }
 
 ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling');
+ok(Role::Bling::Bling->meta->does_role('Role::Bling::Bling'), '... our role correctly does() the other role');
 ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling::Bling');
 is(Role::Bling::Bling::Bling->meta->get_method('bling')->(), 
     'Role::Bling::Bling::Bling::bling',
@@ -253,6 +263,15 @@ ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when m
 ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
 ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)');
 
+ok(!My::Test7->does('Role::Boo'), '... our class does() the correct roles');
+ok(!My::Test7->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(My::Test8->does('Role::Boo'), '... our class does() the correct roles');
+ok(My::Test8->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(My::Test9->does('Role::Boo'), '... our class does() the correct roles');
+ok(My::Test9->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+ok(!My::Test10->does('Role::Boo'), '... our class does() the correct roles');
+ok(!My::Test10->does('Role::Boo::Hoo'), '... our class does() the correct roles');
+
 can_ok('My::Test8', 'ghost');
 can_ok('My::Test9', 'ghost');
 can_ok('My::Test10', 'ghost');
@@ -268,22 +287,22 @@ Role override method conflicts
 =cut
 
 {
-    package Role::Spliff;
+    package Role::Plot;
     use strict;
     use warnings;
     use Moose::Role;
     
     override 'twist' => sub {
-        super() . ' -> Role::Spliff::twist';
+        super() . ' -> Role::Plot::twist';
     };
     
-    package Role::Blunt;
+    package Role::Truth;
     use strict;
     use warnings;
     use Moose::Role;
     
     override 'twist' => sub {
-        super() . ' -> Role::Blunt::twist';
+        super() . ' -> Role::Truth::twist';
     };
 }
 
@@ -303,7 +322,7 @@ Role override method conflicts
     extends 'My::Test::Base';
 
     ::lives_ok {
-        with 'Role::Blunt';
+        with 'Role::Truth';
     } '... composed the role with override okay';
        
     package My::Test12;
@@ -314,7 +333,7 @@ Role override method conflicts
     extends 'My::Test::Base';
 
     ::lives_ok {    
-       with 'Role::Spliff';
+       with 'Role::Plot';
     } '... composed the role with override okay';
               
     package My::Test13;
@@ -323,7 +342,7 @@ Role override method conflicts
     use Moose;
 
     ::dies_ok {
-        with 'Role::Spliff';       
+        with 'Role::Plot';       
     } '... cannot compose it because we have no superclass';
     
     package My::Test14;
@@ -334,7 +353,7 @@ Role override method conflicts
     extends 'My::Test::Base';
 
     ::throws_ok {
-        with 'Role::Spliff', 'Role::Blunt';       
+        with 'Role::Plot', 'Role::Truth';       
     } qr/Two \'override\' methods of the same name encountered/, 
       '... cannot compose it because we have no superclass';       
 }
@@ -344,8 +363,37 @@ ok(My::Test12->meta->has_method('twist'), '... the twist method has been added')
 ok(!My::Test13->meta->has_method('twist'), '... the twist method has not been added');
 ok(!My::Test14->meta->has_method('twist'), '... the twist method has not been added');
 
-is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Blunt::twist', '... got the right method return');
-is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Spliff::twist', '... got the right method return');
+ok(!My::Test11->does('Role::Plot'), '... our class does() the correct roles');
+ok(My::Test11->does('Role::Truth'), '... our class does() the correct roles');
+ok(!My::Test12->does('Role::Truth'), '... our class does() the correct roles');
+ok(My::Test12->does('Role::Plot'), '... our class does() the correct roles');
+ok(!My::Test13->does('Role::Plot'), '... our class does() the correct roles');
+ok(!My::Test14->does('Role::Truth'), '... our class does() the correct roles');
+ok(!My::Test14->does('Role::Plot'), '... our class does() the correct roles');
+
+is(My::Test11->twist(), 'My::Test::Base::twist -> Role::Truth::twist', '... got the right method return');
+is(My::Test12->twist(), 'My::Test::Base::twist -> Role::Plot::twist', '... got the right method return');
 ok(!My::Test13->can('twist'), '... no twist method here at all');
 is(My::Test14->twist(), 'My::Test::Base::twist', '... got the right method return (from superclass)');
 
+{
+    package Role::Reality;
+    use strict;
+    use warnings;
+    use Moose::Role;
+
+    ::throws_ok {    
+        with 'Role::Plot';
+    } qr/A local method of the same name as been found/, 
+    '... could not compose roles here, it dies';
+
+    sub twist {
+        'Role::Reality::twist';
+    }
+}    
+
+ok(Role::Reality->meta->has_method('twist'), '... the twist method has not been added');
+ok(!Role::Reality->meta->does_role('Role::Plot'), '... our role does() the correct roles');
+is(Role::Reality->meta->get_method('twist')->(), 
+    'Role::Reality::twist', 
+    '... the twist method returns the right value');

diff --git a/t/045_role_exclusion.t b/t/045_role_exclusion.t
new file mode 100644 (file)
index 0000000..ed6a7ac
--- /dev/null
+++ b/t/045_role_exclusion.t
@@ -0,0 +1,106 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');
+    use_ok('Moose::Role');    
+}
+
+=pod
+
+The idea and examples for this feature are taken
+from the Fortress spec.
+
+http://research.sun.com/projects/plrg/fortress0903.pdf
+
+trait OrganicMolecule extends Molecule 
+    excludes { InorganicMolecule } 
+end 
+trait InorganicMolecule extends Molecule end 
+
+=cut
+
+{
+    package Molecule;
+    use strict;
+    use warnings;
+    use Moose::Role;
+
+    package Molecule::Organic;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    with 'Molecule';
+    excludes 'Molecule::Inorganic';
+    
+    package Molecule::Inorganic;
+    use strict;
+    use warnings;
+    use Moose::Role;     
+    
+    with 'Molecule';       
+}
+
+ok(Molecule::Organic->meta->excludes_role('Molecule::Inorganic'), '... Molecule::Organic exludes Molecule::Inorganic');
+is_deeply(
+   [ Molecule::Organic->meta->get_excluded_roles_list() ], 
+   [ 'Molecule::Inorganic' ],
+   '... Molecule::Organic exludes Molecule::Inorganic');
+
+{
+    package My::Test1;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Molecule::Organic';
+    } '... adding the role (w/ excluded roles) okay';
+
+    package My::Test2;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::throws_ok {
+        with 'Molecule::Organic', 'Molecule::Inorganic';
+    } qr/Conflict detected: Class::MOP::Class::__ANON__::SERIAL::1 excludes role \'Molecule::Inorganic\'/, 
+    '... adding the role w/ excluded role conflict dies okay';    
+    
+    package My::Test3;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Molecule::Organic';
+    } '... adding the role (w/ excluded roles) okay';   
+    
+    ::throws_ok {
+        with 'Molecule::Inorganic';
+    } qr/Conflict detected: My::Test3 excludes role 'Molecule::Inorganic'/, 
+    '... adding the role w/ excluded role conflict dies okay'; 
+}
+
+ok(My::Test1->does('Molecule::Organic'), '... My::Test1 does Molecule::Organic');
+ok(My::Test1->meta->excludes_role('Molecule::Inorganic'), '... My::Test1 excludes Molecule::Organic');
+ok(!My::Test2->does('Molecule::Organic'), '... ! My::Test2 does Molecule::Organic');
+ok(!My::Test2->does('Molecule::Inorganic'), '... ! My::Test2 does Molecule::Inorganic');
+ok(My::Test3->does('Molecule::Organic'), '... My::Test3 does Molecule::Organic');
+ok(My::Test3->meta->excludes_role('Molecule::Inorganic'), '... My::Test3 excludes Molecule::Organic');
+ok(!My::Test3->does('Molecule::Inorganic'), '... ! My::Test3 does Molecule::Inorganic');
+
+
+
+
+
+
+
+
+