xs/MOP.xs

   1 #include "mop.h"
   2
   3 SV *mop_method_metaclass;
   4 SV *mop_associated_metaclass;
   5 SV *mop_wrap;
   6
   7 static bool
   8 find_method (const char *key, STRLEN keylen, SV *val, void *ud)
   9 {
  10     bool *found_method = (bool *)ud;
  11     PERL_UNUSED_ARG(key);
  12     PERL_UNUSED_ARG(keylen);
  13     PERL_UNUSED_ARG(val);
  14     *found_method = TRUE;
  15     return FALSE;
  16 }
  17
  18 EXTERN_C XS(boot_Class__MOP__Package);
  19 EXTERN_C XS(boot_Class__MOP__Attribute);
  20 EXTERN_C XS(boot_Class__MOP__Method);
  21
  22 MODULE = Class::MOP   PACKAGE = Class::MOP
  23
  24 PROTOTYPES: DISABLE
  25
  26 BOOT:
  27     mop_prehash_keys();
  28
  29     mop_method_metaclass     = newSVpvs("method_metaclass");
  30     mop_wrap                 = newSVpvs("wrap");
  31     mop_associated_metaclass = newSVpvs("associated_metaclass");
  32
  33     MOP_CALL_BOOT (boot_Class__MOP__Package);
  34     MOP_CALL_BOOT (boot_Class__MOP__Attribute);
  35     MOP_CALL_BOOT (boot_Class__MOP__Method);
  36
  37 # use prototype here to be compatible with get_code_info from Sub::Identify
  38 void
  39 get_code_info(coderef)
  40     SV *coderef
  41     PROTOTYPE: $
  42     PREINIT:
  43         char *pkg  = NULL;
  44         char *name = NULL;
  45     PPCODE:
  46         SvGETMAGIC(coderef);
  47         if (mop_get_code_info(coderef, &pkg, &name)) {
  48             EXTEND(SP, 2);
  49             mPUSHs(newSVpv(pkg, 0));
  50             mPUSHs(newSVpv(name, 0));
  51         }
  52
  53 # This is some pretty grotty logic. It _should_ be parallel to the
  54 # pure Perl version in lib/Class/MOP.pm, so if you want to understand
  55 # it we suggest you start there.
  56 void
  57 is_class_loaded(klass=&PL_sv_undef)
  58     SV *klass
  59     PREINIT:
  60         HV *stash;
  61         bool found_method = FALSE;
  62     PPCODE:
  63         SvGETMAGIC(klass);
  64         if (!(SvPOKp(klass) && SvCUR(klass))) { /* XXX: SvPOK does not work with magical scalars */
  65             XSRETURN_NO;
  66         }
  67
  68         stash = gv_stashsv(klass, 0);
  69         if (!stash) {
  70             XSRETURN_NO;
  71         }
  72
  73         if (hv_exists_ent (stash, KEY_FOR(VERSION), HASH_FOR(VERSION))) {
  74             HE *version = hv_fetch_ent(stash, KEY_FOR(VERSION), 0, HASH_FOR(VERSION));
  75             SV *version_sv;
  76             if (version && HeVAL(version) && (version_sv = GvSV(HeVAL(version)))) {
  77                 if (SvROK(version_sv)) {
  78                     SV *version_sv_ref = SvRV(version_sv);
  79
  80                     if (SvOK(version_sv_ref)) {
  81                         XSRETURN_YES;
  82                     }
  83                 }
  84                 else if (SvOK(version_sv)) {
  85                     XSRETURN_YES;
  86                 }
  87             }
  88         }
  89
  90         if (hv_exists_ent (stash, KEY_FOR(ISA), HASH_FOR(ISA))) {
  91             HE *isa = hv_fetch_ent(stash, KEY_FOR(ISA), 0, HASH_FOR(ISA));
  92             if (isa && HeVAL(isa) && GvAV(HeVAL(isa)) && av_len(GvAV(HeVAL(isa))) != -1) {
  93                 XSRETURN_YES;
  94             }
  95         }
  96
  97         mop_get_package_symbols(stash, TYPE_FILTER_CODE, find_method, &found_method);
  98         if (found_method) {
  99             XSRETURN_YES;
 100         }
 101
 102         XSRETURN_NO;