# Creation
-#{
+{
# Metaclasses are singletons, so we cache them here.
# there is no need to worry about destruction though
# because they should die only when the program dies.
my $self = shift;
# this is always okay ...
- return if blessed($self) eq 'Class::MOP::Class';
+ return if blessed($self) eq 'Class::MOP::Class' &&
+ $self->instance_metaclass eq 'Class::MOP::Instance';
my @class_list = $self->class_precedence_list;
shift @class_list; # shift off $self->name
|| confess $self->name . "->meta => (" . (blessed($self)) . ")" .
" is not compatible with the " .
$class_name . "->meta => (" . (blessed($meta)) . ")";
+ # NOTE:
+ # we also need to check that instance metaclasses
+ # are compatabile in the same the class.
+ ($self->instance_metaclass->isa($meta->instance_metaclass))
+ || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" .
+ " is not compatible with the " .
+ $class_name . "->meta => (" . ($meta->instance_metaclass) . ")";
}
- }
-#}
+ }
+}
sub create {
my ($class, $package_name, $package_version, %options) = @_;
my ($class, %params) = @_;
my $meta_instance = $class->get_meta_instance();
my $instance = $meta_instance->create_instance();
- $meta_instance->initialize_all_slots($instance);
foreach my $attr ($class->compute_all_applicable_attributes()) {
- $attr->initialize_instance_slot($instance, \%params);
+ $attr->initialize_instance_slot($meta_instance, $instance, \%params);
}
return $instance;
}
# Class::MOP::Class singletons here, they
# should not be cloned.
return $instance if $instance->isa('Class::MOP::Class');
- bless $class->clone_instance($instance, @_) => blessed($instance);
+ $class->clone_instance($instance, @_);
}
sub clone_instance {
my ($class, $instance, %params) = @_;
(blessed($instance))
|| confess "You can only clone instances, \$self is not a blessed instance";
- my $clone = { %$instance, %params };
+ my $meta_instance = $class->get_meta_instance();
+ my $clone = $meta_instance->clone_instance($instance);
+ foreach my $key (%params) {
+ next unless $meta_instance->is_valid_slot($key);
+ $meta_instance->set_slot_value($clone, $key, $params{$key});
+ }
return $clone;
}
if (@_) {
my @supers = @_;
@{$self->name . '::ISA'} = @supers;
+ # NOTE:
+ # we need to check the metaclass
+ # compatability here so that we can
+ # be sure that the superclass is
+ # not potentially creating an issues
+ # we don't know about
+ $self->check_metaclass_compatability();
}
@{$self->name . '::ISA'};
}
(
$self->name,
map {
- # OPTIMIZATION NOTE:
- # we grab the metaclass from the %METAS
- # hash here to save the initialize() call
- # if we can, but it is not always possible
- ($METAS{$_} || $self->initialize($_))->class_precedence_list()
+ $self->initialize($_)->class_precedence_list()
} $self->superclasses()
);
}
sub get_method_list {
my $self = shift;
no strict 'refs';
- grep { $self->has_method($_) } %{$self->name . '::'};
+ grep { $self->has_method($_) } keys %{$self->name . '::'};
}
sub compute_all_applicable_methods {
my ($self, $attribute_name) = @_;
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
- # OPTIMIZATION NOTE:
- # we used to say `if $self->has_attribute($attribute_name)`
- # here, but since get_attribute is called so often, we
- # eliminate the function call here
- return $self->{'%:attributes'}->{$attribute_name}
- if exists $self->{'%:attributes'}->{$attribute_name};
+ return $self->get_attribute_map->{$attribute_name}
+ if $self->has_attribute($attribute_name);
return;
}
sub get_attribute_list {
my $self = shift;
- # OPTIMIZATION NOTE:
- # We don't use get_attribute_map here because
- # we ask for the attribute list quite often
- # in compute_all_applicable_attributes, so
- # eliminating the function call helps
- keys %{$self->{'%:attributes'}};
+ keys %{$self->get_attribute_map};
}
sub compute_all_applicable_attributes {
next if $seen_class{$class};
$seen_class{$class}++;
# fetch the meta-class ...
- # OPTIMIZATION NOTE:
- # we grab the metaclass from the %METAS
- # hash here to save the initialize() call
- my $meta = $METAS{$class};
+ my $meta = $self->initialize($class);
foreach my $attr_name ($meta->get_attribute_list()) {
next if exists $seen_attr{$attr_name};
$seen_attr{$attr_name}++;