projects / gitmo/Class-C3-XS.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Version 0.13.
[gitmo/Class-C3-XS.git] / XS.xs
CommitLineData
8995e827 1
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
8995e827 5
25dc7e96 6/* *********** ppport stuff */
7
8#ifndef PERL_UNUSED_VAR
9# define PERL_UNUSED_VAR(x) ((void)x)
10#endif
11
12#if defined(PERL_GCC_PEDANTIC)
13# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
14# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
15# endif
16#endif
17
18#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
19# ifndef PERL_USE_GCC_BRACE_GROUPS
20# define PERL_USE_GCC_BRACE_GROUPS
21# endif
22#endif
23
24#ifndef SvREFCNT_inc
25# ifdef PERL_USE_GCC_BRACE_GROUPS
6ed110b7 26# define SvREFCNT_inc(sv) \
27 ({ \
28 SV * const _sv = (SV*)(sv); \
29 if (_sv) \
30 (SvREFCNT(_sv))++; \
31 _sv; \
25dc7e96 32 })
33# else
6ed110b7 34# define SvREFCNT_inc(sv) \
25dc7e96 35 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
36# endif
37#endif
38
39#ifndef dAX
40# define dAX I32 ax = MARK - PL_stack_base + 1
41#endif
42
43#ifndef dVAR
44# define dVAR dNOOP
45#endif
46
47#ifndef packWARN
48# define packWARN(a) (a)
49#endif
50
51/* *********** end ppport.h stuff */
52
68fe9f29 53#ifndef SVfARG
54# define SVfARG(p) ((void*)(p))
55#endif
56
29e61e10 57/* Most of this code is backported from the bleadperl patch's
b23e9cb9 58 mro.c, and then modified to work with Class::C3's
59 internals.
60*/
8995e827 61
b23e9cb9 62AV*
63__mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
64{
65 AV* retval;
66 GV** gvp;
67 GV* gv;
68 AV* isa;
69 const char* stashname;
70 STRLEN stashname_len;
bb82f0c1 71 I32 made_mortal_cache = 0;
8995e827 72
b23e9cb9 73 assert(stash);
8995e827 74
b23e9cb9 75 stashname = HvNAME(stash);
76 stashname_len = strlen(stashname);
77 if (!stashname)
78 Perl_croak(aTHX_
79 "Can't linearize anonymous symbol table");
8995e827 80
b23e9cb9 81 if (level > 100)
82 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
83 stashname);
8995e827 84
b23e9cb9 85 if(!cache) {
f0294f1b 86 cache = (HV*)sv_2mortal((SV*)newHV());
bb82f0c1 87 made_mortal_cache = 1;
b23e9cb9 88 }
89 else {
6bf46d18 90 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
91 if(cache_entry)
92 return (AV*)SvREFCNT_inc(*cache_entry);
b23e9cb9 93 }
94
95 /* not in cache, make a new one */
96
b23e9cb9 97 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
98 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
b23e9cb9 99 if(isa && AvFILLp(isa) >= 0) {
100 SV** seqs_ptr;
101 I32 seqs_items;
139e8d8c 102 HV* tails;
bb82f0c1 103 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
104 I32* heads;
105
053556af 106 /* This builds @seqs, which is an array of arrays.
107 The members of @seqs are the MROs of
108 the members of @ISA, followed by @ISA itself.
109 */
b23e9cb9 110 I32 items = AvFILLp(isa) + 1;
111 SV** isa_ptr = AvARRAY(isa);
112 while(items--) {
bb82f0c1 113 SV* const isa_item = *isa_ptr++;
114 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
b23e9cb9 115 if(!isa_item_stash) {
053556af 116 /* if no stash, make a temporary fake MRO
117 containing just itself */
bb82f0c1 118 AV* const isa_lin = newAV();
b23e9cb9 119 av_push(isa_lin, newSVsv(isa_item));
bb82f0c1 120 av_push(seqs, (SV*)isa_lin);
b23e9cb9 121 }
122 else {
053556af 123 /* recursion */
124 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
139e8d8c 125
126 if(items == 0 && AvFILLp(seqs) == -1) {
127 /* Only one parent class. For this case, the C3
128 linearisation is this class followed by the parent's
129 linearisation, so don't bother with the expensive
130 calculation. */
131 SV **svp;
132 I32 subrv_items = AvFILLp(isa_lin) + 1;
133 SV *const *subrv_p = AvARRAY(isa_lin);
134
135 /* Hijack the allocated but unused array seqs to be the
136 return value. It's currently mortalised. */
137
138 retval = seqs;
139
140 av_extend(retval, subrv_items);
141 AvFILLp(retval) = subrv_items;
142 svp = AvARRAY(retval);
143
144 /* First entry is this class. */
145 *svp++ = newSVpvn(stashname, stashname_len);
146
147 while(subrv_items--) {
148 /* These values are unlikely to be shared hash key
149 scalars, so no point in adding code to optimising
150 for a case that is unlikely to be true.
151 (Or prove me wrong and do it.) */
152
153 SV *const val = *subrv_p++;
154 *svp++ = newSVsv(val);
155 }
156
157 SvREFCNT_dec(isa_lin);
158 SvREFCNT_inc(retval);
159
160 goto done;
161 }
bb82f0c1 162 av_push(seqs, (SV*)isa_lin);
b23e9cb9 163 }
b23e9cb9 164 }
bb82f0c1 165 av_push(seqs, SvREFCNT_inc((SV*)isa));
139e8d8c 166 tails = (HV*)sv_2mortal((SV*)newHV());
bb82f0c1 167
168 /* This builds "heads", which as an array of integer array
169 indices, one per seq, which point at the virtual "head"
170 of the seq (initially zero) */
bb82f0c1 171 Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
b23e9cb9 172
bb82f0c1 173 /* This builds %tails, which has one key for every class
174 mentioned in the tail of any sequence in @seqs (tail meaning
175 everything after the first class, the "head"). The value
176 is how many times this key appears in the tails of @seqs.
177 */
b23e9cb9 178 seqs_ptr = AvARRAY(seqs);
179 seqs_items = AvFILLp(seqs) + 1;
180 while(seqs_items--) {
bb82f0c1 181 AV* const seq = (AV*)*seqs_ptr++;
b23e9cb9 182 I32 seq_items = AvFILLp(seq);
183 if(seq_items > 0) {
184 SV** seq_ptr = AvARRAY(seq) + 1;
185 while(seq_items--) {
bb82f0c1 186 SV* const seqitem = *seq_ptr++;
3277bbc4 187 /* LVALUE fetch will create a new undefined SV if necessary
188 */
189 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
190 if(he) {
bb82f0c1 191 SV* const val = HeVAL(he);
8e1946dc 192 /* For 5.8.0 and later, sv_inc() with increment undef to
193 an IV of 1, which is what we want for a newly created
194 entry. However, for 5.6.x it will become an NV of
195 1.0, which confuses the SvIVX() checks above */
196 if(SvIOK(val)) {
197 SvIVX(val)++;
198 } else {
199 sv_setiv(val, 1);
200 }
3277bbc4 201 } else {
202 croak("failed to store value in hash");
b23e9cb9 203 }
204 }
205 }
206 }
207
bb82f0c1 208 /* Initialize retval to build the return value in */
209 retval = newAV();
210 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
211
053556af 212 /* This loop won't terminate until we either finish building
213 the MRO, or get an exception. */
b23e9cb9 214 while(1) {
b23e9cb9 215 SV* cand = NULL;
216 SV* winner = NULL;
bb82f0c1 217 int s;
218
053556af 219 /* "foreach $seq (@seqs)" */
bb82f0c1 220 SV** const avptr = AvARRAY(seqs);
221 for(s = 0; s <= AvFILLp(seqs); s++) {
b23e9cb9 222 SV** svp;
bb82f0c1 223 AV * const seq = (AV*)(avptr[s]);
224 SV* seqhead;
053556af 225 if(!seq) continue; /* skip empty seqs */
bb82f0c1 226 svp = av_fetch(seq, heads[s], 0);
053556af 227 seqhead = *svp; /* seqhead = head of this seq */
b23e9cb9 228 if(!winner) {
bb82f0c1 229 HE* tail_entry;
230 SV* val;
053556af 231 /* if we haven't found a winner for this round yet,
232 and this seqhead is not in tails (or the count
233 for it in tails has dropped to zero), then this
234 seqhead is our new winner, and is added to the
235 final MRO immediately */
b23e9cb9 236 cand = seqhead;
237 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
238 && (val = HeVAL(tail_entry))
053556af 239 && (SvIVX(val) > 0))
b23e9cb9 240 continue;
241 winner = newSVsv(cand);
242 av_push(retval, winner);
053556af 243 /* note however that even when we find a winner,
244 we continue looping over @seqs to do housekeeping */
b23e9cb9 245 }
246 if(!sv_cmp(seqhead, winner)) {
053556af 247 /* Once we have a winner (including the iteration
248 where we first found him), inc the head ptr
249 for any seq which had the winner as a head,
250 NULL out any seq which is now empty,
251 and adjust tails for consistency */
252
bb82f0c1 253 const int new_head = ++heads[s];
254 if(new_head > AvFILLp(seq)) {
255 SvREFCNT_dec(avptr[s]);
256 avptr[s] = NULL;
257 }
258 else {
259 HE* tail_entry;
260 SV* val;
261 /* Because we know this new seqhead used to be
262 a tail, we can assume it is in tails and has
263 a positive value, which we need to dec */
264 svp = av_fetch(seq, new_head, 0);
265 seqhead = *svp;
266 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
267 val = HeVAL(tail_entry);
268 sv_dec(val);
269 }
b23e9cb9 270 }
271 }
053556af 272
273 /* if we found no candidates, we are done building the MRO.
274 !cand means no seqs have any entries left to check */
bb82f0c1 275 if(!cand) {
276 Safefree(heads);
277 break;
278 }
053556af 279
280 /* If we had candidates, but nobody won, then the @ISA
281 hierarchy is not C3-incompatible */
62eb9d08 282 if(!winner) {
b6bdbb4c 283 SV *errmsg;
284 I32 i;
053556af 285 /* we have to do some cleanup before we croak */
286
b6bdbb4c 287 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
288 "current merge results [\n", stashname);
289 for (i = 0; i <= av_len(retval); i++) {
290 SV **elem = av_fetch(retval, i, 0);
291 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
292 }
293 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
294
62eb9d08 295 SvREFCNT_dec(retval);
bb82f0c1 296 Safefree(heads);
053556af 297
b6bdbb4c 298 croak("%"SVf, SVfARG(errmsg));
62eb9d08 299 }
b23e9cb9 300 }
301 }
053556af 302 else { /* @ISA was undefined or empty */
303 /* build a retval containing only ourselves */
bb82f0c1 304 retval = newAV();
053556af 305 av_push(retval, newSVpvn(stashname, stashname_len));
bb82f0c1 306 }
b23e9cb9 307
139e8d8c 308done:
053556af 309 /* we don't want anyone modifying the cache entry but us,
310 and we do so by replacing it completely */
b23e9cb9 311 SvREADONLY_on(retval);
bb82f0c1 312
313 if(!made_mortal_cache) {
314 SvREFCNT_inc(retval);
ddc85d9f 315 if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
316 croak("failed to store value in hash");
317 }
bb82f0c1 318 }
319
320 return retval;
b23e9cb9 321}
322
323STATIC I32
324__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
325 I32 i;
326 for (i = startingblock; i >= 0; i--) {
327 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
328 }
329 return i;
330}
331
2605e591 332XS(XS_Class_C3_XS_nextcan);
333XS(XS_Class_C3_XS_nextcan)
b23e9cb9 334{
2605e591 335 dVAR; dXSARGS;
336
e5e121c4 337 SV* self = ST(0);
338 const I32 throw_nomethod = SvIVX(ST(1));
5efa8a5b 339 register I32 cxix = cxstack_ix;
b23e9cb9 340 register const PERL_CONTEXT *ccstack = cxstack;
341 const PERL_SI *top_si = PL_curstackinfo;
342 HV* selfstash;
343 GV* cvgv;
344 SV *stashname;
345 const char *fq_subname;
346 const char *subname;
347 STRLEN fq_subname_len;
348 STRLEN stashname_len;
349 STRLEN subname_len;
350 SV* sv;
351 GV** gvp;
352 AV* linear_av;
353 SV** linear_svp;
b23e9cb9 354 HV* cstash;
355 GV* candidate = NULL;
356 CV* cand_cv = NULL;
357 const char *hvname;
2605e591 358 I32 entries;
6c88cc6a 359 HV* nmcache;
b23e9cb9 360 HE* cache_entry;
22c6f594 361 SV* cachekey;
54d13ec6 362 I32 i;
b23e9cb9 363
2605e591 364 SP -= items;
365
b23e9cb9 366 if(sv_isobject(self))
367 selfstash = SvSTASH(SvRV(self));
368 else
369 selfstash = gv_stashsv(self, 0);
370
371 assert(selfstash);
372
373 hvname = HvNAME(selfstash);
374 if (!hvname)
625e16df 375 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
b23e9cb9 376
b23e9cb9 377 /* This block finds the contextually-enclosing fully-qualified subname,
378 much like looking at (caller($i))[3] until you find a real sub that
5efa8a5b 379 isn't ANON, etc (also skips over pureperl next::method, etc) */
380 for(i = 0; i < 2; i++) {
381 cxix = __dopoptosub_at(ccstack, cxix);
382 for (;;) {
383 /* we may be in a higher stacklevel, so dig down deeper */
384 while (cxix < 0) {
385 if(top_si->si_type == PERLSI_MAIN)
386 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
387 top_si = top_si->si_prev;
388 ccstack = top_si->si_cxstack;
389 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
390 }
b23e9cb9 391
5efa8a5b 392 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
393 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
394 cxix = __dopoptosub_at(ccstack, cxix - 1);
395 continue;
396 }
b23e9cb9 397
5efa8a5b 398 {
399 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
400 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
401 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
402 cxix = dbcxix;
403 continue;
404 }
b23e9cb9 405 }
406 }
b23e9cb9 407
5efa8a5b 408 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
b23e9cb9 409
5efa8a5b 410 if(!isGV(cvgv)) {
411 cxix = __dopoptosub_at(ccstack, cxix - 1);
412 continue;
413 }
b23e9cb9 414
5efa8a5b 415 /* we found a real sub here */
eac662db 416 sv = sv_newmortal();
b23e9cb9 417
5efa8a5b 418 gv_efullname3(sv, cvgv, NULL);
b23e9cb9 419
a2051bf9 420 if (SvPOK(sv)) {
421 fq_subname = SvPVX(sv);
422 fq_subname_len = SvCUR(sv);
423
424 subname = strrchr(fq_subname, ':');
425 } else {
426 subname = NULL;
427 }
b23e9cb9 428
5efa8a5b 429 subname = strrchr(fq_subname, ':');
430 if(!subname)
431 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
b23e9cb9 432
5efa8a5b 433 subname++;
434 subname_len = fq_subname_len - (subname - fq_subname);
435 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
436 cxix = __dopoptosub_at(ccstack, cxix - 1);
437 continue;
438 }
439 break;
b23e9cb9 440 }
5efa8a5b 441 cxix--;
b23e9cb9 442 }
443
444 /* If we made it to here, we found our context */
445
22c6f594 446 /* cachekey = "objpkg|context::method::name" */
447 cachekey = sv_2mortal(newSVpv(hvname, 0));
448 sv_catpvn(cachekey, "|", 1);
449 sv_catsv(cachekey, sv);
b23e9cb9 450
6c88cc6a 451 nmcache = get_hv("next::METHOD_CACHE", 1);
22c6f594 452 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
b23e9cb9 453 SV* val = HeVAL(cache_entry);
454 if(val == &PL_sv_undef) {
455 if(throw_nomethod)
625e16df 456 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
2605e591 457 XSRETURN_EMPTY;
b23e9cb9 458 }
2605e591 459 XPUSHs(sv_2mortal(newRV_inc(val)));
460 XSRETURN(1);
b23e9cb9 461 }
b23e9cb9 462
463 /* beyond here is just for cache misses, so perf isn't as critical */
464
465 stashname_len = subname - fq_subname - 2;
466 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
467
62eb9d08 468 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
b23e9cb9 469
470 linear_svp = AvARRAY(linear_av);
2605e591 471 entries = AvFILLp(linear_av) + 1;
b23e9cb9 472
2605e591 473 while (entries--) {
053556af 474 SV* const linear_sv = *linear_svp++;
b23e9cb9 475 assert(linear_sv);
476 if(sv_eq(linear_sv, stashname))
477 break;
478 }
479
2605e591 480 if(entries > 0) {
29e61e10 481 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
482 HV* cc3_mro = get_hv("Class::C3::MRO", 0);
29e61e10 483
2605e591 484 while (entries--) {
053556af 485 SV* const linear_sv = *linear_svp++;
b23e9cb9 486 assert(linear_sv);
29e61e10 487
488 if(cc3_mro) {
489 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
490 if(he_cc3_mro_class) {
3499e05c 491 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
492 if(SvROK(cc3_mro_class_sv)) {
493 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
494 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
495 if(svp_cc3_mro_class_methods) {
496 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
497 if(SvROK(cc3_mro_class_methods_sv)) {
498 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
499 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
500 continue;
501 }
502 }
29e61e10 503 }
504 }
505 }
506
b23e9cb9 507 cstash = gv_stashsv(linear_sv, FALSE);
508
509 if (!cstash) {
510 if (ckWARN(WARN_MISC))
511 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
512 (void*)linear_sv, hvname);
513 continue;
514 }
515
516 assert(cstash);
517
b23e9cb9 518 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
519 if (!gvp) continue;
520
521 candidate = *gvp;
522 assert(candidate);
523
524 if (SvTYPE(candidate) != SVt_PVGV)
525 gv_init(candidate, cstash, subname, subname_len, TRUE);
526 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
62eb9d08 527 SvREFCNT_dec(linear_av);
b23e9cb9 528 SvREFCNT_inc((SV*)cand_cv);
d581cf05 529 if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
ddc85d9f 530 croak("failed to store value in hash");
531 }
2605e591 532 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
533 XSRETURN(1);
b23e9cb9 534 }
535 }
536 }
537
62eb9d08 538 SvREFCNT_dec(linear_av);
d581cf05 539 if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
ddc85d9f 540 croak("failed to store value in hash");
541 }
b23e9cb9 542 if(throw_nomethod)
625e16df 543 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
2605e591 544 XSRETURN_EMPTY;
b23e9cb9 545}
546
547XS(XS_Class_C3_XS_calculateMRO);
548XS(XS_Class_C3_XS_calculateMRO)
549{
b23e9cb9 550 dVAR; dXSARGS;
b23e9cb9 551
552 SV* classname;
553 HV* class_stash;
554 HV* cache = NULL;
555 AV* res;
556 I32 res_items;
557 I32 ret_items;
558 SV** res_ptr;
559
560 if(items < 1 || items > 2)
561 croak("Usage: calculateMRO(classname[, cache])");
562
563 classname = ST(0);
f0294f1b 564 if(items == 2) cache = (HV*)SvRV(ST(1));
b23e9cb9 565
566 class_stash = gv_stashsv(classname, 0);
625e16df 567 if(!class_stash)
568 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
b23e9cb9 569
62eb9d08 570 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
b23e9cb9 571
b23e9cb9 572 res_items = ret_items = AvFILLp(res) + 1;
573 res_ptr = AvARRAY(res);
574
575 SP -= items;
576
577 while(res_items--) {
578 SV* res_item = *res_ptr++;
62eb9d08 579 XPUSHs(sv_2mortal(newSVsv(res_item)));
b23e9cb9 580 }
62eb9d08 581 SvREFCNT_dec(res);
b23e9cb9 582
583 PUTBACK;
584
585 return;
586}
587
8feecaf9 588XS(XS_Class_C3_XS_plsubgen);
589XS(XS_Class_C3_XS_plsubgen)
590{
25dc7e96 591 dVAR; dXSARGS;
8feecaf9 592
593 SP -= items;
594 XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
595 PUTBACK;
596 return;
597}
598
625e16df 599XS(XS_Class_C3_XS_calc_mdt);
600XS(XS_Class_C3_XS_calc_mdt)
601{
625e16df 602 dVAR; dXSARGS;
625e16df 603
604 SV* classname;
605 HV* cache;
606 HV* class_stash;
607 AV* class_mro;
608 HV* our_c3mro; /* $Class::C3::MRO{classname} */
79782a49 609 SV* has_ovf = NULL;
625e16df 610 HV* methods;
611 I32 mroitems;
612
613 /* temps */
614 HV* hv;
615 HE* he;
625e16df 616 SV** svp;
617
618 if(items < 1 || items > 2)
619 croak("Usage: calculate_method_dispatch_table(classname[, cache])");
620
621 classname = ST(0);
622 class_stash = gv_stashsv(classname, 0);
623 if(!class_stash)
624 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
625
626 if(items == 2) cache = (HV*)SvRV(ST(1));
627
628 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
629
630 our_c3mro = newHV();
ddc85d9f 631 if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
632 croak("failed to store value in hash");
633 }
625e16df 634
635 hv = get_hv("Class::C3::MRO", 1);
ddc85d9f 636 if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
637 croak("failed to store value in hash");
638 }
625e16df 639
640 methods = newHV();
641
642 /* skip first entry */
643 mroitems = AvFILLp(class_mro);
644 svp = AvARRAY(class_mro) + 1;
645 while(mroitems--) {
646 SV* mro_class = *svp++;
647 HV* mro_stash = gv_stashsv(mro_class, 0);
648
649 if(!mro_stash) continue;
650
79782a49 651 if(!has_ovf) {
625e16df 652 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
653 if(ovfp) has_ovf = *ovfp;
79782a49 654 }
625e16df 655
656 hv_iterinit(mro_stash);
ad2debb2 657 while((he = hv_iternext(mro_stash))) {
625e16df 658 CV* code;
659 SV* mskey;
79782a49 660 SV* msval;
661 HE* ourent;
662 HV* meth_hash;
663 SV* orig;
625e16df 664
665 mskey = hv_iterkeysv(he);
666 if(hv_exists_ent(methods, mskey, 0)) continue;
79782a49 667
668 msval = hv_iterval(mro_stash, he);
669 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
670 continue;
671
672 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
673 SV* val = HeVAL(ourent);
674 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
625e16df 675 continue;
676 }
677
79782a49 678 meth_hash = newHV();
679 orig = newSVsv(mro_class);
680 sv_catpvn(orig, "::", 2);
681 sv_catsv(orig, mskey);
ddc85d9f 682 if( !hv_store(meth_hash, "orig", 4, orig, 0)
683 || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
684 || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
685 croak("failed to store value in hash");
686 }
625e16df 687 }
688 }
689
ddc85d9f 690 if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
691 croak("failed to store value in hash");
692 }
693 if(has_ovf) {
694 if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
695 croak("failed to store value in hash");
696 }
697 }
625e16df 698 XSRETURN_EMPTY;
699}
700
6ed110b7 701MODULE = Class::C3::XS PACKAGE = Class::C3::XS
b23e9cb9 702
df0af0e2 703PROTOTYPES: DISABLED
704
b23e9cb9 705BOOT:
706 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
8feecaf9 707 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
625e16df 708 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
2605e591 709 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
625e16df 710
XS speedups for Class::C3 - now lives at https://github.com/moose/Class-C3-XS