From: gfx <gfuji@cpan.org>
Date: Fri, 10 Jul 2009 06:31:49 +0000 (+0900)
Subject: refactoring no-get_method_map with package symmbol APIs
X-Git-Tag: 0.90~19^2~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=55039f82288984867a24b027addcfe9f2a694217;p=gitmo%2FClass-MOP.git

refactoring no-get_method_map with package symmbol APIs
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 90df86a..f5ca01a 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -719,12 +719,20 @@ sub alias_method {
     shift->add_method(@_);
 }
 
+sub _code_is_mine{
+    my($self, $code) = @_;
+    my($code_package, $code_name) = Class::MOP::get_code_info($code);
+    return  $code_package
+        &&  $code_package eq $self->name
+        || ($code_package eq 'constant' && $code_name eq '__ANON__');
+}
+
 sub has_method {
     my ($self, $method_name) = @_;
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    defined $self->get_method($method_name);
+    return defined($self->get_method($method_name));
 }
 
 sub get_method {
@@ -732,83 +740,29 @@ sub get_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    my $class_name = $self->name;
-    my $method_map = $self->_method_map;
-
+    my $method_map    = $self->_method_map;
     my $method_object = $method_map->{$method_name};
 
-    if(!$method_object){
-        my $glob = $self->namespace->{$method_name};
+    if(!($method_object && $method_object->_is_valid_generation)){
+        my $code = $self->get_package_symbol({
+            name  => $method_name,
+            sigil => '&',
+            type  => 'CODE',
+        });
 
-        if(!defined $glob){
+        if(!($code && $self->_code_is_mine($code))){
+            delete $method_map->{$method_name};
             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,
-       );
+        if(!($method_object && $method_object->body == $code)){
+           $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;
 }
diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 0336a57..e5ed66f 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -155,24 +155,19 @@ sub has_package_symbol {
     
     return 0 unless exists $namespace->{$name};   
     
-    # FIXME:
-    # For some really stupid reason 
-    # a typeglob will have a default
-    # value of \undef in the SCALAR 
-    # slot, so we need to work around
-    # this. Which of course means that 
-    # if you put \undef in your scalar
-    # then this is broken.
-
-    if (ref($namespace->{$name}) eq 'SCALAR') {
-        return ($type eq 'CODE');
-    }
-    elsif ($type eq 'SCALAR') {    
-        my $val = *{$namespace->{$name}}{$type};
-        return defined(${$val});
-    }
-    else {
-        defined(*{$namespace->{$name}}{$type});
+    my $entry_ref = \$namespace->{$name};
+    if (ref($entry_ref) eq 'GLOB') {
+        if ($type eq 'SCALAR') {
+            return defined(${ *{$entry_ref}{SCALAR} });
+        }
+        else {
+            return defined(*{$entry_ref}{$type});
+        }
+     }
+     else {
+         # a symbol table entry can be -1 (stub), string (stub with prototype),
+         # or reference (constant)
+         return $type eq 'CODE';
     }
 }
 
@@ -185,21 +180,24 @@ sub get_package_symbol {
 
     my $namespace = $self->namespace;
 
+    # FIXME
     $self->add_package_symbol($variable)
         unless exists $namespace->{$name};
 
-    if (ref($namespace->{$name}) eq 'SCALAR') {
-        if ($type eq 'CODE') {
+    my $entry_ref = \$namespace->{$name};
+
+    if (ref($entry_ref) eq 'GLOB') {
+        return *{$entry_ref}{$type};
+    }
+    else{
+        if($type eq 'CODE'){
             no strict 'refs';
-            return \&{$self->name.'::'.$name};
+            return \&{$self->name . '::' . $name};
         }
-        else {
+        else{
             return undef;
         }
     }
-    else {
-        return *{$namespace->{$name}}{$type};
-    }
 }
 
 sub remove_package_symbol {
diff --git a/t/003_methods.t b/t/003_methods.t
index a176441..a6ba53a 100644
--- a/t/003_methods.t
+++ b/t/003_methods.t
@@ -288,7 +288,8 @@ my $new_method = Bar->meta->get_method('objecty');
 isnt( $method, $new_method,
     'add_method clones method objects as they are added' );
 is( $new_method->original_method, $method,
-    '... the cloned method has the correct original method' );
+    '... the cloned method has the correct original method' )
+        or diag $new_method->dump;
 
 {
     package CustomAccessor;
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index dcac510..04504f4 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 => 298;
+use Test::More tests => 300;
 use Test::Exception;
 
 use Class::MOP;
@@ -76,6 +76,7 @@ my @class_mop_class_methods = qw(
     linearized_isa _superclasses_updated
 
     _method_map
+    _code_is_mine
     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
diff --git a/t/081_meta_package_extension.t b/t/081_meta_package_extension.t
index 84ad5be..8ede745 100644
--- a/t/081_meta_package_extension.t
+++ b/t/081_meta_package_extension.t
@@ -32,7 +32,7 @@ BEGIN {use Class::MOP;
     
         my $glob = gensym();
         *{$glob} = $initial_value if defined $initial_value;
-        $self->namespace->{$name} = $glob;    
+        $self->namespace->{$name} = *{$glob};    
     }       
 }