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 SYNOPSIS
 149
 150   # ... more to come later maybe
 151
 152 =head1 DESCRIPTION
 153
 154 =head1 METHODS
 155
 156 =head2 Construction
 157
 158 =over 4
 159
 160 =item B<wrap (&code)>
 161
 162 =item B<get_original_method>
 163
 164 =back
 165
 166 =head2 Modifiers
 167
 168 =over 4
 169
 170 =item B<add_before_modifier ($code)>
 171
 172 =item B<add_after_modifier ($code)>
 173
 174 =item B<add_around_modifier ($code)>
 175
 176 =back
 177
 178 =head1 AUTHORS
 179
 180 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 181
 182 =head1 COPYRIGHT AND LICENSE
 183
 184 Copyright 2006-2008 by Infinity Interactive, Inc.
 185
 186 L<http://www.iinteractive.com>
 187
 188 This library is free software; you can redistribute it and/or modify
 189 it under the same terms as Perl itself.
 190
 191 =cut
 192