mop.c

   1 #define NEED_newRV_noinc_GLOBAL
   2 #define NEED_sv_2pv_flags_GLOBAL
   3 #define NEED_sv_2pv_nolen_GLOBAL
   4 #define NEED_newSVpvn_flags_GLOBAL
   5 #include "mop.h"
   6
   7 #if PERL_BCDVERSION >= 0x5010000
   8 UV
   9 mop_check_package_cache_flag (pTHX_ HV *stash)
  10 {
  11     assert(SvTYPE(stash) == SVt_PVHV);
  12
  13     /* here we're trying to implement a c version of mro::get_pkg_gen($stash),
  14      * however the perl core doesn't make it easy for us. It doesn't provide an
  15      * api that just does what we want.
  16      *
  17      * However, we know that the information we want is, inside the core,
  18      * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the
  19      * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init,
  20      * which is not public and only available inside the core, as the mro
  21      * interface as well as the structure returned by mro_meta_init isn't
  22      * considered to be stable yet.
  23      *
  24      * Perl_mro_meta_init isn't declared static, so we could just define it
  25      * ourselfs if perls headers don't do that for us, except that won't work
  26      * on platforms where symbols need to be explicitly exported when linking
  27      * shared libraries.
  28      *
  29      * So our, hopefully temporary, solution is to be even more evil and
  30      * basically reimplement HvMROMETA in a very fragile way that'll blow up
  31      * when the relevant parts of the mro implementation in core change.
  32      *
  33      * :-(
  34      *
  35      */
  36
  37     return HvAUX(stash)->xhv_mro_meta
  38          ? HvAUX(stash)->xhv_mro_meta->pkg_gen
  39          : 0;
  40 }
  41
  42 #else /* pre 5.10.0 */
  43
  44 UV
  45 mop_check_package_cache_flag (pTHX_ HV *stash)
  46 {
  47     PERL_UNUSED_ARG(stash);
  48     assert(SvTYPE(stash) == SVt_PVHV);
  49
  50     return PL_sub_generation;
  51 }
  52 #endif
  53
  54 SV *
  55 mop_call0 (pTHX_ SV *const self, SV *const method)
  56 {
  57     dSP;
  58     SV *ret;
  59
  60     PUSHMARK(SP);
  61     XPUSHs(self);
  62     PUTBACK;
  63
  64     call_sv(method, G_SCALAR | G_METHOD);
  65
  66     SPAGAIN;
  67     ret = POPs;
  68     PUTBACK;
  69
  70     return ret;
  71 }
  72
  73 SV *
  74 mop_call1 (pTHX_ SV *const self, SV *const method, SV* const arg1)
  75 {
  76     dSP;
  77     SV *ret;
  78
  79     PUSHMARK(SP);
  80     EXTEND(SP, 2);
  81     PUSHs(self);
  82     PUSHs(arg1);
  83     PUTBACK;
  84
  85     call_sv(method, G_SCALAR | G_METHOD);
  86
  87     SPAGAIN;
  88     ret = POPs;
  89     PUTBACK;
  90
  91     return ret;
  92 }
  93
  94
  95 int
  96 mop_get_code_info (SV *coderef, char **pkg, char **name)
  97 {
  98     if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
  99         return 0;
 100     }
 101
 102     coderef = SvRV(coderef);
 103
 104     /* sub is still being compiled */
 105     if (!CvGV(coderef)) {
 106         return 0;
 107     }
 108
 109     /* I think this only gets triggered with a mangled coderef, but if
 110        we hit it without the guard, we segfault. The slightly odd return
 111        value strikes me as an improvement (mst)
 112     */
 113
 114     if ( isGV_with_GP(CvGV(coderef)) ) {
 115         GV *gv   = CvGV(coderef);
 116         *pkg     = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) );
 117         *name    = GvNAME( CvGV(coderef) );
 118     } else {
 119         *pkg     = "__UNKNOWN__";
 120         *name    = "__ANON__";
 121     }
 122
 123     return 1;
 124 }
 125
 126 void
 127 mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud)
 128 {
 129     dTHX;
 130     HE *he;
 131
 132     (void)hv_iterinit(stash);
 133
 134     if (filter == TYPE_FILTER_NONE) {
 135         while ( (he = hv_iternext(stash)) ) {
 136             STRLEN keylen;
 137             const char *key = HePV(he, keylen);
 138             if (!cb(key, keylen, HeVAL(he), ud)) {
 139                 return;
 140             }
 141         }
 142         return;
 143     }
 144
 145     while ( (he = hv_iternext(stash)) ) {
 146         GV * const gv          = (GV*)HeVAL(he);
 147         STRLEN keylen;
 148         const char * const key = HePV(he, keylen);
 149         SV *sv = NULL;
 150
 151         if(isGV(gv)){
 152             switch (filter) {
 153                 case TYPE_FILTER_CODE:   sv = (SV *)GvCVu(gv); break;
 154                 case TYPE_FILTER_ARRAY:  sv = (SV *)GvAV(gv);  break;
 155                 case TYPE_FILTER_IO:     sv = (SV *)GvIO(gv);  break;
 156                 case TYPE_FILTER_HASH:   sv = (SV *)GvHV(gv);  break;
 157                 case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv);  break;
 158                 default:
 159                     croak("Unknown type");
 160             }
 161         }
 162         /* expand the gv into a real typeglob if it
 163         * contains stub functions or constants and we
 164         * were asked to return CODE references */
 165         else if (filter == TYPE_FILTER_CODE) {
 166             gv_init(gv, stash, key, keylen, GV_ADDMULTI);
 167             sv = (SV *)GvCV(gv);
 168         }
 169
 170         if (sv) {
 171             if (!cb(key, keylen, sv, ud)) {
 172                 return;
 173             }
 174         }
 175     }
 176 }
 177
 178 static bool
 179 collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud)
 180 {
 181     dTHX;
 182     HV *hash = (HV *)ud;
 183
 184     if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) {
 185         croak("failed to store symbol ref");
 186     }
 187
 188     return TRUE;
 189 }
 190
 191 HV *
 192 mop_get_all_package_symbols (HV *stash, type_filter_t filter)
 193 {
 194     dTHX;
 195     HV *ret = newHV ();
 196     mop_get_package_symbols (stash, filter, collect_all_symbols, ret);
 197     return ret;
 198 }
 199
 200
 201 MAGIC*
 202 mop_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl, I32 const flags){
 203     MAGIC* mg;
 204
 205     assert(sv != NULL);
 206     for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
 207         if(mg->mg_virtual == vtbl){
 208             return mg;
 209         }
 210     }
 211
 212     if(flags & MOPf_DIE_ON_FAIL){
 213         croak("mop_mg_find: no MAGIC found for %"SVf, sv_2mortal(newRV_inc(sv)));
 214     }
 215     return NULL;
 216 }
 217
 218 #ifdef DEBUGGING
 219 SV**
 220 mop_av_at_safe(pTHX_ AV* const av, I32 const ix){
 221     assert(av);
 222     assert(SvTYPE(av) == SVt_PVAV);
 223     assert(AvMAX(av) >= ix);
 224     return &AvARRAY(av)[ix];
 225 }
 226 #endif
 227
 228
 229 /*
 230     XXX: 5.8.1 does have shared hash key mechanism, but does not have the APIs,
 231          so the following APIs, which are stolen from 5.8.9, are safe to use.
 232 */
 233 #ifndef SvIsCOW_shared_hash
 234 #define SvIsCOW(sv)             ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
 235                                     (SVf_FAKE | SVf_READONLY))
 236 #define SvIsCOW_shared_hash(sv) (SvIsCOW(sv) && SvLEN(sv) == 0)
 237 #define SvSHARED_HASH(sv) (0 + SvUVX(sv))
 238 #endif
 239
 240 SV*
 241 mop_newSVsv_share(pTHX_ SV* const sv){
 242     STRLEN len;
 243     const char* const pv = SvPV_const(sv, len);
 244     U32 const hash       = SvIsCOW_shared_hash(sv) ? SvSHARED_HASH(sv) : 0U;
 245
 246     return newSVpvn_share(pv, SvUTF8(sv) ? -len : len, hash);
 247 }
 248
 249 SV*
 250 mop_class_of(pTHX_ SV* const sv){
 251     SV* class_name;
 252
 253     if(IsObject(sv)){
 254         HV* const stash = SvSTASH(SvRV(sv));
 255         assert(stash);
 256 #ifdef HvNAME_HEK /* 5.10.0 */
 257         assert(HvNAME_HEK(stash));
 258         class_name = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
 259 #else
 260         assert(HvNAME_get(stash));
 261         class_name = sv_2mortal(newSVpv(HvNAME_get(stash), 0));
 262 #endif
 263    }
 264    else{
 265         class_name = sv;
 266    }
 267    return mop_call1(aTHX_ mop_Class, mop_initialize, class_name);
 268 }