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