Commit | Line | Data |
823419c5 |
1 | package Mouse::Meta::Role::Application; |
2 | use Mouse::Util qw(:meta); |
3 | |
4 | sub new { |
5 | my $class = shift; |
6 | my $args = $class->Mouse::Object::BUILDARGS(@_); |
7 | |
8 | if(exists $args->{exclude} or exists $args->{alias}) { |
9 | warnings::warnif(deprecated => |
10 | 'The alias and excludes options for role application have been' |
11 | . ' renamed -alias and -exclude'); |
12 | |
13 | if($args->{alias} && !exists $args->{-alias}){ |
14 | $args->{-alias} = $args->{alias}; |
15 | } |
16 | if($args->{excludes} && !exists $args->{-excludes}){ |
17 | $args->{-excludes} = $args->{excludes}; |
18 | } |
19 | } |
20 | |
21 | $args->{aliased_methods} = {}; |
22 | if(my $alias = $args->{-alias}){ |
23 | @{$args->{aliased_methods}}{ values %{$alias} } = (); |
24 | } |
25 | |
26 | if(my $excludes = $args->{-excludes}){ |
27 | $args->{-excludes} = {}; # replace with a hash ref |
28 | if(ref $excludes){ |
29 | %{$args->{-excludes}} = (map{ $_ => undef } @{$excludes}); |
30 | } |
31 | else{ |
32 | $args->{-excludes}{$excludes} = undef; |
33 | } |
34 | } |
35 | my $self = bless $args, $class; |
36 | if($class ne __PACKAGE__){ |
37 | $self->meta->_initialize_object($self, $args); |
38 | } |
39 | return $self; |
40 | } |
41 | |
42 | sub apply { |
43 | my($self, $role, $consumer, @extra) = @_; |
44 | my $instance; |
45 | |
46 | if(Mouse::Util::is_a_metaclass($consumer)) { # Application::ToClass |
47 | $self->{_to} = 'class'; |
48 | } |
49 | elsif(Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole |
50 | $self->{_to} = 'role'; |
51 | } |
52 | else { # Appplication::ToInstance |
53 | $self->{_to} = 'instance'; |
54 | $instance = $consumer; |
55 | |
56 | $consumer = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class') |
57 | ->create_anon_class( |
58 | superclasses => [ref $instance], |
23791e49 |
59 | roles => [$role], |
823419c5 |
60 | cache => 1, |
23791e49 |
61 | |
62 | in_application_to_instance => 1, # suppress to apply roles |
823419c5 |
63 | ); |
64 | } |
65 | |
66 | #$self->check_role_exclusions($role, $consumer, @extra); |
67 | $self->check_required_methods($role, $consumer, @extra); |
68 | #$self->check_required_attributes($role, $consumer, @extra); |
69 | |
70 | $self->apply_attributes($role, $consumer, @extra); |
71 | $self->apply_methods($role, $consumer, @extra); |
72 | #$self->apply_override_method_modifiers($role, $consumer, @extra); |
73 | #$self->apply_before_method_modifiers($role, $consumer, @extra); |
74 | #$self->apply_around_method_modifiers($role, $consumer, @extra); |
75 | #$self->apply_after_method_modifiers($role, $consumer, @extra); |
76 | $self->apply_modifiers($role, $consumer, @extra); |
77 | |
78 | $self->_append_roles($role, $consumer); |
79 | |
80 | if(defined $instance){ # Application::ToInstance |
81 | # rebless instance |
82 | bless $instance, $consumer->name; |
83 | $consumer->_initialize_object($instance, $instance, 1); |
84 | } |
85 | |
86 | return; |
87 | } |
88 | |
89 | sub check_required_methods { |
90 | my($self, $role, $consumer) = @_; |
91 | |
92 | if($self->{_to} eq 'role'){ |
93 | $consumer->add_required_methods($role->get_required_method_list); |
94 | } |
95 | else{ # to class or instance |
96 | my $consumer_class_name = $consumer->name; |
97 | |
98 | my @missing; |
99 | foreach my $method_name(@{$role->{required_methods}}){ |
100 | next if exists $self->{aliased_methods}{$method_name}; |
101 | next if exists $role->{methods}{$method_name}; |
102 | next if $consumer_class_name->can($method_name); |
103 | |
104 | push @missing, $method_name; |
105 | } |
106 | if(@missing){ |
107 | $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'", |
108 | $role->name, |
109 | (@missing == 1 ? '' : 's'), # method or methods |
110 | Mouse::Util::quoted_english_list(@missing), |
111 | $consumer_class_name); |
112 | } |
113 | } |
114 | |
115 | return; |
116 | } |
117 | |
118 | sub apply_methods { |
119 | my($self, $role, $consumer) = @_; |
120 | |
121 | my $alias = $self->{-alias}; |
122 | my $excludes = $self->{-excludes}; |
123 | |
124 | foreach my $method_name($role->get_method_list){ |
125 | next if $method_name eq 'meta'; |
126 | |
127 | my $code = $role->get_method_body($method_name); |
128 | |
129 | if(!exists $excludes->{$method_name}){ |
130 | if(!$consumer->has_method($method_name)){ |
131 | # The third argument $role is used in Role::Composite |
132 | $consumer->add_method($method_name => $code, $role); |
133 | } |
134 | } |
135 | |
136 | if(exists $alias->{$method_name}){ |
137 | my $dstname = $alias->{$method_name}; |
138 | |
139 | my $dstcode = $consumer->get_method_body($dstname); |
140 | |
141 | if(defined($dstcode) && $dstcode != $code){ |
142 | $role->throw_error("Cannot create a method alias if a local method of the same name exists"); |
143 | } |
144 | else{ |
145 | $consumer->add_method($dstname => $code, $role); |
146 | } |
147 | } |
148 | } |
149 | |
150 | return; |
151 | } |
152 | |
153 | sub apply_attributes { |
154 | my($self, $role, $consumer) = @_; |
155 | |
156 | for my $attr_name ($role->get_attribute_list) { |
157 | next if $consumer->has_attribute($attr_name); |
158 | |
159 | $consumer->add_attribute($attr_name |
160 | => $role->get_attribute($attr_name)); |
161 | } |
162 | return; |
163 | } |
164 | |
165 | sub apply_modifiers { |
166 | my($self, $role, $consumer) = @_; |
167 | |
168 | if(my $modifiers = $role->{override_method_modifiers}){ |
169 | foreach my $method_name (keys %{$modifiers}){ |
170 | $consumer->add_override_method_modifier( |
171 | $method_name => $modifiers->{$method_name}); |
172 | } |
173 | } |
174 | |
175 | for my $modifier_type (qw/before around after/) { |
176 | my $table = $role->{"${modifier_type}_method_modifiers"} |
177 | or next; |
178 | |
179 | my $add_modifier = "add_${modifier_type}_method_modifier"; |
180 | |
181 | while(my($method_name, $modifiers) = each %{$table}){ |
182 | foreach my $code(@{ $modifiers }) { |
183 | # skip if the modifier is already applied |
184 | next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; |
185 | $consumer->$add_modifier($method_name => $code); |
186 | } |
187 | } |
188 | } |
189 | return; |
190 | } |
191 | |
192 | sub _append_roles { |
193 | my($self, $role, $metaclass_or_role) = @_; |
194 | |
195 | my $roles = $metaclass_or_role->{roles}; |
196 | foreach my $r($role, @{$role->get_roles}){ |
197 | if(!$metaclass_or_role->does_role($r)){ |
198 | push @{$roles}, $r; |
199 | } |
200 | } |
201 | return; |
202 | } |
203 | 1; |
204 | __END__ |
205 | |
206 | =head1 NAME |
207 | |
208 | Mouse::Meta::Role::Application - The Mouse role application class |
209 | |
33aa919d |
210 | =head1 VERSION |
211 | |
8cf6cb3b |
212 | This document describes Mouse version 0.91 |
33aa919d |
213 | |
823419c5 |
214 | =head1 SEE ALSO |
215 | |
216 | L<Moose::Role::Application> |
217 | |
218 | L<Moose::Role::Application::ToClass> |
219 | |
220 | L<Moose::Role::Application::ToRole> |
221 | |
222 | L<Moose::Role::Application::ToInstance> |
223 | |
33aa919d |
224 | =cut |
225 | |