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