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             case SVt_RV:
  95                 if (!SvROK(gv)) {
  96                     break;
  97                 }
  98                 /* fall through */
  99             case SVt_IV:
 100             case SVt_PV:
 101                 /* rafl says that this wastes memory savings that GvSVs have
 102                    in 5.8.9 and 5.10.x. But without it some tests fail. rafl
 103                    says the right thing to do is to handle GvSVs differently
 104                    here. */
 105                 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
 106                 /* fall through */
 107             default:
 108                 break;
 109         }
 110
 111         if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
 112             GV* const cvgv = CvGV(cv);
 113             /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
 114             const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
 115             const char* const cv_name    = GvNAME(cvgv);
 116             SV* method_slot;
 117             SV* method_object;
 118
 119             /* this checks to see that the subroutine is actually from our package  */
 120             if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
 121                 if ( strNE(cvpkg_name, class_name_pv) ) {
 122                     continue;
 123                 }
 124             }
 125
 126             method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
 127             if ( SvOK(method_slot) ) {
 128                 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
 129                 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
 130                     continue;
 131                 }
 132             }
 133
 134             method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
 135
 136             /*
 137                 $method_object = $method_metaclass->wrap(
 138                     $cv,
 139                     associated_metaclass => $self,
 140                     package_name         => $class_name,
 141                     name                 => $method_name
 142                 );
 143             */
 144             ENTER;
 145             SAVETMPS;
 146
 147             PUSHMARK(SP);
 148             EXTEND(SP, 8);
 149             PUSHs(method_metaclass_name); /* invocant */
 150             mPUSHs(newRV_inc((SV*)cv));
 151             PUSHs(associated_metaclass);
 152             PUSHs(self);
 153             PUSHs(key_package_name);
 154             PUSHs(class_name);
 155             PUSHs(key_name);
 156             mPUSHs(newSVpv(method_name, method_name_len));
 157             PUTBACK;
 158
 159             call_sv(wrap, G_SCALAR | G_METHOD);
 160             SPAGAIN;
 161             method_object = POPs;
 162             PUTBACK;
 163             /* $map->{$method_name} = $method_object */
 164             sv_setsv(method_slot, method_object);
 165
 166             FREETMPS;
 167             LEAVE;
 168         }
 169     }
 170 }
 171
 172
 173 /*
 174 get_code_info:
 175   Pass in a coderef, returns:
 176   [ $pkg_name, $coderef_name ] ie:
 177   [ 'Foo::Bar', 'new' ]
 178 */
 179
 180 MODULE = Class::MOP   PACKAGE = Class::MOP
 181
 182 BOOT:
 183     key_name = newSVpvs("name");
 184     key_body = newSVpvs("body");
 185     key_package = newSVpvs("package");
 186     key_package_name = newSVpvs("package_name");
 187
 188     PERL_HASH(hash_name, "name", 4);
 189     PERL_HASH(hash_body, "body", 4);
 190     PERL_HASH(hash_package, "package", 7);
 191     PERL_HASH(hash_package_name, "package_name", 12);
 192
 193     method_metaclass     = newSVpvs("method_metaclass");
 194     wrap                 = newSVpvs("wrap");
 195     associated_metaclass = newSVpvs("associated_metaclass");
 196
 197
 198 PROTOTYPES: ENABLE
 199
 200
 201 void
 202 get_code_info(coderef)
 203   SV* coderef
 204   PREINIT:
 205     char* name;
 206     char* pkg;
 207   PPCODE:
 208     if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
 209       coderef = SvRV(coderef);
 210       /* I think this only gets triggered with a mangled coderef, but if
 211          we hit it without the guard, we segfault. The slightly odd return
 212          value strikes me as an improvement (mst)
 213       */
 214 #ifdef isGV_with_GP
 215       if ( isGV_with_GP(CvGV(coderef)) ) {
 216 #endif
 217         pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
 218         name    = GvNAME( CvGV(coderef) );
 219 #ifdef isGV_with_GP
 220       } else {
 221         pkg     = "__UNKNOWN__";
 222         name    = "__ANON__";
 223       }
 224 #endif
 225
 226       EXTEND(SP, 2);
 227       PUSHs(newSVpvn(pkg, strlen(pkg)));
 228       PUSHs(newSVpvn(name, strlen(name)));
 229     }
 230
 231
 232 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
 233
 234 void
 235 get_all_package_symbols(self, ...)
 236     SV *self
 237     PROTOTYPE: $;$
 238     PREINIT:
 239         HV *stash = NULL;
 240         SV *type_filter = NULL;
 241         register HE *he;
 242     PPCODE:
 243         if ( ! SvROK(self) ) {
 244             die("Cannot call get_all_package_symbols as a class method");
 245         }
 246
 247         switch (GIMME_V) {
 248             case G_VOID: return; break;
 249             case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
 250         }
 251
 252         if ( items > 1 ) type_filter = ST(1);
 253
 254         PUTBACK;
 255
 256         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 257             stash = gv_stashsv(HeVAL(he),0);
 258
 259         if (stash) {
 260
 261             (void)hv_iterinit(stash);
 262
 263             if ( type_filter && SvPOK(type_filter) ) {
 264                 const char *const type = SvPV_nolen(type_filter);
 265
 266                 while ( (he = hv_iternext(stash)) ) {
 267                     SV *const gv = HeVAL(he);
 268                     SV *sv = NULL;
 269                     char *key;
 270                     STRLEN keylen;
 271                     char *package;
 272                     SV *fq;
 273
 274                     switch( SvTYPE(gv) ) {
 275                         case SVt_PV:
 276                         case SVt_IV:
 277                             /* expand the gv into a real typeglob if it
 278                              * contains stub functions and we were asked to
 279                              * return CODE symbols */
 280                             if (*type == 'C') {
 281                                 key = HePV(he, keylen);
 282                                 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
 283                             }
 284                             /* fall through */
 285                         case SVt_PVGV:
 286                             switch (*type) {
 287                                 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
 288                                 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
 289                                 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
 290                                 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
 291                                 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
 292                                 default:
 293                                           croak("Unknown type %s\n", type);
 294                             }
 295                             break;
 296                         case SVt_RV:
 297                             /* BAH! constants are horrible */
 298
 299                             if ( ! SvROK(gv) ) {
 300                                 continue;
 301                             }
 302
 303                             /* we don't really care about the length,
 304                                but that's the API */
 305                             key = HePV(he, keylen);
 306                             package = HvNAME(stash);
 307                             fq = newSVpvf("%s::%s", package, key);
 308                             sv = (SV*)get_cv(SvPV_nolen(fq), 0);
 309                             break;
 310                         default:
 311                             continue;
 312                     }
 313
 314                     if (sv) {
 315                         SV *key = hv_iterkeysv(he);
 316                         SPAGAIN;
 317                         EXTEND(SP, 2);
 318                         PUSHs(key);
 319                         PUSHs(sv_2mortal(newRV_inc(sv)));
 320                         PUTBACK;
 321                     }
 322                 }
 323             } else {
 324                 EXTEND(SP, HvKEYS(stash) * 2);
 325
 326                 while ( (he = hv_iternext(stash)) ) {
 327                     SV *key = hv_iterkeysv(he);
 328                     SV *sv = HeVAL(he);
 329                     SPAGAIN;
 330                     PUSHs(key);
 331                     PUSHs(sv);
 332                     PUTBACK;
 333                 }
 334             }
 335
 336         }
 337
 338 void
 339 name(self)
 340     SV *self
 341     PREINIT:
 342         register HE *he;
 343     PPCODE:
 344         if ( ! SvROK(self) ) {
 345             die("Cannot call name as a class method");
 346         }
 347
 348         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 349             XPUSHs(HeVAL(he));
 350         else
 351             ST(0) = &PL_sv_undef;
 352
 353 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 354
 355 void
 356 name(self)
 357     SV *self
 358     PREINIT:
 359         register HE *he;
 360     PPCODE:
 361         if ( ! SvROK(self) ) {
 362             die("Cannot call name as a class method");
 363         }
 364
 365         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 366             XPUSHs(HeVAL(he));
 367         else
 368             ST(0) = &PL_sv_undef;
 369
 370 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 371
 372 void
 373 name(self)
 374     SV *self
 375     PREINIT:
 376         register HE *he;
 377     PPCODE:
 378         if ( ! SvROK(self) ) {
 379             die("Cannot call name as a class method");
 380         }
 381
 382         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 383             XPUSHs(HeVAL(he));
 384         else
 385             ST(0) = &PL_sv_undef;
 386
 387 void
 388 package_name(self)
 389     SV *self
 390     PREINIT:
 391         register HE *he;
 392     PPCODE:
 393         if ( ! SvROK(self) ) {
 394             die("Cannot call package_name as a class method");
 395         }
 396
 397         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 398             XPUSHs(HeVAL(he));
 399         else
 400             ST(0) = &PL_sv_undef;
 401
 402 void
 403 body(self)
 404     SV *self
 405     PREINIT:
 406         register HE *he;
 407     PPCODE:
 408         if ( ! SvROK(self) ) {
 409             die("Cannot call body as a class method");
 410         }
 411
 412         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 413             XPUSHs(HeVAL(he));
 414         else
 415             ST(0) = &PL_sv_undef;
 416
 417
 418 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 419
 420 void
 421 get_method_map(self)
 422     SV* self
 423     PREINIT:
 424         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
 425         HV* const stash      = gv_stashsv(class_name, TRUE);
 426         UV  const current    = check_package_cache_flag(stash);
 427         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
 428         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
 429     PPCODE:
 430         if ( ! SvRV(self) ) {
 431             die("Cannot call get_method_map as a class method");
 432         }
 433
 434         /* in  $self->{methods} does not yet exist (or got deleted) */
 435         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
 436             SV* new_map_ref = newRV_noinc((SV*)newHV());
 437             sv_2mortal(new_map_ref);
 438             sv_setsv(map_ref, new_map_ref);
 439         }
 440
 441         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
 442             ENTER;
 443             SAVETMPS;
 444
 445             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
 446             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 447
 448             FREETMPS;
 449             LEAVE;
 450         }
 451
 452         XPUSHs(map_ref);
 453