use Carp 'confess';
use Scalar::Util 'blessed';
-use Mouse::Util;
+use Mouse::Util qw(load_class is_class_loaded);
use Mouse::Meta::Attribute;
use Mouse::Meta::Module; # class_of()
}
}
-sub load_class {
- my $class = shift;
-
- if (!Mouse::Util::is_valid_class_name($class)) {
- my $display = defined($class) ? $class : 'undef';
- confess "Invalid class name ($display)";
- }
-
- return 1 if is_class_loaded($class);
-
- (my $file = "$class.pm") =~ s{::}{/}g;
-
- eval { CORE::require($file) };
- confess "Could not load class ($class) because : $@" if $@;
-
- return 1;
-}
-
-my %is_class_loaded_cache;
-sub is_class_loaded {
- my $class = shift;
-
- return 0 if ref($class) || !defined($class) || !length($class);
-
- return 1 if exists $is_class_loaded_cache{$class};
-
- # walk the symbol table tree to avoid autovififying
- # \*{${main::}{"Foo::"}} == \*main::Foo::
-
- my $pack = \*::;
- foreach my $part (split('::', $class)) {
- return 0 unless exists ${$$pack}{"${part}::"};
- $pack = \*{${$$pack}{"${part}::"}};
- }
-
- # check for $VERSION or @ISA
- return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION}
- && defined *{${$$pack}{VERSION}}{SCALAR};
- return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA}
- && defined *{${$$pack}{ISA}}{ARRAY};
-
- # check for any method
- foreach ( keys %{$$pack} ) {
- next if substr($_, -2, 2) eq '::';
- return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE};
- }
-
- # fail
- return 0;
-}
-
1;
__END__
use base qw(Mouse::Meta::Module);
+sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
sub _new {
my($class, %args) = @_;
sub make_mutable { not_supported }
-sub is_immutable { $_[0]->{is_immutable} }
+sub is_immutable { $_[0]->{is_immutable} }
+sub is_mutable { !$_[0]->{is_immutable} }
sub _install_modifier {
my ( $self, $into, $type, $name, $code ) = @_;
$name,
$code
);
+ $self->{methods}{$name}++; # register it to the method map
+ return;
};
}
sub add_override_method_modifier {
my ($self, $name, $code) = @_;
- my $pkg = $self->name;
- my $method = "${pkg}::${name}";
+ my $package = $self->name;
- # Class::Method::Modifiers won't do this for us, so do it ourselves
+ my $body = $package->can($name)
+ or $self->throw_error("You cannot override '$name' because it has no super method");
- my $body = $pkg->can($name)
- or $self->throw_error("You cannot override '$method' because it has no super method");
-
- no strict 'refs';
- *$method = sub { $code->($pkg, $body, @_) };
+ $self->add_method($name => sub { $code->($package, $body, @_) });
}
sub does_role {
--- /dev/null
+package Mouse::Meta::Method;\r
+use strict;\r
+use warnings;\r
+\r
+use overload\r
+ '&{}' => 'body',\r
+ fallback => 1,\r
+;\r
+\r
+sub new{\r
+ my($class, %args) = @_;\r
+\r
+ return bless \%args, $class;\r
+}\r
+\r
+sub body { $_[0]->{body} }\r
+sub name { $_[0]->{name} }\r
+sub package{ $_[0]->{name} }\r
+\r
+\r
+1;\r
+\r
+__END__\r
use strict;
use warnings;
-use Mouse::Util qw/get_code_info not_supported/;
+use Mouse::Util qw/get_code_info not_supported load_class/;
use Scalar::Util qw/blessed/;
sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
sub get_attribute { $_[0]->{attributes}->{$_[1]} }
sub get_attribute_list{ keys %{$_[0]->{attributes}} }
+sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} }
sub namespace{
my $name = $_[0]->{package};
}
sub get_method{
- Carp::croak("get_method() is not yet implemented");
+ my($self, $method_name) = @_;
+
+ if($self->has_method($method_name)){
+ my $method_metaclass = $self->method_metaclass;
+ load_class($method_metaclass);
+
+ my $package = $self->name;
+ return $method_metaclass->new(
+ body => $package->can($method_name),
+ name => $method_name,
+ package => $package,
+ );
+ }
+
+ return undef;
}
sub get_method_list {\r
use Mouse::Util qw(not_supported);
use base qw(Mouse::Meta::Module);
+sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
+
sub _new {
my $class = shift;
my %args = @_;
sub get_roles { $_[0]->{roles} }
+sub get_required_method_list{
+ return @{ $_[0]->{required_methods} };
+}
sub add_required_methods {
my $self = shift;
push @{$self->{required_methods}}, @methods;
}
+sub requires_method {
+ my($self, $name) = @_;
+ return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
+}
+
sub add_attribute {
my $self = shift;
my $name = shift;
- my $spec = shift;
- $self->{attributes}->{$name} = $spec;
+
+ $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
}
sub _check_required_methods{
my $role_name = $role->name;
my $class_name = $class->name;
- my $alias = $args->{alias};
+
+ my $alias = (exists $args->{alias} && !exists $args->{-alias}) ? $args->{alias} : $args->{-alias};
+ my $excludes = (exists $args->{excludes} && !exists $args->{-excludes}) ? $args->{excludes} : $args->{-excludes};
+
+ my %exclude_map;
+
+ if(defined $excludes){
+ if(ref $excludes){
+ %exclude_map = map{ $_ => undef } @{$excludes};
+ }
+ else{
+ $exclude_map{$excludes} = undef;
+ }
+ }
foreach my $method_name($role->get_method_list){
next if $method_name eq 'meta';
my $code = $role_name->can($method_name);
- if(do{ no strict 'refs'; defined &{$class_name . '::' . $method_name} }){
- # XXX what's Moose's behavior?
- }
- else{
- $class->add_method($method_name => $code);
+
+ if(!exists $exclude_map{$method_name}){
+ if(!$class->has_method($method_name)){
+ $class->add_method($method_name => $code);
+ }
}
if($alias && $alias->{$method_name}){
my $dstname = $alias->{$method_name};
- if(do{ no strict 'refs'; defined &{$class_name . '::' . $dstname} }){
- # XXX wat's Moose's behavior?
+
+ my $slot = do{ no strict 'refs'; \*{$class_name . '::' . $dstname} };
+ if(defined(*{$slot}{CODE}) && *{$slot}{CODE} != $code){
+ $class->throw_error("Cannot create a method alias if a local method of the same name exists");
}
else{
$class->add_method($dstname => $code);
my $modifiers = $role->{"${modifier_type}_method_modifiers"};
while(my($method_name, $modifier_codes) = each %{$modifiers}){
- foreach my $code(@{$modifier_codes}){
+ foreach my $code(ref($modifier_codes) eq 'ARRAY' ? @{$modifier_codes} : $modifier_codes){
$class->$add_modifier($method_name => $code);
}
}
return;
}
-for my $modifier_type (qw/before after around override/) {
+for my $modifier_type (qw/before after around/) {
my $modifier = "${modifier_type}_method_modifiers";
my $add_method_modifier = sub {
*{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
}
+sub add_override_method_modifier{
+ my($self, $method_name, $method) = @_;
+
+ (!$self->has_method($method_name))\r
+ || $self->throw_error("Cannot add an override of method '$method_name' " .\r
+ "because there is a local version of '$method_name'");
+
+ $self->{override_method_modifiers}->{$method_name} = $method;
+}
+
+sub has_override_method_modifier {\r
+ my ($self, $method_name) = @_;\r
+ return exists $self->{override_method_modifiers}->{$method_name};\r
+}\r
+\r
+sub get_override_method_modifier {\r
+ my ($self, $method_name) = @_;\r
+ return $self->{override_method_modifiers}->{$method_name};\r
+}
+
+sub get_method_modifier_list {
+ my($self, $modifier_type) = @_;
+
+ return keys %{ $self->{$modifier_type . '_method_modifiers'} };
+}
+
# This is currently not passing all the Moose tests.
sub does_role {
my ($self, $role_name) = @_;
--- /dev/null
+package Mouse::Meta::Role::Method;\r
+use strict;\r
+use warnings;\r
+\r
+use base qw(Mouse::Meta::Method);\r
+\r
+1;\r
+\r
+__END__\r
+\r
use B ();
our @EXPORT_OK = qw(
+ load_class
+ is_class_loaded
get_linear_isa
apply_all_roles
get_code_info
return 0 if ref($class);
return 0 unless defined($class);
- return 0 unless length($class);
return 1 if $class =~ /^\w+(?:::\w+)*$/;
my $found;
my %exceptions;
for my $class (@classes) {
- unless ( is_valid_class_name($class) ) {
- my $display = defined($class) ? $class : 'undef';
- confess "Invalid class name ($display)";
- }
-
my $e = _try_load_one_class($class);
if ($e) {
sub _try_load_one_class {
my $class = shift;
- return if Mouse::is_class_loaded($class);
+ unless ( is_valid_class_name($class) ) {
+ my $display = defined($class) ? $class : 'undef';
+ confess "Invalid class name ($display)";
+ }
+
+ return if is_class_loaded($class);
my $file = $class . '.pm';
$file =~ s{::}{/}g;
};
}
+
+sub load_class {
+ my $class = shift;
+ my $e = _try_load_one_class($class);
+ confess "Could not load class ($class) because : $e" if $e;
+
+ return 1;
+}
+
+my %is_class_loaded_cache;
+sub is_class_loaded {
+ my $class = shift;
+
+ return 0 if ref($class) || !defined($class) || !length($class);
+
+ return 1 if exists $is_class_loaded_cache{$class};
+
+ # walk the symbol table tree to avoid autovififying
+ # \*{${main::}{"Foo::"}} == \*main::Foo::
+
+ my $pack = \*::;
+ foreach my $part (split('::', $class)) {
+ return 0 unless exists ${$$pack}{"${part}::"};
+ $pack = \*{${$$pack}{"${part}::"}};
+ }
+
+ # check for $VERSION or @ISA
+ return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION}
+ && defined *{${$$pack}{VERSION}}{SCALAR};
+ return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA}
+ && defined *{${$$pack}{ISA}}{ARRAY};
+
+ # check for any method
+ foreach ( keys %{$$pack} ) {
+ next if substr($_, -2, 2) eq '::';
+ return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE};
+ }
+
+ # fail
+ return 0;
+}
+
+
sub apply_all_roles {
my $meta = Mouse::Meta::Class->initialize(shift);
--- /dev/null
+package Test::Mouse;\r
+\r
+use strict;\r
+use warnings;\r
+use Mouse ();\r
+\r
+use base qw(Test::Builder::Module);\r
+\r
+our @EXPORT = qw(meta_ok does_ok has_attribute_ok);\r
+\r
+sub find_meta{ Mouse::class_of($class_or_obj) }\r
+\r
+sub meta_ok ($;$) {\r
+ my ($class_or_obj, $message) = @_;\r
+\r
+ $message ||= "The object has a meta";\r
+\r
+ if (find_meta($class_or_obj)) {\r
+ return __PACKAGE__->builder->ok(1, $message)\r
+ }\r
+ else {\r
+ return __PACKAGE__->builder->ok(0, $message);\r
+ }\r
+}\r
+\r
+sub does_ok ($$;$) {\r
+ my ($class_or_obj, $does, $message) = @_;\r
+\r
+ $message ||= "The object does $does";\r
+\r
+ my $meta = find_meta($class_or_obj);\r
+ if ($meta && $meta->does_role($does)) {\r
+ return __PACKAGE__->builder->ok(1, $message)\r
+ }\r
+ else {\r
+ return __PACKAGE__->builder->ok(0, $message);\r
+ }\r
+}\r
+\r
+sub has_attribute_ok ($$;$) {\r
+ my ($class_or_obj, $attr_name, $message) = @_;\r
+\r
+ $message ||= "The object does has an attribute named $attr_name";\r
+\r
+ my $meta = find_meta($class_or_obj);\r
+\r
+ if ($meta->find_attribute_by_name($attr_name)) {\r
+ return __PACKAGE__->builder->ok(1, $message)\r
+ }\r
+ else {\r
+ return __PACKAGE__->builder->ok(0, $message);\r
+ }\r
+}\r
+\r
+1;\r
+\r
+__END__\r
+\r
+=pod\r
+\r
+=head1 NAME\r
+\r
+Test::Mouse - Test functions for Mouse specific features\r
+\r
+=head1 SYNOPSIS\r
+\r
+ use Test::More plan => 1;\r
+ use Test::Mouse;\r
+\r
+ meta_ok($class_or_obj, "... Foo has a ->meta");\r
+ does_ok($class_or_obj, $role, "... Foo does the Baz role");\r
+ has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");\r
+\r
+=cut\r
+\r
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 26;
+use Test::Exception;
+
+use Mouse::Meta::Role;
+
+{
+ package FooRole;
+
+ our $VERSION = '0.01';
+
+ sub foo { 'FooRole::foo' }
+}
+
+my $foo_role = Mouse::Meta::Role->initialize('FooRole');
+isa_ok($foo_role, 'Mouse::Meta::Role');
+#isa_ok($foo_role, 'Class::MOP::Module');
+
+is($foo_role->name, 'FooRole', '... got the right name of FooRole');
+is($foo_role->version, '0.01', '... got the right version of FooRole');
+
+# methods ...
+
+ok($foo_role->has_method('foo'), '... FooRole has the foo method');
+is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method');
+
+isa_ok($foo_role->get_method('foo'), 'Mouse::Meta::Role::Method');
+
+is_deeply(
+ [ $foo_role->get_method_list() ],
+ [ 'foo' ],
+ '... got the right method list');
+
+# attributes ...
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [],
+ '... got the right attribute list');
+
+ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
+
+lives_ok {
+ $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo'));
+} '... added the bar attribute okay';
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [ 'bar' ],
+ '... got the right attribute list');
+
+ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
+
+is_deeply(
+ join('|', %{$foo_role->get_attribute('bar')}),
+ join('|', %{+{ is => 'rw', isa => 'Foo' }}),
+ '... got the correct description of the bar attribute');
+
+lives_ok {
+ $foo_role->add_attribute('baz' => (is => 'ro'));
+} '... added the baz attribute okay';
+
+is_deeply(
+ [ sort $foo_role->get_attribute_list() ],
+ [ 'bar', 'baz' ],
+ '... got the right attribute list');
+
+ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
+
+is_deeply(
+ $foo_role->get_attribute('baz'),
+ { is => 'ro' },
+ '... got the correct description of the baz attribute');
+
+lives_ok {
+ $foo_role->remove_attribute('bar');
+} '... removed the bar attribute okay';
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [ 'baz' ],
+ '... got the right attribute list');
+
+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 => 36;
+use Test::More tests => 40;
use Test::Exception;
=pod
NOTE:
Should we be testing here that the has & override
-are injecting their methods correctly? In other
+are injecting their methods correctly? In other
words, should 'has_method' return true for them?
=cut
{
package FooRole;
use Mouse::Role;
-
+
our $VERSION = '0.01';
-
+
has 'bar' => (is => 'rw', isa => 'Foo');
- has 'baz' => (is => 'ro');
-
+ has 'baz' => (is => 'ro');
+
sub foo { 'FooRole::foo' }
- sub boo { 'FooRole::boo' }
-
+ 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" };
-
+
+ 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 { augment() } '... augment() is not supported';
+ ::dies_ok { inner() } '... inner() is not supported';
no Mouse::Role;
}
my $foo_role = FooRole->meta;
isa_ok($foo_role, 'Mouse::Meta::Role');
-SKIP: { skip "Mouse: doesn't use Class::MOP" => 1;
-isa_ok($foo_role, 'Class::MOP::Module');
-}
+#isa_ok($foo_role, 'Class::MOP::Module');
is($foo_role->name, 'FooRole', '... got the right name of FooRole');
-is($foo_role->version, '0.01', '... got the right version of FooRole');
+is($foo_role->version, '0.01', '... got the right version of FooRole');
# methods ...
-TODO: { todo_skip "Mouse: not yet implemented" => 6;
-ok($foo_role->has_method('foo'), '... FooRole has the foo method');
-is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method');
+
+ok($foo_role->has_method('foo'), '... FooRole has the foo method');
+is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method');
isa_ok($foo_role->get_method('foo'), 'Mouse::Meta::Role::Method');
is($foo_role->get_method('boo')->body, \&FooRole::boo, '... FooRole got the boo method');
isa_ok($foo_role->get_method('boo'), 'Mouse::Meta::Role::Method');
-}
is_deeply(
[ sort $foo_role->get_method_list() ],
ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
-is $foo_role->get_attribute('bar')->{is}, 'rw', '... got the correct description of the bar attribute';
+{
+local $TODO = 'definition_context is not yet implemented';
+my $bar_attr = $foo_role->get_attribute('bar');
+is($bar_attr->{is}, 'rw',
+ 'bar attribute is rw');
+is($bar_attr->{isa}, 'Foo',
+ 'bar attribute isa Foo');
+is(ref($bar_attr->{definition_context}), 'HASH',
+ 'bar\'s definition context is a hash');
+is($bar_attr->{definition_context}->{package}, 'FooRole',
+ 'bar was defined in FooRole');
ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
-is(
- $foo_role->get_attribute('baz')->{is},
- 'ro',
- '... got the correct description of the baz attribute');
+my $baz_attr = $foo_role->get_attribute('baz');
+is($baz_attr->{is}, 'ro',
+ 'baz attribute is ro');
+is(ref($baz_attr->{definition_context}), 'HASH',
+ 'bar\'s definition context is a hash');
+is($baz_attr->{definition_context}->{package}, 'FooRole',
+ 'baz was defined in FooRole');
+} # end of TODO (definition_context)
# method modifiers
-TODO: { todo_skip "Mouse: not yet implemented" => 15;
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",
+is(($foo_role->get_before_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:before",
'... got the right method back');
is_deeply(
'... 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",
+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(($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",
+is(($foo_role->get_around_method_modifiers('boo'))[0]->(),
+ "FooRole::boo:around",
'... got the right method back');
is_deeply(
[ '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",
+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",
+is($foo_role->get_override_method_modifier('fling')->(),
+ "FooRole::fling:override",
'... got the right method back');
is_deeply(
[ 'bling', 'fling' ],
'... got the right list of override method modifiers');
-}
use strict;
use warnings;
-use Test::More;
-BEGIN {
- plan skip_all =>
- "This test requires Class::Method::Modifiers or Class::Method::Modifiers::Fast"
- unless eval {
- require Class::Method::Modifiers::Fast;
- } or eval {
- require Class::Method::Modifiers;
- };
-}
-plan tests => 86;
+use Test::More tests => 86;
use Test::Exception;
{
sub foo {'FooRole::foo'}
override 'boo' => sub { 'FooRole::boo -> ' . super() };
-# sub boo { 'FooRole::boo -> ' . shift->SUPER::boo() }
around 'blau' => sub {
my $c = shift;
'... the FooBarClass->meta !does_role OtherRole' );
foreach my $method_name (qw(bar baz foo boo blau goo)) {
-# ok( $foo_class_meta->has_method($method_name), ## Mouse: no ->has_method
- ok( FooClass->can($method_name),
+ #use Data::Dumper; $Data::Dumper::Maxdepth=1; diag(Dumper $foo_class_meta->{methods});
+ ok( $foo_class_meta->has_method($method_name),
'... FooClass has the method ' . $method_name );
-# ok( $foobar_class_meta->has_method($method_name), ## Mouse: no ->has_method
- ok( FooClass->can($method_name),
+ ok( $foobar_class_meta->has_method($method_name),
'... FooBarClass has the method ' . $method_name );
}
-#ok( !$foo_class_meta->has_method('woot'), ## Mouse: no ->has_method
-ok( !FooClass->can('woot'),
+ok( !$foo_class_meta->has_method('woot'),
'... FooClass lacks the method woot' );
-#ok( $foobar_class_meta->has_method('woot'), ## Mouse: no ->has_method
-ok( FooBarClass->can('woot'),
+ok( $foobar_class_meta->has_method('woot'),
'... FooBarClass has the method woot' );
foreach my $attr_name (qw(bar baz)) {
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 74;
+use Test::Exception;
+
+
+
+{
+ # NOTE:
+ # this tests that repeated role
+ # composition will not cause
+ # a conflict between two methods
+ # which are actually the same anyway
+
+ {
+ package RootA;
+ use Mouse::Role;
+
+ sub foo { "RootA::foo" }
+
+ package SubAA;
+ use Mouse::Role;
+
+ with "RootA";
+
+ sub bar { "SubAA::bar" }
+
+ package SubAB;
+ use Mouse;
+
+ ::lives_ok {
+ with "SubAA", "RootA";
+ } '... role was composed as expected';
+ }
+
+ ok( SubAB->does("SubAA"), "does SubAA");
+ ok( SubAB->does("RootA"), "does RootA");
+
+ isa_ok( my $i = SubAB->new, "SubAB" );
+
+ can_ok( $i, "bar" );
+ is( $i->bar, "SubAA::bar", "... got thr right bar rv" );
+
+ can_ok( $i, "foo" );
+ my $foo_rv;
+ lives_ok {
+ $foo_rv = $i->foo;
+ } '... called foo successfully';
+ 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 Mouse::Role;
+
+ sub foo { "RootB::foo" }
+
+ package SubBA;
+ use Mouse::Role;
+
+ with "RootB";
+
+ has counter => (
+ isa => "Num",
+ is => "rw",
+ default => 0,
+ );
+
+ after foo => sub {
+ $_[0]->counter( $_[0]->counter + 1 );
+ };
+
+ package SubBB;
+ use Mouse;
+
+ ::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)" );
+
+ ok(SubBA->meta->has_method('foo'), '... this has the foo method');
+ #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 Mouse::Role;
+
+ sub foo { "RootC::foo" }
+
+ package SubCA;
+ use Mouse::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 Mouse::Role;
+
+ requires "method";
+ requires "other";
+
+ sub another { "abstract" }
+
+ package ConcreteA;
+ use Mouse::Role;
+ with "Abstract";
+
+ sub other { "concrete a" }
+
+ package ConcreteB;
+ use Mouse::Role;
+ with "Abstract";
+
+ sub method { "concrete b" }
+
+ package ConcreteC;
+ use Mouse::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 Mouse;
+
+ eval { with ::shuffle qw/ConcreteA ConcreteB/ };
+ ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
+
+ package SimpleClassWithAll;
+ use Mouse;
+
+ 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 Mouse;
+
+ eval { with ::shuffle qw/ConcreteC ConcreteB/ };
+ ::ok( !$@, "composition without abstract" ) || ::diag $@;
+
+ package ClassWithAll;
+ use Mouse;
+
+ eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
+ ::ok( !$@, "composition with abstract" ) || ::diag $@;
+
+ package ClassWithEverything;
+ use Mouse;
+
+ 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 warnings;
use Test::More;
BEGIN {
- plan skip_all =>
- "This test requires Class::Method::Modifiers or Class::Method::Modifiers::Fast"
- unless eval {
- require Class::Method::Modifiers::Fast;
- } or eval {
- require Class::Method::Modifiers;
- };
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 8;
}
-plan tests => 6;
-
-
# this test script ensures that my idiom of:
# role: sub BUILD, after BUILD
# continues to work to run code after object initialization, whether the class
do {
package ClassWithBUILD;
use Mouse;
- with 'TestRole';
+
+ ::stderr_is {
+ with 'TestRole';
+ } '';
sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' }
};
do {
- package ClassWithoutBUILD;
+ package ExplicitClassWithBUILD;
use Mouse;
- with 'TestRole';
-};
-
-is_deeply([splice @CALLS], [], "no calls to BUILD yet");
-ClassWithBUILD->new;
+ ::stderr_is {
+ with 'TestRole' => { excludes => 'BUILD' };
+ } '';
-is_deeply([splice @CALLS], [
- 'TestRole::BUILD:before',
- 'ClassWithBUILD::BUILD',
- 'TestRole::BUILD:after',
-]);
-
-ClassWithoutBUILD->new;
+ sub BUILD { push @CALLS, 'ExplicitClassWithBUILD::BUILD' }
+};
-is_deeply([splice @CALLS], [
- 'TestRole::BUILD:before',
- 'TestRole::BUILD',
- 'TestRole::BUILD:after',
-]);
+do {
+ package ClassWithoutBUILD;
+ use Mouse;
+ with 'TestRole';
+};
-ClassWithBUILD->meta->make_immutable;
-ClassWithoutBUILD->meta->make_immutable;
+{
+ is_deeply([splice @CALLS], [], "no calls to BUILD yet");
-is_deeply([splice @CALLS], [], "no calls to BUILD yet");
+ ClassWithBUILD->new;
-ClassWithBUILD->new;
+ is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'ClassWithBUILD::BUILD',
+ 'TestRole::BUILD:after',
+ ]);
-is_deeply([splice @CALLS], [
- 'TestRole::BUILD:before',
- 'ClassWithBUILD::BUILD',
- 'TestRole::BUILD:after',
-]);
+ ClassWithoutBUILD->new;
-ClassWithoutBUILD->new;
+ is_deeply([splice @CALLS], [
+ 'TestRole::BUILD:before',
+ 'TestRole::BUILD',
+ 'TestRole::BUILD:after',
+ ]);
-is_deeply([splice @CALLS], [
- 'TestRole::BUILD:before',
- 'TestRole::BUILD',
- 'TestRole::BUILD:after',
-]);
+ if (ClassWithBUILD->meta->is_mutable) {
+ ClassWithBUILD->meta->make_immutable;
+ ClassWithoutBUILD->meta->make_immutable;
+ redo;
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+# test role and class
+package SomeRole;
+use Mouse::Role;
+
+requires 'foo';
+
+package SomeClass;
+use Mouse;
+has 'foo' => (is => 'rw');
+with 'SomeRole';
+
+package main;
+
+#my $c = SomeClass->new;
+#isa_ok( $c, 'SomeClass');
+
+for my $modifier_type (qw[ before around after ]) {
+ my $get_func = "get_${modifier_type}_method_modifiers";
+ my @mms = eval{ SomeRole->meta->$get_func('foo') };
+ is($@, '', "$get_func for no method mods does not die");
+ is(scalar(@mms),0,'is an empty list');
+}
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+{
+ package Foo;
+ use Mouse::Role;
+
+ use overload
+ q{""} => sub { 42 },
+ fallback => 1;
+
+ no Mouse::Role;
+}
+
+{
+ package Bar;
+ use Mouse;
+ with 'Foo';
+ no Mouse;
+}
+
+my $bar = Bar->new;
+
+TODO: {
+ local $TODO = "the special () method isn't properly composed into the class";
+ is("$bar", 42, 'overloading can be composed');
+}
http://research.sun.com/projects/plrg/fortress0903.pdf
-trait OrganicMolecule extends Molecule
- excludes { InorganicMolecule }
-end
-trait InorganicMolecule extends Molecule end
+trait OrganicMolecule extends Molecule
+ excludes { InorganicMolecule }
+end
+trait InorganicMolecule extends Molecule end
=cut
package Molecule::Organic;
use Mouse::Role;
-
+
with 'Molecule';
excludes 'Molecule::Inorganic';
-
+
package Molecule::Inorganic;
- use Mouse::Role;
-
- with 'Molecule';
+ use Mouse::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::Organic->meta->get_excluded_roles_list() ],
[ 'Molecule::Inorganic' ],
'... Molecule::Organic exludes Molecule::Inorganic');
=pod
-Check some basic conflicts when combining
+Check some basic conflicts when combining
the roles into the same class
=cut
{
package My::Test1;
use Mouse;
-
+
::lives_ok {
with 'Molecule::Organic';
} '... adding the role (w/ excluded roles) okay';
package My::Test2;
use Mouse;
-
+
::throws_ok {
with 'Molecule::Organic', 'Molecule::Inorganic';
- } qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/,
- '... adding the role w/ excluded role conflict dies okay';
-
+ } qr/Conflict detected: Role Molecule::Organic excludes role 'Molecule::Inorganic'/,
+ '... adding the role w/ excluded role conflict dies okay';
+
package My::Test3;
use Mouse;
-
+
::lives_ok {
with 'Molecule::Organic';
- } '... adding the role (w/ excluded roles) okay';
-
+ } '... 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';
+ } 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');
=pod
-Check some basic conflicts when combining
+Check some basic conflicts when combining
the roles into the a superclass
=cut
{
package Methane;
use Mouse;
-
+
with 'Molecule::Organic';
-
+
package My::Test4;
use Mouse;
-
- extends 'Methane';
-
+
+ extends 'Methane';
+
::throws_ok {
- with 'Molecule::Inorganic';
+ with 'Molecule::Inorganic';
} qr/Conflict detected: My::Test4 excludes role \'Molecule::Inorganic\'/,
'... cannot add exculded role into class which extends Methane';
}
=pod
NOTE:
-A fair amount of these tests will likely be irrelevant
+A fair amount of these tests will likely be irrelevant
once we have more fine grained control over the class
building process. A lot of the edge cases tested here
-are actually related to class construction order and
+are actually related to class construction order and
not any real functionality.
- SL
-Role which requires a method implemented
-in another role as an override (it does
+Role which requires a method implemented
+in another role as an override (it does
not remove the requirement)
=cut
use strict;
use warnings;
use Mouse::Role;
-
+
requires 'foo';
-
+
package Role::ProvideFoo;
use strict;
use warnings;
use Mouse::Role;
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will not exist yet (but we will live)';
-
- override 'foo' => sub { 'Role::ProvideFoo::foo' };
+
+ override 'foo' => sub { 'Role::ProvideFoo::foo' };
}
is_deeply(
- [ Role::ProvideFoo->meta->get_required_method_list ],
- [ 'foo' ],
+ [ 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
+Role which requires a method implemented
+in the consuming class as an override.
+It will fail since method modifiers are
second class citizens.
=cut
use Mouse;
sub foo { 'Class::ProvideFoo::Base::foo' }
-
+
package Class::ProvideFoo::Override1;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will be found in the superclass';
-
- override 'foo' => sub { 'Class::ProvideFoo::foo' };
-
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
package Class::ProvideFoo::Override2;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
- override 'foo' => sub { 'Class::ProvideFoo::foo' };
-
+
+ override 'foo' => sub { 'Class::ProvideFoo::foo' };
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method exists, although it is overriden locally';
=pod
-Now same thing, but with a before
+Now same thing, but with a before
method modifier.
=cut
{
package Class::ProvideFoo::Before1;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will be found in the superclass';
-
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
-
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
package Class::ProvideFoo::Before2;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
-
+
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
::lives_ok {
with 'Role::RequireFoo';
- } '... the required "foo" method exists, although it is a before modifier locally';
-
+ } '... the required "foo" method exists, although it is a before modifier locally';
+
package Class::ProvideFoo::Before3;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
+
sub foo { 'Class::ProvideFoo::foo' }
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
-
+ before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
::lives_ok {
with 'Role::RequireFoo';
- } '... the required "foo" method exists locally, and it is modified locally';
-
+ } '... the required "foo" method exists locally, and it is modified locally';
+
package Class::ProvideFoo::Before4;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
- sub foo { 'Class::ProvideFoo::foo' }
- before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
+
+ 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__,
+ ::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)';
-
-}
+ } '... the required "foo" method exists in the symbol table (and we will live)';
+
+}
=pod
=cut
{
-
+
package Class::ProvideFoo::Attr1;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method will be found in the superclass (but then overriden)';
-
+
has 'foo' => (is => 'ro');
-
+
package Class::ProvideFoo::Attr2;
use Mouse;
-
+
extends 'Class::ProvideFoo::Base';
-
- has 'foo' => (is => 'ro');
-
+
+ has 'foo' => (is => 'ro');
+
::lives_ok {
with 'Role::RequireFoo';
} '... the required "foo" method exists, and is an accessor';
-}
+}
# ...
-# a method required in a role, but then
-# implemented in the superclass (as an
+# a method required in a role, but then
+# implemented in the superclass (as an
# attribute accessor too)
-
+
{
package Foo::Class::Base;
use Mouse;
-
- has 'bar' => (
- isa => 'Int',
- is => 'rw',
+
+ has 'bar' => (
+ isa => 'Int',
+ is => 'rw',
default => sub { 1 }
);
}
{
package Foo::Role;
use Mouse::Role;
-
+
requires 'bar';
-
- has 'foo' => (
- isa => 'Int',
- is => 'rw',
- lazy => 1,
- default => sub { (shift)->bar + 1 }
+
+ has 'foo' => (
+ isa => 'Int',
+ is => 'rw',
+ lazy => 1,
+ default => sub { (shift)->bar + 1 }
);
}
{
package Foo::Class::Child;
use Mouse;
extends 'Foo::Class::Base';
-
+
::lives_ok {
with 'Foo::Role';
} '... our role combined successfully';
=pod
-Check for repeated inheritance causing
-a method conflict (which is not really
+Check for repeated inheritance causing
+a method conflict (which is not really
a conflict)
=cut
{
package Role::Base;
use Mouse::Role;
-
+
sub foo { 'Role::Base::foo' }
-
+
package Role::Derived1;
- use Mouse::Role;
-
+ use Mouse::Role;
+
with 'Role::Base';
-
+
package Role::Derived2;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::Base';
-
+
package My::Test::Class1;
- use Mouse;
-
+ use Mouse;
+
::lives_ok {
- with 'Role::Derived1', 'Role::Derived2';
+ with 'Role::Derived1', 'Role::Derived2';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance causing
-a method conflict with method modifiers
+Check for repeated inheritance causing
+a method conflict with method modifiers
(which is not really a conflict)
=cut
{
package Role::Base2;
use Mouse::Role;
-
+
override 'foo' => sub { super() . ' -> Role::Base::foo' };
-
+
package Role::Derived3;
- use Mouse::Role;
-
+ use Mouse::Role;
+
with 'Role::Base2';
-
+
package Role::Derived4;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::Base2';
package My::Test::Class2::Base;
use Mouse;
-
+
sub foo { 'My::Test::Class2::Base' }
-
+
package My::Test::Class2;
- use Mouse;
-
- extends 'My::Test::Class2::Base';
-
+ use Mouse;
+
+ extends 'My::Test::Class2::Base';
+
::lives_ok {
- with 'Role::Derived3', 'Role::Derived4';
+ with 'Role::Derived3', 'Role::Derived4';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance of the
-same code. There are no conflicts with
+Check for repeated inheritance of the
+same code. There are no conflicts with
before/around/after method modifiers.
-This tests around, but should work the
+This tests around, but should work the
same for before/afters as well
=cut
{
package Role::Base3;
use Mouse::Role;
-
+
around 'foo' => sub { 'Role::Base::foo(' . (shift)->() . ')' };
-
+
package Role::Derived5;
- use Mouse::Role;
-
+ use Mouse::Role;
+
with 'Role::Base3';
-
+
package Role::Derived6;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::Base3';
package My::Test::Class3::Base;
use Mouse;
-
+
sub foo { 'My::Test::Class3::Base' }
-
+
package My::Test::Class3;
- use Mouse;
-
- extends 'My::Test::Class3::Base';
-
+ use Mouse;
+
+ extends 'My::Test::Class3::Base';
+
::lives_ok {
- with 'Role::Derived5', 'Role::Derived6';
+ with 'Role::Derived5', 'Role::Derived6';
} '... roles composed okay (no conflicts)';
}
=pod
-Check for repeated inheritance causing
-a attr conflict (which is not really
+Check for repeated inheritance causing
+a attr conflict (which is not really
a conflict)
=cut
{
package Role::Base4;
use Mouse::Role;
-
+
has 'foo' => (is => 'ro', default => 'Role::Base::foo');
-
+
package Role::Derived7;
- use Mouse::Role;
-
+ use Mouse::Role;
+
with 'Role::Base4';
-
+
package Role::Derived8;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::Base4';
-
+
package My::Test::Class4;
- use Mouse;
-
+ use Mouse;
+
::lives_ok {
- with 'Role::Derived7', 'Role::Derived8';
+ with 'Role::Derived7', 'Role::Derived8';
} '... roles composed okay (no conflicts)';
}
=pod
This test can be used as a basis for the runtime role composition.
-Apparently it is not as simple as just making an anon class. One of
+Apparently it is not as simple as just making an anon class. One of
the problems is the way that anon classes are DESTROY-ed, which is
not very compatible with how instances are dealt with.
}
my $obj = My::Class->new;
-isa_ok($obj, 'My::Class');
-
+isa_ok($obj, 'My::Class');
+
my $obj2 = My::Class->new;
-isa_ok($obj2, 'My::Class');
+isa_ok($obj2, 'My::Class');
{
ok(!$obj->can( 'talk' ), "... the role is not composed yet");
-
+
ok(!$obj->does('Bark'), '... we do not do any roles yet');
-
+
Bark->meta->apply($obj);
ok($obj->does('Bark'), '... we now do the Bark role');
- ok(!My::Class->does('Bark'), '... the class does not do the Bark role');
+ ok(!My::Class->does('Bark'), '... the class does not do the Bark role');
isa_ok($obj, 'My::Class');
isnt(blessed($obj), 'My::Class', '... but it is no longer blessed into My::Class');
ok(!My::Class->can('talk'), "... the role is not composed at the class level");
ok($obj->can('talk'), "... the role is now composed at the object level");
-
+
is($obj->talk, 'woof', '... got the right return value for the newly composed method');
}
{
ok(!$obj2->does('Bark'), '... we do not do any roles yet');
-
+
Bark->meta->apply($obj2);
-
+
ok($obj2->does('Bark'), '... we now do the Bark role');
is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing');
}
Sleeper->meta->apply($obj);
ok($obj->does('Bark'), '... we still do the Bark role');
- ok($obj->does('Sleeper'), '... we now do the Sleeper role too');
-
- ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');
-
- isnt(blessed($obj), blessed($obj2), '... they no longer share the same anon-class/role thing');
-
+ ok($obj->does('Sleeper'), '... we now do the Sleeper role too');
+
+ ok(!My::Class->does('Sleeper'), '... the class does not do the Sleeper role');
+
+ isnt(blessed($obj), blessed($obj2), '... they no longer share the same anon-class/role thing');
+
isa_ok($obj, 'My::Class');
is(My::Class->sleep, 'nite-nite', '... the original method still responds as expected');
is($obj->sleep, 'snore', '... got the right return value for the newly composed method');
- is($obj->talk, 'zzz', '... got the right return value for the newly composed method');
+ is($obj->talk, 'zzz', '... got the right return value for the newly composed method');
}
{
ok(!$obj2->does('Sleeper'), '... we do not do any roles yet');
-
+
Sleeper->meta->apply($obj2);
-
+
ok($obj2->does('Sleeper'), '... we now do the Bark role');
is(blessed($obj), blessed($obj2), '... they share the same anon-class/role thing again');
}
package My::Class;
use Mouse;
- with 'My::Role' => { excludes => 'bar' };
+ with 'My::Role' => { -excludes => 'bar' };
}
ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz);
package My::OtherRole;
use Mouse::Role;
- with 'My::Role' => { excludes => 'foo' };
+ with 'My::Role' => { -excludes => 'foo' };
sub foo { 'My::OtherRole::foo' }
sub bar { 'My::OtherRole::bar' }
use Mouse;
::lives_ok {
- with 'Foo::Role' => { excludes => 'foo' },
- 'Bar::Role' => { excludes => 'foo' },
+ with 'Foo::Role' => { -excludes => 'foo' },
+ 'Bar::Role' => { -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
::throws_ok {
with 'Foo::Role',
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { -excludes => 'foo' },
'Baz::Role';
} qr/Due to a method name conflict in roles 'Baz::Role' and 'Foo::Role', the method 'foo' must be implemented or excluded by 'My::Foo::Class::Broken'/,
'... composed our roles correctly';
use Mouse::Role;
::lives_ok {
- with 'Foo::Role' => { excludes => 'foo' },
- 'Bar::Role' => { excludes => 'foo' },
+ with 'Foo::Role' => { -excludes => 'foo' },
+ 'Bar::Role' => { -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
::lives_ok {
with 'Foo::Role',
- 'Bar::Role' => { excludes => 'foo' },
+ 'Bar::Role' => { -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
use strict;
use warnings;
-use Test::More tests => 35;
+use Test::More tests => 46;
use Test::Exception;
use Mouse;
::lives_ok {
- with 'My::Role' => { alias => { bar => 'role_bar' } };
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
} '... this succeeds';
package My::Class::Failure;
use Mouse;
::throws_ok {
- with 'My::Role' => { alias => { bar => 'role_bar' } };
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
} qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
sub role_bar { 'FAIL' }
use Mouse::Role;
::lives_ok {
- with 'My::Role' => { alias => { bar => 'role_bar' } };
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
} '... this succeeds';
sub bar { 'My::OtherRole::bar' }
use Mouse::Role;
::throws_ok {
- with 'My::Role' => { alias => { bar => 'role_bar' } };
- } qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists';
sub role_bar { 'FAIL' }
}
ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
-ok(!My::OtherRole->meta->requires_method('bar'), '... and the &bar method is not required');
+ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required');
{
use Mouse::Role;
::lives_ok {
- with 'My::Role' => { alias => { bar => 'role_bar' } };
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
} '... this succeeds';
}
ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
-ok(My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is required');
+ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required');
{
package Foo::Role;
use Mouse;
::lives_ok {
- with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
use Mouse;
::throws_ok {
- with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
'Baz::Role';
} qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/,
'... composed our roles correctly';
use Mouse::Role;
::lives_ok {
- with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'bar_foo' }, excludes => 'foo' },
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
use Mouse::Role;
::lives_ok {
- with 'Foo::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
- 'Bar::Role' => { alias => { 'foo' => 'foo_foo' }, excludes => 'foo' },
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
'Baz::Role';
} '... composed our roles correctly';
}
ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method");
ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required');
+{
+ package My::Foo::AliasOnly;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } },
+ } '... composed our roles correctly';
+}
+
+ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method');
+ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method');
+
+{
+ package Role::Foo;
+ use Mouse::Role;
+
+ sub x1 {}
+ sub y1 {}
+}
+
+{
+ package Role::Bar;
+ use Mouse::Role;
+
+ use Test::Exception;
+
+ lives_ok {
+ with 'Role::Foo' => {
+ -alias => { x1 => 'foo_x1' },
+ -excludes => ['y1'],
+ };
+ }
+ 'Compose Role::Foo into Role::Bar with alias and exclude';
+
+ sub x1 {}
+ sub y1 {}
+}
+
+{
+ my $bar = Role::Bar->meta;
+ ok( $bar->has_method($_), "has $_ method" )
+ for qw( x1 y1 foo_x1 );
+}
+
+{
+ package Role::Baz;
+ use Mouse::Role;
+
+ use Test::Exception;
+
+ lives_ok {
+ with 'Role::Foo' => {
+ -alias => { x1 => 'foo_x1' },
+ -excludes => ['y1'],
+ };
+ }
+ 'Compose Role::Foo into Role::Baz with alias and exclude';
+}
+
+{
+ my $baz = Role::Baz->meta;
+ ok( $baz->has_method($_), "has $_ method" )
+ for qw( x1 foo_x1 );
+ ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' );
+}
{
package Foo;
use Mouse::Role;
-
+
sub foo { 'Foo::foo' }
sub bar { 'Foo::bar' }
sub baz { 'Foo::baz' }
- sub gorch { 'Foo::gorch' }
-
+ sub gorch { 'Foo::gorch' }
+
package Bar;
use Mouse::Role;
sub foo { 'Bar::foo' }
sub bar { 'Bar::bar' }
sub baz { 'Bar::baz' }
- sub gorch { 'Bar::gorch' }
+ sub gorch { 'Bar::gorch' }
package Baz;
use Mouse::Role;
-
+
sub foo { 'Baz::foo' }
sub bar { 'Baz::bar' }
sub baz { 'Baz::baz' }
- sub gorch { 'Baz::gorch' }
-
+ sub gorch { 'Baz::gorch' }
+
package Gorch;
use Mouse::Role;
-
+
sub foo { 'Gorch::foo' }
sub bar { 'Gorch::bar' }
sub baz { 'Gorch::baz' }
- sub gorch { 'Gorch::gorch' }
+ sub gorch { 'Gorch::gorch' }
}
{
package My::Class;
use Mouse;
-
+
::lives_ok {
- with 'Foo' => { excludes => [qw/bar baz gorch/], alias => { gorch => 'foo_gorch' } },
- 'Bar' => { excludes => [qw/foo baz gorch/] },
- 'Baz' => { excludes => [qw/foo bar gorch/], alias => { foo => 'baz_foo', bar => 'baz_bar' } },
- 'Gorch' => { excludes => [qw/foo bar baz/] };
+ with 'Foo' => { -excludes => [qw/bar baz gorch/], -alias => { gorch => 'foo_gorch' } },
+ 'Bar' => { -excludes => [qw/foo baz gorch/] },
+ 'Baz' => { -excludes => [qw/foo bar gorch/], -alias => { foo => 'baz_foo', bar => 'baz_bar' } },
+ 'Gorch' => { -excludes => [qw/foo bar baz/] };
} '... everything works out all right';
}
}
my $obj = Foo->new;
-isa_ok($obj, 'Foo');
+isa_ok($obj, 'Foo');
ok(!$obj->can( 'talk' ), "... the role is not composed yet");
ok(!$obj->can( 'fur' ), 'ditto');
}
my $bar = Bar->new;
-isa_ok($bar, 'Bar');
+isa_ok($bar, 'Bar');
my $foo = Foo->new;
-isa_ok($foo, 'Foo');
+isa_ok($foo, 'Foo');
ok(!$bar->can( 'talk' ), "... the role is not composed yet");
=pod
-This basically just makes sure that using +name
+This basically just makes sure that using +name
on role attributes works right.
=cut
{
package Foo::Role;
use Mouse::Role;
-
+
has 'bar' => (
is => 'rw',
- isa => 'Int',
+ isa => 'Int',
default => sub { 10 },
);
-
+
package Foo;
use Mouse;
-
+
with 'Foo::Role';
-
+
::lives_ok {
has '+bar' => (default => sub { 100 });
- } '... extended the attribute successfully';
+ } '... extended the attribute successfully';
}
my $foo = Foo->new;
for (1..3) {
has "err$_" => (
isa => 'Str | Int',
+ is => 'bare',
);
}
package Foo;
use Mouse;
has 'bar' => (is => 'ro');
-
+
package Bar;
use Mouse::Role;
-
- has 'baz' => (is => 'ro', default => 'BAZ');
+
+ has 'baz' => (is => 'ro', default => 'BAZ');
}
# normal ...
{
package Role::Foo;
use Mouse::Role;
-
+
package Role::Bar;
use Mouse::Role;
package Role::Baz;
- use Mouse::Role;
-
+ use Mouse::Role;
+
package Role::Gorch;
- use Mouse::Role;
+ use Mouse::Role;
}
{
roles => [
Role::Foo->meta,
Role::Bar->meta,
- Role::Baz->meta,
+ Role::Baz->meta,
]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
is_deeply($c->get_roles, [
Role::Foo->meta,
Role::Bar->meta,
- Role::Baz->meta,
+ Role::Baz->meta,
], '... got the right roles');
-
+
ok($c->does_role($_), '... our composite does the role ' . $_)
for qw(
Role::Foo
Role::Bar
- Role::Baz
+ Role::Baz
);
-
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this composed okay';
-
+ } '... this composed okay';
+
##... now nest 'em
- {
+ {
my $c2 = Mouse::Meta::Role::Composite->new(
roles => [
$c,
is_deeply($c2->get_roles, [
$c,
- Role::Gorch->meta,
+ Role::Gorch->meta,
], '... got the right roles');
ok($c2->does_role($_), '... our composite does the role ' . $_)
for qw(
Role::Foo
Role::Bar
- Role::Baz
- Role::Gorch
- );
+ Role::Baz
+ Role::Gorch
+ );
}
}
{
package Role::Foo;
use Mouse::Role;
-
+
package Role::Bar;
use Mouse::Role;
-
+
package Role::ExcludesFoo;
use Mouse::Role;
excludes 'Role::Foo';
-
+
package Role::DoesExcludesFoo;
use Mouse::Role;
- with 'Role::ExcludesFoo';
-
+ with 'Role::ExcludesFoo';
+
package Role::DoesFoo;
use Mouse::Role;
- with 'Role::Foo';
+ with 'Role::Foo';
}
ok(Role::ExcludesFoo->meta->excludes_role('Role::Foo'), '... got the right exclusions');
isa_ok($c, 'Mouse::Meta::Role::Composite');
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives as expected';
+ } '... this lives as expected';
}
# test no conflicts w/exclusion
my $c = Mouse::Meta::Role::Composite->new(
roles => [
Role::Bar->meta,
- Role::ExcludesFoo->meta,
+ Role::ExcludesFoo->meta,
]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name');
-
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives as expected';
-
- is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
+ } '... this lives as expected';
+
+ is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
}
]
)
);
-
+
} '... this fails as expected';
# test conflict with an "inherited" exclusion of an "inherited" role
dies_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply(
- Mouse::Meta::Role::Composite->new(
+ Mouse::Meta::Role::Composite->new(
roles => [
- Role::DoesFoo->meta,
+ Role::DoesFoo->meta,
Role::DoesExcludesFoo->meta,
]
)
{
package Role::Foo;
- use Mouse::Role;
+ use Mouse::Role;
requires 'foo';
-
+
package Role::Bar;
use Mouse::Role;
requires 'bar';
-
+
package Role::ProvidesFoo;
- use Mouse::Role;
+ use Mouse::Role;
sub foo { 'Role::ProvidesFoo::foo' }
-
+
package Role::ProvidesBar;
- use Mouse::Role;
- sub bar { 'Role::ProvidesBar::bar' }
+ use Mouse::Role;
+ sub bar { 'Role::ProvidesBar::bar' }
}
# test simple requirement
roles => [
Role::Foo->meta,
Role::Bar->meta,
- ]
+ ]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'bar', 'foo' ],
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
-
- lives_ok {
+ is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
+
+ lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[],
roles => [
Role::Foo->meta,
Role::ProvidesFoo->meta,
- Role::Bar->meta,
+ Role::Bar->meta,
]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'bar' ],
roles => [
Role::Foo->meta,
Role::ProvidesFoo->meta,
- Role::ProvidesBar->meta,
- Role::Bar->meta,
+ Role::ProvidesBar->meta,
+ Role::Bar->meta,
]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_required_method_list ],
[ ],
{
package Role::Foo;
- use Mouse::Role;
+ use Mouse::Role;
has 'foo' => (is => 'rw');
-
+
package Role::Bar;
use Mouse::Role;
has 'bar' => (is => 'rw');
-
+
package Role::FooConflict;
- use Mouse::Role;
+ use Mouse::Role;
has 'foo' => (is => 'rw');
-
+
package Role::BarConflict;
use Mouse::Role;
has 'bar' => (is => 'rw');
-
+
package Role::AnotherFooConflict;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::FooConflict';
}
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_attribute_list ],
[ 'bar', 'foo' ],
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
+ Role::Bar->meta,
Role::FooConflict->meta,
- Role::BarConflict->meta,
+ Role::BarConflict->meta,
]
)
);
{
package Role::Foo;
use Mouse::Role;
-
- sub foo { 'Role::Foo::foo' }
-
+
+ sub foo { 'Role::Foo::foo' }
+
package Role::Bar;
use Mouse::Role;
sub bar { 'Role::Bar::bar' }
-
+
package Role::FooConflict;
- use Mouse::Role;
-
- sub foo { 'Role::FooConflict::foo' }
-
+ use Mouse::Role;
+
+ sub foo { 'Role::FooConflict::foo' }
+
package Role::BarConflict;
use Mouse::Role;
-
+
sub bar { 'Role::BarConflict::bar' }
-
+
package Role::AnotherFooConflict;
- use Mouse::Role;
+ use Mouse::Role;
with 'Role::FooConflict';
sub baz { 'Role::AnotherFooConflict::baz' }
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_method_list ],
[ 'bar', 'foo' ],
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_method_list ],
[],
'... got the right list of methods'
- );
-
+ );
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'foo' ],
'... got the right list of required methods'
- );
+ );
}
# test complex conflict
my $c = Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
+ Role::Bar->meta,
Role::FooConflict->meta,
- Role::BarConflict->meta,
+ Role::BarConflict->meta,
]
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name');
+ is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name');
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
[ sort $c->get_method_list ],
[],
'... got the right list of methods'
- );
-
+ );
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'bar', 'foo' ],
'... got the right list of required methods'
- );
+ );
}
# test simple conflict
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
-
+ } '... this succeeds as expected';
+
is_deeply(
[ sort $c->get_method_list ],
[ 'baz' ],
'... got the right list of methods'
- );
-
+ );
+
is_deeply(
[ sort $c->get_required_method_list ],
[ 'foo' ],
'... got the right list of required methods'
- );
+ );
}
{
package Role::Foo;
use Mouse::Role;
-
+
override foo => sub { 'Role::Foo::foo' };
-
+
package Role::Bar;
use Mouse::Role;
override bar => sub { 'Role::Bar::bar' };
-
+
package Role::FooConflict;
- use Mouse::Role;
-
+ use Mouse::Role;
+
override foo => sub { 'Role::FooConflict::foo' };
-
+
package Role::FooMethodConflict;
- use Mouse::Role;
-
- sub foo { 'Role::FooConflict::foo' }
-
+ use Mouse::Role;
+
+ sub foo { 'Role::FooConflict::foo' }
+
package Role::BarMethodConflict;
use Mouse::Role;
-
+
sub bar { 'Role::BarConflict::bar' }
}
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
-
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this lives ok';
-
+ } '... this lives ok';
+
is_deeply(
[ sort $c->get_method_modifier_list('override') ],
[ 'bar', 'foo' ],
# test simple overrides w/ conflicts
dies_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply(
- Mouse::Meta::Role::Composite->new(
+ Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
Role::FooMethodConflict->meta,
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
- Role::FooConflict->meta,
+ Role::Bar->meta,
+ Role::FooConflict->meta,
]
)
);
# test simple overrides w/ conflicts
dies_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply(
- Mouse::Meta::Role::Composite->new(
+ Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
- Role::Bar->meta,
- Role::FooMethodConflict->meta,
+ Role::Bar->meta,
+ Role::FooMethodConflict->meta,
]
)
);
use Mouse::Role;
before foo => sub { 'Role::Foo::foo' };
- around foo => sub { 'Role::Foo::foo' };
- after foo => sub { 'Role::Foo::foo' };
+ around foo => sub { 'Role::Foo::foo' };
+ after foo => sub { 'Role::Foo::foo' };
around baz => sub { [ 'Role::Foo', @{shift->(@_)} ] };
package Role::Bar;
use Mouse::Role;
before bar => sub { 'Role::Bar::bar' };
- around bar => sub { 'Role::Bar::bar' };
- after bar => sub { 'Role::Bar::bar' };
+ around bar => sub { 'Role::Bar::bar' };
+ after bar => sub { 'Role::Bar::bar' };
package Role::Baz;
use Mouse::Role;
);
isa_ok($c, 'Mouse::Meta::Role::Composite');
- is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
+ is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
- } '... this succeeds as expected';
+ } '... this succeeds as expected';
is_deeply(
[ sort $c->get_method_modifier_list('before') ],
[ sort $c->get_method_modifier_list('after') ],
[ 'bar', 'foo' ],
'... got the right list of methods'
- );
+ );
is_deeply(
[ sort $c->get_method_modifier_list('around') ],
[ 'bar', 'baz', 'foo' ],
'... got the right list of methods'
- );
+ );
}
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More tests => 17;
{
package Role::Foo;
use Mouse::Role;
- sub foo { }
+ sub foo { (caller(0))[3] }
}
{
is( $meth->original_fully_qualified_name, 'Role::Foo::foo',
'original fq name is Role::Foo::foo' );
}
+
+isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo");
+
+{
+ local $TODO =
+ "multiply-consumed roles' subs take on their most recently used name";
+ is( ClassB->foo, 'ClassB::foo', 'ClassB::foo knows its name' );
+ is( ClassA->foo, 'ClassA::foo', 'ClassA::foo knows its name' );
+}
{
package My::Role;
use Mouse::Role;
-
+
sub foo { "FOO" }
- sub bar { "BAR" }
+ sub bar { "BAR" }
}
{
package My::Class;
use Mouse;
-
+
with 'My::Role' => {
- alias => { foo => 'baz', bar => 'gorch' },
- excludes => ['foo', 'bar'],
+ -alias => { foo => 'baz', bar => 'gorch' },
+ -excludes => ['foo', 'bar'],
};
}
{
package My::Role::Again;
use Mouse::Role;
-
+
with 'My::Role' => {
- alias => { foo => 'baz', bar => 'gorch' },
- excludes => ['foo', 'bar'],
+ -alias => { foo => 'baz', bar => 'gorch' },
+ -excludes => ['foo', 'bar'],
};
-
+
package My::Class::Again;
use Mouse;
-
+
with 'My::Role::Again';
}
ok($role->is_anon_role, "the role knows it's anonymous");
ok(Class::MOP::is_class_loaded(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded");
-ok(Class::MOP::load_class(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes load_class");
+ok(Class::MOP::class_of(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of");
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+do {
+ package My::Meta::Role;
+ use Mouse;
+ BEGIN { extends 'Mouse::Meta::Role' };
+};
+
+do {
+ package My::Role;
+ use Mouse::Role -metaclass => 'My::Meta::Role';
+};
+
+is(My::Role->meta->meta->name, 'My::Meta::Role');
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 24;
+
+do {
+ package Role::Foo;
+ use Mouse::Role;
+
+ sub foo { }
+
+
+ package Consumer::Basic;
+ use Mouse;
+
+ with 'Role::Foo';
+
+ package Consumer::Excludes;
+ use Mouse;
+
+ with 'Role::Foo' => { -excludes => 'foo' };
+
+ package Consumer::Aliases;
+ use Mouse;
+
+ with 'Role::Foo' => { -alias => { 'foo' => 'role_foo' } };
+
+ package Consumer::Overrides;
+ use Mouse;
+
+ with 'Role::Foo';
+
+ sub foo { }
+};
+
+my @basic = Consumer::Basic->meta->role_applications;
+my @excludes = Consumer::Excludes->meta->role_applications;
+my @aliases = Consumer::Aliases->meta->role_applications;
+my @overrides = Consumer::Overrides->meta->role_applications;
+
+is(@basic, 1);
+is(@excludes, 1);
+is(@aliases, 1);
+is(@overrides, 1);
+
+my $basic = $basic[0];
+my $excludes = $excludes[0];
+my $aliases = $aliases[0];
+my $overrides = $overrides[0];
+
+isa_ok($basic, 'Mouse::Meta::Role::Application::ToClass');
+isa_ok($excludes, 'Mouse::Meta::Role::Application::ToClass');
+isa_ok($aliases, 'Mouse::Meta::Role::Application::ToClass');
+isa_ok($overrides, 'Mouse::Meta::Role::Application::ToClass');
+
+is($basic->role, Role::Foo->meta);
+is($excludes->role, Role::Foo->meta);
+is($aliases->role, Role::Foo->meta);
+is($overrides->role, Role::Foo->meta);
+
+is($basic->class, Consumer::Basic->meta);
+is($excludes->class, Consumer::Excludes->meta);
+is($aliases->class, Consumer::Aliases->meta);
+is($overrides->class, Consumer::Overrides->meta);
+
+is_deeply($basic->get_method_aliases, {});
+is_deeply($excludes->get_method_aliases, {});
+is_deeply($aliases->get_method_aliases, { foo => 'role_foo' });
+is_deeply($overrides->get_method_aliases, {});
+
+is_deeply($basic->get_method_exclusions, []);
+is_deeply($excludes->get_method_exclusions, ['foo']);
+is_deeply($aliases->get_method_exclusions, []);
+is_deeply($overrides->get_method_exclusions, []);
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+my $OPTS;
+do {
+ package My::Singleton::Role;
+ use Mouse::Role;
+
+ sub foo { 'My::Singleton::Role' }
+
+ package My::Role::Metaclass;
+ use Mouse;
+ BEGIN { extends 'Mouse::Meta::Role' };
+
+ sub _role_for_combination {
+ my ($self, $opts) = @_;
+ $OPTS = $opts;
+ return My::Singleton::Role->meta;
+ }
+
+ package My::Special::Role;
+ use Mouse::Role -metaclass => 'My::Role::Metaclass';
+
+ sub foo { 'My::Special::Role' }
+
+ package My::Usual::Role;
+ use Mouse::Role;
+
+ sub bar { 'My::Usual::Role' }
+
+ package My::Class;
+ use Mouse;
+
+ with (
+ 'My::Special::Role' => { number => 1 },
+ 'My::Usual::Role' => { number => 2 },
+ );
+};
+
+is(My::Class->foo, 'My::Singleton::Role', 'role_for_combination applied');
+is(My::Class->bar, 'My::Usual::Role', 'collateral role');
+is_deeply($OPTS, { number => 1 });
+
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+{
+ package Bomb;
+ use Mouse::Role;
+
+ sub fuse { }
+ sub explode { }
+
+ package Spouse;
+ use Mouse::Role;
+
+ sub fuse { }
+ sub explode { }
+
+ package Caninish;
+ use Mouse::Role;
+
+ sub bark { }
+
+ package Treeve;
+ use Mouse::Role;
+
+ sub bark { }
+}
+
+package PracticalJoke;
+use Mouse;
+
+::throws_ok {
+ with 'Bomb', 'Spouse';
+} qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/;
+
+::throws_ok {
+ with (
+ 'Bomb', 'Spouse',
+ 'Caninish', 'Treeve',
+ );
+} qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/;
+
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 6;
{
package Animal;
package Cat;
use Mouse::Role;
with 'Animal', {
- alias => { eat => 'drink' },
+ -alias => { eat => 'drink' },
+ -excludes => [qw(eat)],
};
sub eat { 'good!' }
}
package Dog;
use Mouse;
with 'Animal', {
- alias => { eat => 'drink' }
+ -alias => { eat => 'drink' },
};
}
my $d = Dog->new();
is($d->drink(), 'delicious');
+is($d->eat(), 'delicious');
my $t = Tama->new;
is $t->drink(), 'delicious';
projects / gitmo/Mouse.git / commitdiff