lib/Mouse/Meta/Role/Composite.pm

   1 package Mouse::Meta::Role::Composite;
   2 use Mouse::Util; # enables strict and warnings
   3 use Mouse::Meta::Role;
   4 use Mouse::Meta::Role::Application;
   5 our @ISA = qw(Mouse::Meta::Role);
   6
   7 sub get_method_list {
   8     my($self) = @_;
   9     return keys %{ $self->{methods} };
  10 }
  11
  12 sub add_method {
  13     my($self, $method_name, $code, $role) = @_;
  14
  15     if( ($self->{methods}{$method_name} || 0) == $code){
  16         # This role already has the same method.
  17         return;
  18     }
  19
  20     if($method_name eq 'meta'){
  21         $self->SUPER::add_method($method_name => $code);
  22     }
  23     else{
  24         # no need to add a subroutine to the stash
  25         my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
  26         push @{$roles}, $role;
  27         if(@{$roles} > 1){
  28             $self->{conflicting_methods}{$method_name}++;
  29         }
  30         $self->{methods}{$method_name} = $code;
  31     }
  32     return;
  33 }
  34
  35 sub get_method_body {
  36     my($self, $method_name) = @_;
  37     return $self->{methods}{$method_name};
  38 }
  39
  40 sub has_method {
  41     # my($self, $method_name) = @_;
  42     return 0; # to fool apply_methods() in combine()
  43 }
  44
  45 sub has_attribute {
  46     # my($self, $method_name) = @_;
  47     return 0; # to fool appply_attributes() in combine()
  48 }
  49
  50 sub has_override_method_modifier {
  51     # my($self, $method_name) = @_;
  52     return 0; # to fool apply_modifiers() in combine()
  53 }
  54
  55 sub add_attribute {
  56     my $self      = shift;
  57     my $attr_name = shift;
  58     my $spec      = (@_ == 1 ? $_[0] : {@_});
  59
  60     my $existing = $self->{attributes}{$attr_name};
  61     if($existing && $existing != $spec){
  62         $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
  63                          . "during composition. This is fatal error and cannot be disambiguated.");
  64     }
  65     $self->SUPER::add_attribute($attr_name, $spec);
  66     return;
  67 }
  68
  69 sub add_override_method_modifier {
  70     my($self, $method_name, $code) = @_;
  71
  72     my $existing = $self->{override_method_modifiers}{$method_name};
  73     if($existing && $existing != $code){
  74         $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
  75                           . "composition (Two 'override' methods of the same name encountered). "
  76                           . "This is fatal error.")
  77     }
  78     $self->SUPER::add_override_method_modifier($method_name, $code);
  79     return;
  80 }
  81
  82 sub apply {
  83     my $self     = shift;
  84     my $consumer = shift;
  85
  86     Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
  87     return;
  88 }
  89
  90 package Mouse::Meta::Role::Application::RoleSummation;
  91 our @ISA = qw(Mouse::Meta::Role::Application);
  92
  93 sub apply_methods {
  94     my($self, $role, $consumer, @extra) = @_;
  95
  96     if(exists $role->{conflicting_methods}){
  97         my $consumer_class_name = $consumer->name;
  98
  99         my @conflicting = grep{ !$consumer_class_name->can($_) }
 100             keys %{ $role->{conflicting_methods} };
 101
 102         if(@conflicting == 1){
 103             my $method_name = $conflicting[0];
 104             my $roles       = Mouse::Util::quoted_english_list( map{ $_->name }
 105                 @{ $role->{composed_roles_by_method}{$method_name} });
 106             $self->throw_error(
 107                sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
 108                    $roles, $method_name, $consumer_class_name
 109             );
 110         }
 111         elsif(@conflicting > 1){
 112             my %seen;
 113             my $roles = Mouse::Util::quoted_english_list(
 114                 grep{ !$seen{$_}++ } # uniq
 115                 map { $_->name }
 116                 map { @{$_} } @{ $role->{composed_roles_by_method} }{@conflicting}
 117             );
 118
 119             $self->throw_error(
 120                sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
 121                    $roles,
 122                    Mouse::Util::quoted_english_list(@conflicting),
 123                    $consumer_class_name
 124             );
 125         }
 126     }
 127
 128     $self->SUPER::apply_methods($role, $consumer, @extra);
 129     return;
 130 }
 131
 132 package Mouse::Meta::Role::Composite;
 133 1;
 134 __END__
 135
 136 =head1 NAME
 137
 138 Mouse::Meta::Role::Composite - An object to represent the set of roles
 139
 140 =head1 VERSION
 141
 142 This document describes Mouse version 0.70
 143
 144 =head1 SEE ALSO
 145
 146 L<Moose::Meta::Role::Composite>
 147
 148 =cut