root/lang/perl/Class-Accessor-XS/trunk/XS.xs @ 29104

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

/* Magic識別子: &accessor_identityはプログラム中で一意の値を持つ */
MGVTBL accessor_identity;

static MAGIC*
my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){
    MAGIC* mg;
    for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
        if(mg->mg_virtual == vtbl){
            break;
        }
    }
    return mg;
}


/* code template */
XS(XS_Class_Accessor_XS_accessor); /* to pass -Wmissing-prototypes */
XS(XS_Class_Accessor_XS_accessor){
    dVAR; dXSARGS;

    SV* self;
    MAGIC* const mg = my_mg_find_by_vtbl(aTHX_ (SV*)cv, &accessor_identity);
    assert(mg);

    if(items < 1 || items > 2){
        Perl_croak(aTHX_ "Usage: $obj->%"SVf, mg->mg_obj);
    }

    self = ST(0);

    if(!(SvRV(self) && SvTYPE(SvRV(self)) == SVt_PVHV)){
        Perl_croak(aTHX_ "Not a HASH reference");
    }

    SP -= items;
    {
        HV* const obj    = (HV*)SvRV(self);
        SV* const key    = mg->mg_obj;
        U32 const hash   = (U32)XSANY.any_i32;
        SV* retval;

        if(items == 1){ /* read */
            HE* const slot = hv_fetch_ent(obj, key, FALSE, hash);
            retval = slot ? hv_iterval(obj, slot) : &PL_sv_undef;
        }
        else{ /* write */
            retval = newSVsv(ST(1));
            hv_store_ent(obj, key, retval, hash);
        }

        ST(0) = retval;
        XSRETURN(1);
    }
}

MODULE = Class::Accessor::XS    PACKAGE = Class::Accessor::XS

PROTOTYPES: DISABLE


void
mk_accessors(SV* klass, ...)
PREINIT:
    I32 i;
CODE:
    /* code generator */
    for(i = 1; i < items; i++){
        SV* const name       = ST(i);
        SV* const fq_name    = newSVpvf("%"SVf"::%"SVf, klass, name);
        STRLEN pvlen;
        const char* const pv = SvPV_const(fq_name, pvlen);
        CV* const xsub       = newXS(pv, XS_Class_Accessor_XS_accessor, __FILE__);
        U32 hash;

        PERL_HASH(hash, pv, pvlen);
        CvXSUBANY(xsub).any_i32 = (I32)hash;

        sv_magicext((SV*)xsub, fq_name, PERL_MAGIC_ext, &accessor_identity, NULL, 0);
        SvREFCNT_dec(fq_name); /* refcnt++ in sv_magixext() */
    }