requires => {
'Scalar::Util' => '1.18',
'Carp' => '0',
- 'Class::MOP' => '0.31',
+ 'Class::MOP' => '0.34',
'Sub::Name' => '0.02',
'UNIVERSAL::require' => '0.10',
'Sub::Exporter' => '0.954',
- fixed &unimport to not remove the &inner and &super
keywords because we need to localize them.
- fixed number of spelling/grammer issues, thanks Theory :)
- *~~ experimental feature ~~*
+
+ **~~ experimental & undocumented feature ~~**
- added the method and self keywords, they are basically
just sugar, and they may not stay around.
default => sub { {} }
));
+## method modifiers
+
+__PACKAGE__->meta->add_attribute('before_method_modifiers' => (
+ reader => 'get_before_method_modifiers_map',
+ default => sub { {} } # (<name> => [ (CODE) ])
+));
+
+__PACKAGE__->meta->add_attribute('after_method_modifiers' => (
+ reader => 'get_after_method_modifiers_map',
+ default => sub { {} } # (<name> => [ (CODE) ])
+));
+
+__PACKAGE__->meta->add_attribute('around_method_modifiers' => (
+ reader => 'get_around_method_modifiers_map',
+ default => sub { {} } # (<name> => [ (CODE) ])
+));
+
+__PACKAGE__->meta->add_attribute('override_method_modifiers' => (
+ reader => 'get_override_method_modifiers_map',
+ default => sub { {} } # (<name> => CODE)
+));
+
## Methods
sub method_metaclass { 'Moose::Meta::Role::Method' }
keys %{$self->get_attribute_map};
}
+# method modifiers
+
+# mimic the metaclass API
+sub add_before_method_modifier { (shift)->_add_method_modifier('before', @_) }
+sub add_around_method_modifier { (shift)->_add_method_modifier('around', @_) }
+sub add_after_method_modifier { (shift)->_add_method_modifier('after', @_) }
+
+sub _add_method_modifier {
+ my ($self, $modifier_type, $method_name, $method) = @_;
+ my $accessor = "get_${modifier_type}_method_modifiers_map";
+ $self->$accessor->{$method_name} = []
+ unless exists $self->$accessor->{$method_name};
+ my $modifiers = $self->$accessor->{$method_name};
+ # NOTE:
+ # check to see that we aren't adding the
+ # same code twice. We err in favor of the
+ # first on here, this may not be as expected
+ foreach my $modifier (@{$modifiers}) {
+ return if $modifier == $method;
+ }
+ push @{$modifiers} => $method;
+}
+
+sub add_override_method_modifier {
+ my ($self, $method_name, $method) = @_;
+ (!$self->has_method($method_name))
+ || confess "Cannot add an override of method '$method_name' " .
+ "because there is a local version of '$method_name'";
+ $self->get_override_method_modifiers_map->{$method_name} = $method;
+}
+
+sub has_before_method_modifiers { (shift)->_has_method_modifiers('before', @_) }
+sub has_around_method_modifiers { (shift)->_has_method_modifiers('around', @_) }
+sub has_after_method_modifiers { (shift)->_has_method_modifiers('after', @_) }
+
+# override just checks for one,..
+# but we can still re-use stuff
+sub has_override_method_modifier { (shift)->_has_method_modifiers('override', @_) }
+
+sub _has_method_modifiers {
+ my ($self, $modifier_type, $method_name) = @_;
+ my $accessor = "get_${modifier_type}_method_modifiers_map";
+ # NOTE:
+ # for now we assume that if it exists,..
+ # it has at least one modifier in it
+ (exists $self->$accessor->{$method_name}) ? 1 : 0;
+}
+
+sub get_before_method_modifiers { (shift)->_get_method_modifiers('before', @_) }
+sub get_around_method_modifiers { (shift)->_get_method_modifiers('around', @_) }
+sub get_after_method_modifiers { (shift)->_get_method_modifiers('after', @_) }
+
+sub _get_method_modifiers {
+ my ($self, $modifier_type, $method_name) = @_;
+ my $accessor = "get_${modifier_type}_method_modifiers_map";
+ @{$self->$accessor->{$method_name}};
+}
+
+sub get_override_method_modifier {
+ my ($self, $method_name) = @_;
+ $self->get_override_method_modifiers_map->{$method_name};
+}
+
+sub get_method_modifier_list {
+ my ($self, $modifier_type) = @_;
+ my $accessor = "get_${modifier_type}_method_modifiers_map";
+ keys %{$self->$accessor};
+}
## applying a role to a class ...
"to be implemented by '" . $other->name . "'";
}
}
+ else {
+ # NOTE:
+ # we need to make sure that the method is
+ # not a method modifier, because those do
+ # not satisfy the requirements ...
+ my $method = $other->get_method($required_method_name);
+ # check if it is an override or a generated accessor ..
+ (!$method->isa('Moose::Meta::Method::Overriden') &&
+ !$method->isa('Class::MOP::Attribute::Accessor'))
+ || confess "'" . $self->name . "' requires the method '$required_method_name' " .
+ "to be implemented by '" . $other->name . "', the method is only a method modifier";
+ # before/after/around methods are a little trickier
+ # since we wrap the original local method (if applicable)
+ # so we need to check if the original wrapped method is
+ # from the same package, and not a wrap of the super method
+ if ($method->isa('Class::MOP::Method::Wrapped')) {
+ ($method->get_original_method->package_name eq $other->name)
+ || confess "'" . $self->name . "' requires the method '$required_method_name' " .
+ "to be implemented by '" . $other->name . "', the method is only a method modifier";
+ }
+ }
}
}
}
}
+sub _apply_override_method_modifiers {
+ my ($self, $other) = @_;
+ foreach my $method_name ($self->get_method_modifier_list('override')) {
+ # it if it has one already then ...
+ if ($other->has_method($method_name)) {
+ # if it is being composed into another role
+ # we have a conflict here, because you cannot
+ # combine an overriden method with a locally
+ # defined one
+ if ($other->isa('Moose::Meta::Role')) {
+ confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
+ "during composition (A local method of the same name as been found). This " .
+ "is fatal error.";
+ }
+ else {
+ # if it is a class, then we
+ # just ignore this here ...
+ next;
+ }
+ }
+ else {
+ # if no local method is found, then we
+ # must check if we are a role or class
+ if ($other->isa('Moose::Meta::Role')) {
+ # if we are a role, we need to make sure
+ # we dont have a conflict with the role
+ # we are composing into
+ if ($other->has_override_method_modifier($method_name) &&
+ $other->get_override_method_modifier($method_name) != $self->get_override_method_modifier($method_name)) {
+ confess "Role '" . $self->name . "' has encountered an 'override' method conflict " .
+ "during composition (Two 'override' methods of the same name encountered). " .
+ "This is fatal error.";
+ }
+ else {
+ # if there is no conflict,
+ # just add it to the role
+ $other->add_override_method_modifier(
+ $method_name,
+ $self->get_override_method_modifier($method_name)
+ );
+ }
+ }
+ else {
+ # if this is not a role, then we need to
+ # find the original package of the method
+ # so that we can tell the class were to
+ # find the right super() method
+ my $method = $self->get_override_method_modifier($method_name);
+ my $package = svref_2object($method)->GV->STASH->NAME;
+ # if it is a class, we just add it
+ $other->add_override_method_modifier($method_name, $method, $package);
+ }
+ }
+ }
+}
+
+sub _apply_method_modifiers {
+ my ($self, $modifier_type, $other) = @_;
+ my $add = "add_${modifier_type}_method_modifier";
+ my $get = "get_${modifier_type}_method_modifiers";
+ foreach my $method_name ($self->get_method_modifier_list($modifier_type)) {
+ $other->$add(
+ $method_name,
+ $_
+ ) foreach $self->$get($method_name);
+ }
+}
+
+sub _apply_before_method_modifiers { (shift)->_apply_method_modifiers('before' => @_) }
+sub _apply_around_method_modifiers { (shift)->_apply_method_modifiers('around' => @_) }
+sub _apply_after_method_modifiers { (shift)->_apply_method_modifiers('after' => @_) }
+
sub apply {
my ($self, $other) = @_;
$self->_check_required_methods($other);
$self->_apply_attributes($other);
- $self->_apply_methods($other);
+ $self->_apply_methods($other);
+
+ $self->_apply_override_method_modifiers($other);
+ $self->_apply_before_method_modifiers($other);
+ $self->_apply_around_method_modifiers($other);
+ $self->_apply_after_method_modifiers($other);
$other->add_role($self);
}
=back
+=over 4
+
+=item B<add_after_method_modifier>
+
+=item B<add_around_method_modifier>
+
+=item B<add_before_method_modifier>
+
+=item B<add_override_method_modifier>
+
+=over 4
+
+=back
+
+=item B<has_after_method_modifiers>
+
+=item B<has_around_method_modifiers>
+
+=item B<has_before_method_modifiers>
+
+=item B<has_override_method_modifier>
+
+=over 4
+
+=back
+
+=item B<get_after_method_modifiers>
+
+=item B<get_around_method_modifiers>
+
+=item B<get_before_method_modifiers>
+
+=item B<get_method_modifier_list>
+
+=over 4
+
+=back
+
+=item B<get_override_method_modifier>
+
+=item B<get_after_method_modifiers_map>
+
+=item B<get_around_method_modifiers_map>
+
+=item B<get_before_method_modifiers_map>
+
+=item B<get_override_method_modifiers_map>
+
+=back
+
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
before => sub {
my $meta = _find_meta();
return subname 'Moose::Role::before' => sub (@&) {
- confess "Moose::Role does not currently support 'before'";
+ my $code = pop @_;
+ $meta->add_before_method_modifier($_, $code) for @_;
};
},
after => sub {
my $meta = _find_meta();
return subname 'Moose::Role::after' => sub (@&) {
- confess "Moose::Role does not currently support 'after'";
+ my $code = pop @_;
+ $meta->add_after_method_modifier($_, $code) for @_;
};
},
around => sub {
my $meta = _find_meta();
return subname 'Moose::Role::around' => sub (@&) {
- confess "Moose::Role does not currently support 'around'";
+ my $code = pop @_;
+ $meta->add_around_method_modifier($_, $code) for @_;
};
},
super => sub {
my $meta = _find_meta();
- return subname 'Moose::Role::super' => sub {
- confess "Moose::Role cannot support 'super'";
- };
+ return subname 'Moose::Role::super' => sub {};
},
override => sub {
my $meta = _find_meta();
return subname 'Moose::Role::override' => sub ($&) {
- confess "Moose::Role cannot support 'override'";
+ my ($name, $code) = @_;
+ $meta->add_override_method_modifier($name, $code);
};
},
inner => sub {
my $meta = _find_meta();
return subname 'Moose::Role::inner' => sub {
- confess "Moose::Role cannot support 'inner'";
+ confess "Moose::Role cannot support 'inner'";
};
},
augment => sub {
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 28;
use Test::Exception;
BEGIN {
ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute');
+# method modifiers
+
+ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier');
+
+my $method = sub { "FooRole::boo:before" };
+lives_ok {
+ $foo_role->add_before_method_modifier('boo' => $method);
+} '... added a method modifier okay';
+
+ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier');
+is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back');
+
+is_deeply(
+ [ $foo_role->get_method_modifier_list('before') ],
+ [ 'boo' ],
+ '... got the right list of before method modifiers');
use strict;
use warnings;
-use Test::More tests => 25;
+use Test::More tests => 35;
use Test::Exception;
BEGIN {
sub foo { 'FooRole::foo' }
sub boo { 'FooRole::boo' }
-
+
+ before 'boo' => sub { "FooRole::boo:before" };
+
+ after 'boo' => sub { "FooRole::boo:after1" };
+ after 'boo' => sub { "FooRole::boo:after2" };
+
+ around 'boo' => sub { "FooRole::boo:around" };
+
+ override 'bling' => sub { "FooRole::bling:override" };
+ override 'fling' => sub { "FooRole::fling:override" };
+
::dies_ok { extends() } '... extends() is not supported';
- ::dies_ok { augment() } '... augment() is not supported';
- ::dies_ok { inner() } '... inner() is not supported';
- ::dies_ok { overrides() } '... overrides() is not supported';
- ::dies_ok { super() } '... super() is not supported';
- ::dies_ok { after() } '... after() is not supported';
- ::dies_ok { before() } '... before() is not supported';
- ::dies_ok { around() } '... around() is not supported';
+ ::dies_ok { augment() } '... augment() is not supported';
+ ::dies_ok { inner() } '... inner() is not supported';
}
my $foo_role = FooRole->meta;
{ is => 'ro' },
'... got the correct description of the baz attribute');
+# method modifiers
+
+ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier');
+is(($foo_role->get_before_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:before",
+ '... got the right method back');
+
+is_deeply(
+ [ $foo_role->get_method_modifier_list('before') ],
+ [ 'boo' ],
+ '... got the right list of before method modifiers');
+
+ok($foo_role->has_after_method_modifiers('boo'), '... now we have a boo:after modifier');
+is(($foo_role->get_after_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:after1",
+ '... got the right method back');
+is(($foo_role->get_after_method_modifiers('boo'))[1]->(),
+ "FooRole::boo:after2",
+ '... got the right method back');
+
+is_deeply(
+ [ $foo_role->get_method_modifier_list('after') ],
+ [ 'boo' ],
+ '... got the right list of after method modifiers');
+
+ok($foo_role->has_around_method_modifiers('boo'), '... now we have a boo:around modifier');
+is(($foo_role->get_around_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:around",
+ '... got the right method back');
+
+is_deeply(
+ [ $foo_role->get_method_modifier_list('around') ],
+ [ 'boo' ],
+ '... got the right list of around method modifiers');
+
+## overrides
+
+ok($foo_role->has_override_method_modifier('bling'), '... now we have a bling:override modifier');
+is($foo_role->get_override_method_modifier('bling')->(),
+ "FooRole::bling:override",
+ '... got the right method back');
+
+ok($foo_role->has_override_method_modifier('fling'), '... now we have a fling:override modifier');
+is($foo_role->get_override_method_modifier('fling')->(),
+ "FooRole::fling:override",
+ '... got the right method back');
+
+is_deeply(
+ [ sort $foo_role->get_method_modifier_list('override') ],
+ [ 'bling', 'fling' ],
+ '... got the right list of override method modifiers');
+
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 39;
use Test::Exception;
BEGIN {
use_ok('Moose::Role');
}
-
-
{
package FooRole;
use Moose::Role;
sub goo { 'FooRole::goo' }
sub foo { 'FooRole::foo' }
+
+ override 'boo' => sub { 'FooRole::boo -> ' . super() };
+
+ around 'blau' => sub {
+ my $c = shift;
+ 'FooRole::blau -> ' . $c->();
+ };
package BarClass;
use Moose;
extends 'BarClass';
with 'FooRole';
+
+ sub blau { 'FooClass::blau' }
sub goo { 'FooClass::goo' } # << overrides the one from the role ...
}
ok($foo_class_meta->does_role('FooRole'), '... the FooClass->meta does_role FooRole');
ok(!$foo_class_meta->does_role('OtherRole'), '... the FooClass->meta !does_role OtherRole');
-foreach my $method_name (qw(bar baz foo goo)) {
+foreach my $method_name (qw(bar baz foo boo blau goo)) {
ok($foo_class_meta->has_method($method_name), '... FooClass has the method ' . $method_name);
}
can_ok($foo, 'bar');
can_ok($foo, 'baz');
can_ok($foo, 'foo');
+can_ok($foo, 'boo');
can_ok($foo, 'goo');
+can_ok($foo, 'blau');
is($foo->foo, 'FooRole::foo', '... got the right value of foo');
is($foo->goo, 'FooClass::goo', '... got the right value of goo');
is($foo->bar, $foo2, '... got the right value for bar now');
+is($foo->boo, 'FooRole::boo -> BarClass::boo', '... got the right value from ->boo');
+is($foo->blau, 'FooRole::blau -> FooClass::blau', '... got the right value from ->blau');
use strict;
use warnings;
-use Test::More tests => 67;
+use Test::More tests => 90;
use Test::Exception;
BEGIN {
=cut
+{
+ package Role::Plot;
+ use Moose::Role;
+
+ override 'twist' => sub {
+ super() . ' -> Role::Plot::twist';
+ };
+
+ package Role::Truth;
+ use Moose::Role;
+
+ override 'twist' => sub {
+ super() . ' -> Role::Truth::twist';
+ };
+}
+
+{
+ package My::Test::Base;
+ use Moose;
+
+ sub twist { 'My::Test::Base::twist' }
+
+ package My::Test11;
+ use Moose;
+
+ extends 'My::Test::Base';
+
+ ::lives_ok {
+ with 'Role::Truth';
+ } '... composed the role with override okay';
+
+ package My::Test12;
+ use Moose;
+
+ extends 'My::Test::Base';
+
+ ::lives_ok {
+ with 'Role::Plot';
+ } '... composed the role with override okay';
+
+ package My::Test13;
+ use Moose;
+
+ ::dies_ok {
+ with 'Role::Plot';
+ } '... cannot compose it because we have no superclass';
+
+ package My::Test14;
+ use Moose;
+
+ extends 'My::Test::Base';
+
+ ::throws_ok {
+ with 'Role::Plot', 'Role::Truth';
+ } qr/Two \'override\' methods of the same name encountered/,
+ '... cannot compose it because we have no superclass';
+}
+
+ok(My::Test11->meta->has_method('twist'), '... the twist method has been added');
+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');
+
+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 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');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Role');
+}
+
+=pod
+
+Role which requires a method implemented
+in another role as an override (it does
+not remove the requirement)
+
+=cut
+
+{
+ package Role::RequireFoo;
+ use strict;
+ use warnings;
+ use Moose::Role;
+
+ requires 'foo';
+
+ package Role::ProvideFoo;
+ use strict;
+ use warnings;
+ use Moose::Role;
+
+ ::lives_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method will not exist yet (but we will live)';
+
+ override 'foo' => sub { 'Role::ProvideFoo::foo' };
+}
+
+is_deeply(
+ [ Role::ProvideFoo->meta->get_required_method_list ],
+ [ 'foo' ],
+ '... foo method is still required for Role::ProvideFoo');
+
+=pod
+
+Role which requires a method implemented
+in the consuming class as an override.
+It will fail since method modifiers are
+second class citizens.
+
+=cut
+
+{
+ package Class::ProvideFoo::Base;
+ use Moose;
+
+ sub foo { 'Class::ProvideFoo::Base::foo' }
+
+ package Class::ProvideFoo::Override1;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method will not exist yet (and we will die)';
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
+ package Class::ProvideFoo::Override2;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method exists, but it is an override (and we will die)';
+
+}
+
+=pod
+
+Now same thing, but with a before
+method modifier.
+
+=cut
+
+{
+ package Class::ProvideFoo::Before1;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method will not exist yet (and we will die)';
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ package Class::ProvideFoo::Before2;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method exists, but it is a before (and we will die)';
+
+ package Class::ProvideFoo::Before3;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ ::lives_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method will not exist yet (and we will die)';
+
+ sub foo { 'Class::ProvideFoo::foo' }
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ package Class::ProvideFoo::Before4;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ sub foo { 'Class::ProvideFoo::foo' }
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped');
+ ::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__,
+ '... but the original method is from our package');
+
+ ::lives_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method exists in the symbol table (and we will live)';
+
+ package Class::ProvideFoo::Before5;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped');
+ ::isnt(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__,
+ '... but the original method is not from our package');
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method exists, but it is a before wrapping the super (and we will die)';
+}
+
+=pod
+
+Now same thing, but with a method from an attribute
+method modifier.
+
+=cut
+
+{
+
+ package Class::ProvideFoo::Attr1;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method will not exist yet (and we will die)';
+
+ has 'foo' => (is => 'ro');
+
+ package Class::ProvideFoo::Attr2;
+ use Moose;
+
+ extends 'Class::ProvideFoo::Base';
+
+ has 'foo' => (is => 'ro');
+
+ ::dies_ok {
+ with 'Role::RequireFoo';
+ } '... the required "foo" method exists, but it is a before (and we will die)';
+}
+
+
\ No newline at end of file
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More tests => 34;
use Test::Exception;
BEGIN {
=pod
Check for repeated inheritence causing
+a method conflict with method modifiers
+(which is not really a conflict)
+
+=cut
+
+{
+ package Role::Base2;
+ use Moose::Role;
+
+ override 'foo' => sub { super() . ' -> Role::Base::foo' };
+
+ package Role::Derived3;
+ use Moose::Role;
+
+ with 'Role::Base2';
+
+ package Role::Derived4;
+ use Moose::Role;
+
+ with 'Role::Base2';
+
+ package My::Test::Class2::Base;
+ use Moose;
+
+ sub foo { 'My::Test::Class2::Base' }
+
+ package My::Test::Class2;
+ use Moose;
+
+ extends 'My::Test::Class2::Base';
+
+ ::lives_ok {
+ with 'Role::Derived3', 'Role::Derived4';
+ } '... roles composed okay (no conflicts)';
+}
+
+ok(Role::Base2->meta->has_override_method_modifier('foo'), '... have the method foo as expected');
+ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected');
+ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected');
+ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected');
+isa_ok(My::Test::Class2->meta->get_method('foo'), 'Moose::Meta::Method::Overriden');
+ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected');
+isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method');
+
+is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method');
+is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method');
+
+=pod
+
+Check for repeated inheritence of the
+same code. There are no conflicts with
+before/around/after method modifiers.
+
+This tests around, but should work the
+same for before/afters as well
+
+=cut
+
+{
+ package Role::Base3;
+ use Moose::Role;
+
+ around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' };
+
+ package Role::Derived5;
+ use Moose::Role;
+
+ with 'Role::Base3';
+
+ package Role::Derived6;
+ use Moose::Role;
+
+ with 'Role::Base3';
+
+ package My::Test::Class3::Base;
+ use Moose;
+
+ sub foo { 'My::Test::Class3::Base' }
+
+ package My::Test::Class3;
+ use Moose;
+
+ extends 'My::Test::Class3::Base';
+
+ ::lives_ok {
+ with 'Role::Derived5', 'Role::Derived6';
+ } '... roles composed okay (no conflicts)';
+}
+
+ok(Role::Base3->meta->has_around_method_modifiers('foo'), '... have the method foo as expected');
+ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected');
+ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected');
+ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected');
+isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped');
+ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected');
+isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method');
+
+is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method');
+is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method');
+
+=pod
+
+Check for repeated inheritence causing
a attr conflict (which is not really
a conflict)
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 77;
use Test::Exception;
BEGIN {
is($foo_rv, "RootA::foo", "... got the right foo rv");
}
+{
+ # NOTE:
+ # this edge cases shows the application of
+ # an after modifier over a method which
+ # was added during role composotion.
+ # The way this will work is as follows:
+ # role SubBA will consume RootB and
+ # get a local copy of RootB::foo, it
+ # will also store a deferred after modifier
+ # to be applied to whatever class SubBA is
+ # composed into.
+ # When class SubBB comsumed role SubBA, the
+ # RootB::foo method is added to SubBB, then
+ # the deferred after modifier from SubBA is
+ # applied to it.
+ # It is important to note that the application
+ # of the after modifier does not happen until
+ # role SubBA is composed into SubAA.
+
+ {
+ package RootB;
+ use Moose::Role;
+
+ sub foo { "RootB::foo" }
+
+ package SubBA;
+ use Moose::Role;
+
+ with "RootB";
+
+ has counter => (
+ isa => "Num",
+ is => "rw",
+ default => 0,
+ );
+
+ after foo => sub {
+ $_[0]->counter( $_[0]->counter + 1 );
+ };
+
+ package SubBB;
+ use Moose;
+
+ ::lives_ok {
+ with "SubBA";
+ } '... composed the role successfully';
+ }
+
+ ok( SubBB->does("SubBA"), "BB does SubBA" );
+ ok( SubBB->does("RootB"), "BB does RootB" );
+
+ isa_ok( my $i = SubBB->new, "SubBB" );
+
+ can_ok( $i, "foo" );
+
+ my $foo_rv;
+ lives_ok {
+ $foo_rv = $i->foo
+ } '... called foo successfully';
+ is( $foo_rv, "RootB::foo", "foo rv" );
+ is( $i->counter, 1, "after hook called" );
+
+ lives_ok { $i->foo } '... called foo successfully (again)';
+ is( $i->counter, 2, "after hook called (again)" );
+
+ can_ok('SubBA', 'foo');
+ my $subba_foo_rv;
+ lives_ok {
+ $subba_foo_rv = SubBA::foo();
+ } '... called the sub as a function correctly';
+ is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
+}
+
+{
+ # NOTE:
+ # this checks that an override method
+ # does not try to trample over a locally
+ # composed in method. In this case the
+ # RootC::foo, which is composed into
+ # SubCA cannot be trampled with an
+ # override of 'foo'
+ {
+ package RootC;
+ use Moose::Role;
+
+ sub foo { "RootC::foo" }
+
+ package SubCA;
+ use Moose::Role;
+
+ with "RootC";
+
+ ::dies_ok {
+ override foo => sub { "overridden" };
+ } '... cannot compose an override over a local method';
+ }
+}
+
+# NOTE:
+# need to talk to Yuval about the motivation behind
+# this test, I am not sure we are testing anything
+# useful here (although more tests cant hurt)
+
+{
+ use List::Util qw/shuffle/;
+
+ {
+ package Abstract;
+ use Moose::Role;
+
+ requires "method";
+ requires "other";
+
+ sub another { "abstract" }
+
+ package ConcreteA;
+ use Moose::Role;
+ with "Abstract";
+
+ sub other { "concrete a" }
+
+ package ConcreteB;
+ use Moose::Role;
+ with "Abstract";
+
+ sub method { "concrete b" }
+
+ package ConcreteC;
+ use Moose::Role;
+ with "ConcreteA";
+
+ # NOTE:
+ # this was originally override, but
+ # that wont work (see above set of tests)
+ # so I switched it to around.
+ # However, this may not be testing the
+ # same thing that was originally intended
+ around other => sub {
+ return ( (shift)->() . " + c" );
+ };
+
+ package SimpleClassWithSome;
+ use Moose;
+
+ eval { with ::shuffle qw/ConcreteA ConcreteB/ };
+ ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
+
+ package SimpleClassWithAll;
+ use Moose;
+
+ eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ };
+ ::ok( !$@, "simple composition with abstract" ) || ::diag $@;
+ }
+
+ foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) {
+ foreach my $role (qw/Abstract ConcreteA ConcreteB/) {
+ ok( $class->does($role), "$class does $role");
+ }
+
+ foreach my $method (qw/method other another/) {
+ can_ok( $class, $method );
+ }
+
+ is( eval { $class->another }, "abstract", "provided by abstract" );
+ is( eval { $class->other }, "concrete a", "provided by concrete a" );
+ is( eval { $class->method }, "concrete b", "provided by concrete b" );
+ }
+
+ {
+ package ClassWithSome;
+ use Moose;
+
+ eval { with ::shuffle qw/ConcreteC ConcreteB/ };
+ ::ok( !$@, "composition without abstract" ) || ::diag $@;
+
+ package ClassWithAll;
+ use Moose;
+
+ eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
+ ::ok( !$@, "composition with abstract" ) || ::diag $@;
+
+ package ClassWithEverything;
+ use Moose;
+
+ eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash
+ ::ok( !$@, "can compose ConcreteA and ConcreteC together" );
+ }
+
+ foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) {
+ foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) {
+ ok( $class->does($role), "$class does $role");
+ }
+
+ foreach my $method (qw/method other another/) {
+ can_ok( $class, $method );
+ }
+
+ is( eval { $class->another }, "abstract", "provided by abstract" );
+ is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" );
+ is( eval { $class->method }, "concrete b", "provided by concrete b" );
+ }
+}
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More tests => 21;
use Test::Exception;
BEGIN {
## Roles
-=begin nonsense
-
{
package Constraint;
use Moose::Role;
ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly');
is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly');
-=cut
projects / gitmo/Moose.git / commitdiff