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