From: Stevan Little Date: Tue, 2 May 2006 13:58:00 +0000 (+0000) Subject: cloning X-Git-Tag: 0_29_02~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f72591997c6bc1c516bc7bb1fba150b57ff3f82b;p=gitmo%2FClass-MOP.git cloning --- diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod index 1f04012..6df324a 100644 --- a/examples/ArrayBasedStorage.pod +++ b/examples/ArrayBasedStorage.pod @@ -24,13 +24,18 @@ sub create_instance { $self->bless_instance_structure([]); } +sub clone_instance { + my ($self, $instance) = shift; + $self->bless_instance_structure([ @$instance ]); +} + # operations on meta instance sub get_slot_index_map { (shift)->{slot_index_map} } sub get_all_slots { my $self = shift; - return sort @{$self->{slots}}; + return sort $self->SUPER::get_all_slots; } sub get_slot_value { diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 64e6d24..99afc6f 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -53,7 +53,12 @@ Class::MOP::Class->meta->add_attribute( Class::MOP::Class->meta->add_attribute( Class::MOP::Attribute->new('%:attributes' => ( - reader => 'get_attribute_map', + reader => { + # NOTE: we need to do this in order + # for the instance meta-object to + # not fall into meta-circular death + 'get_attribute_map' => sub { (shift)->{'%:attributes'} } + }, init_arg => ':attributes', default => sub { {} } )) diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 62877fb..2184c0d 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -19,7 +19,7 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } # 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. @@ -98,9 +98,16 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } || 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) = @_; @@ -205,14 +212,19 @@ sub clone_object { # 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; } @@ -250,11 +262,7 @@ sub class_precedence_list { ( $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() ); } @@ -509,12 +517,8 @@ sub get_attribute { 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; } @@ -532,12 +536,7 @@ sub remove_attribute { 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 { @@ -552,10 +551,7 @@ 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}++; diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 6cb6f0a..66e1f45 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -28,7 +28,7 @@ sub new { # assumption,.. but you can # never tell <:) meta => $meta, - slots => \@slots, + slots => { map { $_ => undef } @slots }, } => $class; } @@ -42,11 +42,21 @@ sub bless_instance_structure { bless $instance_structure, $self->{meta}->name; } +sub clone_instance { + my ($self, $instance) = @_; + $self->bless_instance_structure({ %$instance }); +} + # operations on meta instance sub get_all_slots { my $self = shift; - return @{$self->{slots}}; + return keys %{$self->{slots}}; +} + +sub is_valid_slot { + my ($self, $slot_name) = @_; + exists $self->{slots}->{$slot_name} ? 1 : 0; } # operations on created instances @@ -193,6 +203,8 @@ then calls C to bless it into the class. This does just exactly what it says it does. +=item B + =back =head2 Instrospection @@ -207,6 +219,8 @@ we will add then when we need them basically. This will return the current list of slots based on what was given to this object in C. +=item B + =back =head2 Operations on Instance Structures @@ -236,6 +250,10 @@ require that the C<$instance_structure> is passed into them. =head2 Inlineable Instance Operations +This part of the API is currently un-used. It is there for use +in future experiments in class finailization mostly. Best to +ignore this for now. + =over 4 =item B diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index ddb26e9..75e8429 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -106,8 +106,8 @@ ok($meta->get_attribute('$:package')->has_init_arg, '... Class::MOP::Class $:pac is($meta->get_attribute('$:package')->init_arg, ':package', '... Class::MOP::Class $:package\'s a init_arg is :package'); ok($meta->get_attribute('%:attributes')->has_reader, '... Class::MOP::Class %:attributes has a reader'); -is($meta->get_attribute('%:attributes')->reader, - 'get_attribute_map', +is(ref($meta->get_attribute('%:attributes')->reader), + 'HASH', '... Class::MOP::Class %:attributes\'s a reader is &get_attribute_map'); ok($meta->get_attribute('%:attributes')->has_init_arg, '... Class::MOP::Class %:attributes has a init_arg');