From: Jesse Luehrs <doy@tozt.net>
Date: Sun, 26 Sep 2010 09:04:53 +0000 (-0500)
Subject: basic implementation of preserving attrs/methods across reinitialization
X-Git-Tag: 1.09~32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2d09de80149e2715c3a56f6d25ed1cc7879a7106;hp=75c4dcf327f0c824a890a909148af0b7a3faba2a;p=gitmo%2FClass-MOP.git

basic implementation of preserving attrs/methods across reinitialization
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 628fee5..24621c8 100644
--- 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
 
 {
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index f9d9a09..e3e9c1b 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -53,7 +53,7 @@ my @class_mop_class_methods = qw(
 
     is_pristine
 
-    initialize create
+    initialize reinitialize create
 
     update_package_cache_flag
     reset_package_cache_flag
@@ -79,6 +79,12 @@ my @class_mop_class_methods = qw(
     _can_fix_metaclass_incompatibility_by_subclassing
     _can_fix_metaclass_incompatibility
 
+    _get_associated_single_metaclass
+    _get_compatible_single_metaclass_by_subclassing
+    _get_compatible_single_metaclass
+    _make_metaobject_compatible
+    _restore_metaobjects_from
+
     add_meta_instance_dependencies remove_meta_instance_dependencies update_meta_instance_dependencies
     add_dependent_meta_instance remove_dependent_meta_instance
     invalidate_meta_instances invalidate_meta_instance
diff --git a/t/049_metaclass_reinitialize.t b/t/049_metaclass_reinitialize.t
index a9c0e26..423a49c 100644
--- a/t/049_metaclass_reinitialize.t
+++ b/t/049_metaclass_reinitialize.t
@@ -8,6 +8,7 @@ use Test::Exception;
     package Foo;
     use metaclass;
     sub foo {}
+    Foo->meta->add_attribute('bar');
 }
 
 sub check_meta_sanity {
@@ -15,6 +16,7 @@ sub check_meta_sanity {
     isa_ok($meta, 'Class::MOP::Class');
     is($meta->name, 'Foo');
     ok($meta->has_method('foo'));
+    ok($meta->has_attribute('bar'));
 }
 
 can_ok('Foo', 'meta');
diff --git a/xt/author/pod_coverage.t b/xt/author/pod_coverage.t
index be543c4..4a7bfdf 100644
--- a/xt/author/pod_coverage.t
+++ b/xt/author/pod_coverage.t
@@ -45,6 +45,7 @@ my %trustme = (
         'create_meta_instance',
         'reset_package_cache_flag',
         'update_package_cache_flag',
+        'reinitialize',
 
         # doc'd with rebless_instance
         'rebless_instance_away',