Test execution of stub meta methods after the stub functions got defined.
[gitmo/Class-MOP.git] / MOP.xs
1 /* There's a lot of cases of doubled parens in here like this:
2
3   while ( (he = ...) ) {
4
5 This shuts up warnings from gcc -Wall
6 */
7
8 #include "EXTERN.h"
9 #include "perl.h"
10 #include "XSUB.h"
11
12 #define NEED_sv_2pv_flags
13 #define NEED_sv_2pv_nolen
14 #include "ppport.h"
15
16 SV *key_name;
17 U32 hash_name;
18
19 SV *key_package;
20 U32 hash_package;
21
22 SV *key_package_name;
23 U32 hash_package_name;
24
25 SV *key_body;
26 U32 hash_body;
27
28 SV* method_metaclass;
29 SV* associated_metaclass;
30 SV* wrap;
31
32
33 #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
34 #ifdef HvMROMETA /* 5.10.0 */
35
36 #ifndef mro_meta_init
37 #define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
38 #endif /* !mro_meta_init */
39
40 static UV
41 mop_check_package_cache_flag(pTHX_ HV* stash) {
42     assert(SvTYPE(stash) == SVt_PVHV);
43
44     return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
45 }
46
47 #else /* pre 5.10.0 */
48
49 static UV
50 mop_check_package_cache_flag(pTHX_ HV* stash) {
51     PERL_UNUSED_ARG(stash);
52     assert(SvTYPE(stash) == SVt_PVHV);
53
54     return PL_sub_generation;
55 }
56 #endif
57
58 #define call0(s, m)  mop_call0(aTHX_ s, m)
59 static SV*
60 mop_call0(pTHX_ SV* const self, SV* const method) {
61     dSP;
62     SV* ret;
63
64     PUSHMARK(SP);
65     XPUSHs(self);
66     PUTBACK;
67
68     call_sv(method, G_SCALAR | G_METHOD);
69
70     SPAGAIN;
71     ret = POPs;
72     PUTBACK;
73
74     return ret;
75 }
76
77 static void
78 mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
79     const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
80     SV*   method_metaclass_name;
81     char* method_name;
82     I32   method_name_len;
83     GV* gv;
84     dSP;
85
86     /* this function massivly overlaps with the xs version of
87      * get_all_package_symbols. a common c function to walk the symbol table
88      * should be factored out and used by both.  --rafl */
89
90     hv_iterinit(stash);
91     while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
92         CV* cv;
93         switch (SvTYPE (gv)) {
94             case SVt_RV:
95                 if (!SvROK(gv)) {
96                     break;
97                 }
98                 /* fall through */
99             case SVt_IV:
100             case SVt_PV:
101                 /* rafl says that this wastes memory savings that GvSVs have
102                    in 5.8.9 and 5.10.x. But without it some tests fail. rafl
103                    says the right thing to do is to handle GvSVs differently
104                    here. */
105                 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
106                 /* fall through */
107         }
108
109         if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
110             GV* const cvgv = CvGV(cv);
111             /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
112             const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
113             const char* const cv_name    = GvNAME(cvgv);
114             SV* method_slot;
115             SV* method_object;
116
117             /* this checks to see that the subroutine is actually from our package  */
118             if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
119                 if ( strNE(cvpkg_name, class_name_pv) ) {
120                     continue;
121                 }
122             }
123
124             method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
125             if ( SvOK(method_slot) ) {
126                 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
127                 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
128                     continue;
129                 }
130             }
131
132             method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
133
134             /*
135                 $method_object = $method_metaclass->wrap(
136                     $cv,
137                     associated_metaclass => $self,
138                     package_name         => $class_name,
139                     name                 => $method_name
140                 );
141             */
142             ENTER;
143             SAVETMPS;
144
145             PUSHMARK(SP);
146             EXTEND(SP, 8);
147             PUSHs(method_metaclass_name); /* invocant */
148             mPUSHs(newRV_inc((SV*)cv));
149             PUSHs(associated_metaclass);
150             PUSHs(self);
151             PUSHs(key_package_name);
152             PUSHs(class_name);
153             PUSHs(key_name);
154             mPUSHs(newSVpv(method_name, method_name_len));
155             PUTBACK;
156
157             call_sv(wrap, G_SCALAR | G_METHOD);
158             SPAGAIN;
159             method_object = POPs;
160             PUTBACK;
161             /* $map->{$method_name} = $method_object */
162             sv_setsv(method_slot, method_object);
163
164             FREETMPS;
165             LEAVE;
166         }
167     }
168 }
169
170
171 /*
172 get_code_info:
173   Pass in a coderef, returns:
174   [ $pkg_name, $coderef_name ] ie:
175   [ 'Foo::Bar', 'new' ]
176 */
177
178 MODULE = Class::MOP   PACKAGE = Class::MOP
179
180 BOOT:
181     key_name = newSVpvs("name");
182     key_body = newSVpvs("body");
183     key_package = newSVpvs("package");
184     key_package_name = newSVpvs("package_name");
185
186     PERL_HASH(hash_name, "name", 4);
187     PERL_HASH(hash_body, "body", 4);
188     PERL_HASH(hash_package, "package", 7);
189     PERL_HASH(hash_package_name, "package_name", 12);
190
191     method_metaclass     = newSVpvs("method_metaclass");
192     wrap                 = newSVpvs("wrap");
193     associated_metaclass = newSVpvs("associated_metaclass");
194
195
196 PROTOTYPES: ENABLE
197
198
199 void
200 get_code_info(coderef)
201   SV* coderef
202   PREINIT:
203     char* name;
204     char* pkg;
205   PPCODE:
206     if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
207       coderef = SvRV(coderef);
208       /* I think this only gets triggered with a mangled coderef, but if
209          we hit it without the guard, we segfault. The slightly odd return
210          value strikes me as an improvement (mst)
211       */
212 #ifdef isGV_with_GP
213       if ( isGV_with_GP(CvGV(coderef)) ) {
214 #endif
215         pkg     = HvNAME( GvSTASH(CvGV(coderef)) );
216         name    = GvNAME( CvGV(coderef) );
217 #ifdef isGV_with_GP
218       } else {
219         pkg     = "__UNKNOWN__";
220         name    = "__ANON__";
221       }
222 #endif
223
224       EXTEND(SP, 2);
225       PUSHs(newSVpvn(pkg, strlen(pkg)));
226       PUSHs(newSVpvn(name, strlen(name)));
227     }
228
229
230 MODULE = Class::MOP   PACKAGE = Class::MOP::Package
231
232 void
233 get_all_package_symbols(self, ...)
234     SV *self
235     PROTOTYPE: $;$
236     PREINIT:
237         HV *stash = NULL;
238         SV *type_filter = NULL;
239         register HE *he;
240     PPCODE:
241         if ( ! SvROK(self) ) {
242             die("Cannot call get_all_package_symbols as a class method");
243         }
244
245         switch (GIMME_V) {
246             case G_VOID: return; break;
247             case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
248         }
249
250         if ( items > 1 ) type_filter = ST(1);
251
252         PUTBACK;
253
254         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
255             stash = gv_stashsv(HeVAL(he),0);
256
257         if (stash) {
258
259             (void)hv_iterinit(stash);
260
261             if ( type_filter && SvPOK(type_filter) ) {
262                 const char *const type = SvPV_nolen(type_filter);
263
264                 while ( (he = hv_iternext(stash)) ) {
265                     SV *const gv = HeVAL(he);
266                     SV *sv = NULL;
267                     char *key;
268                     STRLEN keylen;
269                     char *package;
270                     SV *fq;
271
272                     switch( SvTYPE(gv) ) {
273                         case SVt_PV:
274                         case SVt_IV:
275                             /* expand the gv into a real typeglob if it
276                              * contains stub functions and we were asked to
277                              * return CODE symbols */
278                             if (*type == 'C') {
279                                 key = HePV(he, keylen);
280                                 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
281                             }
282                             /* fall through */
283                         case SVt_PVGV:
284                             switch (*type) {
285                                 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
286                                 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
287                                 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
288                                 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
289                                 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
290                                 default:
291                                           croak("Unknown type %s\n", type);
292                             }
293                             break;
294                         case SVt_RV:
295                             /* BAH! constants are horrible */
296
297                             if ( ! SvROK(gv) ) {
298                                 continue;
299                             }
300
301                             /* we don't really care about the length,
302                                but that's the API */
303                             key = HePV(he, keylen);
304                             package = HvNAME(stash);
305                             fq = newSVpvf("%s::%s", package, key);
306                             sv = (SV*)get_cv(SvPV_nolen(fq), 0);
307                             break;
308                         default:
309                             continue;
310                     }
311
312                     if (sv) {
313                         SV *key = hv_iterkeysv(he);
314                         SPAGAIN;
315                         EXTEND(SP, 2);
316                         PUSHs(key);
317                         PUSHs(sv_2mortal(newRV_inc(sv)));
318                         PUTBACK;
319                     }
320                 }
321             } else {
322                 EXTEND(SP, HvKEYS(stash) * 2);
323
324                 while ( (he = hv_iternext(stash)) ) {
325                     SV *key = hv_iterkeysv(he);
326                     SV *sv = HeVAL(he);
327                     SPAGAIN;
328                     PUSHs(key);
329                     PUSHs(sv);
330                     PUTBACK;
331                 }
332             }
333
334         }
335
336 void
337 name(self)
338     SV *self
339     PREINIT:
340         register HE *he;
341     PPCODE:
342         if ( ! SvROK(self) ) {
343             die("Cannot call name as a class method");
344         }
345
346         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
347             XPUSHs(HeVAL(he));
348         else
349             ST(0) = &PL_sv_undef;
350
351 MODULE = Class::MOP   PACKAGE = Class::MOP::Attribute
352
353 void
354 name(self)
355     SV *self
356     PREINIT:
357         register HE *he;
358     PPCODE:
359         if ( ! SvROK(self) ) {
360             die("Cannot call name as a class method");
361         }
362
363         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
364             XPUSHs(HeVAL(he));
365         else
366             ST(0) = &PL_sv_undef;
367
368 MODULE = Class::MOP   PACKAGE = Class::MOP::Method
369
370 void
371 name(self)
372     SV *self
373     PREINIT:
374         register HE *he;
375     PPCODE:
376         if ( ! SvROK(self) ) {
377             die("Cannot call name as a class method");
378         }
379
380         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
381             XPUSHs(HeVAL(he));
382         else
383             ST(0) = &PL_sv_undef;
384
385 void
386 package_name(self)
387     SV *self
388     PREINIT:
389         register HE *he;
390     PPCODE:
391         if ( ! SvROK(self) ) {
392             die("Cannot call package_name as a class method");
393         }
394
395         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
396             XPUSHs(HeVAL(he));
397         else
398             ST(0) = &PL_sv_undef;
399
400 void
401 body(self)
402     SV *self
403     PREINIT:
404         register HE *he;
405     PPCODE:
406         if ( ! SvROK(self) ) {
407             die("Cannot call body as a class method");
408         }
409
410         if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
411             XPUSHs(HeVAL(he));
412         else
413             ST(0) = &PL_sv_undef;
414
415
416 MODULE = Class::MOP    PACKAGE = Class::MOP::Class
417
418 void
419 get_method_map(self)
420     SV* self
421     PREINIT:
422         SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
423         HV* const stash      = gv_stashsv(class_name, TRUE);
424         UV  const current    = check_package_cache_flag(stash);
425         SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
426         SV* const map_ref    = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
427     PPCODE:
428         if ( ! SvRV(self) ) {
429             die("Cannot call get_method_map as a class method");
430         }
431
432         /* in  $self->{methods} does not yet exist (or got deleted) */
433         if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
434             SV* new_map_ref = newRV_noinc((SV*)newHV());
435             sv_2mortal(new_map_ref);
436             sv_setsv(map_ref, new_map_ref);
437         }
438
439         if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
440             ENTER;
441             SAVETMPS;
442
443             mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
444             sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
445
446             FREETMPS;
447             LEAVE;
448         }
449
450         XPUSHs(map_ref);
451