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, |
85d8f996 |
75 | orig => $code->body, |
38bf2a25 |
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, |
85d8f996 |
90 | original_method => $code, |
38bf2a25 |
91 | |
92 | modifier_table => $modifier_table, |
93 | ); |
94 | } |
95 | |
96 | sub _new { |
97 | my $class = shift; |
98 | return Class::MOP::Class->initialize($class)->new_object(@_) |
99 | if $class ne __PACKAGE__; |
100 | |
101 | my $params = @_ == 1 ? $_[0] : {@_}; |
102 | |
103 | return bless { |
104 | # inherited from Class::MOP::Method |
105 | 'body' => $params->{body}, |
106 | 'associated_metaclass' => $params->{associated_metaclass}, |
107 | 'package_name' => $params->{package_name}, |
108 | 'name' => $params->{name}, |
109 | 'original_method' => $params->{original_method}, |
110 | |
111 | # defined in this class |
112 | 'modifier_table' => $params->{modifier_table} |
113 | } => $class; |
114 | } |
115 | |
116 | sub get_original_method { |
117 | my $code = shift; |
85d8f996 |
118 | $code->original_method; |
38bf2a25 |
119 | } |
120 | |
121 | sub add_before_modifier { |
122 | my $code = shift; |
123 | my $modifier = shift; |
124 | unshift @{$code->{'modifier_table'}->{before}} => $modifier; |
125 | $_build_wrapped_method->($code->{'modifier_table'}); |
126 | } |
127 | |
128 | sub before_modifiers { |
129 | my $code = shift; |
130 | return @{$code->{'modifier_table'}->{before}}; |
131 | } |
132 | |
133 | sub add_after_modifier { |
134 | my $code = shift; |
135 | my $modifier = shift; |
136 | push @{$code->{'modifier_table'}->{after}} => $modifier; |
137 | $_build_wrapped_method->($code->{'modifier_table'}); |
138 | } |
139 | |
140 | sub after_modifiers { |
141 | my $code = shift; |
142 | return @{$code->{'modifier_table'}->{after}}; |
143 | } |
144 | |
145 | { |
146 | # NOTE: |
147 | # this is another possible candidate for |
148 | # optimization as well. There is an overhead |
149 | # associated with the currying that, if |
150 | # eliminated might make around modifiers |
151 | # more manageable. |
152 | my $compile_around_method = sub {{ |
153 | my $f1 = pop; |
154 | return $f1 unless @_; |
155 | my $f2 = pop; |
156 | push @_, sub { $f2->( $f1, @_ ) }; |
157 | redo; |
158 | }}; |
159 | |
160 | sub add_around_modifier { |
161 | my $code = shift; |
162 | my $modifier = shift; |
163 | unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier; |
164 | $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->( |
165 | @{$code->{'modifier_table'}->{around}->{methods}}, |
85d8f996 |
166 | $code->{'modifier_table'}->{orig} |
38bf2a25 |
167 | ); |
168 | $_build_wrapped_method->($code->{'modifier_table'}); |
169 | } |
170 | } |
171 | |
172 | sub around_modifiers { |
173 | my $code = shift; |
174 | return @{$code->{'modifier_table'}->{around}->{methods}}; |
175 | } |
176 | |
177 | sub _make_compatible_with { |
178 | my $self = shift; |
179 | my ($other) = @_; |
180 | |
181 | # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped |
182 | # objects are subclasses of CMOP::Method, but when we get to moose, they'll |
183 | # need to be compatible with Moose::Meta::Method, which isn't possible. the |
184 | # right solution here is to make ::Wrapped into a role that gets applied to |
185 | # whatever the method_metaclass happens to be and get rid of |
186 | # wrapped_method_metaclass entirely, but that's not going to happen until |
187 | # we ditch cmop and get roles into the bootstrapping, so. i'm not |
188 | # maintaining the previous behavior of turning them into instances of the |
189 | # new method_metaclass because that's equally broken, and at least this way |
190 | # any issues will at least be detectable and potentially fixable. -doy |
191 | return $self unless $other->_is_compatible_with($self->_real_ref_name); |
192 | |
193 | return $self->SUPER::_make_compatible_with(@_); |
194 | } |
195 | |
196 | 1; |
197 | |
198 | # ABSTRACT: Method Meta Object for methods with before/after/around modifiers |
199 | |
200 | __END__ |
201 | |
202 | =pod |
203 | |
204 | =head1 DESCRIPTION |
205 | |
206 | This is a L<Class::MOP::Method> subclass which implements before, |
207 | after, and around method modifiers. |
208 | |
209 | =head1 METHODS |
210 | |
211 | =head2 Construction |
212 | |
213 | =over 4 |
214 | |
215 | =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >> |
216 | |
217 | This is the constructor. It accepts a L<Class::MOP::Method> object and |
218 | a hash of options. |
219 | |
220 | The options are: |
221 | |
222 | =over 8 |
223 | |
224 | =item * name |
225 | |
226 | The method name (without a package name). This will be taken from the |
227 | provided L<Class::MOP::Method> object if it is not provided. |
228 | |
229 | =item * package_name |
230 | |
231 | The package name for the method. This will be taken from the provided |
232 | L<Class::MOP::Method> object if it is not provided. |
233 | |
234 | =item * associated_metaclass |
235 | |
236 | An optional L<Class::MOP::Class> object. This is the metaclass for the |
237 | method's class. |
238 | |
239 | =back |
240 | |
241 | =item B<< $metamethod->get_original_method >> |
242 | |
243 | This returns the L<Class::MOP::Method> object that was passed to the |
244 | constructor. |
245 | |
246 | =item B<< $metamethod->add_before_modifier($code) >> |
247 | |
248 | =item B<< $metamethod->add_after_modifier($code) >> |
249 | |
250 | =item B<< $metamethod->add_around_modifier($code) >> |
251 | |
252 | These methods all take a subroutine reference and apply it as a |
253 | modifier to the original method. |
254 | |
255 | =item B<< $metamethod->before_modifiers >> |
256 | |
257 | =item B<< $metamethod->after_modifiers >> |
258 | |
259 | =item B<< $metamethod->around_modifiers >> |
260 | |
261 | These methods all return a list of subroutine references which are |
262 | acting as the specified type of modifier. |
263 | |
264 | =back |
265 | |
266 | =cut |
267 | |