package Mouse::Meta::Role::Composite;
-use Mouse::Util qw(english_list); # enables strict and warnings
+use Mouse::Util; # enables strict and warnings
use Mouse::Meta::Role;
+use Mouse::Meta::Role::Application;
our @ISA = qw(Mouse::Meta::Role);
-sub get_method_list{
+# FIXME: Mouse::Meta::Role::Composite does things in different way from Moose's
+# Moose: creates a new class for the consumer, and applies roles to it.
+# Mouse: creates a coposite role and apply roles to the role,
+# and then applies it to the consumer.
+
+sub new {
+ my $class = shift;
+ my $args = $class->Mouse::Object::BUILDARGS(@_);
+ my $roles = delete $args->{roles};
+ my $self = $class->create_anon_role(%{$args});
+ foreach my $role_spec(@{$roles}) {
+ my($role, $args) = ref($role_spec) eq 'ARRAY'
+ ? @{$role_spec}
+ : ($role_spec, {});
+ $role->apply($self, %{$args});
+ }
+ return $self;
+}
+
+sub get_method_list {
my($self) = @_;
return keys %{ $self->{methods} };
}
return;
}
- if($method_name ne 'meta'){
+ if($method_name eq 'meta'){
+ $self->SUPER::add_method($method_name => $code);
+ }
+ else{
+ # no need to add a subroutine to the stash
my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
push @{$roles}, $role;
if(@{$roles} > 1){
$self->{conflicting_methods}{$method_name}++;
}
+ $self->{methods}{$method_name} = $code;
}
-
- $self->{methods}{$method_name} = $code;
- # no need to add a subroutine to the stash
return;
}
sub has_method {
# my($self, $method_name) = @_;
- return 0; # to fool _apply_methods() in combine()
+ return 0; # to fool apply_methods() in combine()
}
-sub has_attribute{
+sub has_attribute {
# my($self, $method_name) = @_;
- return 0; # to fool _appply_attributes() in combine()
+ return 0; # to fool appply_attributes() in combine()
}
-sub has_override_method_modifier{
+sub has_override_method_modifier {
# my($self, $method_name) = @_;
- return 0; # to fool _apply_modifiers() in combine()
+ return 0; # to fool apply_modifiers() in combine()
}
-sub add_attribute{
- my($self, $attr_name, $spec) = @_;
+sub add_attribute {
+ my $self = shift;
+ my $attr_name = shift;
+ my $spec = (@_ == 1 ? $_[0] : {@_});
my $existing = $self->{attributes}{$attr_name};
if($existing && $existing != $spec){
return;
}
-sub add_override_method_modifier{
+sub add_override_method_modifier {
my($self, $method_name, $code) = @_;
my $existing = $self->{override_method_modifiers}{$method_name};
return;
}
-# components of apply()
+sub apply {
+ my $self = shift;
+ my $consumer = shift;
+
+ Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
+ return;
+}
+
+package Mouse::Meta::Role::Application::RoleSummation;
+our @ISA = qw(Mouse::Meta::Role::Application);
-sub _apply_methods{
- my($self, $applicant, $args) = @_;
+sub apply_methods {
+ my($self, $role, $consumer, @extra) = @_;
- if(exists $self->{conflicting_methods}){
- my $applicant_class_name = $applicant->name;
+ if(exists $role->{conflicting_methods}){
+ my $consumer_class_name = $consumer->name;
- my @conflicting = sort grep{ !$applicant_class_name->can($_) } keys %{ $self->{conflicting_methods} };
+ my @conflicting = grep{ !$consumer_class_name->can($_) }
+ keys %{ $role->{conflicting_methods} };
- if(@conflicting == 1){
- my $method_name = $conflicting[0];
- my @roles = sort @{ $self->{composed_roles_by_method}{$method_name} };
- $self->throw_error(
- sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
- english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $applicant->name
- );
- }
- elsif(@conflicting > 1){
- my $methods = english_list(map{ sprintf q{'%s'}, $_ } @conflicting);
+ if(@conflicting) {
+ my $method_name_conflict = (@conflicting == 1
+ ? 'a method name conflict'
+ : 'method name conflicts');
my %seen;
- my $roles = english_list(
- sort map{ my $name = $_->name; $seen{$name}++ ? () : sprintf q{'%s'}, $name }
- map{ @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
+ my $roles = Mouse::Util::quoted_english_list(
+ grep{ !$seen{$_}++ } # uniq
+ map { $_->name }
+ map { @{$_} }
+ @{ $role->{composed_roles_by_method} }{@conflicting}
);
- $self->throw_error(
- sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
- $roles, $methods, $applicant->name
- );
+ $self->throw_error(sprintf
+ q{Due to %s in roles %s,}
+ . q{ the method%s %s must be implemented or excluded by '%s'},
+ $method_name_conflict,
+ $roles,
+ (@conflicting > 1 ? 's' : ''),
+ Mouse::Util::quoted_english_list(@conflicting),
+ $consumer_class_name);
}
}
- $self->SUPER::_apply_methods($applicant, $args);
+ $self->SUPER::apply_methods($role, $consumer, @extra);
return;
}
+
+package Mouse::Meta::Role::Composite;
1;
__END__
=head1 VERSION
-This document describes Mouse version 0.40_09
+This document describes Mouse version 0.76
=head1 SEE ALSO