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.65';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Method';
  14
  15 # NOTE:
  16 # this ugly beast is the result of trying
  17 # to micro optimize this as much as possible
  18 # while not completely loosing maintainability.
  19 # At this point it's "fast enough", after all
  20 # you can't get something for nothing :)
  21 my $_build_wrapped_method = sub {
  22     my $modifier_table = shift;
  23     my ($before, $after, $around) = (
  24         $modifier_table->{before},
  25         $modifier_table->{after},
  26         $modifier_table->{around},
  27     );
  28     if (@$before && @$after) {
  29         $modifier_table->{cache} = sub {
  30             $_->(@_) for @{$before};
  31             my @rval;
  32             ((defined wantarray) ?
  33                 ((wantarray) ?
  34                     (@rval = $around->{cache}->(@_))
  35                     :
  36                     ($rval[0] = $around->{cache}->(@_)))
  37                 :
  38                 $around->{cache}->(@_));
  39             $_->(@_) for @{$after};
  40             return unless defined wantarray;
  41             return wantarray ? @rval : $rval[0];
  42         }
  43     }
  44     elsif (@$before && !@$after) {
  45         $modifier_table->{cache} = sub {
  46             $_->(@_) for @{$before};
  47             return $around->{cache}->(@_);
  48         }
  49     }
  50     elsif (@$after && !@$before) {
  51         $modifier_table->{cache} = sub {
  52             my @rval;
  53             ((defined wantarray) ?
  54                 ((wantarray) ?
  55                     (@rval = $around->{cache}->(@_))
  56                     :
  57                     ($rval[0] = $around->{cache}->(@_)))
  58                 :
  59                 $around->{cache}->(@_));
  60             $_->(@_) for @{$after};
  61             return unless defined wantarray;
  62             return wantarray ? @rval : $rval[0];
  63         }
  64     }
  65     else {
  66         $modifier_table->{cache} = $around->{cache};
  67     }
  68 };
  69
  70 sub wrap {
  71     my ( $class, $code, %params ) = @_;
  72
  73     (blessed($code) && $code->isa('Class::MOP::Method'))
  74         || confess "Can only wrap blessed CODE";
  75
  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(
  88         sub { $modifier_table->{cache}->(@_) },
  89         # get these from the original
  90         # unless explicitly overriden
  91         package_name => $params{package_name} || $code->package_name,
  92         name         => $params{name}         || $code->name,
  93     );
  94     $method->{'modifier_table'} = $modifier_table;
  95     $method;
  96 }
  97
  98 sub get_original_method {
  99     my $code = shift;
 100     $code->{'modifier_table'}->{orig};
 101 }
 102
 103 sub add_before_modifier {
 104     my $code     = shift;
 105     my $modifier = shift;
 106     unshift @{$code->{'modifier_table'}->{before}} => $modifier;
 107     $_build_wrapped_method->($code->{'modifier_table'});
 108 }
 109
 110 sub add_after_modifier {
 111     my $code     = shift;
 112     my $modifier = shift;
 113     push @{$code->{'modifier_table'}->{after}} => $modifier;
 114     $_build_wrapped_method->($code->{'modifier_table'});
 115 }
 116
 117 {
 118     # NOTE:
 119     # this is another possible candidate for
 120     # optimization as well. There is an overhead
 121     # associated with the currying that, if
 122     # eliminated might make around modifiers
 123     # more manageable.
 124     my $compile_around_method = sub {{
 125         my $f1 = pop;
 126         return $f1 unless @_;
 127         my $f2 = pop;
 128         push @_, sub { $f2->( $f1, @_ ) };
 129         redo;
 130     }};
 131
 132     sub add_around_modifier {
 133         my $code     = shift;
 134         my $modifier = shift;
 135         unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
 136         $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
 137             @{$code->{'modifier_table'}->{around}->{methods}},
 138             $code->{'modifier_table'}->{orig}->body
 139         );
 140         $_build_wrapped_method->($code->{'modifier_table'});
 141     }
 142 }
 143
 144 1;
 145
 146 __END__
 147
 148 =pod
 149
 150 =head1 NAME
 151
 152 Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
 153
 154 =head1 DESCRIPTION
 155
 156 This is a L<Class::MOP::Method> subclass which provides the funtionality
 157 to wrap a given CODE reference with before, after and around method modifiers.
 158
 159 =head1 METHODS
 160
 161 =head2 Construction
 162
 163 =over 4
 164
 165 =item B<wrap ($code)>
 166
 167 This is the constructor, it will return a B<Class::MOP::Method::Wrapped>
 168 instance that can be used to add before, after and around modifiers to.
 169
 170 =item B<get_original_method>
 171
 172 This returns the original CODE reference that was provided to the
 173 constructor.
 174
 175 =back
 176
 177 =head2 Modifiers
 178
 179 These three methods will add the method modifiers to the wrapped
 180 CODE reference. For more information on how method modifiers work,
 181 see the section in L<Class::MOP::Class>.
 182
 183 =over 4
 184
 185 =item B<add_before_modifier ($code)>
 186
 187 =item B<add_after_modifier ($code)>
 188
 189 =item B<add_around_modifier ($code)>
 190
 191 =back
 192
 193 =head1 AUTHORS
 194
 195 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 196
 197 =head1 COPYRIGHT AND LICENSE
 198
 199 Copyright 2006-2008 by Infinity Interactive, Inc.
 200
 201 L<http://www.iinteractive.com>
 202
 203 This library is free software; you can redistribute it and/or modify
 204 it under the same terms as Perl itself.
 205
 206 =cut
 207