70c7971adadde8a695e04baa189d256a3a924efe
[gitmo/Mouse.git] / 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) {
103             my $method_name_conflict = (@conflicting == 1
104                 ? 'a method name conflict'
105                 : 'method name conflicts');
106
107             my %seen;
108             my $roles = Mouse::Util::quoted_english_list(
109                 grep{ !$seen{$_}++ } # uniq
110                 map { $_->name }
111                 map { @{$_} }
112                 @{ $role->{composed_roles_by_method} }{@conflicting}
113             );
114
115             $self->throw_error(sprintf
116                   q{Due to %s in roles %s,}
117                 . q{ the method%s %s must be implemented or excluded by '%s'},
118                     $method_name_conflict,
119                     $roles,
120                     (@conflicting > 1 ? 's' : ''),
121                     Mouse::Util::quoted_english_list(@conflicting),
122                     $consumer_class_name);
123         }
124     }
125
126     $self->SUPER::apply_methods($role, $consumer, @extra);
127     return;
128 }
129
130 package Mouse::Meta::Role::Composite;
131 1;
132 __END__
133
134 =head1 NAME
135
136 Mouse::Meta::Role::Composite - An object to represent the set of roles
137
138 =head1 VERSION
139
140 This document describes Mouse version 0.70
141
142 =head1 SEE ALSO
143
144 L<Moose::Meta::Role::Composite>
145
146 =cut