2 package Class::MOP::Method::Wrapped;
8 use Scalar::Util 'blessed';
10 our $VERSION = '0.60';
11 our $AUTHORITY = 'cpan:STEVAN';
13 use base 'Class::MOP::Method';
16 # this ugly beast is the result of trying
17 # to micro optimize this as much as possible
18 # while not completely loosing maintainability.
19 # At this point it's "fast enough", after all
20 # you can't get something for nothing :)
21 my $_build_wrapped_method = sub {
22 my $modifier_table = shift;
23 my ($before, $after, $around) = (
24 $modifier_table->{before},
25 $modifier_table->{after},
26 $modifier_table->{around},
28 if (@$before && @$after) {
29 $modifier_table->{cache} = sub {
30 $_->(@_) for @{$before};
32 ((defined wantarray) ?
34 (@rval = $around->{cache}->(@_))
36 ($rval[0] = $around->{cache}->(@_)))
38 $around->{cache}->(@_));
39 $_->(@_) for @{$after};
40 return unless defined wantarray;
41 return wantarray ? @rval : $rval[0];
44 elsif (@$before && !@$after) {
45 $modifier_table->{cache} = sub {
46 $_->(@_) for @{$before};
47 return $around->{cache}->(@_);
50 elsif (@$after && !@$before) {
51 $modifier_table->{cache} = sub {
53 ((defined wantarray) ?
55 (@rval = $around->{cache}->(@_))
57 ($rval[0] = $around->{cache}->(@_)))
59 $around->{cache}->(@_));
60 $_->(@_) for @{$after};
61 return unless defined wantarray;
62 return wantarray ? @rval : $rval[0];
66 $modifier_table->{cache} = $around->{cache};
71 my ( $class, $code, %params ) = @_;
73 (blessed($code) && $code->isa('Class::MOP::Method'))
74 || confess "Can only wrap blessed CODE";
76 my $modifier_table = {
86 $_build_wrapped_method->($modifier_table);
87 my $method = $class->SUPER::wrap(
88 sub { $modifier_table->{cache}->(@_) },
89 # get these from the original
90 # unless explicitly overriden
91 package_name => $params{package_name} || $code->package_name,
92 name => $params{name} || $code->name,
94 $method->{'%!modifier_table'} = $modifier_table;
98 sub get_original_method {
100 $code->{'%!modifier_table'}->{orig};
103 sub add_before_modifier {
105 my $modifier = shift;
106 unshift @{$code->{'%!modifier_table'}->{before}} => $modifier;
107 $_build_wrapped_method->($code->{'%!modifier_table'});
110 sub add_after_modifier {
112 my $modifier = shift;
113 push @{$code->{'%!modifier_table'}->{after}} => $modifier;
114 $_build_wrapped_method->($code->{'%!modifier_table'});
119 # this is another possible candidate for
120 # optimization as well. There is an overhead
121 # associated with the currying that, if
122 # eliminated might make around modifiers
124 my $compile_around_method = sub {{
126 return $f1 unless @_;
128 push @_, sub { $f2->( $f1, @_ ) };
132 sub add_around_modifier {
134 my $modifier = shift;
135 unshift @{$code->{'%!modifier_table'}->{around}->{methods}} => $modifier;
136 $code->{'%!modifier_table'}->{around}->{cache} = $compile_around_method->(
137 @{$code->{'%!modifier_table'}->{around}->{methods}},
138 $code->{'%!modifier_table'}->{orig}->body
140 $_build_wrapped_method->($code->{'%!modifier_table'});
152 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
156 This is a L<Class::MOP::Method> subclass which provides the funtionality
157 to wrap a given CODE reference with before, after and around method modifiers.
165 =item B<wrap ($code)>
167 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
168 instance that can be used to add before, after and around modifiers to.
170 =item B<get_original_method>
172 This returns the original CODE reference that was provided to the
179 These three methods will add the method modifiers to the wrapped
180 CODE reference. For more information on how method modifiers work,
181 see the section in L<Class::MOP::Class>.
185 =item B<add_before_modifier ($code)>
187 =item B<add_after_modifier ($code)>
189 =item B<add_around_modifier ($code)>
195 Stevan Little E<lt>stevan@iinteractive.comE<gt>
197 =head1 COPYRIGHT AND LICENSE
199 Copyright 2006-2008 by Infinity Interactive, Inc.
201 L<http://www.iinteractive.com>
203 This library is free software; you can redistribute it and/or modify
204 it under the same terms as Perl itself.