MOP.xs

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