2 package Class::MOP::Method::Wrapped;
8 use Scalar::Util 'blessed';
10 our $AUTHORITY = 'cpan:STEVAN';
12 use base 'Class::MOP::Method';
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},
27 if (@$before && @$after) {
28 $modifier_table->{cache} = sub {
29 for my $c (@$before) { $c->(@_) };
31 ((defined wantarray) ?
33 (@rval = $around->{cache}->(@_))
35 ($rval[0] = $around->{cache}->(@_)))
37 $around->{cache}->(@_));
38 for my $c (@$after) { $c->(@_) };
39 return unless defined wantarray;
40 return wantarray ? @rval : $rval[0];
43 elsif (@$before && !@$after) {
44 $modifier_table->{cache} = sub {
45 for my $c (@$before) { $c->(@_) };
46 return $around->{cache}->(@_);
49 elsif (@$after && !@$before) {
50 $modifier_table->{cache} = sub {
52 ((defined wantarray) ?
54 (@rval = $around->{cache}->(@_))
56 ($rval[0] = $around->{cache}->(@_)))
58 $around->{cache}->(@_));
59 for my $c (@$after) { $c->(@_) };
60 return unless defined wantarray;
61 return wantarray ? @rval : $rval[0];
65 $modifier_table->{cache} = $around->{cache};
70 my ( $class, $code, %params ) = @_;
72 (blessed($code) && $code->isa('Class::MOP::Method'))
73 || confess "Can only wrap blessed CODE";
75 my $modifier_table = {
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,
93 modifier_table => $modifier_table,
99 return Class::MOP::Class->initialize($class)->new_object(@_)
100 if $class ne __PACKAGE__;
102 my $params = @_ == 1 ? $_[0] : {@_};
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},
112 # defined in this class
113 'modifier_table' => $params->{modifier_table}
117 sub get_original_method {
119 $code->{'modifier_table'}->{orig};
122 sub add_before_modifier {
124 my $modifier = shift;
125 unshift @{$code->{'modifier_table'}->{before}} => $modifier;
126 $_build_wrapped_method->($code->{'modifier_table'});
129 sub before_modifiers {
131 return @{$code->{'modifier_table'}->{before}};
134 sub add_after_modifier {
136 my $modifier = shift;
137 push @{$code->{'modifier_table'}->{after}} => $modifier;
138 $_build_wrapped_method->($code->{'modifier_table'});
141 sub after_modifiers {
143 return @{$code->{'modifier_table'}->{after}};
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
153 my $compile_around_method = sub {{
155 return $f1 unless @_;
157 push @_, sub { $f2->( $f1, @_ ) };
161 sub add_around_modifier {
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
169 $_build_wrapped_method->($code->{'modifier_table'});
173 sub around_modifiers {
175 return @{$code->{'modifier_table'}->{around}->{methods}};
178 sub _make_compatible_with {
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);
194 return $self->SUPER::_make_compatible_with(@_);
199 # ABSTRACT: Method Meta Object for methods with before/after/around modifiers
207 This is a L<Class::MOP::Method> subclass which implements before,
208 after, and around method modifiers.
216 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
218 This is the constructor. It accepts a L<Class::MOP::Method> object and
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.
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.
235 =item * associated_metaclass
237 An optional L<Class::MOP::Class> object. This is the metaclass for the
242 =item B<< $metamethod->get_original_method >>
244 This returns the L<Class::MOP::Method> object that was passed to the
247 =item B<< $metamethod->add_before_modifier($code) >>
249 =item B<< $metamethod->add_after_modifier($code) >>
251 =item B<< $metamethod->add_around_modifier($code) >>
253 These methods all take a subroutine reference and apply it as a
254 modifier to the original method.
256 =item B<< $metamethod->before_modifiers >>
258 =item B<< $metamethod->after_modifiers >>
260 =item B<< $metamethod->around_modifiers >>
262 These methods all return a list of subroutine references which are
263 acting as the specified type of modifier.