cloning

diff --git a/examples/ArrayBasedStorage.pod b/examples/ArrayBasedStorage.pod
index 1f04012..6df324a 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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<bless_instance_structure> to bless it into the class.
 
 This does just exactly what it says it does.
 
+=item B<clone_instance ($instance_structure)>
+
 =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<new>.
 
+=item B<is_valid_slot ($slot_name)>
+
 =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<inline_slot_access ($instance_structure, $slot_name)>

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index ddb26e9..75e8429 100644 (file)
--- 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');