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