fixing clone_instance to DW I Mean

diff --git a/Changes b/Changes
index 40b7f76..3938ebc 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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<construct_instance> (which means if 
 you override C<construct_instance>, you need to override this one too).
-
-This method will clone the C<$instance> structure created by the 
-C<construct_instance> method, and apply any C<%params> passed to it 
-to change the attribute values. The structure returned is (like with 
-C<construct_instance>) an unC<bless>ed 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<blessed> 
+then it will look for a C<clone> method. If a C<clone> method is found, 
+then it is called and the return value is added to the clone. If a 
+C<clone> method is B<not> 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<blessed>, then it will be deep-copied using L<Clone>.
+
+The cloned structure returned is (like with C<construct_instance>) an 
+unC<bless>ed HASH reference, it is your responsibility to then bless 
+this cloned structure into the right class (which C<clone_object> will
+do for you).
 
 =back
 

diff --git a/t/020_attribute.t b/t/020_attribute.t
index 539bb51..56a0acf 100644 (file)
--- 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');                
 }