xs/MethodAccessor.xs

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