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.64_04';
  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 add_after_modifier {
 112     my $code     = shift;
 113     my $modifier = shift;
 114     push @{$code->{'modifier_table'}->{after}} => $modifier;
 115     $_build_wrapped_method->($code->{'modifier_table'});
 116 }
 117
 118 {
 119     # NOTE:
 120     # this is another possible candidate for
 121     # optimization as well. There is an overhead
 122     # associated with the currying that, if
 123     # eliminated might make around modifiers
 124     # more manageable.
 125     my $compile_around_method = sub {{
 126         my $f1 = pop;
 127         return $f1 unless @_;
 128         my $f2 = pop;
 129         push @_, sub { $f2->( $f1, @_ ) };
 130         redo;
 131     }};
 132
 133     sub add_around_modifier {
 134         my $code     = shift;
 135         my $modifier = shift;
 136         unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
 137         $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
 138             @{$code->{'modifier_table'}->{around}->{methods}},
 139             $code->{'modifier_table'}->{orig}->body
 140         );
 141         $_build_wrapped_method->($code->{'modifier_table'});
 142     }
 143 }
 144
 145 1;
 146
 147 __END__
 148
 149 =pod
 150
 151 =head1 NAME
 152
 153 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
 154
 155 =head1 DESCRIPTION
 156
 157 This is a L<Class::MOP::Method> subclass which provides the funtionality
 158 to wrap a given CODE reference with before, after and around method modifiers.
 159
 160 =head1 METHODS
 161
 162 =head2 Construction
 163
 164 =over 4
 165
 166 =item B<wrap ($code)>
 167
 168 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
 169 instance that can be used to add before, after and around modifiers to.
 170
 171 =item B<get_original_method>
 172
 173 This returns the original CODE reference that was provided to the
 174 constructor.
 175
 176 =back
 177
 178 =head2 Modifiers
 179
 180 These three methods will add the method modifiers to the wrapped
 181 CODE reference. For more information on how method modifiers work,
 182 see the section in L<Class::MOP::Class>.
 183
 184 =over 4
 185
 186 =item B<add_before_modifier ($code)>
 187
 188 =item B<add_after_modifier ($code)>
 189
 190 =item B<add_around_modifier ($code)>
 191
 192 =back
 193
 194 =head1 AUTHORS
 195
 196 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 197
 198 =head1 COPYRIGHT AND LICENSE
 199
 200 Copyright 2006-2008 by Infinity Interactive, Inc.
 201
 202 L<http://www.iinteractive.com>
 203
 204 This library is free software; you can redistribute it and/or modify
 205 it under the same terms as Perl itself.
 206
 207 =cut
 208