supported RegExp method name for before/after/around method modifier.

tried override and augment, but they don't work. so, made a TODO test for mst.

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 983f87c..caf7c2c 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -112,25 +112,19 @@ use Moose::Util ();
         before => sub {
             my $class = $CALLER;
             return Class::MOP::subname('Moose::before' => sub (@&) {
-                my $code = pop @_;
-                my $meta = $class->meta;
-                $meta->add_before_method_modifier( $_, $code ) for @_;
+                Moose::Util::add_method_modifier($class, 'before', \@_);
             });
         },
         after => sub {
             my $class = $CALLER;
             return Class::MOP::subname('Moose::after' => sub (@&) {
-                my $code = pop @_;
-                my $meta = $class->meta;
-                $meta->add_after_method_modifier( $_, $code ) for @_;
+                Moose::Util::add_method_modifier($class, 'after', \@_);
             });
         },
         around => sub {
             my $class = $CALLER;
             return Class::MOP::subname('Moose::around' => sub (@&) {
-                my $code = pop @_;
-                my $meta = $class->meta;
-                $meta->add_around_method_modifier( $_, $code ) for @_;
+                Moose::Util::add_method_modifier($class, 'around', \@_);
             });
         },
         super => sub {

diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm
index e63222b..95cea17 100644 (file)
--- a/lib/Moose/Util.pm
+++ b/lib/Moose/Util.pm
@@ -20,6 +20,7 @@ my @exports = qw[
     get_all_attribute_values
     resolve_metatrait_alias
     resolve_metaclass_alias
+    add_method_modifier
 ];
 
 Sub::Exporter::setup_exporter({
@@ -143,6 +144,24 @@ sub resolve_metaclass_alias {
     }
 }
 
+sub add_method_modifier {
+    my ( $class_or_obj, $modifier_name, $args ) = @_;
+    my $meta                = find_meta($class_or_obj);
+    my $code                = pop @{$args};
+    my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
+    if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
+        if ( $method_modifier_type eq 'Regexp' ) {
+            my @all_methods = $meta->compute_all_applicable_methods;
+            my @matched_methods
+                = grep { $_->{name} =~ @{$args}[0] } @all_methods;
+            $meta->$add_modifier_method( $_->{name}, $code )
+                for @matched_methods;
+        }
+    }
+    else {
+        $meta->$add_modifier_method( $_, $code ) for @{$args};
+    }
+}
 
 1;
 
@@ -226,6 +245,8 @@ Resolve a short name like in e.g.
 
 to a full class name.
 
+=item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
+
 =back
 
 =head1 TODO

diff --git a/t/500_test_moose/005_method_modifier_with_regexp.t b/t/500_test_moose/005_method_modifier_with_regexp.t
new file mode 100644 (file)
index 0000000..23a1fab
--- /dev/null
+++ b/t/500_test_moose/005_method_modifier_with_regexp.t
@@ -0,0 +1,177 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 13;
+
+BEGIN {
+    use_ok('Moose');
+}
+
+{
+
+    package Dog;
+    use Moose;
+
+    sub bark_once {
+        my $self = shift;
+        return 'bark';
+    }
+
+    sub bark_twice {
+        return 'barkbark';
+    }
+
+    around qr/bark.*/ => sub {
+        'Dog::around';
+    };
+
+}
+
+my $dog = Dog->new;
+is( $dog->bark_once,  'Dog::around', 'around modifier is called' );
+is( $dog->bark_twice, 'Dog::around', 'around modifier is called' );
+
+{
+
+    package Cat;
+    use Moose;
+    our $BEFORE_BARK_COUNTER = 0;
+    our $AFTER_BARK_COUNTER  = 0;
+
+    sub bark_once {
+        my $self = shift;
+        return 'bark';
+    }
+
+    sub bark_twice {
+        return 'barkbark';
+    }
+
+    before qr/bark.*/ => sub {
+        $BEFORE_BARK_COUNTER++;
+    };
+
+    after qr/bark.*/ => sub {
+        $AFTER_BARK_COUNTER++;
+    };
+
+}
+
+my $cat = Cat->new;
+$cat->bark_once;
+is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' );
+is( $Cat::AFTER_BARK_COUNTER,  1, 'after modifier is called once' );
+$cat->bark_twice;
+is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' );
+is( $Cat::AFTER_BARK_COUNTER,  2, 'after modifier is called twice' );
+
+{
+
+    package Animal;
+    use Moose;
+    our $BEFORE_BARK_COUNTER = 0;
+    our $AFTER_BARK_COUNTER  = 0;
+
+    sub bark_once {
+        my $self = shift;
+        return 'bark';
+    }
+
+    sub bark_twice {
+        return 'barkbark';
+    }
+
+    before qr/bark.*/ => sub {
+        $BEFORE_BARK_COUNTER++;
+    };
+
+    after qr/bark.*/ => sub {
+        $AFTER_BARK_COUNTER++;
+    };
+}
+
+{
+
+    package Cow;
+    use Moose;
+    extends 'Animal';
+
+    override 'bark_once' => sub {
+        my $self = shift;
+        return 'cow';
+    };
+
+    override 'bark_twice' => sub {
+        return 'cowcow';
+    };
+}
+
+TODO: {
+    local $TODO = "method modifier isn't called if method id overridden";
+    my $cow = Cow->new;
+    $cow->bark_once;
+    is( $Animal::BEFORE_BARK_COUNTER, 1,
+        'before modifier is called if method is overridden' );
+    is( $Animal::AFTER_BARK_COUNTER, 1,
+        'after modifier is called if method is overridden' );
+}
+
+{
+
+    package Penguin;
+    use Moose;
+    extends 'Animal';
+    our $AUGMENT_CALLED = 0;
+
+    augment 'bark_once' => sub {
+        my $self = shift;
+        $self->dummy;
+        inner();
+        $self->dummy;
+    };
+
+    sub dummy {
+        $AUGMENT_CALLED++;
+    }
+}
+$Animal::BEFORE_BARK_COUNTER = 0;
+$Animal::AFTER_BARK_COUNTER  = 0;
+my $penguin = Penguin->new;
+warn $penguin->bark_once;
+is( $Animal::BEFORE_BARK_COUNTER, 1,
+    'before modifier is called if augment is used' );
+is( $Animal::AFTER_BARK_COUNTER, 1,
+    'after modifier is called if augment is used' );
+TODO: {
+    local $TODO = "The method modifier isn't called if the augment specified it";
+    is( $Penguin::AUGMENT_CALLED, 2, 'augment is called' );
+}
+
+{
+
+    package MyDog;
+    use Moose;
+    our $BEFORE_BARK_COUNTER=0;
+    sub bark {
+        my $self = shift;
+        return 'bark';
+    }
+    
+    sub bark_twice {
+        my $self = shift;
+        return 'barkbark';
+    }
+
+    before qw/bark bark_twice/ => sub {
+        $BEFORE_BARK_COUNTER++;
+    };
+
+}
+
+my $my_dog = MyDog->new;
+$my_dog->bark;
+$my_dog->bark_twice;
+is($MyDog::BEFORE_BARK_COUNTER, 2, "before method modifier is called twice");
+