xs/MOP.xs

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