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 canidate 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 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 183
 184 =head1 COPYRIGHT AND LICENSE
 185
 186 Copyright 2006 by Infinity Interactive, Inc.
 187
 188 L<http://www.iinteractive.com>
 189
 190 This library is free software; you can redistribute it and/or modify
 191 it under the same terms as Perl itself.
 192
 193 =cut
 194