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         switch (GIMME_V) {
 333             case G_VOID: return; break;
 334             case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
 335         }
 336
 337         PUTBACK;
 338
 339         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
 340             stash = gv_stashsv(HeVAL(he), 0);
 341         }
 342
 343
 344         if (!stash) {
 345             XSRETURN_EMPTY;
 346         }
 347
 348         symbols = get_all_package_symbols(stash, filter);
 349
 350         EXTEND(SP, HvKEYS(symbols) * 2);
 351         while ((he = hv_iternext(symbols))) {
 352             PUSHs(hv_iterkeysv(he));
 353             PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
 354         }
 355
 356         SvREFCNT_dec((SV *)symbols);
 357
 358 void
 359 name(self)
 360     SV *self
 361     PREINIT:
 362         register HE *he;
 363     PPCODE:
 364         if ( ! SvROK(self) ) {
 365             die("Cannot call name as a class method");
 366         }
 367
 368         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 369             XPUSHs(HeVAL(he));
 370         else
 371             ST(0) = &PL_sv_undef;
 372
 373 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 374
 375 void
 376 name(self)
 377     SV *self
 378     PREINIT:
 379         register HE *he;
 380     PPCODE:
 381         if ( ! SvROK(self) ) {
 382             die("Cannot call name as a class method");
 383         }
 384
 385         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 386             XPUSHs(HeVAL(he));
 387         else
 388             ST(0) = &PL_sv_undef;
 389
 390 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 391
 392 void
 393 name(self)
 394     SV *self
 395     PREINIT:
 396         register HE *he;
 397     PPCODE:
 398         if ( ! SvROK(self) ) {
 399             die("Cannot call name as a class method");
 400         }
 401
 402         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 403             XPUSHs(HeVAL(he));
 404         else
 405             ST(0) = &PL_sv_undef;
 406
 407 void
 408 package_name(self)
 409     SV *self
 410     PREINIT:
 411         register HE *he;
 412     PPCODE:
 413         if ( ! SvROK(self) ) {
 414             die("Cannot call package_name as a class method");
 415         }
 416
 417         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 418             XPUSHs(HeVAL(he));
 419         else
 420             ST(0) = &PL_sv_undef;
 421
 422 void
 423 body(self)
 424     SV *self
 425     PREINIT:
 426         register HE *he;
 427     PPCODE:
 428         if ( ! SvROK(self) ) {
 429             die("Cannot call body as a class method");
 430         }
 431
 432         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 433             XPUSHs(HeVAL(he));
 434         else
 435             ST(0) = &PL_sv_undef;
 436
 437
 438 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 439
 440 void
 441 get_method_map(self)
 442     SV* self
 443     PREINIT:
 444         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
 445         HV* const stash      = gv_stashsv(class_name, TRUE);
 446         UV  const current    = check_package_cache_flag(stash);
 447         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
 448         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
 449     PPCODE:
 450         if ( ! SvRV(self) ) {
 451             die("Cannot call get_method_map as a class method");
 452         }
 453
 454         /* in  $self->{methods} does not yet exist (or got deleted) */
 455         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
 456             SV* new_map_ref = newRV_noinc((SV*)newHV());
 457             sv_2mortal(new_map_ref);
 458             sv_setsv(map_ref, new_map_ref);
 459         }
 460
 461         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
 462             ENTER;
 463             SAVETMPS;
 464
 465             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
 466             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 467
 468             FREETMPS;
 469             LEAVE;
 470         }
 471
 472         XPUSHs(map_ref);
 473