lib/Mouse/Meta/Role/Composite.pm

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