[libclass-tiny-perl] 04/07: cache a lot of @ISA and method checks

[gregor herrmann]

This is an automated email from the git hooks/post-receive script.

gregoa pushed a commit to annotated tag release-0.007
in repository libclass-tiny-perl.

commit 0bd37c1d0b3738f2ba9e76214b88792ac285bad6
Author: David Golden <dagolden at cpan.org>
Date:   Sat Sep 7 16:24:30 2013 -0400

    cache a lot of @ISA and method checks
    
    By caching the linear ISA and checks for BUILD/DEMOLISH/can
    on methods, we avoid having to compute them repeatedly
    in new and DESTROY.
---
 lib/Class/Tiny.pm | 55 +++++++++++++++++++++++--------------------------------
 1 file changed, 23 insertions(+), 32 deletions(-)

diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm
index da485ac..9eb7da9 100644
--- a/lib/Class/Tiny.pm
+++ b/lib/Class/Tiny.pm
@@ -79,7 +79,10 @@ package Class::Tiny::Object;
 # ABSTRACT: Base class for classes built with Class::Tiny
 # VERSION
 
-my %can_cache;
+my %CAN_CACHE;
+my %LINEAR_ISA_CACHE;
+my %DEMOLISH_CACHE;
+my %BUILD_CACHE;
 
 sub new {
     my $class = shift;
@@ -100,20 +103,21 @@ sub new {
 
     # create object and invoke BUILD
     my $self = bless {%$args}, $class;
-    if ( @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" ) {
-        $self->BUILD($args) if defined *{"$class\::BUILD"};
-    }
-    else {
-        for my $s ( reverse @{ mro::get_linear_isa($class) } ) {
-            &{ *{"$s\::BUILD"}{CODE} }( $self, $args ) if defined *{"$s\::BUILD"}{CODE};
-        }
+    my $linear_isa = $LINEAR_ISA_CACHE{$class} ||=
+      @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
+      ? [$class]
+      : mro::get_linear_isa($class);
+
+    for my $s ( reverse @$linear_isa ) {
+        my $builder = $BUILD_CACHE{$s} ||= *{"$s\::BUILD"}{CODE};
+        $builder->( $self, $args ) if $builder;
     }
 
     # unknown attributes still in $args are fatal
     my @bad;
     for my $k ( keys %$args ) {
         push( @bad, $k )
-          unless $can_cache{$class}{$k} ||= $self->can($k); # a heuristic to catch typos
+          unless $CAN_CACHE{$class}{$k} ||= $self->can($k); # a heuristic to catch typos
     }
     Carp::croak("Invalid attributes for $class: @bad") if @bad;
 
@@ -130,29 +134,16 @@ sub DESTROY {
       defined ${^GLOBAL_PHASE}
       ? ${^GLOBAL_PHASE} eq 'DESTRUCT'
       : Devel::GlobalDestruction::in_global_destruction();
-    if ( @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" ) {
-        if ( defined *{"$class\::DEMOLISH"} ) {
-            my $e = do {
-                local ( $?, $@ );
-                eval { $self->DEMOLISH($in_global_destruction) };
-                $@;
-            };
-            no warnings 'misc'; # avoid (in cleanup) warnings
-            die $e if $e;       # rethrow
-        }
-    }
-    else {
-        for my $s ( @{ mro::get_linear_isa($class) } ) {
-            my $demolisher = *{"$s\::DEMOLISH"}{CODE};
-            next unless $demolisher;
-            my $e = do {
-                local ( $?, $@ );
-                eval { $self->$demolisher($in_global_destruction) };
-                $@;
-            };
-            no warnings 'misc'; # avoid (in cleanup) warnings
-            die $e if $e;       # rethrow
-        }
+    for my $s ( @{ $LINEAR_ISA_CACHE{$class} } ) {
+        my $demolisher = $DEMOLISH_CACHE{$s} ||= *{"$s\::DEMOLISH"}{CODE};
+        next unless $demolisher;
+        my $e = do {
+            local ( $?, $@ );
+            eval { $demolisher->( $self, $in_global_destruction ) };
+            $@;
+        };
+        no warnings 'misc'; # avoid (in cleanup) warnings
+        die $e if $e;       # rethrow
     }
 }
 

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git