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.73';
  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 @{$before};
  32             my @rval;
  33             ((defined wantarray) ?
  34                 ((wantarray) ?
  35                     (@rval = $around->{cache}->(@_))
  36                     :
  37                     ($rval[0] = $around->{cache}->(@_)))
  38                 :
  39                 $around->{cache}->(@_));
  40             $_->(@_) for @{$after};
  41             return unless defined wantarray;
  42             return wantarray ? @rval : $rval[0];
  43         }
  44     }
  45     elsif (@$before && !@$after) {
  46         $modifier_table->{cache} = sub {
  47             $_->(@_) for @{$before};
  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 @{$after};
  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     my $method = $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     $method->{'modifier_table'} = $modifier_table;
  96     $method;
  97 }
  98
  99 sub get_original_method {
 100     my $code = shift;
 101     $code->{'modifier_table'}->{orig};
 102 }
 103
 104 sub add_before_modifier {
 105     my $code     = shift;
 106     my $modifier = shift;
 107     unshift @{$code->{'modifier_table'}->{before}} => $modifier;
 108     $_build_wrapped_method->($code->{'modifier_table'});
 109 }
 110
 111 sub before_modifiers {
 112     my $code = shift;
 113     return @{$code->{'modifier_table'}->{before}};
 114 }
 115
 116 sub add_after_modifier {
 117     my $code     = shift;
 118     my $modifier = shift;
 119     push @{$code->{'modifier_table'}->{after}} => $modifier;
 120     $_build_wrapped_method->($code->{'modifier_table'});
 121 }
 122
 123 sub after_modifiers {
 124     my $code = shift;
 125     return @{$code->{'modifier_table'}->{after}};
 126 }
 127
 128 {
 129     # NOTE:
 130     # this is another possible candidate for
 131     # optimization as well. There is an overhead
 132     # associated with the currying that, if
 133     # eliminated might make around modifiers
 134     # more manageable.
 135     my $compile_around_method = sub {{
 136         my $f1 = pop;
 137         return $f1 unless @_;
 138         my $f2 = pop;
 139         push @_, sub { $f2->( $f1, @_ ) };
 140         redo;
 141     }};
 142
 143     sub add_around_modifier {
 144         my $code     = shift;
 145         my $modifier = shift;
 146         unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
 147         $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
 148             @{$code->{'modifier_table'}->{around}->{methods}},
 149             $code->{'modifier_table'}->{orig}->body
 150         );
 151         $_build_wrapped_method->($code->{'modifier_table'});
 152     }
 153 }
 154
 155 sub around_modifiers {
 156     my $code = shift;
 157     return @{$code->{'modifier_table'}->{around}->{methods}};
 158 }
 159
 160 1;
 161
 162 __END__
 163
 164 =pod
 165
 166 =head1 NAME
 167
 168 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
 169
 170 =head1 DESCRIPTION
 171
 172 This is a L<Class::MOP::Method> subclass which provides the funtionality
 173 to wrap a given CODE reference with before, after and around method modifiers.
 174
 175 =head1 METHODS
 176
 177 =head2 Construction
 178
 179 =over 4
 180
 181 =item B<wrap ($code)>
 182
 183 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
 184 instance that can be used to add before, after and around modifiers to.
 185
 186 =item B<get_original_method>
 187
 188 This returns the original CODE reference that was provided to the
 189 constructor.
 190
 191 =back
 192
 193 =head2 Modifiers
 194
 195 These three methods will add the method modifiers to the wrapped
 196 CODE reference. For more information on how method modifiers work,
 197 see the section in L<Class::MOP::Class>.
 198
 199 =over 4
 200
 201 =item B<add_before_modifier ($code)>
 202
 203 =item B<add_after_modifier ($code)>
 204
 205 =item B<add_around_modifier ($code)>
 206
 207 =back
 208
 209 These three methods each returna list of method modifiers I<in the
 210 order in which they are run>.
 211
 212 =over 4
 213
 214 =item B<before_modifiers>
 215
 216 =item B<after_modifiers>
 217
 218 =item B<around_modifiers>
 219
 220 =back
 221
 222 =head1 AUTHORS
 223
 224 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 225
 226 =head1 COPYRIGHT AND LICENSE
 227
 228 Copyright 2006-2008 by Infinity Interactive, Inc.
 229
 230 L<http://www.iinteractive.com>
 231
 232 This library is free software; you can redistribute it and/or modify
 233 it under the same terms as Perl itself.
 234
 235 =cut
 236