xs/MOP.xs

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