Merge branch 'topic/no-get_method_map' of git://github.com/gfx/class-mop

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index bb2385b..e3a143b 100644 (file)
--- 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);
 
@@ -716,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";
 
-    exists $self->get_method_map->{$method_name};
+    return defined($self->get_method($method_name));
 }
 
 sub get_method {
@@ -729,7 +740,29 @@ sub get_method {
     (defined $method_name && $method_name)
         || confess "You must define a method name";
 
-    return $self->get_method_map->{$method_name};
+    my $method_map    = $self->_method_map;
+    my $method_object = $method_map->{$method_name};
+    my $code = $self->get_package_symbol({
+        name  => $method_name,
+        sigil => '&',
+        type  => 'CODE',
+    });
+
+    if (!($method_object && $method_object->body == ($code || 0))){
+        if ($code && $self->_code_is_mine($code)) {
+           $method_object = $method_map->{$method_name} = $self->wrap_method_body(
+               body                 => $code,
+               name                 => $method_name,
+               associated_metaclass => $self,
+           );
+        }
+        else {
+            delete $method_map->{$method_name};
+            return undef;
+        }
+    }
+
+    return $method_object;
 }
 
 sub remove_method {
@@ -752,7 +785,7 @@ sub remove_method {
 
 sub get_method_list {
     my $self = shift;
-    keys %{$self->get_method_map};
+    return grep { $self->has_method($_) } keys %{ $self->namespace };
 }
 
 sub find_method_by_name {

diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 0336a57..e5ed66f 100644 (file)
--- 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 (file)
--- 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 5c870ce..04504f4 100644 (file)
--- 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 => 300;
 use Test::Exception;
 
 use Class::MOP;
@@ -75,6 +75,8 @@ my @class_mop_class_methods = qw(
     superclasses subclasses direct_subclasses class_precedence_list
     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 (file)
--- 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};    
     }       
 }