MOP.xs

   1 /* There's a lot of cases of doubled parens in here like this:
   2
   3   while ( (he = ...) ) {
   4
   5 This shuts up warnings from gcc -Wall
   6 */
   7
   8 #include "EXTERN.h"
   9 #include "perl.h"
  10 #include "XSUB.h"
  11
  12 #define NEED_sv_2pv_flags
  13 #define NEED_sv_2pv_nolen
  14 #include "ppport.h"
  15
  16 SV *key_name;
  17 U32 hash_name;
  18
  19 SV *key_package;
  20 U32 hash_package;
  21
  22 SV *key_package_name;
  23 U32 hash_package_name;
  24
  25 SV *key_body;
  26 U32 hash_body;
  27
  28 SV* method_metaclass;
  29 SV* associated_metaclass;
  30 SV* wrap;
  31
  32
  33 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
  34 #ifdef HvMROMETA /* 5.10.0 */
  35
  36 #ifndef mro_meta_init
  37 #define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
  38 #endif /* !mro_meta_init */
  39
  40 static UV
  41 mop_check_package_cache_flag(pTHX_ HV* stash) {
  42     assert(SvTYPE(stash) == SVt_PVHV);
  43
  44     return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
  45 }
  46
  47 #else /* pre 5.10.0 */
  48
  49 static UV
  50 mop_check_package_cache_flag(pTHX_ HV* stash) {
  51     PERL_UNUSED_ARG(stash);
  52     assert(SvTYPE(stash) == SVt_PVHV);
  53
  54     return PL_sub_generation;
  55 }
  56 #endif
  57
  58 #define call0(s, m)  mop_call0(aTHX_ s, m)
  59 static SV*
  60 mop_call0(pTHX_ SV* const self, SV* const method) {
  61     dSP;
  62     SV* ret;
  63
  64     PUSHMARK(SP);
  65     XPUSHs(self);
  66     PUTBACK;
  67
  68     call_sv(method, G_SCALAR | G_METHOD);
  69
  70     SPAGAIN;
  71     ret = POPs;
  72     PUTBACK;
  73
  74     return ret;
  75 }
  76
  77 static void
  78 mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
  79     const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
  80     SV*   method_metaclass_name;
  81     char* method_name;
  82     I32   method_name_len;
  83     GV* gv;
  84     dSP;
  85
  86     /* this function massivly overlaps with the xs version of
  87      * get_all_package_symbols. a common c function to walk the symbol table
  88      * should be factored out and used by both.  --rafl */
  89
  90     hv_iterinit(stash);
  91     while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
  92         CV* cv;
  93         switch (SvTYPE (gv)) {
  94 #ifndef SVt_RV
  95             case SVt_RV:
  96 #endif
  97             case SVt_IV:
  98             case SVt_PV:
  99                 /* rafl says that this wastes memory savings that GvSVs have
 100                    in 5.8.9 and 5.10.x. But without it some tests fail. rafl
 101                    says the right thing to do is to handle GvSVs differently
 102                    here. */
 103                 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
 104                 /* fall through */
 105             default:
 106                 break;
 107         }
 108
 109         if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
 110             GV* const cvgv = CvGV(cv);
 111             /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
 112             const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
 113             const char* const cv_name    = GvNAME(cvgv);
 114             SV* method_slot;
 115             SV* method_object;
 116
 117             /* this checks to see that the subroutine is actually from our package  */
 118             if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
 119                 if ( strNE(cvpkg_name, class_name_pv) ) {
 120                     continue;
 121                 }
 122             }
 123
 124             method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
 125             if ( SvOK(method_slot) ) {
 126                 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
 127                 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
 128                     continue;
 129                 }
 130             }
 131
 132             method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
 133
 134             /*
 135                 $method_object = $method_metaclass->wrap(
 136                     $cv,
 137                     associated_metaclass => $self,
 138                     package_name         => $class_name,
 139                     name                 => $method_name
 140                 );
 141             */
 142             ENTER;
 143             SAVETMPS;
 144
 145             PUSHMARK(SP);
 146             EXTEND(SP, 8);
 147             PUSHs(method_metaclass_name); /* invocant */
 148             mPUSHs(newRV_inc((SV*)cv));
 149             PUSHs(associated_metaclass);
 150             PUSHs(self);
 151             PUSHs(key_package_name);
 152             PUSHs(class_name);
 153             PUSHs(key_name);
 154             mPUSHs(newSVpv(method_name, method_name_len));
 155             PUTBACK;
 156
 157             call_sv(wrap, G_SCALAR | G_METHOD);
 158             SPAGAIN;
 159             method_object = POPs;
 160             PUTBACK;
 161             /* $map->{$method_name} = $method_object */
 162             sv_setsv(method_slot, method_object);
 163
 164             FREETMPS;
 165             LEAVE;
 166         }
 167     }
 168 }
 169
 170 typedef enum {
 171     TYPE_FILTER_NONE,
 172     TYPE_FILTER_CODE,
 173     TYPE_FILTER_ARRAY,
 174     TYPE_FILTER_IO,
 175     TYPE_FILTER_HASH,
 176     TYPE_FILTER_SCALAR,
 177 } type_filter_t;
 178
 179 static HV *
 180 get_all_package_symbols(HV *stash, type_filter_t filter)
 181 {
 182     HE *he;
 183     HV *ret = newHV();
 184
 185     (void)hv_iterinit(stash);
 186
 187     if (filter == TYPE_FILTER_NONE) {
 188         while ( (he = hv_iternext(stash)) ) {
 189             STRLEN keylen;
 190             char *key = HePV(he, keylen);
 191             hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0);
 192         }
 193
 194         return ret;
 195     }
 196
 197     while ( (he = hv_iternext(stash)) ) {
 198         SV *const gv = HeVAL(he);
 199         SV *sv = NULL;
 200         char *key;
 201         STRLEN keylen;
 202         char *package;
 203         SV *fq;
 204
 205         switch( SvTYPE(gv) ) {
 206 #ifndef SVt_RV
 207             case SVt_RV:
 208 #endif
 209             case SVt_PV:
 210             case SVt_IV:
 211                 /* expand the gv into a real typeglob if it
 212                  * contains stub functions and we were asked to
 213                  * return CODE symbols */
 214                 if (filter == TYPE_FILTER_CODE) {
 215                     if (SvROK(gv)) {
 216                         /* we don't really care about the length,
 217                            but that's the API */
 218                         key = HePV(he, keylen);
 219                         package = HvNAME(stash);
 220                         fq = newSVpvf("%s::%s", package, key);
 221                         sv = (SV *)get_cv(SvPV_nolen(fq), 0);
 222                         break;
 223                     }
 224
 225                     key = HePV(he, keylen);
 226                     gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
 227                 }
 228                 /* fall through */
 229             case SVt_PVGV:
 230                 switch (filter) {
 231                     case TYPE_FILTER_CODE:   sv = (SV *)GvCVu(gv); break;
 232                     case TYPE_FILTER_ARRAY:  sv = (SV *)GvAV(gv);  break;
 233                     case TYPE_FILTER_IO:     sv = (SV *)GvIO(gv);  break;
 234                     case TYPE_FILTER_HASH:   sv = (SV *)GvHV(gv);  break;
 235                     case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv);  break;
 236                     default:
 237                         croak("Unknown type");
 238                 }
 239                 break;
 240             default:
 241                 continue;
 242         }
 243
 244         if (sv) {
 245             char *key = HePV(he, keylen);
 246             hv_store(ret, key, keylen, newRV_inc(sv), 0);
 247         }
 248     }
 249
 250     return ret;
 251 }
 252
 253 /*
 254 get_code_info:
 255   Pass in a coderef, returns:
 256   [ $pkg_name, $coderef_name ] ie:
 257   [ 'Foo::Bar', 'new' ]
 258 */
 259
 260 MODULE = Class::MOP   PACKAGE = Class::MOP
 261
 262 BOOT:
 263     key_name = newSVpvs("name");
 264     key_body = newSVpvs("body");
 265     key_package = newSVpvs("package");
 266     key_package_name = newSVpvs("package_name");
 267
 268     PERL_HASH(hash_name, "name", 4);
 269     PERL_HASH(hash_body, "body", 4);
 270     PERL_HASH(hash_package, "package", 7);
 271     PERL_HASH(hash_package_name, "package_name", 12);
 272
 273     method_metaclass     = newSVpvs("method_metaclass");
 274     wrap                 = newSVpvs("wrap");
 275     associated_metaclass = newSVpvs("associated_metaclass");
 276
 277
 278 PROTOTYPES: ENABLE
 279
 280
 281 void
 282 get_code_info(coderef)
 283   SV* coderef
 284   PREINIT:
 285     char* name;
 286     char* pkg;
 287   PPCODE:
 288     if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
 289       coderef = SvRV(coderef);
 290       /* I think this only gets triggered with a mangled coderef, but if
 291          we hit it without the guard, we segfault. The slightly odd return
 292          value strikes me as an improvement (mst)
 293       */
 294 #ifdef isGV_with_GP
 295       if ( isGV_with_GP(CvGV(coderef)) ) {
 296 #endif
 297         pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
 298         name    = GvNAME( CvGV(coderef) );
 299 #ifdef isGV_with_GP
 300       } else {
 301         pkg     = "__UNKNOWN__";
 302         name    = "__ANON__";
 303       }
 304 #endif
 305
 306       EXTEND(SP, 2);
 307       PUSHs(newSVpvn(pkg, strlen(pkg)));
 308       PUSHs(newSVpvn(name, strlen(name)));
 309     }
 310
 311
 312 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
 313
 314 void
 315 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 316     SV *self
 317     type_filter_t filter
 318     PROTOTYPE: $;$
 319     PREINIT:
 320         HV *stash = NULL;
 321         HV *symbols = NULL;
 322         register HE *he;
 323     PPCODE:
 324         if ( ! SvROK(self) ) {
 325             die("Cannot call get_all_package_symbols as a class method");
 326         }
 327
 328         if (GIMME_V == G_VOID) {
 329             XSRETURN_EMPTY;
 330         }
 331
 332
 333         PUTBACK;
 334
 335         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
 336             stash = gv_stashsv(HeVAL(he), 0);
 337         }
 338
 339
 340         if (!stash) {
 341             switch (GIMME_V) {
 342                 case G_SCALAR: XSRETURN_UNDEF; break;
 343                 case G_ARRAY:  XSRETURN_EMPTY; break;
 344             }
 345         }
 346
 347         symbols = get_all_package_symbols(stash, filter);
 348
 349         switch (GIMME_V) {
 350             case G_SCALAR:
 351                 PUSHs(sv_2mortal(newRV_inc((SV *)symbols)));
 352                 break;
 353             case G_ARRAY:
 354                 warn("Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.");
 355
 356                 EXTEND(SP, HvKEYS(symbols) * 2);
 357
 358                 while ((he = hv_iternext(symbols))) {
 359                     PUSHs(hv_iterkeysv(he));
 360                     PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
 361                 }
 362
 363                 break;
 364             default:
 365                 break;
 366         }
 367
 368         SvREFCNT_dec((SV *)symbols);
 369
 370 void
 371 name(self)
 372     SV *self
 373     PREINIT:
 374         register HE *he;
 375     PPCODE:
 376         if ( ! SvROK(self) ) {
 377             die("Cannot call name as a class method");
 378         }
 379
 380         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 381             XPUSHs(HeVAL(he));
 382         else
 383             ST(0) = &PL_sv_undef;
 384
 385 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 386
 387 void
 388 name(self)
 389     SV *self
 390     PREINIT:
 391         register HE *he;
 392     PPCODE:
 393         if ( ! SvROK(self) ) {
 394             die("Cannot call name as a class method");
 395         }
 396
 397         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 398             XPUSHs(HeVAL(he));
 399         else
 400             ST(0) = &PL_sv_undef;
 401
 402 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 403
 404 void
 405 name(self)
 406     SV *self
 407     PREINIT:
 408         register HE *he;
 409     PPCODE:
 410         if ( ! SvROK(self) ) {
 411             die("Cannot call name as a class method");
 412         }
 413
 414         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 415             XPUSHs(HeVAL(he));
 416         else
 417             ST(0) = &PL_sv_undef;
 418
 419 void
 420 package_name(self)
 421     SV *self
 422     PREINIT:
 423         register HE *he;
 424     PPCODE:
 425         if ( ! SvROK(self) ) {
 426             die("Cannot call package_name as a class method");
 427         }
 428
 429         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 430             XPUSHs(HeVAL(he));
 431         else
 432             ST(0) = &PL_sv_undef;
 433
 434 void
 435 body(self)
 436     SV *self
 437     PREINIT:
 438         register HE *he;
 439     PPCODE:
 440         if ( ! SvROK(self) ) {
 441             die("Cannot call body as a class method");
 442         }
 443
 444         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 445             XPUSHs(HeVAL(he));
 446         else
 447             ST(0) = &PL_sv_undef;
 448
 449
 450 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 451
 452 void
 453 get_method_map(self)
 454     SV* self
 455     PREINIT:
 456         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
 457         HV* const stash      = gv_stashsv(class_name, TRUE);
 458         UV  const current    = check_package_cache_flag(stash);
 459         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
 460         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
 461     PPCODE:
 462         if ( ! SvRV(self) ) {
 463             die("Cannot call get_method_map as a class method");
 464         }
 465
 466         /* in  $self->{methods} does not yet exist (or got deleted) */
 467         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
 468             SV* new_map_ref = newRV_noinc((SV*)newHV());
 469             sv_2mortal(new_map_ref);
 470             sv_setsv(map_ref, new_map_ref);
 471         }
 472
 473         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
 474             ENTER;
 475             SAVETMPS;
 476
 477             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
 478             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 479
 480             FREETMPS;
 481             LEAVE;
 482         }
 483
 484         XPUSHs(map_ref);
 485