lib/Class/MOP/Method/Wrapped.pm

   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
  10 our $VERSION   = '0.83';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Method';
  15
  16 # NOTE:
  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},
  28     );
  29     if (@$before && @$after) {
  30         $modifier_table->{cache} = sub {
  31             $_->(@_) for @{$before};
  32             my @rval;
  33             ((defined wantarray) ?
  34                 ((wantarray) ?
  35                     (@rval = $around->{cache}->(@_))
  36                     :
  37                     ($rval[0] = $around->{cache}->(@_)))
  38                 :
  39                 $around->{cache}->(@_));
  40             $_->(@_) for @{$after};
  41             return unless defined wantarray;
  42             return wantarray ? @rval : $rval[0];
  43         }
  44     }
  45     elsif (@$before && !@$after) {
  46         $modifier_table->{cache} = sub {
  47             $_->(@_) for @{$before};
  48             return $around->{cache}->(@_);
  49         }
  50     }
  51     elsif (@$after && !@$before) {
  52         $modifier_table->{cache} = sub {
  53             my @rval;
  54             ((defined wantarray) ?
  55                 ((wantarray) ?
  56                     (@rval = $around->{cache}->(@_))
  57                     :
  58                     ($rval[0] = $around->{cache}->(@_)))
  59                 :
  60                 $around->{cache}->(@_));
  61             $_->(@_) for @{$after};
  62             return unless defined wantarray;
  63             return wantarray ? @rval : $rval[0];
  64         }
  65     }
  66     else {
  67         $modifier_table->{cache} = $around->{cache};
  68     }
  69 };
  70
  71 sub wrap {
  72     my ( $class, $code, %params ) = @_;
  73
  74     (blessed($code) && $code->isa('Class::MOP::Method'))
  75         || confess "Can only wrap blessed CODE";
  76
  77     my $modifier_table = {
  78         cache  => undef,
  79         orig   => $code,
  80         before => [],
  81         after  => [],
  82         around => {
  83             cache   => $code->body,
  84             methods => [],
  85         },
  86     };
  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,
  94     );
  95     $method->{'modifier_table'} = $modifier_table;
  96     $method;
  97 }
  98
  99 sub get_original_method {
 100     my $code = shift;
 101     $code->{'modifier_table'}->{orig};
 102 }
 103
 104 sub add_before_modifier {
 105     my $code     = shift;
 106     my $modifier = shift;
 107     unshift @{$code->{'modifier_table'}->{before}} => $modifier;
 108     $_build_wrapped_method->($code->{'modifier_table'});
 109 }
 110
 111 sub before_modifiers {
 112     my $code = shift;
 113     return @{$code->{'modifier_table'}->{before}};
 114 }
 115
 116 sub add_after_modifier {
 117     my $code     = shift;
 118     my $modifier = shift;
 119     push @{$code->{'modifier_table'}->{after}} => $modifier;
 120     $_build_wrapped_method->($code->{'modifier_table'});
 121 }
 122
 123 sub after_modifiers {
 124     my $code = shift;
 125     return @{$code->{'modifier_table'}->{after}};
 126 }
 127
 128 {
 129     # NOTE:
 130     # this is another possible candidate for
 131     # optimization as well. There is an overhead
 132     # associated with the currying that, if
 133     # eliminated might make around modifiers
 134     # more manageable.
 135     my $compile_around_method = sub {{
 136         my $f1 = pop;
 137         return $f1 unless @_;
 138         my $f2 = pop;
 139         push @_, sub { $f2->( $f1, @_ ) };
 140         redo;
 141     }};
 142
 143     sub add_around_modifier {
 144         my $code     = shift;
 145         my $modifier = shift;
 146         unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
 147         $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
 148             @{$code->{'modifier_table'}->{around}->{methods}},
 149             $code->{'modifier_table'}->{orig}->body
 150         );
 151         $_build_wrapped_method->($code->{'modifier_table'});
 152     }
 153 }
 154
 155 sub around_modifiers {
 156     my $code = shift;
 157     return @{$code->{'modifier_table'}->{around}->{methods}};
 158 }
 159
 160 1;
 161
 162 __END__
 163
 164 =pod
 165
 166 =head1 NAME
 167
 168 Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
 169
 170 =head1 DESCRIPTION
 171
 172 This is a L<Class::MOP::Method> subclass which implements before,
 173 after, and around method modifiers.
 174
 175 =head1 METHODS
 176
 177 =head2 Construction
 178
 179 =over 4
 180
 181 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
 182
 183 This is the constructor. It accepts a L<Class::MOP::Method> object and
 184 a hash of options.
 185
 186 The options are:
 187
 188 =over 8
 189
 190 =item * name
 191
 192 The method name (without a package name). This will be taken from the
 193 provided L<Class::MOP::Method> object if it is not provided.
 194
 195 =item * package_name
 196
 197 The package name for the method. This will be taken from the provided
 198 L<Class::MOP::Method> object if it is not provided.
 199
 200 =item * associated_metaclass
 201
 202 An optional L<Class::MOP::Class> object. This is the metaclass for the
 203 method's class.
 204
 205 =back
 206
 207 =item B<< $metamethod->get_original_method >>
 208
 209 This returns the L<Class::MOP::Method> object that was passed to the
 210 constructor.
 211
 212 =item B<< $metamethod->add_before_modifier($code) >>
 213
 214 =item B<< $metamethod->add_after_modifier($code) >>
 215
 216 =item B<< $metamethod->add_around_modifier($code) >>
 217
 218 These methods all take a subroutine reference and apply it as a
 219 modifier to the original method.
 220
 221 =item B<< $metamethod->before_modifiers >>
 222
 223 =item B<< $metamethod->after_modifiers >>
 224
 225 =item B<< $metamethod->around_modifiers >>
 226
 227 These methods all return a list of subroutine references which are
 228 acting as the specified type of modifier.
 229
 230 =back
 231
 232 =head1 AUTHORS
 233
 234 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 235
 236 =head1 COPYRIGHT AND LICENSE
 237
 238 Copyright 2006-2009 by Infinity Interactive, Inc.
 239
 240 L<http://www.iinteractive.com>
 241
 242 This library is free software; you can redistribute it and/or modify
 243 it under the same terms as Perl itself.
 244
 245 =cut
 246