From: gfx <gfuji@cpan.org>
Date: Fri, 10 Jul 2009 03:26:44 +0000 (+0900)
Subject: Improve get_method/has_method/add_method not to use get_method_map.
X-Git-Tag: 0.90~19^2~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3cf189f335625b5ceb9ba49895ee9c78af07dbaa;p=gitmo%2FClass-MOP.git

Improve get_method/has_method/add_method not to use get_method_map.

Normal method objects, or implicit methods, are no longer created until required.
bench/loading-benchmark.pl says this makes loading time 10% faster.
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 8810338..90df86a 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -347,6 +347,8 @@ sub constructor_class        { $_[0]->{'constructor_class'}           }
 sub constructor_name         { $_[0]->{'constructor_name'}            }
 sub destructor_class         { $_[0]->{'destructor_class'}            }
 
+sub _method_map              { $_[0]->{'methods'}                     }
+
 # Instance Construction & Cloning
 
 sub new_object {
@@ -616,15 +618,16 @@ sub add_method {
                 name         => $method_name            
             ) if $method->can('clone');
         }
+
+        $method->attach_to_class($self);
+        $self->_method_map->{$method_name} = $method;
     }
     else {
+        # If a raw code reference is supplied, its method object is not created.
+        # The method object won't be created until required.
         $body = $method;
-        $method = $self->wrap_method_body( body => $body, name => $method_name );
     }
 
-    $method->attach_to_class($self);
-
-    $self->get_method_map->{$method_name} = $method;
 
     my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
 
@@ -721,7 +724,7 @@ sub has_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    exists $self->get_method_map->{$method_name};
+    defined $self->get_method($method_name);
 }
 
 sub get_method {
@@ -729,7 +732,85 @@ sub get_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    return $self->get_method_map->{$method_name};
+    my $class_name = $self->name;
+    my $method_map = $self->_method_map;
+
+    my $method_object = $method_map->{$method_name};
+
+    if(!$method_object){
+        my $glob = $self->namespace->{$method_name};
+
+        if(!defined $glob){
+            return undef;
+        }
+
+        my $code;
+        if(ref(\$glob) eq 'GLOB'){
+            $code = *{$glob}{CODE};
+            if(!defined $code){
+                return undef;
+            }
+            my($code_package, $code_name) = Class::MOP::get_code_info($code);
+
+            if(!$code_package
+                    || ( !($code_package eq 'constant' && $code_name eq '__ANON__')
+                            && $code_package ne $class_name ) ){
+                return undef;
+            }
+        }
+        else{ # stubs or constants
+            no strict 'refs';
+            $code = \&{$class_name . '::' . $method_name};
+        }
+        $method_object = $method_map->{$method_name} = $self->wrap_method_body(
+            body                 => $code,
+            name                 => $method_name,
+            associated_metaclass => $self,
+       );
+       $method_object->_update_generation();
+    }
+    else{ # $method_object already exists
+        if(!$method_object->_is_valid_generation){
+            my $glob = $self->namespace->{$method_name};
+            if(!defined $glob){
+                delete $method_map->{$method_name};
+                return undef;
+            }
+
+            my $code;
+            if(ref(\$glob) eq 'GLOB'){
+                $code = *{$glob}{CODE};
+                if(!defined($code)){
+                    delete $method_map->{$method_name};
+                    return undef;
+                }
+            }
+            else{ # stubs or constants
+                no strict 'refs';
+                $code = \&{$class_name . '::' . $method_name};
+            }
+
+            if($method_object->body != $code){ # changed for some reason
+                 my($code_package, $code_name) = Class::MOP::get_code_info($code);
+                 if(!$code_package
+                         || ( !($code_package eq 'constant' && $code_name eq '__ANON__')
+                                 && $code_package ne $class_name ) ){
+                     delete $method_map->{$method_name};
+                     return undef;
+                 }
+
+                 # update $method_map
+                 $method_object = $method_map->{$method_name} = $self->wrap_method_body(
+                     body                 => $code,
+                     name                 => $method_name,
+                     associated_metaclass => $self,
+                );
+            }
+            $method_object->_update_generation();
+        }
+    }
+
+    return $method_object;
 }
 
 sub remove_method {
diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index ea580ab..c6e7afc 100644
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -57,6 +57,25 @@ sub _new {
 
 sub associated_metaclass { shift->{'associated_metaclass'} }
 
+sub _is_valid_generation{
+    my($self) = @_;
+    my $metaclass = $self->associated_metaclass;
+
+    if($metaclass){
+        return( ($self->{_generation} || 0) == Class::MOP::check_package_cache_flag($metaclass->name) );
+    }
+    else{
+        return 1;
+    }
+}
+
+sub _update_generation {
+    my($self) = @_;
+    my $metaclass = $self->associated_metaclass
+        or confess("No metaclass associated to the method " . $self->name);
+    $self->{_generation} = Class::MOP::check_package_cache_flag($metaclass->name);
+}
+
 sub attach_to_class {
     my ( $self, $class ) = @_;
     $self->{associated_metaclass} = $class;
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 5c870ce..dcac510 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 296;
+use Test::More tests => 298;
 use Test::Exception;
 
 use Class::MOP;
@@ -75,6 +75,7 @@ my @class_mop_class_methods = qw(
     superclasses subclasses direct_subclasses class_precedence_list
     linearized_isa _superclasses_updated
 
+    _method_map
     has_method get_method add_method remove_method alias_method wrap_method_body
     get_method_list get_method_map get_all_method_names get_all_methods compute_all_applicable_methods
         find_method_by_name find_all_methods_by_name find_next_method_by_name