xs/Instance.xs

   1 #include "mop.h"
   2
   3 #define CHECK_INSTANCE(instance) STMT_START{                          \
   4         if(!(SvROK(instance) && SvTYPE(SvRV(instance)) == SVt_PVHV)){ \
   5             croak("Invalid object for instance managers");            \
   6         }                                                             \
   7     } STMT_END
   8
   9 SV*
  10 mop_instance_create(pTHX_ SV* const mi PERL_UNUSED_DECL, HV* const stash) {
  11     assert(stash);
  12     return sv_bless( newRV_noinc((SV*)newHV()), stash );
  13 }
  14
  15 SV*
  16 mop_instance_clone(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance) {
  17     HV* proto;
  18     assert(instance);
  19
  20     CHECK_INSTANCE(instance);
  21     proto = newHVhv((HV*)SvRV(instance));
  22     return sv_bless( newRV_noinc((SV*)proto), SvSTASH(SvRV(instance)) );
  23 }
  24
  25
  26
  27 bool
  28 mop_instance_has_slot(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance, SV* const slot) {
  29     assert(instance);
  30     assert(slot);
  31     CHECK_INSTANCE(instance);
  32     return hv_exists_ent((HV*)SvRV(instance), slot, 0U);
  33 }
  34
  35 SV*
  36 mop_instance_get_slot(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance, SV* const slot) {
  37     HE* he;
  38     assert(instance);
  39     assert(slot);
  40     CHECK_INSTANCE(instance);
  41     he = hv_fetch_ent((HV*)SvRV(instance), slot, FALSE, 0U);
  42     return he ? HeVAL(he) : NULL;
  43 }
  44
  45 SV*
  46 mop_instance_set_slot(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance, SV* const slot, SV* const value) {
  47     HE* he;
  48     SV* sv;
  49     assert(instance);
  50     assert(slot);
  51     assert(value);
  52     CHECK_INSTANCE(instance);
  53     he = hv_fetch_ent((HV*)SvRV(instance), slot, TRUE, 0U);
  54     sv = HeVAL(he);
  55     sv_setsv_mg(sv, value);
  56     return sv;
  57 }
  58
  59 SV*
  60 mop_instance_delete_slot(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance, SV* const slot) {
  61     assert(instance);
  62     assert(slot);
  63     CHECK_INSTANCE(instance);
  64     return hv_delete_ent((HV*)SvRV(instance), slot, 0, 0U);
  65 }
  66
  67 void
  68 mop_instance_weaken_slot(pTHX_ SV* const mi PERL_UNUSED_DECL, SV* const instance, SV* const slot) {
  69     HE* he;
  70     assert(instance);
  71     assert(slot);
  72     CHECK_INSTANCE(instance);
  73     he = hv_fetch_ent((HV*)SvRV(instance), slot, FALSE, 0U);
  74     if(he){
  75         sv_rvweaken(HeVAL(he));
  76     }
  77 }
  78
  79 static const mop_instance_vtbl mop_default_instance_vtbl = {
  80     mop_instance_create,
  81     mop_instance_clone,
  82     mop_instance_has_slot,
  83     mop_instance_get_slot,
  84     mop_instance_set_slot,
  85     mop_instance_delete_slot,
  86     mop_instance_weaken_slot,
  87 };
  88
  89
  90 const mop_instance_vtbl*
  91 mop_get_default_instance_vtbl(pTHX){
  92     return &mop_default_instance_vtbl;
  93 }
  94
  95 MODULE = Class::MOP::Instance  PACKAGE = Class::MOP::Instance
  96
  97 PROTOTYPES: DISABLE
  98
  99 VERSIONCHECK: DISABLE
 100
 101 BOOT:
 102     INSTALL_SIMPLE_READER(Instance, associated_metaclass);
 103
 104 void*
 105 can_xs(SV* self)
 106 PREINIT:
 107     CV* const default_method  = get_cv("Class::MOP::Instance::get_slot_value", FALSE);
 108     SV* const method          = newSVpvs_flags("get_slot_value", SVs_TEMP);
 109     SV* code_ref;
 110 CODE:
 111     /* $self->can("get_slot_value") == \&Class::MOP::Instance::get_slot_value */
 112     code_ref = mop_call1(aTHX_ self, mop_can, method);
 113     if(SvROK(code_ref) && SvRV(code_ref) == (SV*)default_method){
 114         RETVAL = (void*)&mop_default_instance_vtbl;
 115     }
 116     else{
 117         RETVAL = NULL;
 118     }
 119 OUTPUT:
 120     RETVAL
 121
 122 SV*
 123 create_instance(SV* self)
 124 PREINIT:
 125     SV* class_name;
 126 CODE:
 127     class_name = mop_call0_pvs(self, "_class_name");
 128     RETVAL = mop_instance_create(aTHX_ NULL, gv_stashsv(class_name, TRUE));
 129 OUTPUT:
 130     RETVAL
 131
 132 SV*
 133 clone_instance(SV* self, SV* instance)
 134 CODE:
 135     PERL_UNUSED_VAR(self);
 136     RETVAL = mop_instance_clone(aTHX_ NULL, instance);
 137 OUTPUT:
 138     RETVAL
 139
 140 bool
 141 is_slot_initialized(SV* self, SV* instance, SV* slot)
 142 CODE:
 143     PERL_UNUSED_VAR(self);
 144     RETVAL = mop_instance_has_slot(aTHX_ NULL, instance, slot);
 145 OUTPUT:
 146     RETVAL
 147
 148 SV*
 149 get_slot_value(SV* self, SV* instance, SV* slot)
 150 CODE:
 151     PERL_UNUSED_VAR(self);
 152     RETVAL = mop_instance_get_slot(aTHX_ NULL, instance, slot);
 153     RETVAL = RETVAL ? newSVsv(RETVAL) : &PL_sv_undef;
 154 OUTPUT:
 155     RETVAL
 156
 157 SV*
 158 set_slot_value(SV* self, SV* instance, SV* slot, SV* value)
 159 CODE:
 160     PERL_UNUSED_VAR(self);
 161     RETVAL = mop_instance_set_slot(aTHX_ NULL, instance, slot, value);
 162     SvREFCNT_inc_simple_void_NN(RETVAL);
 163 OUTPUT:
 164     RETVAL
 165
 166 SV*
 167 deinitialize_slot(SV* self, SV* instance, SV* slot)
 168 CODE:
 169     PERL_UNUSED_VAR(self);
 170     RETVAL = mop_instance_delete_slot(aTHX_ NULL, instance, slot);
 171     if(RETVAL){
 172         SvREFCNT_inc_simple_void_NN(RETVAL);
 173     }
 174     else{
 175         RETVAL = &PL_sv_undef;
 176     }
 177 OUTPUT:
 178     RETVAL
 179
 180 void
 181 weaken_slot_value(SV* self, SV* instance, SV* slot)
 182 CODE:
 183     PERL_UNUSED_VAR(self);
 184     mop_instance_weaken_slot(aTHX_ NULL, instance, slot);