From: Stevan Little Date: Sun, 19 Feb 2006 21:21:49 +0000 (+0000) Subject: fixing clone_instance to DW I Mean X-Git-Tag: 0_12~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a27ae83fc6e52764abc62620a6527d451f44e97c;p=gitmo%2FClass-MOP.git fixing clone_instance to DW I Mean --- diff --git a/Changes b/Changes index 40b7f76..3938ebc 100644 --- a/Changes +++ b/Changes @@ -3,6 +3,12 @@ Revision history for Perl extension Class-MOP. 0.11 * examples/ - added example of changing method dispatch order to C3 + + * Class::MOP::Class + - changed how clone_instance behaves, it now goes through + each attribute and does what is appropriate (see docs + for a more detailed description) + - added docs and tests 0.10 Tues Feb. 14, 2006 ** This release was mostly about writing more tests and diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 119f89e..b973fcf 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -148,14 +148,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { Class::MOP::Attribute->meta->add_method('clone' => sub { my $self = shift; - my $class = $self->associated_class; - $self->detach_from_class() if defined $class; - my $clone = $self->meta->clone_object($self, @_); - if (defined $class) { - $self->attach_to_class($class); - $clone->attach_to_class($class); - } - return $clone; + $self->meta->clone_object($self, @_); }); 1; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index b699f11..2d57710 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -187,12 +187,35 @@ sub clone_instance { # the best thing is to write a more # controled &clone method locally # in the class (see Class::MOP) - my $clone = Clone::clone($instance); + my $clone = {}; foreach my $attr ($class->compute_all_applicable_attributes()) { my $init_arg = $attr->init_arg(); # try to fetch the init arg from the %params ... - $clone->{$attr->name} = $params{$init_arg} - if exists $params{$init_arg}; + # (no sense in cloning if we are overriding it) + if (exists $params{$init_arg}) { + $clone->{$attr->name} = $params{$init_arg} + } + else { + # if it is an object ... + if (blessed($instance->{$attr->name})) { + # see if it has a clone method ... + if ($instance->{$attr->name}->can('clone')) { + # if so ,.. call it + $clone->{$attr->name} = $instance->{$attr->name}->clone(); + } + # otherwise we assume that it does + # not wish to be cloned, and just + # copy the reference ... + else { + $clone->{$attr->name} = $instance->{$attr->name}; + } + } + # if it is not an object, then we + # deep clone it ... + else { + $clone->{$attr->name} = Clone::clone($instance->{$attr->name}); + } + } } return $clone; } @@ -654,13 +677,21 @@ but that is considered bad style, so we do not do that. This method is a compliment of C (which means if you override C, you need to override this one too). - -This method will clone the C<$instance> structure created by the -C method, and apply any C<%params> passed to it -to change the attribute values. The structure returned is (like with -C) an unCed HASH reference, it is your -responsibility to then bless this cloned structure into the right -class. +This method will clone the C<$instance> structure in the following +way: + +If the attribute name is in C<%params> it will use that, otherwise it +will attempt to clone the value in that slot. If the value is C +then it will look for a C method. If a C method is found, +then it is called and the return value is added to the clone. If a +C method is B found, then we will respect the object's +encapsulation and not clone it, and just copy the object's pointer. If +the value is not C, then it will be deep-copied using L. + +The cloned structure returned is (like with C) an +unCed HASH reference, it is your responsibility to then bless +this cloned structure into the right class (which C will +do for you). =back diff --git a/t/020_attribute.t b/t/020_attribute.t index 539bb51..56a0acf 100644 --- a/t/020_attribute.t +++ b/t/020_attribute.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 58; +use Test::More tests => 67; use Test::Exception; BEGIN { @@ -24,10 +24,23 @@ BEGIN { ok(!$attr->has_writer, '... $attr does not have an writer'); ok(!$attr->has_default, '... $attr does not have an default'); + my $class = Class::MOP::Class->initialize('Foo'); + isa_ok($class, 'Class::MOP::Class'); + + lives_ok { + $attr->attach_to_class($class); + } '... attached a class successfully'; + + is($attr->associated_class, $class, '... the class was associated correctly'); + my $attr_clone = $attr->clone(); isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, $class, '... the associated classes are the same though'); + is($attr_clone->associated_class, $class, '... the associated classes are the same though'); + is_deeply($attr, $attr_clone, '... but they are the same inside'); } @@ -53,6 +66,10 @@ BEGIN { isa_ok($attr_clone, 'Class::MOP::Attribute'); isnt($attr, $attr_clone, '... but they are different instances'); + is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though'); + is($attr->associated_class, undef, '... the associated class is actually undef'); + is($attr_clone->associated_class, undef, '... the associated class is actually undef'); + is_deeply($attr, $attr_clone, '... but they are the same inside'); }