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 'reftype', 'blessed';
   9 use Sub::Name    'subname';
  10
  11 our $VERSION   = '0.02';
  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 = shift;
  73     my $code  = shift;
  74     (blessed($code) && $code->isa('Class::MOP::Method'))
  75         || confess "Can only wrap blessed CODE";
  76     my $modifier_table = {
  77         cache  => undef,
  78         orig   => $code,
  79         before => [],
  80         after  => [],
  81         around => {
  82             cache   => $code->body,
  83             methods => [],
  84         },
  85     };
  86     $_build_wrapped_method->($modifier_table);
  87     my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
  88     $method->{'%!modifier_table'} = $modifier_table;
  89     $method;
  90 }
  91
  92 sub get_original_method {
  93     my $code = shift;
  94     $code->{'%!modifier_table'}->{orig};
  95 }
  96
  97 sub add_before_modifier {
  98     my $code     = shift;
  99     my $modifier = shift;
 100     unshift @{$code->{'%!modifier_table'}->{before}} => $modifier;
 101     $_build_wrapped_method->($code->{'%!modifier_table'});
 102 }
 103
 104 sub add_after_modifier {
 105     my $code     = shift;
 106     my $modifier = shift;
 107     push @{$code->{'%!modifier_table'}->{after}} => $modifier;
 108     $_build_wrapped_method->($code->{'%!modifier_table'});
 109 }
 110
 111 {
 112     # NOTE:
 113     # this is another possible candidate for
 114     # optimization as well. There is an overhead
 115     # associated with the currying that, if
 116     # eliminated might make around modifiers
 117     # more manageable.
 118     my $compile_around_method = sub {{
 119         my $f1 = pop;
 120         return $f1 unless @_;
 121         my $f2 = pop;
 122         push @_, sub { $f2->( $f1, @_ ) };
 123         redo;
 124     }};
 125
 126     sub add_around_modifier {
 127         my $code     = shift;
 128         my $modifier = shift;
 129         unshift @{$code->{'%!modifier_table'}->{around}->{methods}} => $modifier;
 130         $code->{'%!modifier_table'}->{around}->{cache} = $compile_around_method->(
 131             @{$code->{'%!modifier_table'}->{around}->{methods}},
 132             $code->{'%!modifier_table'}->{orig}->body
 133         );
 134         $_build_wrapped_method->($code->{'%!modifier_table'});
 135     }
 136 }
 137
 138 1;
 139
 140 __END__
 141
 142 =pod
 143
 144 =head1 NAME
 145
 146 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
 147
 148 =head1 DESCRIPTION
 149
 150 This is a L<Class::MOP::Method> subclass which provides the funtionality
 151 to wrap a given CODE reference with before, after and around method modifiers.
 152
 153 =head1 METHODS
 154
 155 =head2 Construction
 156
 157 =over 4
 158
 159 =item B<wrap ($code)>
 160
 161 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
 162 instance that can be used to add before, after and around modifiers to.
 163
 164 =item B<get_original_method>
 165
 166 This returns the original CODE reference that was provided to the
 167 constructor.
 168
 169 =back
 170
 171 =head2 Modifiers
 172
 173 These three methods will add the method modifiers to the wrapped
 174 CODE reference. For more information on how method modifiers work,
 175 see the section in L<Class::MOP::Class>.
 176
 177 =over 4
 178
 179 =item B<add_before_modifier ($code)>
 180
 181 =item B<add_after_modifier ($code)>
 182
 183 =item B<add_around_modifier ($code)>
 184
 185 =back
 186
 187 =head1 AUTHORS
 188
 189 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 190
 191 =head1 COPYRIGHT AND LICENSE
 192
 193 Copyright 2006-2008 by Infinity Interactive, Inc.
 194
 195 L<http://www.iinteractive.com>
 196
 197 This library is free software; you can redistribute it and/or modify
 198 it under the same terms as Perl itself.
 199
 200 =cut
 201