From: Yuval Kogman Date: Mon, 18 Aug 2008 23:25:09 +0000 (+0000) Subject: Initial version of Moose::XS X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ea12c9154152231bb8ba80626c1c44bc095973d;p=gitmo%2FMoose.git Initial version of Moose::XS --- diff --git a/Moose.xs b/Moose.xs new file mode 100644 index 0000000..3089492 --- /dev/null +++ b/Moose.xs @@ -0,0 +1,285 @@ +#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 + + diff --git a/t/700_xs/001_basic.t b/t/700_xs/001_basic.t new file mode 100644 index 0000000..66498f8 --- /dev/null +++ b/t/700_xs/001_basic.t @@ -0,0 +1,66 @@ +#!/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 ); +