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

Revision 29104, 2.2 kB (checked in by gfx, 5 years ago)

initial import

Line 
1#define PERL_NO_GET_CONTEXT
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6#include "ppport.h"
7
8/* Magic識別子: &accessor_identityはプログラム中で一意の値を持つ */
9MGVTBL accessor_identity;
10
11static MAGIC*
12my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){
13    MAGIC* mg;
14    for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
15        if(mg->mg_virtual == vtbl){
16            break;
17        }
18    }
19    return mg;
20}
21
22
23/* code template */
24XS(XS_Class_Accessor_XS_accessor); /* to pass -Wmissing-prototypes */
25XS(XS_Class_Accessor_XS_accessor){
26    dVAR; dXSARGS;
27
28    SV* self;
29    MAGIC* const mg = my_mg_find_by_vtbl(aTHX_ (SV*)cv, &accessor_identity);
30    assert(mg);
31
32    if(items < 1 || items > 2){
33        Perl_croak(aTHX_ "Usage: $obj->%"SVf, mg->mg_obj);
34    }
35
36    self = ST(0);
37
38    if(!(SvRV(self) && SvTYPE(SvRV(self)) == SVt_PVHV)){
39        Perl_croak(aTHX_ "Not a HASH reference");
40    }
41
42    SP -= items;
43    {
44        HV* const obj    = (HV*)SvRV(self);
45        SV* const key    = mg->mg_obj;
46        U32 const hash   = (U32)XSANY.any_i32;
47        SV* retval;
48
49        if(items == 1){ /* read */
50            HE* const slot = hv_fetch_ent(obj, key, FALSE, hash);
51            retval = slot ? hv_iterval(obj, slot) : &PL_sv_undef;
52        }
53        else{ /* write */
54            retval = newSVsv(ST(1));
55            hv_store_ent(obj, key, retval, hash);
56        }
57
58        ST(0) = retval;
59        XSRETURN(1);
60    }
61}
62
63MODULE = Class::Accessor::XS    PACKAGE = Class::Accessor::XS
64
65PROTOTYPES: DISABLE
66
67
68void
69mk_accessors(SV* klass, ...)
70PREINIT:
71    I32 i;
72CODE:
73    /* code generator */
74    for(i = 1; i < items; i++){
75        SV* const name       = ST(i);
76        SV* const fq_name    = newSVpvf("%"SVf"::%"SVf, klass, name);
77        STRLEN pvlen;
78        const char* const pv = SvPV_const(fq_name, pvlen);
79        CV* const xsub       = newXS(pv, XS_Class_Accessor_XS_accessor, __FILE__);
80        U32 hash;
81
82        PERL_HASH(hash, pv, pvlen);
83        CvXSUBANY(xsub).any_i32 = (I32)hash;
84
85        sv_magicext((SV*)xsub, fq_name, PERL_MAGIC_ext, &accessor_identity, NULL, 0);
86        SvREFCNT_dec(fq_name); /* refcnt++ in sv_magixext() */
87    }
88
Note: See TracBrowser for help on using the browser.