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