xs/MethodAccessor.xs

   1 #include "mop.h"
   2
   3
   4 static MGVTBL mop_accessor_vtbl; /* the MAGIC identity */
   5
   6 MAGIC*
   7 mop_accessor_get_mg(pTHX_ CV* const xsub){
   8     return mop_mg_find(aTHX_ (SV*)xsub, &mop_accessor_vtbl, MOPf_DIE_ON_FAIL);
   9 }
  10
  11 CV*
  12 mop_install_accessor(pTHX_ const char* const fq_name, const char* const key, I32 const keylen, XSPROTO(accessor_impl), const mop_instance_vtbl* vtbl){
  13     CV* const xsub  = newXS((char*)fq_name, accessor_impl, __FILE__);
  14     SV* const keysv = newSVpvn_share(key, keylen, 0U);
  15     AV* const meta  = newAV();
  16
  17     if(!vtbl){
  18         vtbl = mop_get_default_instance_vtbl(aTHX);
  19     }
  20
  21     sv_magicext((SV*)xsub, (SV*)meta, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
  22     SvREFCNT_dec(meta); /* sv_magicext() increases refcnt in mg_obj */
  23
  24     av_store(meta, 0, keysv);
  25
  26     return xsub;
  27 }
  28
  29
  30 static CV*
  31 mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl), mop_instance_vtbl* const vtbl){
  32     /* $key = $accessor->associated_attribute->name */
  33     SV* const attr = mop_call0(aTHX_ accessor, mop_associated_attribute);
  34     SV* const key  = mop_call0(aTHX_ attr, mop_name);
  35     STRLEN klen;
  36     const char* const kpv = SvPV_const(key, klen);
  37
  38     return mop_install_accessor(aTHX_ NULL /* anonymous */, kpv, klen, accessor_impl, vtbl);
  39 }
  40
  41 SV*
  42 mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv) {
  43     SV* self;
  44
  45     if(items < 1){
  46         croak("too few arguments for %s", GvNAME(CvGV(cv)));
  47     }
  48
  49     self = ST(0);
  50     if(!(SvROK(self) && SvOBJECT(SvRV(self)))){
  51         croak("cant call %s as a class method", GvNAME(CvGV(cv)));
  52     }
  53     return self;
  54 }
  55
  56 XS(mop_xs_simple_accessor)
  57 {
  58     dVAR; dXSARGS;
  59     dMOP_METHOD_COMMON; /* self, mg */
  60     SV* value;
  61     if(items == 1){ /* reader */
  62         value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
  63     }
  64     else if (items == 2){ /* writer */
  65         value = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1));
  66     }
  67     else{
  68         croak("expected exactly one or two argument");
  69     }
  70
  71     ST(0) = value ? value : &PL_sv_undef;
  72     XSRETURN(1);
  73 }
  74
  75
  76 XS(mop_xs_simple_reader)
  77 {
  78     dVAR; dXSARGS;
  79     dMOP_METHOD_COMMON; /* self, mg */
  80     SV* value;
  81
  82     if (items != 1) {
  83         croak("expected exactly one argument");
  84     }
  85
  86     value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
  87     ST(0) = value ? value : &PL_sv_undef;
  88     XSRETURN(1);
  89 }
  90
  91 XS(mop_xs_simple_writer)
  92 {
  93     dVAR; dXSARGS;
  94     dMOP_METHOD_COMMON; /* self, mg */
  95
  96     if (items != 2) {
  97         croak("expected exactly two argument");
  98     }
  99
 100     ST(0) = MOP_mg_vtbl(mg)->set_slot(aTHX_ self, MOP_mg_key(mg), ST(1));
 101     XSRETURN(1);
 102 }
 103
 104 XS(mop_xs_simple_clearer)
 105 {
 106     dVAR; dXSARGS;
 107     dMOP_METHOD_COMMON; /* self, mg */
 108     SV* value;
 109
 110     if (items != 1) {
 111         croak("expected exactly one argument");
 112     }
 113
 114     value = MOP_mg_vtbl(mg)->delete_slot(aTHX_ self, MOP_mg_key(mg));
 115     ST(0) = value ? value : &PL_sv_undef;
 116     XSRETURN(1);
 117 }
 118
 119
 120 XS(mop_xs_simple_predicate)
 121 {
 122     dVAR; dXSARGS;
 123     dMOP_METHOD_COMMON; /* self, mg */
 124
 125     if (items != 1) {
 126         croak("expected exactly one argument");
 127     }
 128
 129     ST(0) = boolSV( MOP_mg_vtbl(mg)->has_slot(aTHX_ self, MOP_mg_key(mg)) );
 130     XSRETURN(1);
 131 }
 132
 133
 134 XS(mop_xs_simple_predicate_for_metaclass)
 135 {
 136     dVAR; dXSARGS;
 137     dMOP_METHOD_COMMON; /* self, mg */
 138     SV* value;
 139
 140     if (items != 1) {
 141         croak("expected exactly one argument");
 142     }
 143
 144     value = MOP_mg_vtbl(mg)->get_slot(aTHX_ self, MOP_mg_key(mg));
 145     ST(0) = boolSV( value && SvOK(value ));
 146     XSRETURN(1);
 147 }
 148
 149 MODULE = Class::MOP::Method::Accessor   PACKAGE = Class::MOP::Method::Accessor
 150
 151 PROTOTYPES: DISABLE
 152
 153 BOOT:
 154     INSTALL_SIMPLE_READER_WITH_KEY(Method::Accessor, associated_attribute, attribute);
 155     INSTALL_SIMPLE_READER(Method::Accessor, accessor_type);
 156
 157
 158 CV*
 159 _generate_accessor_method_xs(SV* self, void* instance_vtbl)
 160 CODE:
 161     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor, instance_vtbl);
 162 OUTPUT:
 163     RETVAL
 164
 165 CV*
 166 _generate_reader_method_xs(SV* self, void* instance_vtbl)
 167 CODE:
 168     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader, instance_vtbl);
 169 OUTPUT:
 170     RETVAL
 171
 172 CV*
 173 _generate_writer_method_xs(SV* self, void* instance_vtbl)
 174 CODE:
 175     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer, instance_vtbl);
 176 OUTPUT:
 177     RETVAL
 178
 179 CV*
 180 _generate_predicate_method_xs(SV* self, void* instance_vtbl)
 181 CODE:
 182     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate, instance_vtbl);
 183 OUTPUT:
 184     RETVAL
 185
 186 CV*
 187 _generate_clearer_method_xs(SV* self, void* instance_vtbl)
 188 CODE:
 189     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer, instance_vtbl);
 190 OUTPUT:
 191     RETVAL
 192