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
 102     if(!(flags & ~GV_NOADD_MASK)){ /* for shortcut fetching */
 103         SV* const ns = mop_call0(aTHX_ self, mop_namespace);
 104         GV** gvp;
 105         if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){
 106             croak("namespace() did not return a hash reference");
 107         }
 108         gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE);
 109         if(gvp && isGV_with_GP(*gvp)){
 110             return *gvp;
 111         }
 112     }
 113
 114     package_name = mop_call0(aTHX_ self, KEY_FOR(name));
 115
 116     if(!SvOK(package_name)){
 117         croak("name() did not return a defined value");
 118     }
 119
 120     return gv_fetchpv(Perl_form(aTHX_ "%"SVf"::%s", package_name, var_name), flags, type);
 121 }
 122
 123 static SV*
 124 mop_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){
 125     SV* sv;
 126
 127     if(!gv){
 128         return NULL;
 129     }
 130
 131     assert(isGV_with_GP(gv));
 132
 133     switch(type){
 134     case SVt_PVAV:
 135         sv = (SV*)(add ? GvAVn(gv) : GvAV(gv));
 136         break;
 137     case SVt_PVHV:
 138         sv = (SV*)(add ? GvHVn(gv) : GvHV(gv));
 139         break;
 140     case SVt_PVCV:
 141         sv = (SV*)GvCV(gv);
 142         break;
 143     case SVt_PVIO:
 144         sv = (SV*)(add ? GvIOn(gv) : GvIO(gv));
 145         break;
 146     case SVt_PVGV:
 147         sv = (SV*)gv;
 148         break;
 149     default: /* SCALAR */
 150         sv =       add ? GvSVn(gv) : GvSV(gv);
 151         break;
 152     }
 153
 154     return sv;
 155 }
 156
 157
 158 static void
 159 mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
 160 {
 161     const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
 162     SV   *method_metaclass_name;
 163     char *method_name;
 164     I32   method_name_len;
 165     SV   *coderef;
 166     HV   *symbols;
 167     dSP;
 168
 169     symbols = mop_get_all_package_symbols(stash, TYPE_FILTER_CODE);
 170     sv_2mortal((SV*)symbols);
 171     (void)hv_iterinit(symbols);
 172     while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
 173         CV *cv = (CV *)SvRV(coderef);
 174         char *cvpkg_name;
 175         char *cv_name;
 176         SV *method_slot;
 177         SV *method_object;
 178
 179         if (!mop_get_code_info(coderef, &cvpkg_name, &cv_name)) {
 180             continue;
 181         }
 182
 183         /* this checks to see that the subroutine is actually from our package  */
 184         if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
 185             if ( strNE(cvpkg_name, class_name_pv) ) {
 186                 continue;
 187             }
 188         }
 189
 190         method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
 191         if ( SvOK(method_slot) ) {
 192             SV *const body = mop_call0(aTHX_ method_slot, KEY_FOR(body)); /* $method_object->body() */
 193             if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
 194                 continue;
 195             }
 196         }
 197
 198         method_metaclass_name = mop_call0(aTHX_ self, mop_method_metaclass); /* $self->method_metaclass() */
 199
 200         /*
 201             $method_object = $method_metaclass->wrap(
 202                 $cv,
 203                 associated_metaclass => $self,
 204                 package_name         => $class_name,
 205                 name                 => $method_name
 206             );
 207         */
 208         ENTER;
 209         SAVETMPS;
 210
 211         PUSHMARK(SP);
 212         EXTEND(SP, 8);
 213         PUSHs(method_metaclass_name); /* invocant */
 214         mPUSHs(newRV_inc((SV *)cv));
 215         PUSHs(mop_associated_metaclass);
 216         PUSHs(self);
 217         PUSHs(KEY_FOR(package_name));
 218         PUSHs(class_name);
 219         PUSHs(KEY_FOR(name));
 220         mPUSHs(newSVpv(method_name, method_name_len));
 221         PUTBACK;
 222
 223         call_sv(mop_wrap, G_SCALAR | G_METHOD);
 224         SPAGAIN;
 225         method_object = POPs;
 226         PUTBACK;
 227         /* $map->{$method_name} = $method_object */
 228         sv_setsv(method_slot, method_object);
 229
 230         FREETMPS;
 231         LEAVE;
 232     }
 233 }
 234
 235 MODULE = Class::MOP::Package   PACKAGE = Class::MOP::Package
 236
 237 PROTOTYPES: DISABLE
 238
 239 void
 240 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 241     SV *self
 242     type_filter_t filter
 243     PREINIT:
 244         HV *stash = NULL;
 245         HV *symbols = NULL;
 246         register HE *he;
 247     PPCODE:
 248         if ( ! SvROK(self) ) {
 249             die("Cannot call get_all_package_symbols as a class method");
 250         }
 251
 252         if (GIMME_V == G_VOID) {
 253             XSRETURN_EMPTY;
 254         }
 255
 256         PUTBACK;
 257
 258         if ( (he = hv_fetch_ent((HV *)SvRV(self), KEY_FOR(package), 0, HASH_FOR(package))) ) {
 259             stash = gv_stashsv(HeVAL(he), 0);
 260         }
 261
 262
 263         if (!stash) {
 264             XSRETURN_UNDEF;
 265         }
 266
 267         symbols = mop_get_all_package_symbols(stash, filter);
 268         PUSHs(sv_2mortal(newRV_noinc((SV *)symbols)));
 269
 270 void
 271 get_method_map(self)
 272     SV *self
 273     PREINIT:
 274         HV *const obj        = (HV *)SvRV(self);
 275         SV *const class_name = HeVAL( hv_fetch_ent(obj, KEY_FOR(package), 0, HASH_FOR(package)) );
 276         HV *const stash      = gv_stashsv(class_name, 0);
 277         UV current;
 278         SV *cache_flag;
 279         SV *map_ref;
 280     PPCODE:
 281         if (!stash) {
 282              mXPUSHs(newRV_noinc((SV *)newHV()));
 283              return;
 284         }
 285
 286         current    = mop_check_package_cache_flag(aTHX_ stash);
 287         cache_flag = HeVAL( hv_fetch_ent(obj, KEY_FOR(package_cache_flag), TRUE, HASH_FOR(package_cache_flag)));
 288         map_ref    = HeVAL( hv_fetch_ent(obj, KEY_FOR(methods), TRUE, HASH_FOR(methods)));
 289
 290         /* $self->{methods} does not yet exist (or got deleted) */
 291         if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
 292             SV *new_map_ref = newRV_noinc((SV *)newHV());
 293             sv_2mortal(new_map_ref);
 294             sv_setsv(map_ref, new_map_ref);
 295         }
 296
 297         if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
 298             mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
 299             sv_setuv(cache_flag, mop_check_package_cache_flag(aTHX_ stash)); /* update_cache_flag() */
 300         }
 301
 302         XPUSHs(map_ref);
 303
 304 BOOT:
 305     INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
 306
 307
 308 SV*
 309 add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
 310 PREINIT:
 311     svtype type;
 312     const char* type_name;
 313     const char* var_name;
 314     STRLEN var_name_len;
 315     GV* gv;
 316 CODE:
 317     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 318     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
 319
 320     if(SvOK(ref)){ /* add_package_symbol with a value */
 321         if(type == SVt_PV){
 322             if(!SvROK(ref)){
 323                 ref = newRV_noinc(newSVsv(ref));
 324                 sv_2mortal(ref);
 325             }
 326         }
 327         else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
 328             croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
 329         }
 330
 331         if(type == SVt_PVCV && GvCV(gv)){
 332             /* XXX: clear it before redefinition */
 333             SvREFCNT_dec(GvCV(gv));
 334             GvCV(gv) = NULL;
 335         }
 336         sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */
 337
 338         if(type == SVt_PVCV){ /* name a subroutine */
 339             CV* const subr = (CV*)SvRV(ref);
 340             if(CvANON(subr)
 341                 && CvGV(subr)
 342                 && isGV(CvGV(subr))
 343                 && strEQ(GvNAME(CvGV(subr)), "__ANON__")){
 344
 345                 CvGV(subr) = gv;
 346                 CvANON_off(subr);
 347             }
 348         }
 349         RETVAL = ref;
 350         SvREFCNT_inc_simple_void_NN(ref);
 351     }
 352     else{
 353         SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
 354         RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
 355     }
 356 OUTPUT:
 357     RETVAL
 358
 359 bool
 360 has_package_symbol(SV* self, SV* variable)
 361 PREINIT:
 362     svtype type;
 363     const char* type_name;
 364     const char* var_name;
 365     STRLEN var_name_len;
 366     GV* gv;
 367 CODE:
 368     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 369     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
 370     RETVAL = mop_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE;
 371 OUTPUT:
 372     RETVAL
 373
 374 SV*
 375 get_package_symbol(SV* self, SV* variable, ...)
 376 PREINIT:
 377     svtype type;
 378     const char* type_name;
 379     const char* var_name;
 380     STRLEN var_name_len;
 381     I32 flags = 0;
 382     GV* gv;
 383     SV* sv;
 384 CODE:
 385     { /* parse options */
 386         I32 i;
 387         if((items % 2) != 0){
 388             croak("Odd number of arguments for get_package_symbol()");
 389         }
 390         for(i = 2; i < items; i += 2){
 391             SV* const opt = ST(i);
 392             SV* const val = ST(i+1);
 393             if(strEQ(SvPV_nolen_const(opt), "create")){
 394                 if(SvTRUE(val)){
 395                     flags |= GV_ADDMULTI;
 396                 }
 397                 else{
 398                     flags &= ~GV_ADDMULTI;
 399                 }
 400             }
 401             else{
 402                 warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
 403             }
 404         }
 405     }
 406     mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
 407     gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
 408     sv = mop_gv_elem(aTHX_ gv, type, FALSE);
 409
 410     RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
 411 OUTPUT:
 412     RETVAL