From: gfx <gfuji@cpan.org>
Date: Fri, 28 Aug 2009 04:28:47 +0000 (+0900)
Subject: Refactor method generators, preparing XS constructor generator
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6c9f331dffe7939690e6f24b43cda0d846824db7;p=gitmo%2FClass-MOP.git

Refactor method generators, preparing XS constructor generator
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 7a6d089..7695d42 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -519,7 +519,9 @@ Class::MOP::Attribute->meta->add_attribute(
 
 Class::MOP::Attribute->meta->add_method('clone' => sub {
     my $self  = shift;
-    $self->meta->clone_object($self, @_);
+    my $cloned = $self->meta->clone_object($self, @_);
+    $cloned->BUILD();
+    return $cloned;
 });
 
 ## --------------------------------------------------------
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 77bba0f..97b47aa 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -52,7 +52,9 @@ sub new {
         confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
     }
 
-    $class->_new(\%options);
+    my $self = $class->_new(\%options);
+    $self->BUILD(); # Initializer in XS
+    return $self;
 }
 
 sub _new {
@@ -98,7 +100,9 @@ sub clone {
     my %options = @_;
     (blessed($self))
         || confess "Can only clone an instance";
-    return bless { %{$self}, %options } => ref($self);
+    my $cloned = bless { %{$self}, %options } => ref($self);
+    $cloned->BUILD();
+    return $cloned;
 }
 
 sub initialize_instance_slot {
diff --git a/mop.h b/mop.h
index 1c8ef31..ccb0ea5 100644
--- a/mop.h
+++ b/mop.h
@@ -87,9 +87,12 @@ typedef struct {
 const mop_instance_vtbl* mop_get_default_instance_vtbl(pTHX);
 
 #define MOP_mg_obj(mg)   ((mg)->mg_obj)
-#define MOP_mg_vtbl(mg)  ((const mop_instance_vtbl*)(mg)->mg_ptr)
+#define MOP_mg_ptr(mg)   ((mg)->mg_ptr)
+#define MOP_mg_vtbl(mg)  ((const mop_instance_vtbl*)MOP_mg_ptr(mg))
 #define MOP_mg_flags(mg) ((mg)->mg_private)
 
+#define MOP_mg_obj_refcounted_on(mg)    (void)((mg)->mg_flags |= MGf_REFCOUNTED);
+
 #define MOP_mg_slot(mg)   MOP_mg_obj(mg)
 
 #define MOP_mg_create_instance(mg, stash) MOP_mg_vtbl(mg)->create_instance (aTHX_ (stash))
@@ -99,6 +102,9 @@ const mop_instance_vtbl* mop_get_default_instance_vtbl(pTHX);
 #define MOP_mg_delete_slot(mg, o)         MOP_mg_vtbl(mg)->delete_slot     (aTHX_ (o), MOP_mg_slot(mg))
 #define MOP_mg_weaken_slot(mg, o)         MOP_mg_vtbl(mg)->weaken_slot     (aTHX_ (o), MOP_mg_slot(mg))
 
+/* Class::MOP::Attribute stuff */
+
+MAGIC* mop_attr_get_mg(pTHX_ SV* const attr);
 
 /* Class::MOP::Method::Accessor stuff */
 
diff --git a/xs/Attribute.xs b/xs/Attribute.xs
index 14f9940..ca2c4fb 100644
--- a/xs/Attribute.xs
+++ b/xs/Attribute.xs
@@ -1,5 +1,16 @@
 #include "mop.h"
 
+static MGVTBL mop_attr_vtbl;
+
+
+MAGIC*
+mop_attr_get_mg(pTHX_ SV* const attr){
+    if(!SvROK(attr)) croak("Invalid object");
+
+    return mop_mg_find(aTHX_ SvRV(attr), &mop_attr_vtbl, MOPf_DIE_ON_FAIL);
+}
+
+
 MODULE = Class::MOP::Attribute   PACKAGE = Class::MOP::Attribute
 
 PROTOTYPES: DISABLE
@@ -31,3 +42,13 @@ BOOT:
     INSTALL_SIMPLE_PREDICATE(Attribute, initializer);
     INSTALL_SIMPLE_PREDICATE(Attribute, default);
 
+void
+BUILD(SV* self)
+PREINIT:
+    mop_instance_vtbl* vtbl;
+CODE:
+    if(!( SvROK(self) && SvOBJECT(SvRV(self)) )){
+        croak("Invalid object");
+    }
+    sv_magicext(SvRV(self), NULL, PERL_MAGIC_ext, &mop_attr_vtbl, NULL, 0);
+
diff --git a/xs/MethodAccessor.xs b/xs/MethodAccessor.xs
index 6c34c7d..0e04011 100644
--- a/xs/MethodAccessor.xs
+++ b/xs/MethodAccessor.xs
@@ -52,10 +52,24 @@ mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl), mo
     /* $key = $accessor->associated_attribute->name */
     SV* const attr = mop_call0(aTHX_ accessor, mop_associated_attribute);
     SV* const key  = mop_call0(aTHX_ attr, mop_name);
+
     STRLEN klen;
     const char* const kpv = SvPV_const(key, klen);
 
-    return mop_install_accessor(aTHX_ NULL /* anonymous */, kpv, klen, accessor_impl, vtbl);
+    MAGIC* mg       = mop_attr_get_mg(aTHX_ attr);
+
+    CV* const xsub = newXS(NULL, accessor_impl, __FILE__);
+    sv_2mortal((SV*)xsub);
+
+    /* XXX: when attr is destroyed, all the associated xsub must be released */
+    CvXSUBANY(xsub).any_ptr = (void*)mg;
+
+    MOP_mg_obj(mg) = newSVpvn_share(kpv, klen, 0U);
+    MOP_mg_obj_refcounted_on(mg);
+
+    MOP_mg_ptr(mg) = vtbl; /* FIXME */
+
+    return xsub;
 }
 
 SV*