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