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
 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 #ifndef SVt_RV
 274                         case SVt_RV:
 275 #endif
 276                         case SVt_PV:
 277                         case SVt_IV:
 278                             /* expand the gv into a real typeglob if it
 279                              * contains stub functions and we were asked to
 280                              * return CODE symbols */
 281                             if (*type == 'C') {
 282                                 if (SvROK(gv)) {
 283                                     /* we don't really care about the length,
 284                                        but that's the API */
 285                                     key = HePV(he, keylen);
 286                                     package = HvNAME(stash);
 287                                     fq = newSVpvf("%s::%s", package, key);
 288                                     sv = (SV*)get_cv(SvPV_nolen(fq), 0);
 289                                     break;
 290                                 }
 291
 292                                 key = HePV(he, keylen);
 293                                 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
 294                             }
 295                             /* fall through */
 296                         case SVt_PVGV:
 297                             switch (*type) {
 298                                 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
 299                                 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
 300                                 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
 301                                 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
 302                                 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
 303                                 default:
 304                                           croak("Unknown type %s\n", type);
 305                             }
 306                             break;
 307                         default:
 308                             continue;
 309                     }
 310
 311                     if (sv) {
 312                         SV *key = hv_iterkeysv(he);
 313                         SPAGAIN;
 314                         EXTEND(SP, 2);
 315                         PUSHs(key);
 316                         PUSHs(sv_2mortal(newRV_inc(sv)));
 317                         PUTBACK;
 318                     }
 319                 }
 320             } else {
 321                 EXTEND(SP, HvKEYS(stash) * 2);
 322
 323                 while ( (he = hv_iternext(stash)) ) {
 324                     SV *key = hv_iterkeysv(he);
 325                     SV *sv = HeVAL(he);
 326                     SPAGAIN;
 327                     PUSHs(key);
 328                     PUSHs(sv);
 329                     PUTBACK;
 330                 }
 331             }
 332
 333         }
 334
 335 void
 336 name(self)
 337     SV *self
 338     PREINIT:
 339         register HE *he;
 340     PPCODE:
 341         if ( ! SvROK(self) ) {
 342             die("Cannot call name as a class method");
 343         }
 344
 345         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
 346             XPUSHs(HeVAL(he));
 347         else
 348             ST(0) = &PL_sv_undef;
 349
 350 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
 351
 352 void
 353 name(self)
 354     SV *self
 355     PREINIT:
 356         register HE *he;
 357     PPCODE:
 358         if ( ! SvROK(self) ) {
 359             die("Cannot call name as a class method");
 360         }
 361
 362         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 363             XPUSHs(HeVAL(he));
 364         else
 365             ST(0) = &PL_sv_undef;
 366
 367 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
 368
 369 void
 370 name(self)
 371     SV *self
 372     PREINIT:
 373         register HE *he;
 374     PPCODE:
 375         if ( ! SvROK(self) ) {
 376             die("Cannot call name as a class method");
 377         }
 378
 379         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
 380             XPUSHs(HeVAL(he));
 381         else
 382             ST(0) = &PL_sv_undef;
 383
 384 void
 385 package_name(self)
 386     SV *self
 387     PREINIT:
 388         register HE *he;
 389     PPCODE:
 390         if ( ! SvROK(self) ) {
 391             die("Cannot call package_name as a class method");
 392         }
 393
 394         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
 395             XPUSHs(HeVAL(he));
 396         else
 397             ST(0) = &PL_sv_undef;
 398
 399 void
 400 body(self)
 401     SV *self
 402     PREINIT:
 403         register HE *he;
 404     PPCODE:
 405         if ( ! SvROK(self) ) {
 406             die("Cannot call body as a class method");
 407         }
 408
 409         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
 410             XPUSHs(HeVAL(he));
 411         else
 412             ST(0) = &PL_sv_undef;
 413
 414
 415 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
 416
 417 void
 418 get_method_map(self)
 419     SV* self
 420     PREINIT:
 421         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
 422         HV* const stash      = gv_stashsv(class_name, TRUE);
 423         UV  const current    = check_package_cache_flag(stash);
 424         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
 425         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
 426     PPCODE:
 427         if ( ! SvRV(self) ) {
 428             die("Cannot call get_method_map as a class method");
 429         }
 430
 431         /* in  $self->{methods} does not yet exist (or got deleted) */
 432         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
 433             SV* new_map_ref = newRV_noinc((SV*)newHV());
 434             sv_2mortal(new_map_ref);
 435             sv_setsv(map_ref, new_map_ref);
 436         }
 437
 438         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
 439             ENTER;
 440             SAVETMPS;
 441
 442             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
 443             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
 444
 445             FREETMPS;
 446             LEAVE;
 447         }
 448
 449         XPUSHs(map_ref);
 450