From: Dann Date: Tue, 20 May 2008 11:16:56 +0000 (+0000) Subject: supported RegExp method name for before/after/around method modifier. X-Git-Tag: 0_55~160 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5f71050b357fb1966e206920a5853779f58516a9;p=gitmo%2FMoose.git 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 --- 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 --- 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 + =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 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"); +