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         }
 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
 171 /*
 172 get_code_info:
 173   Pass in a coderef, returns:
 174   [ $pkg_name, $coderef_name ] ie:
 175   [ 'Foo::Bar', 'new' ]
 176 */
 177
 178 MODULE = Class::MOP   PACKAGE = Class::MOP
 179
 180 BOOT:
 181     key_name = newSVpvs("name");
 182     key_body = newSVpvs("body");
 183     key_package = newSVpvs("package");
 184     key_package_name = newSVpvs("package_name");
 185
 186     PERL_HASH(hash_name, "name", 4);
 187     PERL_HASH(hash_body, "body", 4);
 188     PERL_HASH(hash_package, "package", 7);
 189     PERL_HASH(hash_package_name, "package_name", 12);
 190
 191     method_metaclass     = newSVpvs("method_metaclass");
 192     wrap                 = newSVpvs("wrap");
 193     associated_metaclass = newSVpvs("associated_metaclass");
 194
 195
 196 PROTOTYPES: ENABLE
 197
 198
 199 void
 200 get_code_info(coderef)
 201   SV* coderef
 202   PREINIT:
 203     char* name;
 204     char* pkg;
 205   PPCODE:
 206     if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
 207       coderef = SvRV(coderef);
 208       /* I think this only gets triggered with a mangled coderef, but if
 209          we hit it without the guard, we segfault. The slightly odd return
 210          value strikes me as an improvement (mst)
 211       */
 212 #ifdef isGV_with_GP
 213       if ( isGV_with_GP(CvGV(coderef)) ) {
 214 #endif
 215         pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
 216         name    = GvNAME( CvGV(coderef) );
 217 #ifdef isGV_with_GP
 218       } else {
 219         pkg     = "__UNKNOWN__";
 220         name    = "__ANON__";
 221       }
 222 #endif
 223
 224       EXTEND(SP, 2);
 225       PUSHs(newSVpvn(pkg, strlen(pkg)));
 226       PUSHs(newSVpvn(name, strlen(name)));
 227     }
 228
 229
 230 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
 231
 232 void
 233 get_all_package_symbols(self, ...)
 234     SV *self
 235     PROTOTYPE: $;$
 236     PREINIT:
 237         HV *stash = NULL;
 238         SV *type_filter = NULL;
 239         register HE *he;
 240     PPCODE:
 241         if ( ! SvROK(self) ) {
 242             die("Cannot call get_all_package_symbols as a class method");
 243         }
 244
 245         switch (GIMME_V) {
 246             case G_VOID: return; break;
 247             case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
 248         }
 249
 250         if ( items > 1 ) type_filter = ST(1);
 251
 252         PUTBACK;
 253
 254         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 255             stash = gv_stashsv(HeVAL(he),0);
 256
 257         if (stash) {
 258
 259             (void)hv_iterinit(stash);
 260
 261             if ( type_filter && SvPOK(type_filter) ) {
 262                 const char *const type = SvPV_nolen(type_filter);
 263
 264                 while ( (he = hv_iternext(stash)) ) {
 265                     SV *const gv = HeVAL(he);
 266                     SV *sv = NULL;
 267                     char *key;
 268                     STRLEN keylen;
 269                     char *package;
 270                     SV *fq;
 271
 272                     switch( SvTYPE(gv) ) {
 273                         case SVt_PV:
 274                         case SVt_IV:
 275                             /* expand the gv into a real typeglob if it
 276                              * contains stub functions and we were asked to
 277                              * return CODE symbols */
 278                             if (*type == 'C') {
 279                                 key = HePV(he, keylen);
 280                                 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
 281                             }
 282                             /* fall through */
 283                         case SVt_PVGV:
 284                             switch (*type) {
 285                                 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
 286                                 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
 287                                 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
 288                                 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
 289                                 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
 290                                 default:
 291                                           croak("Unknown type %s\n", type);
 292                             }
 293                             break;
 294                         case SVt_RV:
 295                             /* BAH! constants are horrible */
 296
 297                             if ( ! SvROK(gv) ) {
 298                                 continue;
 299                             }
 300
 301                             /* we don't really care about the length,
 302                                but that's the API */
 303                             key = HePV(he, keylen);
 304                             package = HvNAME(stash);
 305                             fq = newSVpvf("%s::%s", package, key);
 306                             sv = (SV*)get_cv(SvPV_nolen(fq), 0);
 307                             break;
 308                         default:
 309                             continue;
 310                     }
 311
 312                     if (sv) {
 313                         SV *key = hv_iterkeysv(he);
 314                         SPAGAIN;
 315                         EXTEND(SP, 2);
 316                         PUSHs(key);
 317                         PUSHs(sv_2mortal(newRV_inc(sv)));
 318                         PUTBACK;
 319                     }
 320                 }
 321             } else {
 322                 EXTEND(SP, HvKEYS(stash) * 2);
 323
 324                 while ( (he = hv_iternext(stash)) ) {
 325                     SV *key = hv_iterkeysv(he);
 326                     SV *sv = HeVAL(he);
 327                     SPAGAIN;
 328                     PUSHs(key);
 329                     PUSHs(sv);
 330                     PUTBACK;
 331                 }
 332             }
 333
 334         }
 335
 336 void
 337 name(self)
 338     SV *self
 339     PREINIT:
 340         register HE *he;
 341     PPCODE:
 342         if ( ! SvROK(self) ) {
 343             die("Cannot call name as a class method");
 344         }
 345
 346         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 347             XPUSHs(HeVAL(he));
 348         else
 349             ST(0) = &PL_sv_undef;
 350
 351 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 352
 353 void
 354 name(self)
 355     SV *self
 356     PREINIT:
 357         register HE *he;
 358     PPCODE:
 359         if ( ! SvROK(self) ) {
 360             die("Cannot call name as a class method");
 361         }
 362
 363         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 364             XPUSHs(HeVAL(he));
 365         else
 366             ST(0) = &PL_sv_undef;
 367
 368 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 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_name, 0, hash_name)) )
 381             XPUSHs(HeVAL(he));
 382         else
 383             ST(0) = &PL_sv_undef;
 384
 385 void
 386 package_name(self)
 387     SV *self
 388     PREINIT:
 389         register HE *he;
 390     PPCODE:
 391         if ( ! SvROK(self) ) {
 392             die("Cannot call package_name as a class method");
 393         }
 394
 395         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 396             XPUSHs(HeVAL(he));
 397         else
 398             ST(0) = &PL_sv_undef;
 399
 400 void
 401 body(self)
 402     SV *self
 403     PREINIT:
 404         register HE *he;
 405     PPCODE:
 406         if ( ! SvROK(self) ) {
 407             die("Cannot call body as a class method");
 408         }
 409
 410         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 411             XPUSHs(HeVAL(he));
 412         else
 413             ST(0) = &PL_sv_undef;
 414
 415
 416 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 417
 418 void
 419 get_method_map(self)
 420     SV* self
 421     PREINIT:
 422         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
 423         HV* const stash      = gv_stashsv(class_name, TRUE);
 424         UV  const current    = check_package_cache_flag(stash);
 425         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
 426         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
 427     PPCODE:
 428         if ( ! SvRV(self) ) {
 429             die("Cannot call get_method_map as a class method");
 430         }
 431
 432         /* in  $self->{methods} does not yet exist (or got deleted) */
 433         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
 434             SV* new_map_ref = newRV_noinc((SV*)newHV());
 435             sv_2mortal(new_map_ref);
 436             sv_setsv(map_ref, new_map_ref);
 437         }
 438
 439         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
 440             ENTER;
 441             SAVETMPS;
 442
 443             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
 444             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 445
 446             FREETMPS;
 447             LEAVE;
 448         }
 449
 450         XPUSHs(map_ref);
 451