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 use base 'Class::MOP::Method';
  11
  12 # NOTE:
  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},
  24     );
  25     if (@$before && @$after) {
  26         $modifier_table->{cache} = sub {
  27             for my $c (@$before) { $c->(@_) };
  28             my @rval;
  29             ((defined wantarray) ?
  30                 ((wantarray) ?
  31                     (@rval = $around->{cache}->(@_))
  32                     :
  33                     ($rval[0] = $around->{cache}->(@_)))
  34                 :
  35                 $around->{cache}->(@_));
  36             for my $c (@$after) { $c->(@_) };
  37             return unless defined wantarray;
  38             return wantarray ? @rval : $rval[0];
  39         }
  40     }
  41     elsif (@$before && !@$after) {
  42         $modifier_table->{cache} = sub {
  43             for my $c (@$before) { $c->(@_) };
  44             return $around->{cache}->(@_);
  45         }
  46     }
  47     elsif (@$after && !@$before) {
  48         $modifier_table->{cache} = sub {
  49             my @rval;
  50             ((defined wantarray) ?
  51                 ((wantarray) ?
  52                     (@rval = $around->{cache}->(@_))
  53                     :
  54                     ($rval[0] = $around->{cache}->(@_)))
  55                 :
  56                 $around->{cache}->(@_));
  57             for my $c (@$after) { $c->(@_) };
  58             return unless defined wantarray;
  59             return wantarray ? @rval : $rval[0];
  60         }
  61     }
  62     else {
  63         $modifier_table->{cache} = $around->{cache};
  64     }
  65 };
  66
  67 sub wrap {
  68     my ( $class, $code, %params ) = @_;
  69
  70     (blessed($code) && $code->isa('Class::MOP::Method'))
  71         || confess "Can only wrap blessed CODE";
  72
  73     my $modifier_table = {
  74         cache  => undef,
  75         orig   => $code,
  76         before => [],
  77         after  => [],
  78         around => {
  79             cache   => $code->body,
  80             methods => [],
  81         },
  82     };
  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
  91         modifier_table => $modifier_table,
  92     );
  93 }
  94
  95 sub _new {
  96     my $class = shift;
  97     return Class::MOP::Class->initialize($class)->new_object(@_)
  98         if $class ne __PACKAGE__;
  99
 100     my $params = @_ == 1 ? $_[0] : {@_};
 101
 102     return bless {
 103         # inherited from Class::MOP::Method
 104         'body'                 => $params->{body},
 105         'associated_metaclass' => $params->{associated_metaclass},
 106         'package_name'         => $params->{package_name},
 107         'name'                 => $params->{name},
 108         'original_method'      => $params->{original_method},
 109
 110         # defined in this class
 111         'modifier_table'       => $params->{modifier_table}
 112     } => $class;
 113 }
 114
 115 sub get_original_method {
 116     my $code = shift;
 117     $code->{'modifier_table'}->{orig};
 118 }
 119
 120 sub add_before_modifier {
 121     my $code     = shift;
 122     my $modifier = shift;
 123     unshift @{$code->{'modifier_table'}->{before}} => $modifier;
 124     $_build_wrapped_method->($code->{'modifier_table'});
 125 }
 126
 127 sub before_modifiers {
 128     my $code = shift;
 129     return @{$code->{'modifier_table'}->{before}};
 130 }
 131
 132 sub add_after_modifier {
 133     my $code     = shift;
 134     my $modifier = shift;
 135     push @{$code->{'modifier_table'}->{after}} => $modifier;
 136     $_build_wrapped_method->($code->{'modifier_table'});
 137 }
 138
 139 sub after_modifiers {
 140     my $code = shift;
 141     return @{$code->{'modifier_table'}->{after}};
 142 }
 143
 144 {
 145     # NOTE:
 146     # this is another possible candidate for
 147     # optimization as well. There is an overhead
 148     # associated with the currying that, if
 149     # eliminated might make around modifiers
 150     # more manageable.
 151     my $compile_around_method = sub {{
 152         my $f1 = pop;
 153         return $f1 unless @_;
 154         my $f2 = pop;
 155         push @_, sub { $f2->( $f1, @_ ) };
 156         redo;
 157     }};
 158
 159     sub add_around_modifier {
 160         my $code     = shift;
 161         my $modifier = shift;
 162         unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
 163         $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
 164             @{$code->{'modifier_table'}->{around}->{methods}},
 165             $code->{'modifier_table'}->{orig}->body
 166         );
 167         $_build_wrapped_method->($code->{'modifier_table'});
 168     }
 169 }
 170
 171 sub around_modifiers {
 172     my $code = shift;
 173     return @{$code->{'modifier_table'}->{around}->{methods}};
 174 }
 175
 176 sub _make_compatible_with {
 177     my $self = shift;
 178     my ($other) = @_;
 179
 180     # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
 181     # objects are subclasses of CMOP::Method, but when we get to moose, they'll
 182     # need to be compatible with Moose::Meta::Method, which isn't possible. the
 183     # right solution here is to make ::Wrapped into a role that gets applied to
 184     # whatever the method_metaclass happens to be and get rid of
 185     # wrapped_method_metaclass entirely, but that's not going to happen until
 186     # we ditch cmop and get roles into the bootstrapping, so. i'm not
 187     # maintaining the previous behavior of turning them into instances of the
 188     # new method_metaclass because that's equally broken, and at least this way
 189     # any issues will at least be detectable and potentially fixable. -doy
 190     return $self unless $other->_is_compatible_with($self->_real_ref_name);
 191
 192     return $self->SUPER::_make_compatible_with(@_);
 193 }
 194
 195 1;
 196
 197 # ABSTRACT: Method Meta Object for methods with before/after/around modifiers
 198
 199 __END__
 200
 201 =pod
 202
 203 =head1 DESCRIPTION
 204
 205 This is a L<Class::MOP::Method> subclass which implements before,
 206 after, and around method modifiers.
 207
 208 =head1 METHODS
 209
 210 =head2 Construction
 211
 212 =over 4
 213
 214 =item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
 215
 216 This is the constructor. It accepts a L<Class::MOP::Method> object and
 217 a hash of options.
 218
 219 The options are:
 220
 221 =over 8
 222
 223 =item * name
 224
 225 The method name (without a package name). This will be taken from the
 226 provided L<Class::MOP::Method> object if it is not provided.
 227
 228 =item * package_name
 229
 230 The package name for the method. This will be taken from the provided
 231 L<Class::MOP::Method> object if it is not provided.
 232
 233 =item * associated_metaclass
 234
 235 An optional L<Class::MOP::Class> object. This is the metaclass for the
 236 method's class.
 237
 238 =back
 239
 240 =item B<< $metamethod->get_original_method >>
 241
 242 This returns the L<Class::MOP::Method> object that was passed to the
 243 constructor.
 244
 245 =item B<< $metamethod->add_before_modifier($code) >>
 246
 247 =item B<< $metamethod->add_after_modifier($code) >>
 248
 249 =item B<< $metamethod->add_around_modifier($code) >>
 250
 251 These methods all take a subroutine reference and apply it as a
 252 modifier to the original method.
 253
 254 =item B<< $metamethod->before_modifiers >>
 255
 256 =item B<< $metamethod->after_modifiers >>
 257
 258 =item B<< $metamethod->around_modifiers >>
 259
 260 These methods all return a list of subroutine references which are
 261 acting as the specified type of modifier.
 262
 263 =back
 264
 265 =cut
 266