From: Shawn M Moore Date: Wed, 15 Jul 2009 07:21:06 +0000 (-0400) Subject: Merge branch 'topic/no-get_method_map' of git://github.com/gfx/class-mop X-Git-Tag: 0.90~19 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9ec520256a955cf40209cc0c55ed4afe5914c15c;hp=26b2e5ab09bdd030faa1c8fc53066c6adfa22f09;p=gitmo%2FClass-MOP.git 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 --- 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 --- 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 5c870ce..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 => 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 --- 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}; } }