2 package Class::MOP::Method::Wrapped;
8 use Scalar::Util 'blessed';
10 our $VERSION = '0.64_01';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Method';
17 # this ugly beast is the result of trying
18 # to micro optimize this as much as possible
19 # while not completely loosing maintainability.
20 # At this point it's "fast enough", after all
21 # you can't get something for nothing :)
22 my $_build_wrapped_method = sub {
23 my $modifier_table = shift;
24 my ($before, $after, $around) = (
25 $modifier_table->{before},
26 $modifier_table->{after},
27 $modifier_table->{around},
29 if (@$before && @$after) {
30 $modifier_table->{cache} = sub {
31 $_->(@_) for @{$before};
33 ((defined wantarray) ?
35 (@rval = $around->{cache}->(@_))
37 ($rval[0] = $around->{cache}->(@_)))
39 $around->{cache}->(@_));
40 $_->(@_) for @{$after};
41 return unless defined wantarray;
42 return wantarray ? @rval : $rval[0];
45 elsif (@$before && !@$after) {
46 $modifier_table->{cache} = sub {
47 $_->(@_) for @{$before};
48 return $around->{cache}->(@_);
51 elsif (@$after && !@$before) {
52 $modifier_table->{cache} = sub {
54 ((defined wantarray) ?
56 (@rval = $around->{cache}->(@_))
58 ($rval[0] = $around->{cache}->(@_)))
60 $around->{cache}->(@_));
61 $_->(@_) for @{$after};
62 return unless defined wantarray;
63 return wantarray ? @rval : $rval[0];
67 $modifier_table->{cache} = $around->{cache};
72 my ( $class, $code, %params ) = @_;
74 (blessed($code) && $code->isa('Class::MOP::Method'))
75 || confess "Can only wrap blessed CODE";
77 my $modifier_table = {
87 $_build_wrapped_method->($modifier_table);
88 my $method = $class->SUPER::wrap(
89 sub { $modifier_table->{cache}->(@_) },
90 # get these from the original
91 # unless explicitly overriden
92 package_name => $params{package_name} || $code->package_name,
93 name => $params{name} || $code->name,
95 $method->{'modifier_table'} = $modifier_table;
99 sub get_original_method {
101 $code->{'modifier_table'}->{orig};
104 sub add_before_modifier {
106 my $modifier = shift;
107 unshift @{$code->{'modifier_table'}->{before}} => $modifier;
108 $_build_wrapped_method->($code->{'modifier_table'});
111 sub add_after_modifier {
113 my $modifier = shift;
114 push @{$code->{'modifier_table'}->{after}} => $modifier;
115 $_build_wrapped_method->($code->{'modifier_table'});
120 # this is another possible candidate for
121 # optimization as well. There is an overhead
122 # associated with the currying that, if
123 # eliminated might make around modifiers
125 my $compile_around_method = sub {{
127 return $f1 unless @_;
129 push @_, sub { $f2->( $f1, @_ ) };
133 sub add_around_modifier {
135 my $modifier = shift;
136 unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
137 $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
138 @{$code->{'modifier_table'}->{around}->{methods}},
139 $code->{'modifier_table'}->{orig}->body
141 $_build_wrapped_method->($code->{'modifier_table'});
153 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
157 This is a L<Class::MOP::Method> subclass which provides the funtionality
158 to wrap a given CODE reference with before, after and around method modifiers.
166 =item B<wrap ($code)>
168 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
169 instance that can be used to add before, after and around modifiers to.
171 =item B<get_original_method>
173 This returns the original CODE reference that was provided to the
180 These three methods will add the method modifiers to the wrapped
181 CODE reference. For more information on how method modifiers work,
182 see the section in L<Class::MOP::Class>.
186 =item B<add_before_modifier ($code)>
188 =item B<add_after_modifier ($code)>
190 =item B<add_around_modifier ($code)>
196 Stevan Little E<lt>stevan@iinteractive.comE<gt>
198 =head1 COPYRIGHT AND LICENSE
200 Copyright 2006-2008 by Infinity Interactive, Inc.
202 L<http://www.iinteractive.com>
204 This library is free software; you can redistribute it and/or modify
205 it under the same terms as Perl itself.