buncha crap

[gitmo/Class-MOP.git] / lib / Class / MOP / Method.pm

diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index c4aa852..c0ed04c 100644 (file)
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -19,62 +19,14 @@ sub meta {
 
 # construction
 
-sub new { 
+sub wrap { 
     my $class = shift;
     my $code  = shift;
-    (reftype($code) && reftype($code) eq 'CODE')
+    ('CODE' eq (reftype($code) || ''))
         || confess "You must supply a CODE reference to bless";
     bless $code => blessed($class) || $class;
 }
 
-{
-       my %MODIFIERS;
-       
-       sub wrap {
-               my $code = shift;
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-               my $modifier_table = { before => [], after => [] };
-               my $method = $code->new(sub {
-                       $_->(@_) for @{$modifier_table->{before}};
-                       # NOTE: 
-                       # we actually need to be sure to preserve 
-                       # the calling context and call this method
-                       # with the same context too. This just 
-                       # requires some bookkeeping code, thats all.                    
-                       my @rval = $code->(@_);
-                       $_->(@_) for @{$modifier_table->{after}};                       
-                       return wantarray ? @rval : $rval[0];
-               });     
-               $MODIFIERS{$method} = $modifier_table;
-               $method;  
-       }
-       
-       sub add_before_modifier {
-               my $code     = shift;
-               my $modifier = shift;
-               (exists $MODIFIERS{$code})
-                       || confess "You must first wrap your method before adding a modifier";          
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-           (reftype($modifier) && reftype($modifier) eq 'CODE')
-               || confess "You must supply a CODE reference for a modifier";                   
-               unshift @{$MODIFIERS{$code}->{before}} => $modifier;
-       }
-       
-       sub add_after_modifier {
-               my $code     = shift;
-               my $modifier = shift;
-               (exists $MODIFIERS{$code})
-                       || confess "You must first wrap your method before adding a modifier";          
-               (blessed($code))
-                       || confess "Can only ask the package name of a blessed CODE";
-           (reftype($modifier) && reftype($modifier) eq 'CODE')
-               || confess "You must supply a CODE reference for a modifier";                   
-               push @{$MODIFIERS{$code}->{after}} => $modifier;
-       }       
-}
-
 # informational
 
 sub package_name { 
@@ -91,6 +43,106 @@ sub name {
        svref_2object($code)->GV->NAME;
 }
 
+package Class::MOP::Method::Wrapped;
+
+use strict;
+use warnings;
+
+use Carp         'confess';
+use Scalar::Util 'reftype', 'blessed';
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');     
+
+my %MODIFIERS;
+
+sub wrap {
+       my $class = shift;
+       my $code  = shift;
+       (blessed($code) && $code->isa('Class::MOP::Method'))
+               || confess "Can only wrap blessed CODE";
+       my $modifier_table = { 
+               orig   => $code,
+               before => [],
+               after  => [],           
+               around => {
+                       cache   => $code,
+                       methods => [],
+               },
+       };
+       my $method = $class->SUPER::wrap(sub {
+               $_->(@_) for @{$modifier_table->{before}};
+               my (@rlist, $rval);
+               if (defined wantarray) {
+                       if (wantarray) {
+                               @rlist = $modifier_table->{around}->{cache}->(@_);
+                       }
+                       else {
+                               $rval = $modifier_table->{around}->{cache}->(@_);
+                       }
+               }
+               else {
+                       $modifier_table->{around}->{cache}->(@_);
+               }
+               $_->(@_) for @{$modifier_table->{after}};                       
+               return unless defined wantarray;
+               return wantarray ? @rlist : $rval;
+       });     
+       $MODIFIERS{$method} = $modifier_table;
+       $method;  
+}
+
+sub add_before_modifier {
+       my $code     = shift;
+       my $modifier = shift;
+       (exists $MODIFIERS{$code})
+               || confess "You must first wrap your method before adding a modifier";          
+       (blessed($code))
+               || confess "Can only ask the package name of a blessed CODE";
+       ('CODE' eq (reftype($code) || ''))
+        || confess "You must supply a CODE reference for a modifier";                  
+       unshift @{$MODIFIERS{$code}->{before}} => $modifier;
+}
+
+sub add_after_modifier {
+       my $code     = shift;
+       my $modifier = shift;
+       (exists $MODIFIERS{$code})
+               || confess "You must first wrap your method before adding a modifier";          
+       (blessed($code))
+               || confess "Can only ask the package name of a blessed CODE";
+    ('CODE' eq (reftype($code) || ''))
+        || confess "You must supply a CODE reference for a modifier";                  
+       push @{$MODIFIERS{$code}->{after}} => $modifier;
+}
+
+{
+       my $compile_around_method = sub {{
+       my $f1 = pop;
+       return $f1 unless @_;
+       my $f2 = pop;
+       push @_, sub { $f2->( $f1, @_ ) };
+               redo;
+       }};
+
+       sub add_around_modifier {
+               my $code     = shift;
+               my $modifier = shift;
+               (exists $MODIFIERS{$code})
+                       || confess "You must first wrap your method before adding a modifier";          
+               (blessed($code))
+                       || confess "Can only ask the package name of a blessed CODE";
+           ('CODE' eq (reftype($code) || ''))
+               || confess "You must supply a CODE reference for a modifier";                   
+               unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;         
+               $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
+                       @{$MODIFIERS{$code}->{around}->{methods}},
+                       $MODIFIERS{$code}->{orig}
+               );
+       }       
+}
+
 1;
 
 __END__
@@ -132,10 +184,14 @@ to this class.
 
 =over 4
 
-=item B<new (&code)>
+=item B<wrap (&code)>
 
 This simply blesses the C<&code> reference passed to it.
 
+=item B<wrap>
+
+This wraps an existing method so that it can handle method modifiers.
+
 =back
 
 =head2 Informational
@@ -148,11 +204,17 @@ This simply blesses the C<&code> reference passed to it.
 
 =back
 
-=head1 SEE ALSO
+=head2 Modifiers
+
+=over 4
+
+=item B<add_before_modifier ($code)>
+
+=item B<add_after_modifier ($code)>
 
-http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
+=item B<add_around_modifier ($code)>
 
-http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
+=back
 
 =head1 AUTHOR