more method modifier stuff

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 542c968..96c8539 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -230,7 +230,7 @@ sub add_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
     # use reftype here to allow for blessed subs ...
-    (reftype($method) && reftype($method) eq 'CODE')
+    ('CODE' eq (reftype($method) || ''))
         || confess "Your code block must be a CODE reference";
     my $full_method_name = ($self->name . '::' . $method_name);    
 
@@ -241,12 +241,16 @@ sub add_method {
     *{$full_method_name} = subname $full_method_name => $method;
 }
 
+sub add_method_modifier {
+       
+}
+
 sub alias_method {
     my ($self, $method_name, $method) = @_;
     (defined $method_name && $method_name)
         || confess "You must define a method name";
     # use reftype here to allow for blessed subs ...
-    (reftype($method) && reftype($method) eq 'CODE')
+    ('CODE' eq (reftype($method) || ''))
         || confess "Your code block must be a CODE reference";
     my $full_method_name = ($self->name . '::' . $method_name);
 
@@ -713,6 +717,8 @@ other than use B<Sub::Name> to make sure it is tagged with the
 correct name, and therefore show up correctly in stack traces and 
 such.
 
+=item B<add_method_modifier ($modifier_type, $code)>
+
 =item B<alias_method ($method_name, $method)>
 
 This will take a C<$method_name> and CODE reference to that 

diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index 912368a..ef479f3 100644 (file)
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -22,7 +22,7 @@ sub meta {
 sub new { 
     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;
 }
@@ -72,7 +72,7 @@ sub new {
                        || 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')
+       ('CODE' eq (reftype($code) || ''))
                || confess "You must supply a CODE reference for a modifier";                   
                unshift @{$MODIFIERS{$code}->{before}} => $modifier;
        }
@@ -84,7 +84,7 @@ sub new {
                        || 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')
+           ('CODE' eq (reftype($code) || ''))
                || confess "You must supply a CODE reference for a modifier";                   
                push @{$MODIFIERS{$code}->{after}} => $modifier;
        }
@@ -105,7 +105,7 @@ sub new {
                                || 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')
+                   ('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->(
@@ -177,6 +177,10 @@ to this class.
 
 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
@@ -189,11 +193,17 @@ This simply blesses the C<&code> reference passed to it.
 
 =back
 
-=head1 SEE ALSO
+=head2 Modifiers
+
+=over 4
 
-http://dirtsimple.org/2005/01/clos-style-method-combination-for.html
+=item B<add_before_modifier ($code)>
 
-http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html
+=item B<add_after_modifier ($code)>
+
+=item B<add_around_modifier ($code)>
+
+=back
 
 =head1 AUTHOR
 

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index c8308b6..d5dafa9 100644 (file)
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 118;
+use Test::More tests => 120;
 use Test::Exception;
 
 BEGIN {
@@ -37,6 +37,8 @@ my @methods = qw(
     has_method get_method add_method remove_method alias_method
     get_method_list compute_all_applicable_methods find_all_methods_by_name
     
+       add_method_modifier
+
     has_attribute get_attribute add_attribute remove_attribute
     get_attribute_list get_attribute_map compute_all_applicable_attributes
     

diff --git a/t/031_method_modifiers.t b/t/031_method_modifiers.t
index 5bd4d3d..a1d019e 100644 (file)
--- a/t/031_method_modifiers.t
+++ b/t/031_method_modifiers.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More no_plan => 18;
+use Test::More tests => 23;
 use Test::Exception;
 
 BEGIN {
@@ -73,7 +73,44 @@ BEGIN {
        is(scalar $wrapped->(), 4, '... got the right results back from the around methods (in scalar context)');               
 }
 
-
+{
+       my @tracelog;
+       
+       my $method = Class::MOP::Method->new(sub { push @tracelog => 'primary' });
+       isa_ok($method, 'Class::MOP::Method');
+       
+       my $wrapped = $method->wrap();
+       isa_ok($wrapped, 'Class::MOP::Method'); 
+       
+       lives_ok {
+               $wrapped->add_before_modifier(sub { push @tracelog => 'before 1' });
+               $wrapped->add_before_modifier(sub { push @tracelog => 'before 2' });            
+               $wrapped->add_before_modifier(sub { push @tracelog => 'before 3' });            
+       } '... added the before modifier okay';
+       
+       lives_ok {
+               $wrapped->add_around_modifier(sub { push @tracelog => 'around 3'; $_[0]->(); });                
+               $wrapped->add_around_modifier(sub { push @tracelog => 'around 2'; $_[0]->(); });
+               $wrapped->add_around_modifier(sub { push @tracelog => 'around 1'; $_[0]->(); });                                                
+       } '... added the around modifier okay'; 
+       
+       lives_ok {
+               $wrapped->add_after_modifier(sub { push @tracelog => 'after 3' });
+               $wrapped->add_after_modifier(sub { push @tracelog => 'after 2' });
+               $wrapped->add_after_modifier(sub { push @tracelog => 'after 1' });                              
+       } '... added the after modifier okay';  
+       
+       $wrapped->();
+       is_deeply(
+               \@tracelog,
+               [ 
+                 'before 3', 'before 2', 'before 1',  # last-in-first-out order
+                 'around 1', 'around 2', 'around 3',  # last-in-first-out order
+                 'primary',
+                 'after 3', 'after 2', 'after 1',     # first-in-first-out order
+               ],
+               '... got the right tracelog from all our before/around/after methods');
+}