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