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], |
59 | cache => 1, |
60 | ); |
61 | } |
62 | |
63 | #$self->check_role_exclusions($role, $consumer, @extra); |
64 | $self->check_required_methods($role, $consumer, @extra); |
65 | #$self->check_required_attributes($role, $consumer, @extra); |
66 | |
67 | $self->apply_attributes($role, $consumer, @extra); |
68 | $self->apply_methods($role, $consumer, @extra); |
69 | #$self->apply_override_method_modifiers($role, $consumer, @extra); |
70 | #$self->apply_before_method_modifiers($role, $consumer, @extra); |
71 | #$self->apply_around_method_modifiers($role, $consumer, @extra); |
72 | #$self->apply_after_method_modifiers($role, $consumer, @extra); |
73 | $self->apply_modifiers($role, $consumer, @extra); |
74 | |
75 | $self->_append_roles($role, $consumer); |
76 | |
77 | if(defined $instance){ # Application::ToInstance |
78 | # rebless instance |
79 | bless $instance, $consumer->name; |
80 | $consumer->_initialize_object($instance, $instance, 1); |
81 | } |
82 | |
83 | return; |
84 | } |
85 | |
86 | sub check_required_methods { |
87 | my($self, $role, $consumer) = @_; |
88 | |
89 | if($self->{_to} eq 'role'){ |
90 | $consumer->add_required_methods($role->get_required_method_list); |
91 | } |
92 | else{ # to class or instance |
93 | my $consumer_class_name = $consumer->name; |
94 | |
95 | my @missing; |
96 | foreach my $method_name(@{$role->{required_methods}}){ |
97 | next if exists $self->{aliased_methods}{$method_name}; |
98 | next if exists $role->{methods}{$method_name}; |
99 | next if $consumer_class_name->can($method_name); |
100 | |
101 | push @missing, $method_name; |
102 | } |
103 | if(@missing){ |
104 | $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'", |
105 | $role->name, |
106 | (@missing == 1 ? '' : 's'), # method or methods |
107 | Mouse::Util::quoted_english_list(@missing), |
108 | $consumer_class_name); |
109 | } |
110 | } |
111 | |
112 | return; |
113 | } |
114 | |
115 | sub apply_methods { |
116 | my($self, $role, $consumer) = @_; |
117 | |
118 | my $alias = $self->{-alias}; |
119 | my $excludes = $self->{-excludes}; |
120 | |
121 | foreach my $method_name($role->get_method_list){ |
122 | next if $method_name eq 'meta'; |
123 | |
124 | my $code = $role->get_method_body($method_name); |
125 | |
126 | if(!exists $excludes->{$method_name}){ |
127 | if(!$consumer->has_method($method_name)){ |
128 | # The third argument $role is used in Role::Composite |
129 | $consumer->add_method($method_name => $code, $role); |
130 | } |
131 | } |
132 | |
133 | if(exists $alias->{$method_name}){ |
134 | my $dstname = $alias->{$method_name}; |
135 | |
136 | my $dstcode = $consumer->get_method_body($dstname); |
137 | |
138 | if(defined($dstcode) && $dstcode != $code){ |
139 | $role->throw_error("Cannot create a method alias if a local method of the same name exists"); |
140 | } |
141 | else{ |
142 | $consumer->add_method($dstname => $code, $role); |
143 | } |
144 | } |
145 | } |
146 | |
147 | return; |
148 | } |
149 | |
150 | sub apply_attributes { |
151 | my($self, $role, $consumer) = @_; |
152 | |
153 | for my $attr_name ($role->get_attribute_list) { |
154 | next if $consumer->has_attribute($attr_name); |
155 | |
156 | $consumer->add_attribute($attr_name |
157 | => $role->get_attribute($attr_name)); |
158 | } |
159 | return; |
160 | } |
161 | |
162 | sub apply_modifiers { |
163 | my($self, $role, $consumer) = @_; |
164 | |
165 | if(my $modifiers = $role->{override_method_modifiers}){ |
166 | foreach my $method_name (keys %{$modifiers}){ |
167 | $consumer->add_override_method_modifier( |
168 | $method_name => $modifiers->{$method_name}); |
169 | } |
170 | } |
171 | |
172 | for my $modifier_type (qw/before around after/) { |
173 | my $table = $role->{"${modifier_type}_method_modifiers"} |
174 | or next; |
175 | |
176 | my $add_modifier = "add_${modifier_type}_method_modifier"; |
177 | |
178 | while(my($method_name, $modifiers) = each %{$table}){ |
179 | foreach my $code(@{ $modifiers }) { |
180 | # skip if the modifier is already applied |
181 | next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; |
182 | $consumer->$add_modifier($method_name => $code); |
183 | } |
184 | } |
185 | } |
186 | return; |
187 | } |
188 | |
189 | sub _append_roles { |
190 | my($self, $role, $metaclass_or_role) = @_; |
191 | |
192 | my $roles = $metaclass_or_role->{roles}; |
193 | foreach my $r($role, @{$role->get_roles}){ |
194 | if(!$metaclass_or_role->does_role($r)){ |
195 | push @{$roles}, $r; |
196 | } |
197 | } |
198 | return; |
199 | } |
200 | 1; |
201 | __END__ |
202 | |
203 | =head1 NAME |
204 | |
205 | Mouse::Meta::Role::Application - The Mouse role application class |
206 | |
33aa919d |
207 | =head1 VERSION |
208 | |
43c1bb1a |
209 | This document describes Mouse version 0.71 |
33aa919d |
210 | |
823419c5 |
211 | =head1 SEE ALSO |
212 | |
213 | L<Moose::Role::Application> |
214 | |
215 | L<Moose::Role::Application::ToClass> |
216 | |
217 | L<Moose::Role::Application::ToRole> |
218 | |
219 | L<Moose::Role::Application::ToInstance> |
220 | |
33aa919d |
221 | =cut |
222 | |