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     MAGIC* mg;
  17
  18     if(!vtbl){
  19         vtbl = mop_get_default_instance_vtbl(aTHX);
  20     }
  21
  22     if(!fq_name){
  23         /* generated_xsub need sv_2mortal */
  24         sv_2mortal((SV*)xsub);
  25     }
  26
  27     mg = sv_magicext((SV*)xsub, (SV*)meta, PERL_MAGIC_ext, &mop_accessor_vtbl, (char*)vtbl, 0);
  28     SvREFCNT_dec(meta); /* sv_magicext() increases refcnt in mg_obj */
  29
  30     av_store(meta, MOP_MI_SLOT, keysv);
  31
  32     /* NOTE:
  33      * although we use MAGIC for gc, we also store mg to any slot for efficiency (gfx)
  34      */
  35     CvXSUBANY(xsub).any_ptr = (void*)mg;
  36
  37     return xsub;
  38 }
  39
  40
  41 static CV*
  42 mop_instantiate_xs_accessor(pTHX_ SV* const accessor, XSPROTO(accessor_impl), mop_instance_vtbl* const vtbl){
  43     /* $key = $accessor->associated_attribute->name */
  44     SV* const attr = mop_call0(aTHX_ accessor, mop_associated_attribute);
  45     SV* const key  = mop_call0(aTHX_ attr, mop_name);
  46     STRLEN klen;
  47     const char* const kpv = SvPV_const(key, klen);
  48
  49     return mop_install_accessor(aTHX_ NULL /* anonymous */, kpv, klen, accessor_impl, vtbl);
  50 }
  51
  52 SV*
  53 mop_accessor_get_self(pTHX_ I32 const ax, I32 const items, CV* const cv) {
  54     SV* self;
  55
  56     if(items < 1){
  57         croak("too few arguments for %s", GvNAME(CvGV(cv)));
  58     }
  59
  60     /* NOTE: If self has GETMAGIC, $self->accessor will invoke GETMAGIC
  61      *       before calling methods, so SvGETMAGIC(self) is not necessarily needed here.
  62      */
  63
  64     self = ST(0);
  65     if(!(SvROK(self) && SvOBJECT(SvRV(self)))){
  66         croak("cant call %s as a class method", GvNAME(CvGV(cv)));
  67     }
  68     return self;
  69 }
  70
  71 #ifdef DEBUGGING
  72 SV**
  73 mop_debug_mi_access(pTHX_ AV* const mi, I32 const attr_ix){
  74     assert(mi);
  75     assert(SvTYPE(mi) == SVt_PVAV);
  76     assert(AvMAX(mi) >= attr_ix);
  77     return &AvARRAY(mi)[attr_ix];
  78 }
  79 #endif
  80
  81 XS(mop_xs_simple_accessor)
  82 {
  83     dVAR; dXSARGS;
  84     dMOP_METHOD_COMMON; /* self, mg */
  85     SV* value;
  86
  87     if(items == 1){ /* reader */
  88         value = MOP_mg_get_slot(mg, self);
  89     }
  90     else if (items == 2){ /* writer */
  91         value = MOP_mg_set_slot(mg, self, ST(1));
  92     }
  93     else{
  94         croak("expected exactly one or two argument");
  95     }
  96
  97     ST(0) = value ? value : &PL_sv_undef;
  98     XSRETURN(1);
  99 }
 100
 101
 102 XS(mop_xs_simple_reader)
 103 {
 104     dVAR; dXSARGS;
 105     dMOP_METHOD_COMMON; /* self, mg */
 106     SV* value;
 107
 108     if (items != 1) {
 109         croak("expected exactly one argument");
 110     }
 111
 112     value = MOP_mg_get_slot(mg, self);
 113     ST(0) = value ? value : &PL_sv_undef;
 114     XSRETURN(1);
 115 }
 116
 117 XS(mop_xs_simple_writer)
 118 {
 119     dVAR; dXSARGS;
 120     dMOP_METHOD_COMMON; /* self, mg */
 121
 122     if (items != 2) {
 123         croak("expected exactly two argument");
 124     }
 125
 126     ST(0) = MOP_mg_set_slot(mg, self, ST(1));
 127     XSRETURN(1);
 128 }
 129
 130 XS(mop_xs_simple_clearer)
 131 {
 132     dVAR; dXSARGS;
 133     dMOP_METHOD_COMMON; /* self, mg */
 134     SV* value;
 135
 136     if (items != 1) {
 137         croak("expected exactly one argument");
 138     }
 139
 140     value = MOP_mg_delete_slot(mg, self);
 141     ST(0) = value ? value : &PL_sv_undef;
 142     XSRETURN(1);
 143 }
 144
 145
 146 XS(mop_xs_simple_predicate)
 147 {
 148     dVAR; dXSARGS;
 149     dMOP_METHOD_COMMON; /* self, mg */
 150
 151     if (items != 1) {
 152         croak("expected exactly one argument");
 153     }
 154
 155     ST(0) = boolSV( MOP_mg_has_slot(mg, self) );
 156     XSRETURN(1);
 157 }
 158
 159
 160 XS(mop_xs_simple_predicate_for_metaclass)
 161 {
 162     dVAR; dXSARGS;
 163     dMOP_METHOD_COMMON; /* self, mg */
 164     SV* value;
 165
 166     if (items != 1) {
 167         croak("expected exactly one argument");
 168     }
 169
 170     value = MOP_mg_get_slot(mg, self);
 171     ST(0) = boolSV( value && SvOK(value ));
 172     XSRETURN(1);
 173 }
 174
 175 MODULE = Class::MOP::Method::Accessor   PACKAGE = Class::MOP::Method::Accessor
 176
 177 PROTOTYPES: DISABLE
 178
 179 BOOT:
 180     INSTALL_SIMPLE_READER_WITH_KEY(Method::Accessor, associated_attribute, attribute);
 181     INSTALL_SIMPLE_READER(Method::Accessor, accessor_type);
 182
 183
 184 CV*
 185 _generate_accessor_method_xs(SV* self, void* instance_vtbl)
 186 CODE:
 187     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_accessor, instance_vtbl);
 188 OUTPUT:
 189     RETVAL
 190
 191 CV*
 192 _generate_reader_method_xs(SV* self, void* instance_vtbl)
 193 CODE:
 194     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_reader, instance_vtbl);
 195 OUTPUT:
 196     RETVAL
 197
 198 CV*
 199 _generate_writer_method_xs(SV* self, void* instance_vtbl)
 200 CODE:
 201     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_writer, instance_vtbl);
 202 OUTPUT:
 203     RETVAL
 204
 205 CV*
 206 _generate_predicate_method_xs(SV* self, void* instance_vtbl)
 207 CODE:
 208     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_predicate, instance_vtbl);
 209 OUTPUT:
 210     RETVAL
 211
 212 CV*
 213 _generate_clearer_method_xs(SV* self, void* instance_vtbl)
 214 CODE:
 215     RETVAL = mop_instantiate_xs_accessor(aTHX_ self, mop_xs_simple_clearer, instance_vtbl);
 216 OUTPUT:
 217     RETVAL
 218