| Subject: | Performance improvement |
Hello,
Because method modifiers are really useful, I have written its XS
implementation in Data::Util, which is faster than the current
implementation (v1.01), especially in "before" and "after" modifiers.
Moreover, even if no C compiler is available, Data::Util works currectly
because it has also a Pure Perl impementation.
I have attached a patch using Data::Util, requiring Data::Util 0.43. All
the tests are passed, except for t/002-cache.t, which deals with
implementation details.
Regards,
--
Goro Fuji (gfx) GFUJI at CPAN.org
| Subject: | Modifiers.diff |
--- Modifiers.pm.orig 2008-06-27 11:22:48.000000000 +0900
+++ Modifiers.pm 2009-01-19 14:05:46.285500800 +0900
@@ -3,119 +3,45 @@
use strict;
use warnings;
-use MRO::Compat;
-
our $VERSION = '1.01';
-use base 'Exporter';
+use Exporter qw(import);
our @EXPORT = qw(before after around);
our @EXPORT_OK = @EXPORT;
our %EXPORT_TAGS = (
- moose => [qw(before after around)],
+ moose => \@EXPORT,
all => \@EXPORT_OK,
);
use Carp 'confess';
-our %MODIFIER_CACHE;
+use Data::Util;
sub _install_modifier {
my $into = shift;
my $type = shift;
my $code = pop;
- my @names = @_;
-
- for my $name (@names) {
- my $hit = $into->can($name)
- or confess "The method '$name' is not found in the inheritance hierarchy for class $into";
-
- my $qualified = $into.'::'.$name;
- my $cache = $MODIFIER_CACHE{$into}{$name} ||= {
- before => [],
- after => [],
- around => [],
- };
- # this must be the first modifier we're installing
- if (!exists($MODIFIER_CACHE{$into}{$name}{"orig"})) {
- no strict 'refs';
-
- # grab the original method (or undef if the method is inherited)
- $cache->{"orig"} = *{$qualified}{CODE};
-
- # the "innermost" method, the one that "around" will ultimately wrap
- $cache->{"wrapped"} = $cache->{"orig"} || $hit; #sub {
- # # we can't cache this, because new methods or modifiers may be
- # # added between now and when this method is called
- # for my $package (@{ mro::get_linear_isa($into) }) {
- # next if $package eq $into;
- # my $code = *{$package.'::'.$name}{CODE};
- # goto $code if $code;
- # }
- # confess "$qualified\::$name disappeared?";
- #};
- }
-
- # keep these lists in the order the modifiers are called
- if ($type eq 'after') {
- push @{ $cache->{$type} }, $code;
- }
- else {
- unshift @{ $cache->{$type} }, $code;
- }
+ foreach my $name(@_){
+ my $hit = Data::Util::get_code_ref($into, $name);
- # wrap the method with another layer of around. much simpler than
- # the Moose equivalent. :)
- if ($type eq 'around') {
- my $method = $cache->{wrapped};
- $cache->{wrapped} = sub {
- $code->($method, @_);
- };
- }
+ if(!$hit || !Data::Util::subroutine_modifier($hit)){
- # install our new method which dispatches the modifiers, but only
- # if a new type was added
- if (@{ $cache->{$type} } == 1) {
-
- # avoid these hash lookups every method invocation
- my $before = $cache->{"before"};
- my $after = $cache->{"after"};
-
- # this is a coderef that changes every new "around". so we need
- # to take a reference to it. better a deref than a hash lookup
- my $wrapped = \$cache->{"wrapped"};
-
- my $generated = 'sub {';
-
- # before is easy, it doesn't affect the return value(s)
- $generated .= '$_->(@_) for @$before;' if @$before;
-
- if (@$after) {
- $generated .= '
- my @ret;
- if (wantarray) {
- @ret = $$wrapped->(@_);
- }
- else {
- $ret[0] = $$wrapped->(@_);
+ unless($hit){
+ $hit = $into->can($name)
+ or confess "The method '$name' is not found in the inheritance hierarchy for class $into";
}
- $_->(@_) for @$after;
+ $hit = Data::Util::modify_subroutine($hit, $type => [$code]);
- return wantarray ? @ret : $ret[0];
- ';
+ no warnings 'redefine';
+ Data::Util::install_subroutine($into, $name => $hit);
}
- else {
- $generated .= '$$wrapped->(@_);';
+ else{ # $hit exists and is already modified
+ Data::Util::subroutine_modifier($hit, $type => $code);
}
-
- $generated .= '}';
-
- no strict 'refs';
- no warnings 'redefine';
- *$qualified = eval $generated;
- };
}
+ return;
}
sub before {