A first step to cooperate Moose.xs (topic/xs-accessor)

[gitmo/Class-MOP.git] / xs / MethodAccessor.xs

diff --git a/xs/MethodAccessor.xs b/xs/MethodAccessor.xs
old mode 100755 (executable)
new mode 100644 (file)
index 037ed41..0dfe4f3
--- a/xs/MethodAccessor.xs
+++ b/xs/MethodAccessor.xs
@@ -1,13 +1,149 @@
 #include "mop.h"
 
+
+static MGVTBL mop_accessor_vtbl; /* the MAGIC identity */
+
+MAGIC*
+mop_accessor_get_mg(pTHX_ CV* const xsub){
+    return mop_mg_find(aTHX_ (SV*)xsub, &mop_accessor_vtbl, MOPf_DIE_ON_FAIL);
+}
+
+CV*
+mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(accessor_impl), const mop_instance_vtbl* vtbl){
+    CV* const xsub  = newXS((char*)fq_name, accessor_impl, __FILE__);
+    SV* const keysv = newSVpvn_share(key, keylen, 0U);
+    AV* const meta  = newAV();
+
+    if(!vtbl){
+        vtbl = mop_get_default_instance_vtbl(aTHX);
+    }
+
+    sv_magicext((SV*)xsub, (SV*)meta, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
+    SvREFCNT_dec(meta); /* sv_magicext() increases refcnt in mg_obj */
+
+    av_store(meta, 0, keysv);
+
+    return xsub;
+}
+
+
 static CV*
-mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl)){
+mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl), mop_instance_vtbl* const vtbl){
     /* $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 len;
-    const char* const pv = SvPV_const(key, len);
-    return mop_install_simple_accessor(aTHX_ NULL /* anonymous */, pv, len, accessor_impl);
+    STRLEN klen;
+    const char* const kpv = SvPV_const(key, klen);
+
+    return mop_install_accessor(aTHX_ NULL /* anonymous */, kpv, klen, accessor_impl, vtbl);
+}
+
+SV*
+mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv) {
+    SV* self;
+
+    if(items < 1){
+        croak("too few arguments for %s", GvNAME(CvGV(cv)));
+    }
+
+    self = ST(0);
+    if(!(SvROK(self) && SvOBJECT(SvRV(self)))){
+        croak("cant call %s as a class method", GvNAME(CvGV(cv)));
+    }
+    return self;
+}
+
+XS(mop_xs_simple_accessor)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+    SV* value;
+    if(items == 1){ /* reader */
+        value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
+    }
+    else if (items == 2){ /* writer */
+        value = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1));
+    }
+    else{
+        croak("expected exactly one or two argument");
+    }
+
+    ST(0) = value ? value : &PL_sv_undef;
+    XSRETURN(1);
+}
+
+
+XS(mop_xs_simple_reader)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+    SV* value;
+
+    if (items != 1) {
+        croak("expected exactly one argument");
+    }
+
+    value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
+    ST(0) = value ? value : &PL_sv_undef;
+    XSRETURN(1);
+}
+
+XS(mop_xs_simple_writer)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+
+    if (items != 2) {
+        croak("expected exactly two argument");
+    }
+
+    ST(0) = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1));
+    XSRETURN(1);
+}
+
+XS(mop_xs_simple_clearer)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+    SV* value;
+
+    if (items != 1) {
+        croak("expected exactly one argument");
+    }
+
+    value = MOP_mg_vtbl(mg)->delete_slot(aTHX_ self, MOP_mg_key(mg));
+    ST(0) = value ? value : &PL_sv_undef;
+    XSRETURN(1);
+}
+
+
+XS(mop_xs_simple_predicate)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+
+    if (items != 1) {
+        croak("expected exactly one argument");
+    }
+
+    ST(0) = boolSV( MOP_mg_vtbl(mg)->has_slot(aTHX_ self, MOP_mg_key(mg)) );
+    XSRETURN(1);
+}
+
+
+XS(mop_xs_simple_predicate_for_metaclass)
+{
+    dVAR; dXSARGS;
+    dMOP_METHOD_COMMON; /* self, mg */
+    SV* value;
+
+    if (items != 1) {
+        croak("expected exactly one argument");
+    }
+
+    value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
+    ST(0) = boolSV( value && SvOK(value ));
+    XSRETURN(1);
 }
 
 MODULE = Class::MOP::Method::Accessor   PACKAGE = Class::MOP::Method::Accessor
@@ -20,37 +156,37 @@ BOOT:
 
 
 CV*
-_generate_accessor_method_xs(SV* self)
+_generate_accessor_method_xs(SV* self, void* instance_vtbl)
 CODE:
-    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor);
+    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor, instance_vtbl);
 OUTPUT:
     RETVAL
 
 CV*
-_generate_reader_method_xs(SV* self)
+_generate_reader_method_xs(SV* self, void* instance_vtbl)
 CODE:
-    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader);
+    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader, instance_vtbl);
 OUTPUT:
     RETVAL
 
 CV*
-_generate_writer_method_xs(SV* self)
+_generate_writer_method_xs(SV* self, void* instance_vtbl)
 CODE:
-    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer);
+    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer, instance_vtbl);
 OUTPUT:
     RETVAL
 
 CV*
-_generate_predicate_method_xs(SV* self)
+_generate_predicate_method_xs(SV* self, void* instance_vtbl)
 CODE:
-    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate);
+    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate, instance_vtbl);
 OUTPUT:
     RETVAL
 
 CV*
-_generate_clearer_method_xs(SV* self)
+_generate_clearer_method_xs(SV* self, void* instance_vtbl)
 CODE:
-    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer);
+    RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer, instance_vtbl);
 OUTPUT:
     RETVAL