xs/Package.xs

   1
   2 #include "mop.h"
   3
   4 static void
   5 mop_deconstruct_variable_name(pTHX_ SV* const variable,
   6     const char** const var_name, STRLEN* const var_name_len,
   7     svtype* const type,
   8     const char** const type_name) {
   9
  10
  11     if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
  12         /* e.g. variable = { type => "SCALAR", name => "foo" } */
  13         HV* const hv = (HV*)SvRV(variable);
  14         SV** svp;
  15         STRLEN len;
  16         const char* pv;
  17
  18         svp = hv_fetchs(hv, "name", FALSE);
  19         if(!(svp && SvOK(*svp))){
  20             croak("You must pass a variable name");
  21         }
  22         *var_name     = SvPV_const(*svp, len);
  23         *var_name_len = len;
  24         if(len < 1){
  25             croak("You must pass a variable name");
  26         }
  27
  28         svp = hv_fetchs(hv, "type", FALSE);
  29         if(!(svp && SvOK(*svp))) {
  30             croak("You must pass a variable type");
  31         }
  32         pv = SvPV_nolen_const(*svp);
  33         if(strEQ(pv, "SCALAR")){
  34             *type = SVt_PV; /* for all the type of scalars */
  35         }
  36         else if(strEQ(pv, "ARRAY")){
  37             *type = SVt_PVAV;
  38         }
  39         else if(strEQ(pv, "HASH")){
  40             *type = SVt_PVHV;
  41         }
  42         else if(strEQ(pv, "CODE")){
  43             *type = SVt_PVCV;
  44         }
  45         else if(strEQ(pv, "GLOB")){
  46             *type = SVt_PVGV;
  47         }
  48         else if(strEQ(pv, "IO")){
  49             *type = SVt_PVIO;
  50         }
  51         else{
  52             croak("I do not recognize that type '%s'", pv);
  53         }
  54         *type_name = pv;
  55     }
  56     else {
  57         STRLEN len;
  58         const char* pv;
  59         /* e.g. variable = '$foo' */
  60         if(!SvOK(variable)) {
  61             croak("You must pass a variable name");
  62         }
  63         pv = SvPV_const(variable, len);
  64         if(len < 2){
  65             croak("You must pass a variable name including a sigil");
  66         }
  67
  68         *var_name     = pv  + 1;
  69         *var_name_len = len - 1;
  70
  71         switch(pv[0]){
  72         case '$':
  73             *type      = SVt_PV; /* for all the types of scalars */
  74             *type_name = "SCALAR";
  75             break;
  76         case '@':
  77             *type      = SVt_PVAV;
  78             *type_name = "ARRAY";
  79             break;
  80         case '%':
  81             *type      = SVt_PVHV;
  82             *type_name = "HASH";
  83             break;
  84         case '&':
  85             *type      = SVt_PVCV;
  86             *type_name = "CODE";
  87             break;
  88         case '*':
  89             *type      = SVt_PVGV;
  90             *type_name = "GLOB";
  91             break;
  92         default:
  93             croak("I do not recognize that sigil '%c'", pv[0]);
  94         }
  95     }
  96 }
  97
  98 static GV*
  99 mop_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){
 100     SV* package_name;
 101     STRLEN len;
 102     const char* pv;
 103
 104     if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
 105         SV* const ns = mop_call0(aTHX_ self, mop_namespace);
 106         GV** gvp;
 107         if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
 108             croak("namespace() did not return a hash reference");
 109         }
 110         gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE);
 111         if(gvp && isGV_with_GP(*gvp)){
 112             return *gvp;
 113         }
 114     }
 115
 116     package_name = mop_call0(aTHX_ self, KEY_FOR(name));
 117
 118     if(!SvOK(package_name)){
 119         croak("name() did not return a defined value");
 120     }
 121
 122     pv = SvPV_const(package_name, len);
 123
 124     return gv_fetchpvn_flags(Perl_form(aTHX_ "%s::%s", pv, var_name), (len + var_name_len + 2), flags, type);
 125 }
 126
 127 static SV*
 128 mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
 129     SV* sv;
 130
 131     if(!gv){
 132         return NULL;
 133     }
 134
 135     assert(isGV_with_GP(gv));
 136
 137     switch(type){
 138     case SVt_PVAV:
 139         sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
 140         break;
 141     case SVt_PVHV:
 142         sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
 143         break;
 144     case SVt_PVCV:
 145         sv = (SV*)GvCV(gv);
 146         break;
 147     case SVt_PVIO:
 148         sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
 149         break;
 150     case SVt_PVGV:
 151         sv = (SV*)gv;
 152         break;
 153     default: /* SCALAR */
 154         sv =       add ? GvSVn(gv) : GvSV(gv);
 155         break;
 156     }
 157
 158     return sv;
 159 }
 160
 161
 162 static void
 163 mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
 164 {
 165     const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
 166     SV   *method_metaclass_name;
 167     char *method_name;
 168     I32   method_name_len;
 169     SV   *coderef;
 170     HV   *symbols;
 171     dSP;
 172
 173     symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
 174     sv_2mortal((SV*)symbols);
 175     (void)hv_iterinit(symbols);
 176     while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
 177         CV *cv = (CV *)SvRV(coderef);
 178         char *cvpkg_name;
 179         char *cv_name;
 180         SV *method_slot;
 181         SV *method_object;
 182
 183         if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
 184             continue;
 185         }
 186
 187         /* this checks to see that the subroutine is actually from our package  */
 188         if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
 189             if ( strNE(cvpkg_name, class_name_pv) ) {
 190                 continue;
 191             }
 192         }
 193
 194         method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
 195         if ( SvOK(method_slot) ) {
 196             SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
 197             if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
 198                 continue;
 199             }
 200         }
 201
 202         method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
 203
 204         /*
 205             $method_object = $method_metaclass->wrap(
 206                 $cv,
 207                 associated_metaclass => $self,
 208                 package_name         => $class_name,
 209                 name                 => $method_name
 210             );
 211         */
 212         ENTER;
 213         SAVETMPS;
 214
 215         PUSHMARK(SP);
 216         EXTEND(SP, 8);
 217         PUSHs(method_metaclass_name); /* invocant */
 218         mPUSHs(newRV_inc((SV *)cv));
 219         PUSHs(mop_associated_metaclass);
 220         PUSHs(self);
 221         PUSHs(KEY_FOR(package_name));
 222         PUSHs(class_name);
 223         PUSHs(KEY_FOR(name));
 224         mPUSHs(newSVpv(method_name, method_name_len));
 225         PUTBACK;
 226
 227         call_sv(mop_wrap, G_SCALAR | G_METHOD);
 228         SPAGAIN;
 229         method_object = POPs;
 230         PUTBACK;
 231         /* $map->{$method_name} = $method_object */
 232         sv_setsv(method_slot, method_object);
 233
 234         FREETMPS;
 235         LEAVE;
 236     }
 237 }
 238
 239 MODULE = Class::MOP::Package   PACKAGE = Class::MOP::Package
 240
 241 PROTOTYPES: DISABLE
 242
 243 void
 244 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 245     SV *self
 246     type_filter_t filter
 247     PREINIT:
 248         HV *stash = NULL;
 249         HV *symbols = NULL;
 250         register HE *he;
 251     PPCODE:
 252         if ( ! SvROK(self) ) {
 253             die("Cannot call get_all_package_symbols as a class method");
 254         }
 255
 256         if (GIMME_V == G_VOID) {
 257             XSRETURN_EMPTY;
 258         }
 259
 260         PUTBACK;
 261
 262         if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
 263             stash = gv_stashsv(HeVAL(he), 0);
 264         }
 265
 266
 267         if (!stash) {
 268             XSRETURN_UNDEF;
 269         }
 270
 271         symbols = mop_get_all_package_symbols(stash, filter);
 272         PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
 273
 274 void
 275 get_method_map(self)
 276     SV *self
 277     PREINIT:
 278         HV *const obj        = (HV *)SvRV(self);
 279         SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
 280         HV *const stash      = gv_stashsv(class_name, 0);
 281         UV current;
 282         SV *cache_flag;
 283         SV *map_ref;
 284     PPCODE:
 285         if (!stash) {
 286              mXPUSHs(newRV_noinc((SV *)newHV()));
 287              return;
 288         }
 289
 290         current    = mop_check_package_cache_flag(aTHX_ stash);
 291         cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
 292         map_ref    = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
 293
 294         /* $self->{methods} does not yet exist (or got deleted) */
 295         if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
 296             SV *new_map_ref = newRV_noinc((SV *)newHV());
 297             sv_2mortal(new_map_ref);
 298             sv_setsv(map_ref, new_map_ref);
 299         }
 300
 301         if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
 302             mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
 303             sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
 304         }
 305
 306         XPUSHs(map_ref);
 307
 308 BOOT:
 309     INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
 310
 311
 312 SV*
 313 add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
 314 PREINIT:
 315     svtype type;
 316     const char* type_name;
 317     const char* var_name;
 318     STRLEN var_name_len;
 319     GV* gv;
 320 CODE:
 321     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 322     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
 323
 324     if(SvOK(ref)){ /* add_package_symbol with a value */
 325         if(type == SVt_PV){
 326             if(!SvROK(ref)){
 327                 ref = newRV_noinc(newSVsv(ref));
 328                 sv_2mortal(ref);
 329             }
 330         }
 331         else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
 332             croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
 333         }
 334
 335         if(type == SVt_PVCV && GvCV(gv)){
 336             /* XXX: clear it before redefinition */
 337             SvREFCNT_dec(GvCV(gv));
 338             GvCV(gv) = NULL;
 339         }
 340         sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */
 341
 342         if(type == SVt_PVCV){ /* name a subroutine */
 343             CV* const subr = (CV*)SvRV(ref);
 344             if(CvANON(subr)
 345                 && CvGV(subr)
 346                 && isGV(CvGV(subr))
 347                 && strEQ(GvNAME(CvGV(subr)), "__ANON__")){
 348
 349                 /* NOTE:
 350                     A gv "has-a" cv, but a cv refers to a gv as a (pseudo) weak ref.
 351                     so we can replace CvGV with no SvREFCNT_inc/dec.
 352                 */
 353                 CvGV(subr) = gv;
 354                 CvANON_off(subr);
 355             }
 356         }
 357         RETVAL = ref;
 358         SvREFCNT_inc_simple_void_NN(ref);
 359     }
 360     else{
 361         SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
 362         RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
 363     }
 364 OUTPUT:
 365     RETVAL
 366
 367 bool
 368 has_package_symbol(SV* self, SV* variable)
 369 PREINIT:
 370     svtype type;
 371     const char* type_name;
 372     const char* var_name;
 373     STRLEN var_name_len;
 374     GV* gv;
 375 CODE:
 376     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 377     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
 378     RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
 379 OUTPUT:
 380     RETVAL
 381
 382 SV*
 383 get_package_symbol(SV* self, SV* variable, ...)
 384 PREINIT:
 385     svtype type;
 386     const char* type_name;
 387     const char* var_name;
 388     STRLEN var_name_len;
 389     I32 flags = 0;
 390     GV* gv;
 391     SV* sv;
 392 CODE:
 393     if(items > 2){ /* parse options */
 394         I32 i;
 395         if((items % 2) != 0){
 396             croak("Odd number of arguments for get_package_symbol()");
 397         }
 398         for(i = 2; i < items; i += 2){
 399             SV* const opt = ST(i);
 400             SV* const val = ST(i+1);
 401             if(strEQ(SvPV_nolen_const(opt), "create")){
 402                 if(SvTRUE(val)){
 403                     flags |= GV_ADDMULTI;
 404                 }
 405                 else{
 406                     flags &= ~GV_ADDMULTI;
 407                 }
 408             }
 409             else{
 410                 warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
 411             }
 412         }
 413     }
 414     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 415     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
 416     sv = mop_gv_elem(aTHX_ gv, type, FALSE);
 417
 418     RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
 419 OUTPUT:
 420     RETVAL