--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define SLOT_WEAKEN 0x01
+
+/* FIXME
+ * needs to be made into Moose::XS::Meta::Instance and Meta::Slot for the
+ * metadata, with a proper destructor. XSANY still points to this struct, but
+ * it is shared by all functions of the same type.
+ *
+ * Instance contains SvSTASH, and SLOT slots[]
+ *
+ * On recreation of the meta instance we refresh the SLOT value of all the CVs
+ * we installed
+ *
+ * need a good way to handle time between invalidate and regeneration (just
+ * check XSANY and call get_meta_instance if null?)
+ */
+
+
+/* FIXME
+ * slot access is one of 4 values in flags:
+ * 0 == hash
+ * 1 == array
+ * 3 == fptr (allows access into C structs, etc)
+ * 4 == callsv (really a special case of fptr)
+ *
+ * for fptr case we have a pointer to a vtable for get/set/has/delete, all of which take the same args as set_slot_value
+ */
+
+/* FIXME
+ * type constraints are already implemented by konobi
+ * should be trivial to do coercions for the core types, too
+ *
+ * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
+ * call ->isa (should handle vast majority of cases)
+ *
+ * base parametrized types are also trivial
+ *
+ * ClassName is get_stathpvn
+ */
+
+/* FIXME
+ * for a constructor we have SLOT *slots, and iterate that, removing init_arg
+ * we can preallocate the structure to the right size (maybe even with the
+ * right HEs?), and do various other prehashing hacks to gain speed
+ * */
+
+/* FIXME
+ * delegations and attribute helpers:
+ *
+ * typedef struct {
+ * SLOT *slot;
+ * pv *method;
+ * } delegation;
+ *
+ * typedef struct {
+ * SLOT *slot;
+ * I32 *type; // hash, array, whatever + vtable for operation
+ * } attributehelper;
+ */
+
+typedef struct {
+ U32 hash;
+ SV *sv;
+ U32 flags /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
+ /* FIXME
+ * type constraint (pointer or enum union)
+ * default / builder ptr (or SV *)
+ * initializer
+ */
+} SLOT;
+
+#define dSLOT SLOT *slot = INT2PTR(SLOT *, XSANY.any_i32)
+
+/* utility functions */
+
+STATIC SLOT *new_slot_from_key (SV *key, U32 flags) {
+ SLOT *slot = (SLOT *)malloc(sizeof(SLOT));
+ U32 hash;
+ STRLEN len;
+ char *pv = SvPV(key, len);
+
+ PERL_HASH(hash, pv, len);
+ slot->sv = newSVpvn_share(pv, len, hash);
+ slot->hash = hash;
+ slot->flags = flags;
+
+ return slot;
+}
+
+STATIC void weaken(SV *sv) {
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+}
+
+
+/* meta instance protocol */
+
+STATIC SV *get_slot_value(SV *self, SLOT *slot) {
+ HE *he;
+
+ assert(self);
+ assert(SvROK(self));
+ assert(SvTYPE(SvRV(self)) == SVt_PVHV);
+
+ if (he = hv_fetch_ent((HV *)SvRV(self), slot->sv, 0, slot->hash))
+ return HeVAL(he);
+ else
+ return NULL;
+}
+
+STATIC void set_slot_value(SV *self, SLOT *slot, SV *value) {
+ HE *he;
+
+ assert(self);
+ assert(SvROK(self));
+ assert(SvTYPE(SvRV(self)) == SVt_PVHV);
+
+ SvREFCNT_inc(value);
+
+ he = hv_store_ent((HV*)SvRV(self), slot->sv, value, slot->hash);
+ if (he != NULL) {
+ if ( slot->flags & SLOT_WEAKEN )
+ weaken(HeVAL(he));
+ } else {
+ croak("Hash store failed.");
+ }
+}
+
+STATIC bool has_slot_value(SV *self, SLOT *slot) {
+ assert(self);
+ assert(SvROK(self));
+ assert(SvTYPE(SvRV(self)) == SVt_PVHV);
+
+ return hv_exists_ent((HV *)SvRV(self), slot->sv, slot->hash);
+}
+
+
+/* simple high level api */
+
+STATIC XS(simple_getter);
+STATIC XS(simple_getter)
+{
+#ifdef dVAR
+ dVAR;
+#endif
+ dXSARGS;
+ dSLOT;
+ SV *value;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
+
+ SP -= items;
+
+ value = get_slot_value(ST(0), slot);
+
+ if (value) {
+ ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
+ XSRETURN(1);
+ } else {
+ XSRETURN_UNDEF;
+ }
+}
+
+STATIC XS(simple_setter);
+STATIC XS(simple_setter)
+{
+#ifdef dVAR
+ dVAR;
+#endif
+ dXSARGS;
+ dSLOT;
+
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
+
+ SP -= items;
+
+ set_slot_value(ST(0), slot, ST(1));
+
+ ST(0) = ST(1); /* return value */
+ XSRETURN(1);
+}
+
+STATIC XS(simple_accessor);
+STATIC XS(simple_accessor)
+{
+#ifdef dVAR
+ dVAR;
+#endif
+ dXSARGS;
+ dSLOT;
+
+ if (items < 1)
+ Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
+
+ SP -= items;
+
+ if (items > 1) {
+ set_slot_value(ST(0), slot, ST(1));
+ ST(0) = ST(1); /* return value */
+ } else {
+ SV *value = get_slot_value(ST(0), slot);
+ if ( value ) {
+ ST(0) = value;
+ } else {
+ XSRETURN_UNDEF;
+ }
+ }
+
+ XSRETURN(1);
+}
+
+STATIC XS(predicate);
+STATIC XS(predicate)
+{
+#ifdef dVAR
+ dVAR;
+#endif
+ dXSARGS;
+ dSLOT;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
+
+ SP -= items;
+
+ if ( has_slot_value(ST(0), slot) )
+ XSRETURN_YES;
+ else
+ XSRETURN_NO;
+}
+
+enum xs_body {
+ xs_body_simple_getter = 0,
+ xs_body_simple_setter,
+ xs_body_simple_accessor,
+ xs_body_predicate,
+ max_xs_body
+};
+
+STATIC XSPROTO ((*xs_bodies[])) = {
+ simple_getter,
+ simple_setter,
+ simple_accessor,
+ predicate,
+};
+
+MODULE = Moose PACKAGE = Moose::XS
+
+CV *
+install_sub(name, key)
+ INPUT:
+ char *name;
+ SV *key;
+ ALIAS:
+ install_simple_getter = xs_body_simple_getter
+ install_simple_setter = xs_body_simple_setter
+ install_simple_accessor = xs_body_simple_accessor
+ install_predicate = xs_body_predicate
+ PREINIT:
+ CV * cv;
+ CODE:
+ if ( ix >= max_xs_body )
+ croak("Unknown Moose::XS body type");
+
+ cv = newXS(name, xs_bodies[ix], __FILE__);
+
+ if (cv == NULL)
+ croak("Oi vey!");
+
+ /* FIXME leaks, fail for anon classes */
+ XSANY.any_i32 = PTR2IV(new_slot_from_key(key, 0));
+
+ RETVAL = cv;
+ OUTPUT:
+ RETVAL
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ plan skip_all => "no XSLoader" unless eval { require XSLoader };
+
+ plan skip_all => $@ unless eval {
+ require Moose;
+ Moose->XSLoader::load($Moose::VERSION);
+ 1;
+ };
+
+ plan 'no_plan';
+}
+
+ok( defined &Moose::XS::install_simple_getter );
+ok( defined &Moose::XS::install_simple_setter );
+ok( defined &Moose::XS::install_simple_accessor );
+ok( defined &Moose::XS::install_predicate );
+
+{
+ package Foo;
+ use Moose;
+
+ has x => ( is => "rw", predicate => "has_x" );
+ has y => ( is => "ro" );
+ has z => ( reader => "z", setter => "set_z" );
+}
+
+Moose::XS::install_simple_accessor("Foo::x", "x");
+Moose::XS::install_predicate("Foo::has_x", "x");
+Moose::XS::install_simple_getter("Foo::y", "y");
+Moose::XS::install_simple_getter("Foo::z", "z");
+Moose::XS::install_simple_setter("Foo::set_z", "z");
+
+my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE" );
+
+is( $foo->x, "ICKS" );
+is( $foo->y, "WHY" );
+is( $foo->z, "ZEE" );
+
+lives_ok { $foo->x("YASE") };
+
+is( $foo->x, "YASE" );
+
+dies_ok { $foo->y("blah") };
+
+is( $foo->y, "WHY" );
+
+dies_ok { $foo->z("blah") };
+
+is( $foo->z, "ZEE" );
+
+lives_ok { $foo->set_z("new") };
+
+is( $foo->z, "new" );
+
+ok( $foo->has_x );
+
+ok( !Foo->new->has_x );
+
projects / gitmo/Moose.git / commitdiff