Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Method::Wrapped; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed'; |
9 | |
38bf2a25 |
10 | use base 'Class::MOP::Method'; |
11 | |
12 | # NOTE: |
13 | # this ugly beast is the result of trying |
14 | # to micro optimize this as much as possible |
15 | # while not completely loosing maintainability. |
16 | # At this point it's "fast enough", after all |
17 | # you can't get something for nothing :) |
18 | my $_build_wrapped_method = sub { |
19 | my $modifier_table = shift; |
20 | my ($before, $after, $around) = ( |
21 | $modifier_table->{before}, |
22 | $modifier_table->{after}, |
23 | $modifier_table->{around}, |
24 | ); |
25 | if (@$before && @$after) { |
26 | $modifier_table->{cache} = sub { |
27 | for my $c (@$before) { $c->(@_) }; |
28 | my @rval; |
29 | ((defined wantarray) ? |
30 | ((wantarray) ? |
31 | (@rval = $around->{cache}->(@_)) |
32 | : |
33 | ($rval[0] = $around->{cache}->(@_))) |
34 | : |
35 | $around->{cache}->(@_)); |
36 | for my $c (@$after) { $c->(@_) }; |
37 | return unless defined wantarray; |
38 | return wantarray ? @rval : $rval[0]; |
39 | } |
40 | } |
41 | elsif (@$before && !@$after) { |
42 | $modifier_table->{cache} = sub { |
43 | for my $c (@$before) { $c->(@_) }; |
44 | return $around->{cache}->(@_); |
45 | } |
46 | } |
47 | elsif (@$after && !@$before) { |
48 | $modifier_table->{cache} = sub { |
49 | my @rval; |
50 | ((defined wantarray) ? |
51 | ((wantarray) ? |
52 | (@rval = $around->{cache}->(@_)) |
53 | : |
54 | ($rval[0] = $around->{cache}->(@_))) |
55 | : |
56 | $around->{cache}->(@_)); |
57 | for my $c (@$after) { $c->(@_) }; |
58 | return unless defined wantarray; |
59 | return wantarray ? @rval : $rval[0]; |
60 | } |
61 | } |
62 | else { |
63 | $modifier_table->{cache} = $around->{cache}; |
64 | } |
65 | }; |
66 | |
67 | sub wrap { |
68 | my ( $class, $code, %params ) = @_; |
69 | |
70 | (blessed($code) && $code->isa('Class::MOP::Method')) |
71 | || confess "Can only wrap blessed CODE"; |
72 | |
73 | my $modifier_table = { |
74 | cache => undef, |
75 | orig => $code, |
76 | before => [], |
77 | after => [], |
78 | around => { |
79 | cache => $code->body, |
80 | methods => [], |
81 | }, |
82 | }; |
83 | $_build_wrapped_method->($modifier_table); |
84 | return $class->SUPER::wrap( |
85 | sub { $modifier_table->{cache}->(@_) }, |
86 | # get these from the original |
87 | # unless explicitly overriden |
88 | package_name => $params{package_name} || $code->package_name, |
89 | name => $params{name} || $code->name, |
90 | |
91 | modifier_table => $modifier_table, |
92 | ); |
93 | } |
94 | |
95 | sub _new { |
96 | my $class = shift; |
97 | return Class::MOP::Class->initialize($class)->new_object(@_) |
98 | if $class ne __PACKAGE__; |
99 | |
100 | my $params = @_ == 1 ? $_[0] : {@_}; |
101 | |
102 | return bless { |
103 | # inherited from Class::MOP::Method |
104 | 'body' => $params->{body}, |
105 | 'associated_metaclass' => $params->{associated_metaclass}, |
106 | 'package_name' => $params->{package_name}, |
107 | 'name' => $params->{name}, |
108 | 'original_method' => $params->{original_method}, |
109 | |
110 | # defined in this class |
111 | 'modifier_table' => $params->{modifier_table} |
112 | } => $class; |
113 | } |
114 | |
115 | sub get_original_method { |
116 | my $code = shift; |
117 | $code->{'modifier_table'}->{orig}; |
118 | } |
119 | |
120 | sub add_before_modifier { |
121 | my $code = shift; |
122 | my $modifier = shift; |
123 | unshift @{$code->{'modifier_table'}->{before}} => $modifier; |
124 | $_build_wrapped_method->($code->{'modifier_table'}); |
125 | } |
126 | |
127 | sub before_modifiers { |
128 | my $code = shift; |
129 | return @{$code->{'modifier_table'}->{before}}; |
130 | } |
131 | |
132 | sub add_after_modifier { |
133 | my $code = shift; |
134 | my $modifier = shift; |
135 | push @{$code->{'modifier_table'}->{after}} => $modifier; |
136 | $_build_wrapped_method->($code->{'modifier_table'}); |
137 | } |
138 | |
139 | sub after_modifiers { |
140 | my $code = shift; |
141 | return @{$code->{'modifier_table'}->{after}}; |
142 | } |
143 | |
144 | { |
145 | # NOTE: |
146 | # this is another possible candidate for |
147 | # optimization as well. There is an overhead |
148 | # associated with the currying that, if |
149 | # eliminated might make around modifiers |
150 | # more manageable. |
151 | my $compile_around_method = sub {{ |
152 | my $f1 = pop; |
153 | return $f1 unless @_; |
154 | my $f2 = pop; |
155 | push @_, sub { $f2->( $f1, @_ ) }; |
156 | redo; |
157 | }}; |
158 | |
159 | sub add_around_modifier { |
160 | my $code = shift; |
161 | my $modifier = shift; |
162 | unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; |
163 | $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( |
164 | @{$code->{'modifier_table'}->{around}->{methods}}, |
165 | $code->{'modifier_table'}->{orig}->body |
166 | ); |
167 | $_build_wrapped_method->($code->{'modifier_table'}); |
168 | } |
169 | } |
170 | |
171 | sub around_modifiers { |
172 | my $code = shift; |
173 | return @{$code->{'modifier_table'}->{around}->{methods}}; |
174 | } |
175 | |
176 | sub _make_compatible_with { |
177 | my $self = shift; |
178 | my ($other) = @_; |
179 | |
180 | # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped |
181 | # objects are subclasses of CMOP::Method, but when we get to moose, they'll |
182 | # need to be compatible with Moose::Meta::Method, which isn't possible. the |
183 | # right solution here is to make ::Wrapped into a role that gets applied to |
184 | # whatever the method_metaclass happens to be and get rid of |
185 | # wrapped_method_metaclass entirely, but that's not going to happen until |
186 | # we ditch cmop and get roles into the bootstrapping, so. i'm not |
187 | # maintaining the previous behavior of turning them into instances of the |
188 | # new method_metaclass because that's equally broken, and at least this way |
189 | # any issues will at least be detectable and potentially fixable. -doy |
190 | return $self unless $other->_is_compatible_with($self->_real_ref_name); |
191 | |
192 | return $self->SUPER::_make_compatible_with(@_); |
193 | } |
194 | |
195 | 1; |
196 | |
197 | # ABSTRACT: Method Meta Object for methods with before/after/around modifiers |
198 | |
199 | __END__ |
200 | |
201 | =pod |
202 | |
203 | =head1 DESCRIPTION |
204 | |
205 | This is a L<Class::MOP::Method> subclass which implements before, |
206 | after, and around method modifiers. |
207 | |
208 | =head1 METHODS |
209 | |
210 | =head2 Construction |
211 | |
212 | =over 4 |
213 | |
214 | =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> |
215 | |
216 | This is the constructor. It accepts a L<Class::MOP::Method> object and |
217 | a hash of options. |
218 | |
219 | The options are: |
220 | |
221 | =over 8 |
222 | |
223 | =item * name |
224 | |
225 | The method name (without a package name). This will be taken from the |
226 | provided L<Class::MOP::Method> object if it is not provided. |
227 | |
228 | =item * package_name |
229 | |
230 | The package name for the method. This will be taken from the provided |
231 | L<Class::MOP::Method> object if it is not provided. |
232 | |
233 | =item * associated_metaclass |
234 | |
235 | An optional L<Class::MOP::Class> object. This is the metaclass for the |
236 | method's class. |
237 | |
238 | =back |
239 | |
240 | =item B<< $metamethod->get_original_method >> |
241 | |
242 | This returns the L<Class::MOP::Method> object that was passed to the |
243 | constructor. |
244 | |
245 | =item B<< $metamethod->add_before_modifier($code) >> |
246 | |
247 | =item B<< $metamethod->add_after_modifier($code) >> |
248 | |
249 | =item B<< $metamethod->add_around_modifier($code) >> |
250 | |
251 | These methods all take a subroutine reference and apply it as a |
252 | modifier to the original method. |
253 | |
254 | =item B<< $metamethod->before_modifiers >> |
255 | |
256 | =item B<< $metamethod->after_modifiers >> |
257 | |
258 | =item B<< $metamethod->around_modifiers >> |
259 | |
260 | These methods all return a list of subroutine references which are |
261 | acting as the specified type of modifier. |
262 | |
263 | =back |
264 | |
265 | =cut |
266 | |