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