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_newRV_noinc
  13 #define NEED_sv_2pv_flags
  14 #define NEED_sv_2pv_nolen
  15 #include "ppport.h"
  16
  17 SV *key_name;
  18 U32 hash_name;
  19
  20 SV *key_package;
  21 U32 hash_package;
  22
  23 SV *key_package_name;
  24 U32 hash_package_name;
  25
  26 SV *key_body;
  27 U32 hash_body;
  28
  29 SV *key_package_cache_flag;
  30 U32 hash_package_cache_flag;
  31
  32 SV *key_methods;
  33 U32 hash_methods;
  34
  35 SV *key_VERSION;
  36 U32 hash_VERSION;
  37
  38 SV *key_ISA;
  39 U32 hash_ISA;
  40
  41 SV *method_metaclass;
  42 SV *associated_metaclass;
  43 SV *wrap;
  44
  45
  46 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
  47 #if PERL_VERSION >= 10
  48
  49 static UV
  50 mop_check_package_cache_flag(pTHX_ HV* stash) {
  51     assert(SvTYPE(stash) == SVt_PVHV);
  52
  53     /* here we're trying to implement a c version of mro::get_pkg_gen($stash),
  54      * however the perl core doesn't make it easy for us. It doesn't provide an
  55      * api that just does what we want.
  56      *
  57      * However, we know that the information we want is, inside the core,
  58      * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the
  59      * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init,
  60      * which is not public and only available inside the core, as the mro
  61      * interface as well as the structure returned by mro_meta_init isn't
  62      * considered to be stable yet.
  63      *
  64      * Perl_mro_meta_init isn't declared static, so we could just define it
  65      * ourselfs if perls headers don't do that for us, except that won't work
  66      * on platforms where symbols need to be explicitly exported when linking
  67      * shared libraries.
  68      *
  69      * So our, hopefully temporary, solution is to be even more evil and
  70      * basically reimplement HvMROMETA in a very fragile way that'll blow up
  71      * when the relevant parts of the mro implementation in core change.
  72      *
  73      * :-(
  74      *
  75      */
  76
  77     return HvAUX(stash)->xhv_mro_meta
  78          ? HvAUX(stash)->xhv_mro_meta->pkg_gen
  79          : 0;
  80 }
  81
  82 #else /* pre 5.10.0 */
  83
  84 static UV
  85 mop_check_package_cache_flag(pTHX_ HV *stash) {
  86     PERL_UNUSED_ARG(stash);
  87     assert(SvTYPE(stash) == SVt_PVHV);
  88
  89     return PL_sub_generation;
  90 }
  91 #endif
  92
  93 #define call0(s, m)  mop_call0(aTHX_ s, m)
  94 static SV *
  95 mop_call0(pTHX_ SV *const self, SV *const method) {
  96     dSP;
  97     SV *ret;
  98
  99     PUSHMARK(SP);
 100     XPUSHs(self);
 101     PUTBACK;
 102
 103     call_sv(method, G_SCALAR | G_METHOD);
 104
 105     SPAGAIN;
 106     ret = POPs;
 107     PUTBACK;
 108
 109     return ret;
 110 }
 111
 112 static int
 113 get_code_info (SV *coderef, char **pkg, char **name)
 114 {
 115     if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
 116         return 0;
 117     }
 118
 119     coderef = SvRV(coderef);
 120     /* I think this only gets triggered with a mangled coderef, but if
 121        we hit it without the guard, we segfault. The slightly odd return
 122        value strikes me as an improvement (mst)
 123     */
 124 #ifdef isGV_with_GP
 125     if ( isGV_with_GP(CvGV(coderef)) ) {
 126 #endif
 127         *pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
 128         *name    = GvNAME( CvGV(coderef) );
 129 #ifdef isGV_with_GP
 130     } else {
 131         *pkg     = "__UNKNOWN__";
 132         *name    = "__ANON__";
 133     }
 134 #endif
 135
 136     return 1;
 137 }
 138
 139 typedef enum {
 140     TYPE_FILTER_NONE,
 141     TYPE_FILTER_CODE,
 142     TYPE_FILTER_ARRAY,
 143     TYPE_FILTER_IO,
 144     TYPE_FILTER_HASH,
 145     TYPE_FILTER_SCALAR,
 146 } type_filter_t;
 147
 148 static HV *
 149 get_all_package_symbols(HV *stash, type_filter_t filter)
 150 {
 151     HE *he;
 152     HV *ret = newHV();
 153
 154     (void)hv_iterinit(stash);
 155
 156     if (filter == TYPE_FILTER_NONE) {
 157         while ( (he = hv_iternext(stash)) ) {
 158             STRLEN keylen;
 159             char *key = HePV(he, keylen);
 160             if (!hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0)) {
 161                 croak("failed to store glob ref");
 162             }
 163         }
 164
 165         return ret;
 166     }
 167
 168     while ( (he = hv_iternext(stash)) ) {
 169         SV *const gv = HeVAL(he);
 170         SV *sv = NULL;
 171         char *key;
 172         STRLEN keylen;
 173         char *package;
 174         SV *fq;
 175
 176         switch( SvTYPE(gv) ) {
 177 #ifndef SVt_RV
 178             case SVt_RV:
 179 #endif
 180             case SVt_PV:
 181             case SVt_IV:
 182                 /* expand the gv into a real typeglob if it
 183                  * contains stub functions and we were asked to
 184                  * return CODE symbols */
 185                 if (filter == TYPE_FILTER_CODE) {
 186                     if (SvROK(gv)) {
 187                         /* we don't really care about the length,
 188                            but that's the API */
 189                         key = HePV(he, keylen);
 190                         package = HvNAME(stash);
 191                         fq = newSVpvf("%s::%s", package, key);
 192                         sv = (SV *)get_cv(SvPV_nolen(fq), 0);
 193                         break;
 194                     }
 195
 196                     key = HePV(he, keylen);
 197                     gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
 198                 }
 199                 /* fall through */
 200             case SVt_PVGV:
 201                 switch (filter) {
 202                     case TYPE_FILTER_CODE:   sv = (SV *)GvCVu(gv); break;
 203                     case TYPE_FILTER_ARRAY:  sv = (SV *)GvAV(gv);  break;
 204                     case TYPE_FILTER_IO:     sv = (SV *)GvIO(gv);  break;
 205                     case TYPE_FILTER_HASH:   sv = (SV *)GvHV(gv);  break;
 206                     case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv);  break;
 207                     default:
 208                         croak("Unknown type");
 209                 }
 210                 break;
 211             default:
 212                 continue;
 213         }
 214
 215         if (sv) {
 216             char *key = HePV(he, keylen);
 217             if (!hv_store(ret, key, keylen, newRV_inc(sv), 0)) {
 218                 croak("failed to store symbol ref");
 219             }
 220         }
 221     }
 222
 223     return ret;
 224 }
 225
 226
 227 static void
 228 mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map) {
 229     const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
 230     SV   *method_metaclass_name;
 231     char *method_name;
 232     I32   method_name_len;
 233     SV   *coderef;
 234     HV   *symbols;
 235     dSP;
 236
 237     symbols = get_all_package_symbols(stash, TYPE_FILTER_CODE);
 238
 239     (void)hv_iterinit(symbols);
 240     while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) {
 241         CV *cv = (CV *)SvRV(coderef);
 242         char *cvpkg_name;
 243         char *cv_name;
 244         SV *method_slot;
 245         SV *method_object;
 246
 247         if (!get_code_info(coderef, &cvpkg_name, &cv_name)) {
 248             continue;
 249         }
 250
 251         /* this checks to see that the subroutine is actually from our package  */
 252         if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
 253             if ( strNE(cvpkg_name, class_name_pv) ) {
 254                 continue;
 255             }
 256         }
 257
 258         method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
 259         if ( SvOK(method_slot) ) {
 260             SV *const body = call0(method_slot, key_body); /* $method_object->body() */
 261             if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) {
 262                 continue;
 263             }
 264         }
 265
 266         method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
 267
 268         /*
 269             $method_object = $method_metaclass->wrap(
 270                 $cv,
 271                 associated_metaclass => $self,
 272                 package_name         => $class_name,
 273                 name                 => $method_name
 274             );
 275         */
 276         ENTER;
 277         SAVETMPS;
 278
 279         PUSHMARK(SP);
 280         EXTEND(SP, 8);
 281         PUSHs(method_metaclass_name); /* invocant */
 282         mPUSHs(newRV_inc((SV *)cv));
 283         PUSHs(associated_metaclass);
 284         PUSHs(self);
 285         PUSHs(key_package_name);
 286         PUSHs(class_name);
 287         PUSHs(key_name);
 288         mPUSHs(newSVpv(method_name, method_name_len));
 289         PUTBACK;
 290
 291         call_sv(wrap, G_SCALAR | G_METHOD);
 292         SPAGAIN;
 293         method_object = POPs;
 294         PUTBACK;
 295         /* $map->{$method_name} = $method_object */
 296         sv_setsv(method_slot, method_object);
 297
 298         FREETMPS;
 299         LEAVE;
 300     }
 301 }
 302
 303 /*
 304 get_code_info:
 305   Pass in a coderef, returns:
 306   [ $pkg_name, $coderef_name ] ie:
 307   [ 'Foo::Bar', 'new' ]
 308 */
 309
 310 MODULE = Class::MOP   PACKAGE = Class::MOP
 311
 312 BOOT:
 313     key_name = newSVpvs("name");
 314     key_body = newSVpvs("body");
 315     key_package = newSVpvs("package");
 316     key_package_name = newSVpvs("package_name");
 317     key_package_cache_flag = newSVpvs("_package_cache_flag");
 318     key_methods = newSVpvs("methods");
 319     key_VERSION = newSVpvs("VERSION");
 320     key_ISA = newSVpvs("ISA");
 321
 322     PERL_HASH(hash_name, "name", 4);
 323     PERL_HASH(hash_body, "body", 4);
 324     PERL_HASH(hash_package, "package", 7);
 325     PERL_HASH(hash_package_name, "package_name", 12);
 326     PERL_HASH(hash_package_cache_flag, "_package_cache_flag", 19);
 327     PERL_HASH(hash_methods, "methods", 7);
 328     PERL_HASH(hash_VERSION, "VERSION", 7);
 329     PERL_HASH(hash_ISA, "ISA", 3);
 330
 331     method_metaclass     = newSVpvs("method_metaclass");
 332     wrap                 = newSVpvs("wrap");
 333     associated_metaclass = newSVpvs("associated_metaclass");
 334
 335
 336 PROTOTYPES: ENABLE
 337
 338
 339 void
 340 get_code_info(coderef)
 341     SV *coderef
 342     PREINIT:
 343         char *pkg  = NULL;
 344         char *name = NULL;
 345     PPCODE:
 346         if (get_code_info(coderef, &pkg, &name)) {
 347             EXTEND(SP, 2);
 348             PUSHs(newSVpv(pkg, 0));
 349             PUSHs(newSVpv(name, 0));
 350         }
 351
 352 PROTOTYPES: DISABLE
 353
 354 void
 355 is_class_loaded(klass=&PL_sv_undef)
 356     SV *klass
 357     PREINIT:
 358         HV *stash;
 359         char *key;
 360         I32 keylen;
 361         GV *gv;
 362     PPCODE:
 363         if (!SvPOK(klass) || !SvCUR(klass)) {
 364             XSRETURN_NO;
 365         }
 366
 367         stash = gv_stashsv(klass, 0);
 368         if (!stash) {
 369             XSRETURN_NO;
 370         }
 371
 372         if (hv_exists_ent (stash, key_VERSION, hash_VERSION)) {
 373             HE *version = hv_fetch_ent(stash, key_VERSION, 0, hash_VERSION);
 374             if (version && HeVAL(version) && GvSV(HeVAL(version))) {
 375                 XSRETURN_YES;
 376             }
 377         }
 378
 379         if (hv_exists_ent (stash, key_ISA, hash_ISA)) {
 380             HE *isa = hv_fetch_ent(stash, key_ISA, 0, hash_ISA);
 381             if (isa && HeVAL(isa) && GvAV(HeVAL(isa))) {
 382                 XSRETURN_YES;
 383             }
 384         }
 385
 386         (void)hv_iterinit(stash);
 387         while (gv = (GV *)hv_iternextsv(stash, &key, &keylen)) {
 388             if (keylen <= 0) {
 389                 continue;
 390             }
 391
 392             if (key[keylen - 1] == ':' && key[keylen - 2] == ':') {
 393                 continue;
 394             }
 395
 396             if (!isGV(gv) || GvCV(gv) || GvSV(gv) || GvAV(gv) || GvHV(gv) || GvIO(gv) || GvFORM(gv)) {
 397                 XSRETURN_YES;
 398             }
 399         }
 400
 401         XSRETURN_NO;
 402
 403 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
 404
 405 PROTOTYPES: ENABLE
 406
 407 void
 408 get_all_package_symbols(self, filter=TYPE_FILTER_NONE)
 409     SV *self
 410     type_filter_t filter
 411     PROTOTYPE: $;$
 412     PREINIT:
 413         HV *stash = NULL;
 414         HV *symbols = NULL;
 415         register HE *he;
 416     PPCODE:
 417         if ( ! SvROK(self) ) {
 418             die("Cannot call get_all_package_symbols as a class method");
 419         }
 420
 421         if (GIMME_V == G_VOID) {
 422             XSRETURN_EMPTY;
 423         }
 424
 425
 426         PUTBACK;
 427
 428         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) {
 429             stash = gv_stashsv(HeVAL(he), 0);
 430         }
 431
 432
 433         if (!stash) {
 434             switch (GIMME_V) {
 435                 case G_SCALAR: XSRETURN_UNDEF; break;
 436                 case G_ARRAY:  XSRETURN_EMPTY; break;
 437             }
 438         }
 439
 440         symbols = get_all_package_symbols(stash, filter);
 441
 442         switch (GIMME_V) {
 443             case G_SCALAR:
 444                 PUSHs(sv_2mortal(newRV_inc((SV *)symbols)));
 445                 break;
 446             case G_ARRAY:
 447                 warn("Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.");
 448
 449                 EXTEND(SP, HvKEYS(symbols) * 2);
 450
 451                 while ((he = hv_iternext(symbols))) {
 452                     PUSHs(hv_iterkeysv(he));
 453                     PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he))));
 454                 }
 455
 456                 break;
 457             default:
 458                 break;
 459         }
 460
 461         SvREFCNT_dec((SV *)symbols);
 462
 463 void
 464 name(self)
 465     SV *self
 466     PREINIT:
 467         register HE *he;
 468     PPCODE:
 469         if ( ! SvROK(self) ) {
 470             die("Cannot call name as a class method");
 471         }
 472
 473         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 474             XPUSHs(HeVAL(he));
 475         else
 476             ST(0) = &PL_sv_undef;
 477
 478 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 479
 480 void
 481 name(self)
 482     SV *self
 483     PREINIT:
 484         register HE *he;
 485     PPCODE:
 486         if ( ! SvROK(self) ) {
 487             die("Cannot call name as a class method");
 488         }
 489
 490         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 491             XPUSHs(HeVAL(he));
 492         else
 493             ST(0) = &PL_sv_undef;
 494
 495 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 496
 497 void
 498 name(self)
 499     SV *self
 500     PREINIT:
 501         register HE *he;
 502     PPCODE:
 503         if ( ! SvROK(self) ) {
 504             die("Cannot call name as a class method");
 505         }
 506
 507         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 508             XPUSHs(HeVAL(he));
 509         else
 510             ST(0) = &PL_sv_undef;
 511
 512 void
 513 package_name(self)
 514     SV *self
 515     PREINIT:
 516         register HE *he;
 517     PPCODE:
 518         if ( ! SvROK(self) ) {
 519             die("Cannot call package_name as a class method");
 520         }
 521
 522         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 523             XPUSHs(HeVAL(he));
 524         else
 525             ST(0) = &PL_sv_undef;
 526
 527 void
 528 body(self)
 529     SV *self
 530     PREINIT:
 531         register HE *he;
 532     PPCODE:
 533         if ( ! SvROK(self) ) {
 534             die("Cannot call body as a class method");
 535         }
 536
 537         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 538             XPUSHs(HeVAL(he));
 539         else
 540             ST(0) = &PL_sv_undef;
 541
 542
 543 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 544
 545 void
 546 get_method_map(self)
 547     SV *self
 548     PREINIT:
 549         HV *const obj        = (HV *)SvRV(self);
 550         SV *const class_name = HeVAL( hv_fetch_ent(obj, key_package, 0, hash_package) );
 551         HV *const stash      = gv_stashsv(class_name, 0);
 552         UV  const current    = check_package_cache_flag(stash);
 553         SV *const cache_flag = HeVAL( hv_fetch_ent(obj, key_package_cache_flag, TRUE, hash_package_cache_flag));
 554         SV *const map_ref    = HeVAL( hv_fetch_ent(obj, key_methods, TRUE, hash_methods));
 555     PPCODE:
 556         /* in  $self->{methods} does not yet exist (or got deleted) */
 557         if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) {
 558             SV *new_map_ref = newRV_noinc((SV *)newHV());
 559             sv_2mortal(new_map_ref);
 560             sv_setsv(map_ref, new_map_ref);
 561         }
 562
 563         if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) {
 564             mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref));
 565             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 566         }
 567
 568         XPUSHs(map_ref);