Moo like

Makefile.PL

@@ -33,8 +33,8 @@ WriteMakefile(
     LICENSE         => 'perl',
     MIN_PERL_VERSION=> 5.010001,
     CCFLAGS         => $CCFLAGS,
+    OBJECT           => 'XS.o meta.o',
     #LIBS            => ['-lstdc++'],
-    #XSOPT           => '-C++',
 );
 
 {

XS.xs

@@ -10,54 +10,60 @@ static MGVTBL sv_payload_marker;
 static bool optimize_entersub = 1;
 static int unstolen = 0;
 
+#include "xs/meta.h"
 #include "xs/compat.h"
 #include "xs/types.h"
 #include "xs/accessors.h"
 #include "xs/installer.h"
 
 static void
 CAIXS_install_inherited_accessor(pTHX_ SV* full_name, SV* hash_key, SV* pkg_key, SV* read_cb, SV* write_cb, int opts) {
-    shared_keys* payload;
+    install_info info;
     bool need_cb = read_cb && write_cb;
 
     if (need_cb) {
         assert(pkg_key != NULL);
 
         if (opts & IsNamed) {
-            payload = CAIXS_install_accessor<InheritedCbNamed>(aTHX_ full_name, (AccessorOpts)(opts & ~IsNamed));
+            info = CAIXS_install_accessor<InheritedCbNamed>(aTHX_ full_name, (AccessorOpts)(opts & ~IsNamed));
         } else {
-            payload = CAIXS_install_accessor<InheritedCb>(aTHX_ full_name, (AccessorOpts)opts);
+            info = CAIXS_install_accessor<InheritedCb>(aTHX_ full_name, (AccessorOpts)opts);
         }
 
     } else if (pkg_key != NULL) {
-        payload = CAIXS_install_accessor<Inherited>(aTHX_ full_name, (AccessorOpts)opts);
+        info = CAIXS_install_accessor<Inherited>(aTHX_ full_name, (AccessorOpts)opts);
 
     } else {
-        payload = CAIXS_install_accessor<ObjectOnly>(aTHX_ full_name, (AccessorOpts)opts);
+        info = CAIXS_install_accessor<ObjectOnly>(aTHX_ full_name, (AccessorOpts)opts);
+        /*
+        SV* required = &PL_sv_yes;
+        SV* default_val = &PL_sv_undef;
+        caixs::meta::install(info.cv, hash_key, required, default_val);
+        */
     }
 
     STRLEN len;
     const char* hash_key_buf = SvPV_const(hash_key, len);
     SV* s_hash_key = newSVpvn_share(hash_key_buf, SvUTF8(hash_key) ? -(I32)len : (I32)len, 0);
-    payload->hash_key = s_hash_key;
+    info.payload->hash_key = s_hash_key;
 
     if (pkg_key != NULL) {
         const char* pkg_key_buf = SvPV_const(pkg_key, len);
         SV* s_pkg_key = newSVpvn_share(pkg_key_buf, SvUTF8(pkg_key) ? -(I32)len : (I32)len, 0);
-        payload->pkg_key = s_pkg_key;
+        info.payload->pkg_key = s_pkg_key;
     }
 
     if (need_cb) {
         if (SvROK(read_cb) && SvTYPE(SvRV(read_cb)) == SVt_PVCV) {
-            payload->read_cb = SvREFCNT_inc_NN(SvRV(read_cb));
+            info.payload->read_cb = SvREFCNT_inc_NN(SvRV(read_cb));
         } else {
-            payload->read_cb = NULL;
+            info.payload->read_cb = NULL;
         }
 
         if (SvROK(write_cb) && SvTYPE(SvRV(write_cb)) == SVt_PVCV) {
-            payload->write_cb = SvREFCNT_inc_NN(SvRV(write_cb));
+            info.payload->write_cb = SvREFCNT_inc_NN(SvRV(write_cb));
         } else {
-            payload->write_cb = NULL;
+            info.payload->write_cb = NULL;
         }
     }
 }
@@ -66,34 +72,34 @@ static void
 CAIXS_install_class_accessor(pTHX_ SV* full_name, SV* default_sv, bool is_varclass, int opts) {
     bool is_lazy = SvROK(default_sv) && SvTYPE(SvRV(default_sv)) == SVt_PVCV;
 
-    shared_keys* payload;
+    install_info info;
     if (is_lazy) {
-        payload = CAIXS_install_accessor<LazyClass>(aTHX_ full_name, (AccessorOpts)opts);
+        info = CAIXS_install_accessor<LazyClass>(aTHX_ full_name, (AccessorOpts)opts);
 
     } else {
-        payload = CAIXS_install_accessor<PrivateClass>(aTHX_ full_name, (AccessorOpts)opts);
+        info = CAIXS_install_accessor<PrivateClass>(aTHX_ full_name, (AccessorOpts)opts);
     }
 
     if (is_varclass) {
         GV* gv = gv_fetchsv(full_name, GV_ADD, SVt_PV);
         assert(gv);
 
-        payload->storage = GvSV(gv);
-        assert(payload->storage);
+        info.payload->storage = GvSV(gv);
+        assert(info.payload->storage);
 
         /* We take ownership of this glob slot, so if someone changes the glob - they're in trouble */
-        SvREFCNT_inc_simple_void_NN(payload->storage);
+        SvREFCNT_inc_simple_void_NN(info.payload->storage);
 
     } else {
-        payload->storage = newSV(0);
+        info.payload->storage = newSV(0);
     }
 
     if (SvOK(default_sv)) {
         if (is_lazy) {
-            payload->lazy_cb = SvREFCNT_inc_NN(SvRV(default_sv));
+            info.payload->lazy_cb = SvREFCNT_inc_NN(SvRV(default_sv));
 
         } else {
-            sv_setsv(payload->storage, default_sv);
+            sv_setsv(info.payload->storage, default_sv);
         }
     }
 }
@@ -155,6 +161,19 @@ PPCODE:
     XSRETURN_UNDEF;
 }
 
+void
+test_install_meta(SV* full_name, SV* hash_key, SV* required, SV* default_value)
+PPCODE:
+{
+    STRLEN len;
+    const char* name = SvPV_const(full_name, len);
+    CV* cv = get_cvn_flags(name, len, 0);
+    if (!cv) croak("Can't get cv");
+
+    caixs::meta::install(cv, hash_key, required, default_value);
+    XSRETURN_UNDEF;
+}
+
 MODULE = Class::Accessor::Inherited::XS     PACKAGE = Class::Accessor::Inherited::XS::Constants
 PROTOTYPES: DISABLE
 

meta.cc

@@ -0,0 +1,138 @@
+#include "xs/meta.h"
+#include "xs/common.h"
+#include <new>
+
+namespace caixs { namespace meta {
+
+typedef AV* PackageMeta;
+
+static MGVTBL package_marker;
+
+static int field_meta_free(pTHX_ SV*, MAGIC* mg);
+
+struct FieldMeta {
+    SV* name;
+    SV* required;
+    SV* default_value;
+};
+
+
+#define FIELDS_PREALLOCADED 5
+#define FIELD_SV_COUNT 3
+
+static PackageMeta find_package(HV* stash) {
+    MAGIC* mg = CAIXS_mg_findext((SV*)stash, PERL_MAGIC_ext, &package_marker);
+    return (PackageMeta)(mg ? mg->mg_obj : NULL);
+}
+
+static PackageMeta create_package(HV* stash) {
+    AV* meta = newAV();
+    av_extend(meta, FIELDS_PREALLOCADED * FIELD_SV_COUNT);
+
+    sv_magicext((SV*)stash, (SV*)meta, PERL_MAGIC_ext, &package_marker, NULL, 0);
+    SvREFCNT_dec_NN((SV*)meta);
+    SvRMAGICAL_off((SV*)stash);
+
+    return meta;
+}
+
+inline size_t size(PackageMeta meta) { return (AvFILLp(meta) + 1) / FIELD_SV_COUNT;}
+
+void record(PackageMeta meta, SV* hash_key, SV* required, SV* default_value) {
+    FieldMeta* fields = (FieldMeta*)AvARRAY(meta);
+
+    STRLEN name_len;
+    char* name = SvPV(hash_key, name_len);
+
+    /* check that there might be already field meta is defined*/
+    size_t fields_sz = size(meta);
+    for(size_t i = 0; i < fields_sz; ++i) {
+        STRLEN field_len;
+        char* field_name = SvPV(fields[i].name, field_len);
+        if (field_len != name_len) continue;
+
+        if (strcmp(name, field_name) == 0) {
+            croak("object key '%' is already defined", name);
+        }
+    }
+
+    if (SvOK(default_value) && (!SvROK(default_value) || SvTYPE(SvRV(default_value)) != SVt_PVCV))
+        croak("'default' should be a code reference");
+
+    size_t new_sz = AvFILLp(meta) + FIELD_SV_COUNT;
+    av_fill(meta, new_sz);
+
+    SvREFCNT_inc_simple_NN(hash_key);
+    SvREFCNT_inc_simple(default_value);
+    FieldMeta& field = fields[fields_sz];
+
+    field.name = hash_key;
+    field.required = SvTRUE(required) ? &PL_sv_yes : NULL;
+    field.default_value = default_value;
+}
+
+void activate(PackageMeta meta, SV *sv) {
+    HV* hv = (HV*)SvRV(sv);
+
+    FieldMeta* fields = (FieldMeta*)AvARRAY(meta);
+    size_t fields_sz = size(meta);
+    for(size_t i = 0; i < fields_sz; ++i) {
+        FieldMeta& field = fields[i];
+
+        STRLEN field_len;
+        char* field_name = SvPV(field.name, field_len);
+
+        if (SvOK(field.default_value)) {
+            SV** value = hv_fetch(hv, field_name, field_len, 0);
+            if (!value) {
+                dSP;
+                PUSHMARK(SP);
+                int count = call_sv(fields->default_value, G_SCALAR | G_NOARGS);
+                SPAGAIN;
+
+                if (count != 1) croak("unexpected return from 'default': %d, expected: 1", count);
+
+                SV* new_val = POPs;
+                SvREFCNT_inc(new_val);
+                SV** ok = hv_store(hv, field_name, field_len, new_val, 0);
+                if (!ok) SvREFCNT_dec(new_val);
+                PUTBACK;
+            }
+        } else if (field.required == &PL_sv_yes) {
+            SV** value = hv_fetch(hv, field_name, field_len, 0);
+            if (!value) croak("key '%s' is required", field_name);
+            return;
+        }
+    }
+}
+
+// API-helpers
+
+void install (CV *cv, SV* hash_key, SV* required, SV *default_value) {
+    GV* gv = CvGV(cv);
+    if (!gv) croak("cant get CV's glob");
+
+    HV* stash = GvSTASH(gv);
+    if (!stash) croak("can't get stash");
+
+    PackageMeta meta = find_package(stash);
+    if (!meta) meta = create_package(stash);
+    if (!meta) return;
+
+    record(meta, hash_key, required, default_value);
+}
+
+void activate(HV* stash, SV* object) {
+    PackageMeta meta = find_package(stash);
+    if (!meta) return;
+
+    activate(meta, object);
+}
+
+
+
+}}
+
+
+
+

t/xx-mine.t

@@ -0,0 +1,43 @@
+use strict;
+use Test::More;
+use Class::Accessor::Inherited::XS;
+use Class::Accessor::Inherited::XS::Constants;
+
+sub install {
+    my ($package, $key, $required, $default) = @_;
+    Class::Accessor::Inherited::XS::install_constructor("${package}::new");
+    Class::Accessor::Inherited::XS::install_object_accessor("${package}::${key}", $key, None);
+    Class::Accessor::Inherited::XS::test_install_meta("${package}::${key}", $key, $required, $default);
+};
+
+subtest "check required" => sub {
+    subtest "required = 1" => sub {
+        my $package = 't::P' . __LINE__;
+        install($package, 'foo', 1, undef);
+        ok (eval { $package->new(foo => 'v'); 1 }, "when required key is supplied, all ok");
+        is (eval { $package->new(k => 'v'); 1 }, undef, "when required key is missing, die");
+        like $@, qr/key 'foo' is required/;
+    };
+
+    subtest "required = 0" => sub {
+        my $package = 't::P' . __LINE__;
+        install($package, 'foo', 0, undef);
+        ok (eval { $package->new(foo => 'v'); 1 }, "when required key is supplied, all ok");
+        ok (eval { $package->new(foo => 'v'); 1 }, "when required key is missing, all ok");
+    };
+};
+
+subtest "check default" => sub {
+    my $default = \"default-value";
+    my $sub = sub { return $$default } ;
+    my $package = 't::P' . __LINE__;
+    install($package, 'foo', 0, $sub);
+    is $package->new(foo => 'v')->{foo}, 'v';
+    is $package->new->{foo}, 'default-value';
+
+    $default = \undef;
+    is $package->new->{foo}, undef;
+};
+
+
+done_testing;

xs/accessors.h

@@ -240,6 +240,7 @@ static void CAIXS_accessor(pTHX_ SV** SP, CV* cv, HV* stash) {
     }
 
     sv_bless(self, stash);
+    caixs::meta::activate(stash, self);
     *ret = self;
     return;
 }};

xs/common.h

@@ -0,0 +1,25 @@
+#ifndef __INHERITED_XS_COMMON_H_
+#define __INHERITED_XS_COMMON_H_
+
+extern "C" {
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+}
+
+inline MAGIC*
+CAIXS_mg_findext(SV* sv, int type, MGVTBL* vtbl) {
+    MAGIC* mg;
+
+    if (sv) {
+        for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+            if (mg->mg_type == type && mg->mg_virtual == vtbl) {
+                return mg;
+            }
+        }
+    }
+
+    return NULL;
+}
+
+#endif

xs/fimpl.h

@@ -14,7 +14,7 @@ template <AccessorType type, AccessorOpts opts>
 struct CImpl;
 
 template <AccessorType type> inline
-shared_keys*
+install_info
 CAIXS_install_accessor(pTHX_ SV* full_name, AccessorOpts val) {
     return CImpl<type, AccessorOptsBF>::CAIXS_install_accessor(aTHX_ val, full_name);
 }