Conflicts with the last Moose release
[gitmo/Class-MOP.git] / mop.c
1 #include "mop.h"
2
3 void
4 mop_call_xs (pTHX_ XSPROTO(subaddr), CV *cv, SV **mark)
5 {
6     dSP;
7     PUSHMARK(mark);
8     (*subaddr)(aTHX_ cv);
9     PUTBACK;
10 }
11
12 #if PERL_VERSION >= 10
13 UV
14 mop_check_package_cache_flag (pTHX_ HV *stash)
15 {
16     assert(SvTYPE(stash) == SVt_PVHV);
17
18     /* here we're trying to implement a c version of mro::get_pkg_gen($stash),
19      * however the perl core doesn't make it easy for us. It doesn't provide an
20      * api that just does what we want.
21      *
22      * However, we know that the information we want is, inside the core,
23      * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the
24      * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init,
25      * which is not public and only available inside the core, as the mro
26      * interface as well as the structure returned by mro_meta_init isn't
27      * considered to be stable yet.
28      *
29      * Perl_mro_meta_init isn't declared static, so we could just define it
30      * ourselfs if perls headers don't do that for us, except that won't work
31      * on platforms where symbols need to be explicitly exported when linking
32      * shared libraries.
33      *
34      * So our, hopefully temporary, solution is to be even more evil and
35      * basically reimplement HvMROMETA in a very fragile way that'll blow up
36      * when the relevant parts of the mro implementation in core change.
37      *
38      * :-(
39      *
40      */
41
42     return HvAUX(stash)->xhv_mro_meta
43          ? HvAUX(stash)->xhv_mro_meta->pkg_gen
44          : 0;
45 }
46
47 #else /* pre 5.10.0 */
48
49 UV
50 mop_check_package_cache_flag (pTHX_ HV *stash)
51 {
52     PERL_UNUSED_ARG(stash);
53     assert(SvTYPE(stash) == SVt_PVHV);
54
55     return PL_sub_generation;
56 }
57 #endif
58
59 SV *
60 mop_call0 (pTHX_ SV *const self, SV *const method)
61 {
62     dSP;
63     SV *ret;
64
65     PUSHMARK(SP);
66     XPUSHs(self);
67     PUTBACK;
68
69     call_sv(method, G_SCALAR | G_METHOD);
70
71     SPAGAIN;
72     ret = POPs;
73     PUTBACK;
74
75     return ret;
76 }
77
78 int
79 mop_get_code_info (SV *coderef, char **pkg, char **name)
80 {
81     if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
82         return 0;
83     }
84
85     coderef = SvRV(coderef);
86
87     /* sub is still being compiled */
88     if (!CvGV(coderef)) {
89         return 0;
90     }
91
92     /* I think this only gets triggered with a mangled coderef, but if
93        we hit it without the guard, we segfault. The slightly odd return
94        value strikes me as an improvement (mst)
95     */
96 #ifdef isGV_with_GP
97     if ( isGV_with_GP(CvGV(coderef)) ) {
98 #endif
99         *pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
100         *name    = GvNAME( CvGV(coderef) );
101 #ifdef isGV_with_GP
102     } else {
103         *pkg     = "__UNKNOWN__";
104         *name    = "__ANON__";
105     }
106 #endif
107
108     return 1;
109 }
110
111 void
112 mop_get_package_symbols (HV *stash, type_filter_t filter, get_package_symbols_cb_t cb, void *ud)
113 {
114     HE *he;
115
116     (void)hv_iterinit(stash);
117
118     if (filter == TYPE_FILTER_NONE) {
119         while ( (he = hv_iternext(stash)) ) {
120             STRLEN keylen;
121             const char *key = HePV(he, keylen);
122             if (!cb(key, keylen, HeVAL(he), ud)) {
123                 return;
124             }
125         }
126         return;
127     }
128
129     while ( (he = hv_iternext(stash)) ) {
130         SV *const gv = HeVAL(he);
131         SV *sv = NULL;
132         char *key;
133         STRLEN keylen;
134         char *package;
135         SV *fq;
136
137         switch( SvTYPE(gv) ) {
138 #ifndef SVt_RV
139             case SVt_RV:
140 #endif
141             case SVt_PV:
142             case SVt_IV:
143                 /* expand the gv into a real typeglob if it
144                  * contains stub functions and we were asked to
145                  * return CODE symbols */
146                 if (filter == TYPE_FILTER_CODE) {
147                     if (SvROK(gv)) {
148                         /* we don't really care about the length,
149                            but that's the API */
150                         key = HePV(he, keylen);
151                         package = HvNAME(stash);
152                         fq = newSVpvf("%s::%s", package, key);
153                         sv = (SV *)get_cv(SvPV_nolen(fq), 0);
154                         break;
155                     }
156
157                     key = HePV(he, keylen);
158                     gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
159                 }
160                 /* fall through */
161             case SVt_PVGV:
162                 switch (filter) {
163                     case TYPE_FILTER_CODE:   sv = (SV *)GvCVu(gv); break;
164                     case TYPE_FILTER_ARRAY:  sv = (SV *)GvAV(gv);  break;
165                     case TYPE_FILTER_IO:     sv = (SV *)GvIO(gv);  break;
166                     case TYPE_FILTER_HASH:   sv = (SV *)GvHV(gv);  break;
167                     case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv);  break;
168                     default:
169                         croak("Unknown type");
170                 }
171                 break;
172             default:
173                 continue;
174         }
175
176         if (sv) {
177             const char *key = HePV(he, keylen);
178             if (!cb(key, keylen, sv, ud)) {
179                 return;
180             }
181         }
182     }
183 }
184
185 static bool
186 collect_all_symbols (const char *key, STRLEN keylen, SV *val, void *ud)
187 {
188     HV *hash = (HV *)ud;
189
190     if (!hv_store (hash, key, keylen, newRV_inc(val), 0)) {
191         croak("failed to store symbol ref");
192     }
193
194     return TRUE;
195 }
196
197 HV *
198 mop_get_all_package_symbols (HV *stash, type_filter_t filter)
199 {
200     HV *ret = newHV ();
201     mop_get_package_symbols (stash, filter, collect_all_symbols, ret);
202     return ret;
203 }
204
205 #define DECLARE_KEY(name)                    { #name, #name, NULL, 0 }
206 #define DECLARE_KEY_WITH_VALUE(name, value)  { #name, value, NULL, 0 }
207
208 /* the order of these has to match with those in mop.h */
209 static struct {
210     const char *name;
211     const char *value;
212     SV *key;
213     U32 hash;
214 } prehashed_keys[key_last] = {
215     DECLARE_KEY(name),
216     DECLARE_KEY(package),
217     DECLARE_KEY(package_name),
218     DECLARE_KEY(body),
219     DECLARE_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"),
220     DECLARE_KEY(methods),
221     DECLARE_KEY(VERSION),
222     DECLARE_KEY(ISA)
223 };
224
225 SV *
226 mop_prehashed_key_for (mop_prehashed_key_t key)
227 {
228     return prehashed_keys[key].key;
229 }
230
231 U32
232 mop_prehashed_hash_for (mop_prehashed_key_t key)
233 {
234     return prehashed_keys[key].hash;
235 }
236
237 void
238 mop_prehash_keys ()
239 {
240     int i;
241     for (i = 0; i < key_last; i++) {
242         const char *value = prehashed_keys[i].value;
243         prehashed_keys[i].key = newSVpv(value, strlen(value));
244         PERL_HASH(prehashed_keys[i].hash, value, strlen(value));
245     }
246 }
247
248 XS(mop_xs_simple_reader)
249 {
250 #ifdef dVAR
251     dVAR; dXSARGS;
252 #else
253     dXSARGS;
254 #endif
255     register HE *he;
256     mop_prehashed_key_t key = (mop_prehashed_key_t)CvXSUBANY(cv).any_i32;
257     SV *self;
258
259     if (items != 1) {
260         croak("expected exactly one argument");
261     }
262
263     self = ST(0);
264
265     if (!SvROK(self)) {
266         croak("can't call %s as a class method", prehashed_keys[key].name);
267     }
268
269     if (SvTYPE(SvRV(self)) != SVt_PVHV) {
270         croak("object is not a hashref");
271     }
272
273     if ((he = hv_fetch_ent((HV *)SvRV(self), prehashed_keys[key].key, 0, prehashed_keys[key].hash))) {
274         ST(0) = HeVAL(he);
275     }
276     else {
277         ST(0) = &PL_sv_undef;
278     }
279
280     XSRETURN(1);
281 }
282