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