2 package Class::MOP::Method::Wrapped;
8 use Scalar::Util 'blessed';
10 use base 'Class::MOP::Method';
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},
25 if (@$before && @$after) {
26 $modifier_table->{cache} = sub {
27 for my $c (@$before) { $c->(@_) };
29 ((defined wantarray) ?
31 (@rval = $around->{cache}->(@_))
33 ($rval[0] = $around->{cache}->(@_)))
35 $around->{cache}->(@_));
36 for my $c (@$after) { $c->(@_) };
37 return unless defined wantarray;
38 return wantarray ? @rval : $rval[0];
41 elsif (@$before && !@$after) {
42 $modifier_table->{cache} = sub {
43 for my $c (@$before) { $c->(@_) };
44 return $around->{cache}->(@_);
47 elsif (@$after && !@$before) {
48 $modifier_table->{cache} = sub {
50 ((defined wantarray) ?
52 (@rval = $around->{cache}->(@_))
54 ($rval[0] = $around->{cache}->(@_)))
56 $around->{cache}->(@_));
57 for my $c (@$after) { $c->(@_) };
58 return unless defined wantarray;
59 return wantarray ? @rval : $rval[0];
63 $modifier_table->{cache} = $around->{cache};
68 my ( $class, $code, %params ) = @_;
70 (blessed($code) && $code->isa('Class::MOP::Method'))
71 || confess "Can only wrap blessed CODE";
73 my $modifier_table = {
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 original_method => $code,
92 modifier_table => $modifier_table,
98 return Class::MOP::Class->initialize($class)->new_object(@_)
99 if $class ne __PACKAGE__;
101 my $params = @_ == 1 ? $_[0] : {@_};
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},
111 # defined in this class
112 'modifier_table' => $params->{modifier_table}
116 sub get_original_method {
118 $code->original_method;
121 sub add_before_modifier {
123 my $modifier = shift;
124 unshift @{$code->{'modifier_table'}->{before}} => $modifier;
125 $_build_wrapped_method->($code->{'modifier_table'});
128 sub before_modifiers {
130 return @{$code->{'modifier_table'}->{before}};
133 sub add_after_modifier {
135 my $modifier = shift;
136 push @{$code->{'modifier_table'}->{after}} => $modifier;
137 $_build_wrapped_method->($code->{'modifier_table'});
140 sub after_modifiers {
142 return @{$code->{'modifier_table'}->{after}};
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
152 my $compile_around_method = sub {{
154 return $f1 unless @_;
156 push @_, sub { $f2->( $f1, @_ ) };
160 sub add_around_modifier {
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}},
166 $code->{'modifier_table'}->{orig}
168 $_build_wrapped_method->($code->{'modifier_table'});
172 sub around_modifiers {
174 return @{$code->{'modifier_table'}->{around}->{methods}};
177 sub _make_compatible_with {
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);
193 return $self->SUPER::_make_compatible_with(@_);
198 # ABSTRACT: Method Meta Object for methods with before/after/around modifiers
206 This is a L<Class::MOP::Method> subclass which implements before,
207 after, and around method modifiers.
215 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
217 This is the constructor. It accepts a L<Class::MOP::Method> object and
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.
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.
234 =item * associated_metaclass
236 An optional L<Class::MOP::Class> object. This is the metaclass for the
241 =item B<< $metamethod->get_original_method >>
243 This returns the L<Class::MOP::Method> object that was passed to the
246 =item B<< $metamethod->add_before_modifier($code) >>
248 =item B<< $metamethod->add_after_modifier($code) >>
250 =item B<< $metamethod->add_around_modifier($code) >>
252 These methods all take a subroutine reference and apply it as a
253 modifier to the original method.
255 =item B<< $metamethod->before_modifiers >>
257 =item B<< $metamethod->after_modifiers >>
259 =item B<< $metamethod->around_modifiers >>
261 These methods all return a list of subroutine references which are
262 acting as the specified type of modifier.