From: Jesse Luehrs <doy@tozt.net>
Date: Sat, 16 Oct 2010 00:29:23 +0000 (-0500)
Subject: implement inlined access to the mop slot, to fix immutable anon classes
X-Git-Tag: 1.10~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7931f7dbb7c24340c20560f49e32ec258968949b;p=gitmo%2FClass-MOP.git

implement inlined access to the mop slot, to fix immutable anon classes
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 2f71fa1..da6f028 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -640,6 +640,24 @@ sub inline_rebless_instance {
     return $self->get_meta_instance->inline_rebless_instance_structure(@_);
 }
 
+sub _inline_get_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_get_mop_slot(@_);
+}
+
+sub _inline_set_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_set_mop_slot(@_);
+}
+
+sub _inline_clear_mop_slot {
+    my $self = shift;
+
+    return $self->get_meta_instance->_inline_clear_mop_slot(@_);
+}
+
 sub clone_object {
     my $class    = shift;
     my $instance = shift;
diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index b0d9c6a..b02ff36 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -234,6 +234,21 @@ sub inline_rebless_instance_structure {
     "bless $instance => $class_variable";
 }
 
+sub _inline_get_mop_slot {
+    my ($self, $instance) = @_;
+    $self->inline_get_slot_value($instance, $RESERVED_MOP_SLOT);
+}
+
+sub _inline_set_mop_slot {
+    my ($self, $instance, $value) = @_;
+    $self->inline_set_slot_value($instance, $RESERVED_MOP_SLOT, $value);
+}
+
+sub _inline_clear_mop_slot {
+    my ($self, $instance) = @_;
+    $self->inline_deinitialize_slot($instance, $RESERVED_MOP_SLOT);
+}
+
 1;
 
 __END__
diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm
index ac2803c..9a95e9e 100644
--- a/lib/Class/MOP/Method/Constructor.pm
+++ b/lib/Class/MOP/Method/Constructor.pm
@@ -114,6 +114,9 @@ sub _generate_constructor_method_inline {
     $source .= ";\n" . (join ";\n" => map {
         $self->_generate_slot_initializer($_, $idx++)
     } @{ $self->_attributes });
+    if (Class::MOP::metaclass_is_weak($self->associated_metaclass->name)) {
+        $source .= ";\n" . $self->associated_metaclass->_inline_set_mop_slot('$instance', 'Class::MOP::class_of($class)');
+    }
     $source .= ";\n" . 'return $instance';
     $source .= ";\n" . '}';
     warn $source if $self->options->{debug};
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 159f90e..207f94f 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -63,6 +63,7 @@ my @class_mop_class_methods = qw(
     instance_metaclass get_meta_instance
     inline_create_instance
     inline_rebless_instance
+    _inline_get_mop_slot _inline_set_mop_slot _inline_clear_mop_slot
     create_meta_instance _create_meta_instance
     new_object clone_object
     construct_instance _construct_instance
diff --git a/t/048_anon_class_create_init.t b/t/048_anon_class_create_init.t
index 4cda746..b362eae 100644
--- a/t/048_anon_class_create_init.t
+++ b/t/048_anon_class_create_init.t
@@ -40,6 +40,20 @@ my $instance;
 }
 
 {
+    my $meta = Class::MOP::Class->create_anon_class;
+    $meta->make_immutable;
+    $instance = $meta->name->new;
+}
+{
+    my $meta = Class::MOP::class_of($instance);
+    Scalar::Util::weaken($meta);
+    ok($meta, "anon class is kept alive by existing instances (immutable)");
+
+    undef $instance;
+    ok(!$meta, "anon class is collected once instances go away (immutable)");
+}
+
+{
     $instance = Class::MOP::Class->create('Foo')->new_object;
     my $meta = Class::MOP::Class->create_anon_class(superclasses => ['Foo']);
     $meta->rebless_instance($instance);