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 | |
c3d7c8b5 |
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 | |
92d87891 |
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 | |
823419c5 |
26 | sub get_method_list { |
71e7b544 |
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 | |
a062712d |
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 |
71e7b544 |
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 | } |
a062712d |
49 | $self->{methods}{$method_name} = $code; |
71e7b544 |
50 | } |
71e7b544 |
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) = @_; |
823419c5 |
61 | return 0; # to fool apply_methods() in combine() |
71e7b544 |
62 | } |
63 | |
823419c5 |
64 | sub has_attribute { |
71e7b544 |
65 | # my($self, $method_name) = @_; |
823419c5 |
66 | return 0; # to fool appply_attributes() in combine() |
71e7b544 |
67 | } |
68 | |
823419c5 |
69 | sub has_override_method_modifier { |
71e7b544 |
70 | # my($self, $method_name) = @_; |
823419c5 |
71 | return 0; # to fool apply_modifiers() in combine() |
71e7b544 |
72 | } |
73 | |
823419c5 |
74 | sub add_attribute { |
2053291d |
75 | my $self = shift; |
76 | my $attr_name = shift; |
77 | my $spec = (@_ == 1 ? $_[0] : {@_}); |
71e7b544 |
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 | |
823419c5 |
88 | sub add_override_method_modifier { |
71e7b544 |
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 | |
823419c5 |
101 | sub apply { |
102 | my $self = shift; |
103 | my $consumer = shift; |
71e7b544 |
104 | |
823419c5 |
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); |
71e7b544 |
111 | |
823419c5 |
112 | sub apply_methods { |
113 | my($self, $role, $consumer, @extra) = @_; |
114 | |
115 | if(exists $role->{conflicting_methods}){ |
45f22b92 |
116 | my $consumer_class_name = $consumer->name; |
71e7b544 |
117 | |
837d9c57 |
118 | my @conflicting = grep{ !$consumer_class_name->can($_) } |
823419c5 |
119 | keys %{ $role->{conflicting_methods} }; |
71e7b544 |
120 | |
837d9c57 |
121 | if(@conflicting) { |
122 | my $method_name_conflict = (@conflicting == 1 |
123 | ? 'a method name conflict' |
124 | : 'method name conflicts'); |
125 | |
71e7b544 |
126 | my %seen; |
aba0f138 |
127 | my $roles = Mouse::Util::quoted_english_list( |
5af36247 |
128 | grep{ !$seen{$_}++ } # uniq |
129 | map { $_->name } |
837d9c57 |
130 | map { @{$_} } |
131 | @{ $role->{composed_roles_by_method} }{@conflicting} |
71e7b544 |
132 | ); |
133 | |
837d9c57 |
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); |
71e7b544 |
142 | } |
143 | } |
144 | |
823419c5 |
145 | $self->SUPER::apply_methods($role, $consumer, @extra); |
71e7b544 |
146 | return; |
147 | } |
823419c5 |
148 | |
149 | package Mouse::Meta::Role::Composite; |
71e7b544 |
150 | 1; |
151 | __END__ |
152 | |
a25ca8d6 |
153 | =head1 NAME |
154 | |
155 | Mouse::Meta::Role::Composite - An object to represent the set of roles |
156 | |
157 | =head1 VERSION |
158 | |
43c1bb1a |
159 | This document describes Mouse version 0.71 |
a25ca8d6 |
160 | |
161 | =head1 SEE ALSO |
162 | |
163 | L<Moose::Meta::Role::Composite> |
164 | |
165 | =cut |