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