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