From: Stevan Little Date: Wed, 10 May 2006 15:09:49 +0000 (+0000) Subject: role-exclusion X-Git-Tag: 0_09_03~29 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d79e62fdf0519b8a6d25b1520463b9714997ea5f;p=gitmo%2FMoose.git role-exclusion --- diff --git a/TODO b/TODO index 3fde938..6393ccb 100644 --- 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 --- 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 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 + +This will test if this class C 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 This method does the same thing as L, but adds diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 5f66c67..3eb9ef3 100644 --- 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 + +=item B + +=item B + +=item B + +=back + +=over 4 + =item B =item B diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm index 3fd2649..2d6b8d3 100644 --- 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 --- 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 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'); + + + + + + + + +