sub constructor_name { $_[0]->{'constructor_name'} }
sub destructor_class { $_[0]->{'destructor_class'} }
+sub _method_map { $_[0]->{'methods'} }
+
# Instance Construction & Cloning
sub new_object {
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);
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 {
(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 {
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 {
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';
}
}
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 {
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;
use strict;
use warnings;
-use Test::More tests => 296;
+use Test::More tests => 300;
use Test::Exception;
use Class::MOP;
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
my $glob = gensym();
*{$glob} = $initial_value if defined $initial_value;
- $self->namespace->{$name} = $glob;
+ $self->namespace->{$name} = *{$glob};
}
}