basic implementation of preserving attrs/methods across reinitialization

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 628fee5..24621c8 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -46,6 +46,19 @@ sub initialize {
         || $class->_construct_class_instance(package => $package_name, @_);
 }
 
+sub reinitialize {
+    my ( $class, @args ) = @_;
+    unshift @args, "package" if @args % 2;
+    my %options = @args;
+    my $old_metaclass = blessed($options{package})
+        ? $options{package}
+        : Class::MOP::get_metaclass_by_name($options{package});
+    my $new_metaclass = $class->SUPER::reinitialize(@args);
+    $new_metaclass->_restore_metaobjects_from($old_metaclass)
+        if $old_metaclass;
+    return $new_metaclass;
+}
+
 # NOTE: (meta-circularity)
 # this is a special form of _construct_instance
 # (see below), which is used to construct class
@@ -394,6 +407,84 @@ sub _fix_single_metaclass_incompatibility {
     }
 }
 
+sub _get_associated_single_metaclass {
+    my $self = shift;
+    my ($single_meta_name) = @_;
+
+    my $current_single_meta_name;
+    if ($single_meta_name->isa('Class::MOP::Method')) {
+        $current_single_meta_name = $self->method_metaclass;
+    }
+    elsif ($single_meta_name->isa('Class::MOP::Attribute')) {
+        $current_single_meta_name = $self->attribute_metaclass;
+    }
+    else {
+        confess "Can't make $single_meta_name compatible, it isn't an "
+              . "attribute or method metaclass.";
+    }
+
+    return $current_single_meta_name;
+}
+
+sub _get_compatible_single_metaclass_by_subclassing {
+    my $self = shift;
+    my ($single_meta_name) = @_;
+
+    my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name);
+
+    if ($single_meta_name->isa($current_single_meta_name)) {
+        return $single_meta_name;
+    }
+    elsif ($current_single_meta_name->isa($single_meta_name)) {
+        return $current_single_meta_name;
+    }
+
+    return;
+}
+
+sub _get_compatible_single_metaclass {
+    my $self = shift;
+    my ($single_meta_name) = @_;
+
+    return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name);
+}
+
+sub _make_metaobject_compatible {
+    my $self = shift;
+    my ($object) = @_;
+
+    my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object));
+
+    if (!defined($new_metaclass)) {
+        confess "Can't make $object compatible with metaclass "
+              . $self->_get_associated_single_metaclass(blessed($object));
+    }
+
+    # XXX: is this sufficient? i think so... we should never lose attributes
+    # by this process
+    bless($object, $new_metaclass)
+        if blessed($object) ne $new_metaclass;
+
+    return $object;
+}
+
+sub _restore_metaobjects_from {
+    my $self = shift;
+    my ($old_meta) = @_;
+
+    for my $method ($old_meta->_get_local_methods) {
+        $self->_make_metaobject_compatible($method);
+        $self->add_method($method->name => $method);
+    }
+
+    for my $attr (sort { $a->insertion_order <=> $b->insertion_order }
+                       map { $old_meta->get_attribute($_) }
+                           $old_meta->get_attribute_list) {
+        $self->_make_metaobject_compatible($attr);
+        $self->add_attribute($attr);
+    }
+}
+
 ## ANON classes
 
 {