This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restore full name of mro::mro_invalidate_all_method_caches.
[perl5.git] / ext / mro / mro.xs
CommitLineData
b2685f0c
NC
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
5static AV*
6S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
7
8static const struct mro_alg c3_alg =
9 {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
10
11/*
12=for apidoc mro_get_linear_isa_c3
13
14Returns the C3 linearization of @ISA
15the given stash. The return value is a read-only AV*.
16C<level> should be 0 (it is used internally in this
17function's recursion).
18
19You are responsible for C<SvREFCNT_inc()> on the
20return value if you plan to store it anywhere
21semi-permanently (otherwise it might be deleted
22out from under you the next time the cache is
23invalidated).
24
25=cut
26*/
27
28static AV*
29S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
30{
31 AV* retval;
32 GV** gvp;
33 GV* gv;
34 AV* isa;
35 const HEK* stashhek;
36 struct mro_meta* meta;
37
38 assert(HvAUX(stash));
39
40 stashhek = HvNAME_HEK(stash);
41 if (!stashhek)
42 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
43
44 if (level > 100)
45 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
46 HEK_KEY(stashhek));
47
48 meta = HvMROMETA(stash);
49
50 /* return cache if valid */
51 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
52 return retval;
53 }
54
55 /* not in cache, make a new one */
56
57 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
58 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
59
60 /* For a better idea how the rest of this works, see the much clearer
61 pure perl version in Algorithm::C3 0.01:
62 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
63 (later versions go about it differently than this code for speed reasons)
64 */
65
66 if(isa && AvFILLp(isa) >= 0) {
67 SV** seqs_ptr;
68 I32 seqs_items;
69 HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
70 AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
71 I32* heads;
72
73 /* This builds @seqs, which is an array of arrays.
74 The members of @seqs are the MROs of
75 the members of @ISA, followed by @ISA itself.
76 */
77 I32 items = AvFILLp(isa) + 1;
78 SV** isa_ptr = AvARRAY(isa);
79 while(items--) {
80 SV* const isa_item = *isa_ptr++;
81 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
82 if(!isa_item_stash) {
83 /* if no stash, make a temporary fake MRO
84 containing just itself */
85 AV* const isa_lin = newAV();
86 av_push(isa_lin, newSVsv(isa_item));
87 av_push(seqs, MUTABLE_SV(isa_lin));
88 }
89 else {
90 /* recursion */
91 AV* const isa_lin
92 = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
93 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
94 }
95 }
96 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
97
98 /* This builds "heads", which as an array of integer array
99 indices, one per seq, which point at the virtual "head"
100 of the seq (initially zero) */
101 Newxz(heads, AvFILLp(seqs)+1, I32);
102
103 /* This builds %tails, which has one key for every class
104 mentioned in the tail of any sequence in @seqs (tail meaning
105 everything after the first class, the "head"). The value
106 is how many times this key appears in the tails of @seqs.
107 */
108 seqs_ptr = AvARRAY(seqs);
109 seqs_items = AvFILLp(seqs) + 1;
110 while(seqs_items--) {
111 AV *const seq = MUTABLE_AV(*seqs_ptr++);
112 I32 seq_items = AvFILLp(seq);
113 if(seq_items > 0) {
114 SV** seq_ptr = AvARRAY(seq) + 1;
115 while(seq_items--) {
116 SV* const seqitem = *seq_ptr++;
117 /* LVALUE fetch will create a new undefined SV if necessary
118 */
119 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
120 if(he) {
121 SV* const val = HeVAL(he);
122 /* This will increment undef to 1, which is what we
123 want for a newly created entry. */
124 sv_inc(val);
125 }
126 }
127 }
128 }
129
130 /* Initialize retval to build the return value in */
131 retval = newAV();
132 av_push(retval, newSVhek(stashhek)); /* us first */
133
134 /* This loop won't terminate until we either finish building
135 the MRO, or get an exception. */
136 while(1) {
137 SV* cand = NULL;
138 SV* winner = NULL;
139 int s;
140
141 /* "foreach $seq (@seqs)" */
142 SV** const avptr = AvARRAY(seqs);
143 for(s = 0; s <= AvFILLp(seqs); s++) {
144 SV** svp;
145 AV * const seq = MUTABLE_AV(avptr[s]);
146 SV* seqhead;
147 if(!seq) continue; /* skip empty seqs */
148 svp = av_fetch(seq, heads[s], 0);
149 seqhead = *svp; /* seqhead = head of this seq */
150 if(!winner) {
151 HE* tail_entry;
152 SV* val;
153 /* if we haven't found a winner for this round yet,
154 and this seqhead is not in tails (or the count
155 for it in tails has dropped to zero), then this
156 seqhead is our new winner, and is added to the
157 final MRO immediately */
158 cand = seqhead;
159 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
160 && (val = HeVAL(tail_entry))
161 && (SvIVX(val) > 0))
162 continue;
163 winner = newSVsv(cand);
164 av_push(retval, winner);
165 /* note however that even when we find a winner,
166 we continue looping over @seqs to do housekeeping */
167 }
168 if(!sv_cmp(seqhead, winner)) {
169 /* Once we have a winner (including the iteration
170 where we first found him), inc the head ptr
171 for any seq which had the winner as a head,
172 NULL out any seq which is now empty,
173 and adjust tails for consistency */
174
175 const int new_head = ++heads[s];
176 if(new_head > AvFILLp(seq)) {
177 SvREFCNT_dec(avptr[s]);
178 avptr[s] = NULL;
179 }
180 else {
181 HE* tail_entry;
182 SV* val;
183 /* Because we know this new seqhead used to be
184 a tail, we can assume it is in tails and has
185 a positive value, which we need to dec */
186 svp = av_fetch(seq, new_head, 0);
187 seqhead = *svp;
188 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
189 val = HeVAL(tail_entry);
190 sv_dec(val);
191 }
192 }
193 }
194
195 /* if we found no candidates, we are done building the MRO.
196 !cand means no seqs have any entries left to check */
197 if(!cand) {
198 Safefree(heads);
199 break;
200 }
201
202 /* If we had candidates, but nobody won, then the @ISA
203 hierarchy is not C3-incompatible */
204 if(!winner) {
b1172053
FR
205 SV *errmsg;
206 I32 i;
207
208 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
209 "current merge results [\n", HEK_KEY(stashhek));
210 for (i = 0; i <= av_len(retval); i++) {
211 SV **elem = av_fetch(retval, i, 0);
212 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
213 }
214 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
215
b2685f0c
NC
216 /* we have to do some cleanup before we croak */
217
218 SvREFCNT_dec(retval);
219 Safefree(heads);
220
b1172053 221 Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
b2685f0c
NC
222 }
223 }
224 }
225 else { /* @ISA was undefined or empty */
226 /* build a retval containing only ourselves */
227 retval = newAV();
228 av_push(retval, newSVhek(stashhek));
229 }
230
231 /* we don't want anyone modifying the cache entry but us,
232 and we do so by replacing it completely */
233 SvREADONLY_on(retval);
234
235 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
236 MUTABLE_SV(retval)));
b2685f0c
NC
237}
238
239
240/* These two are static helpers for next::method and friends,
241 and re-implement a bunch of the code from pp_caller() in
242 a more efficient manner for this particular usage.
243*/
244
245static I32
246__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
247 I32 i;
248 for (i = startingblock; i >= 0; i--) {
249 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
250 }
251 return i;
252}
253
1e9bd118 254MODULE = mro PACKAGE = mro PREFIX = mro_
b2685f0c
NC
255
256void
1e9bd118
NC
257mro_get_linear_isa(...)
258 PROTOTYPE: $;$
259 PREINIT:
260 AV* RETVAL;
261 HV* class_stash;
262 SV* classname;
263 PPCODE:
264 if(items < 1 || items > 2)
265 croak_xs_usage(cv, "classname [, type ]");
266
267 classname = ST(0);
268 class_stash = gv_stashsv(classname, 0);
269
270 if(!class_stash) {
271 /* No stash exists yet, give them just the classname */
272 AV* isalin = newAV();
273 av_push(isalin, newSVsv(classname));
274 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
275 XSRETURN(1);
276 }
277 else if(items > 1) {
278 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
279 if (!algo)
280 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
281 RETVAL = algo->resolve(aTHX_ class_stash, 0);
282 }
283 else {
284 RETVAL = mro_get_linear_isa(class_stash);
285 }
286 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
287 sv_2mortal(ST(0));
288 XSRETURN(1);
289
290void
291mro_set_mro(...)
292 PROTOTYPE: $$
293 PREINIT:
294 SV* classname;
1e9bd118
NC
295 HV* class_stash;
296 struct mro_meta* meta;
297 PPCODE:
298 if (items != 2)
299 croak_xs_usage(cv, "classname, type");
300
301 classname = ST(0);
302 class_stash = gv_stashsv(classname, GV_ADD);
303 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
304 meta = HvMROMETA(class_stash);
305
306 Perl_mro_set_mro(aTHX_ meta, ST(1));
307
308 XSRETURN_EMPTY;
309
310void
311mro_get_mro(...)
312 PROTOTYPE: $
313 PREINIT:
314 SV* classname;
315 HV* class_stash;
316 PPCODE:
317 if (items != 1)
318 croak_xs_usage(cv, "classname");
319
320 classname = ST(0);
321 class_stash = gv_stashsv(classname, 0);
322
fbb5a95c
NC
323 if (class_stash) {
324 const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
325 ST(0) = newSVpvn_flags(meta->name, meta->length,
326 SVs_TEMP
327 | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
328 } else {
329 ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
330 }
1e9bd118
NC
331 XSRETURN(1);
332
333void
334mro_get_isarev(...)
335 PROTOTYPE: $
336 PREINIT:
337 SV* classname;
338 HE* he;
339 HV* isarev;
340 AV* ret_array;
341 PPCODE:
342 if (items != 1)
343 croak_xs_usage(cv, "classname");
344
345 classname = ST(0);
346
347 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
348 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
349
350 ret_array = newAV();
351 if(isarev) {
352 HE* iter;
353 hv_iterinit(isarev);
354 while((iter = hv_iternext(isarev)))
355 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
356 }
357 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
358
359 PUTBACK;
360
361void
362mro_is_universal(...)
363 PROTOTYPE: $
364 PREINIT:
365 SV* classname;
366 HV* isarev;
367 char* classname_pv;
368 STRLEN classname_len;
369 HE* he;
370 PPCODE:
371 if (items != 1)
372 croak_xs_usage(cv, "classname");
373
374 classname = ST(0);
375
376 classname_pv = SvPV(classname,classname_len);
377
378 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
379 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
380
381 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
382 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
383 XSRETURN_YES;
384 else
385 XSRETURN_NO;
386
387
388void
a4133167 389mro_invalidate_all_method_caches(...)
1e9bd118
NC
390 PROTOTYPE:
391 PPCODE:
392 if (items != 0)
393 croak_xs_usage(cv, "");
394
395 PL_sub_generation++;
396
397 XSRETURN_EMPTY;
398
399void
400mro_get_pkg_gen(...)
401 PROTOTYPE: $
402 PREINIT:
403 SV* classname;
404 HV* class_stash;
405 PPCODE:
406 if(items != 1)
407 croak_xs_usage(cv, "classname");
408
409 classname = ST(0);
410
411 class_stash = gv_stashsv(classname, 0);
412
413 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
414
415 PUTBACK;
416
417void
418mro__nextcan(...)
b2685f0c
NC
419 PREINIT:
420 SV* self = ST(0);
421 const I32 throw_nomethod = SvIVX(ST(1));
422 register I32 cxix = cxstack_ix;
423 register const PERL_CONTEXT *ccstack = cxstack;
424 const PERL_SI *top_si = PL_curstackinfo;
425 HV* selfstash;
426 SV *stashname;
427 const char *fq_subname;
428 const char *subname;
429 STRLEN stashname_len;
430 STRLEN subname_len;
431 SV* sv;
432 GV** gvp;
433 AV* linear_av;
434 SV** linear_svp;
435 const char *hvname;
436 I32 entries;
437 struct mro_meta* selfmeta;
438 HV* nmcache;
439 I32 i;
440 PPCODE:
441 PERL_UNUSED_ARG(cv);
442
443 if(sv_isobject(self))
444 selfstash = SvSTASH(SvRV(self));
445 else
446 selfstash = gv_stashsv(self, GV_ADD);
447
448 assert(selfstash);
449
450 hvname = HvNAME_get(selfstash);
451 if (!hvname)
452 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
453
454 /* This block finds the contextually-enclosing fully-qualified subname,
455 much like looking at (caller($i))[3] until you find a real sub that
456 isn't ANON, etc (also skips over pureperl next::method, etc) */
457 for(i = 0; i < 2; i++) {
458 cxix = __dopoptosub_at(ccstack, cxix);
459 for (;;) {
460 GV* cvgv;
461 STRLEN fq_subname_len;
462
463 /* we may be in a higher stacklevel, so dig down deeper */
464 while (cxix < 0) {
465 if(top_si->si_type == PERLSI_MAIN)
466 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
467 top_si = top_si->si_prev;
468 ccstack = top_si->si_cxstack;
469 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
470 }
471
472 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
473 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
474 cxix = __dopoptosub_at(ccstack, cxix - 1);
475 continue;
476 }
477
478 {
479 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
480 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
481 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
482 cxix = dbcxix;
483 continue;
484 }
485 }
486 }
487
488 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
489
490 if(!isGV(cvgv)) {
491 cxix = __dopoptosub_at(ccstack, cxix - 1);
492 continue;
493 }
494
495 /* we found a real sub here */
496 sv = sv_2mortal(newSV(0));
497
498 gv_efullname3(sv, cvgv, NULL);
499
500 fq_subname = SvPVX(sv);
501 fq_subname_len = SvCUR(sv);
502
503 subname = strrchr(fq_subname, ':');
504 if(!subname)
505 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
506
507 subname++;
508 subname_len = fq_subname_len - (subname - fq_subname);
509 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
510 cxix = __dopoptosub_at(ccstack, cxix - 1);
511 continue;
512 }
513 break;
514 }
515 cxix--;
516 }
517
518 /* If we made it to here, we found our context */
519
520 /* Initialize the next::method cache for this stash
521 if necessary */
522 selfmeta = HvMROMETA(selfstash);
523 if(!(nmcache = selfmeta->mro_nextmethod)) {
524 nmcache = selfmeta->mro_nextmethod = newHV();
525 }
526 else { /* Use the cached coderef if it exists */
527 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
528 if (cache_entry) {
529 SV* const val = HeVAL(cache_entry);
530 if(val == &PL_sv_undef) {
531 if(throw_nomethod)
532 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
533 XSRETURN_EMPTY;
534 }
535 mXPUSHs(newRV_inc(val));
536 XSRETURN(1);
537 }
538 }
539
540 /* beyond here is just for cache misses, so perf isn't as critical */
541
542 stashname_len = subname - fq_subname - 2;
543 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
544
545 /* has ourselves at the top of the list */
546 linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
547
548 linear_svp = AvARRAY(linear_av);
549 entries = AvFILLp(linear_av) + 1;
550
551 /* Walk down our MRO, skipping everything up
552 to the contextually enclosing class */
553 while (entries--) {
554 SV * const linear_sv = *linear_svp++;
555 assert(linear_sv);
556 if(sv_eq(linear_sv, stashname))
557 break;
558 }
559
560 /* Now search the remainder of the MRO for the
561 same method name as the contextually enclosing
562 method */
563 if(entries > 0) {
564 while (entries--) {
565 SV * const linear_sv = *linear_svp++;
566 HV* curstash;
567 GV* candidate;
568 CV* cand_cv;
569
570 assert(linear_sv);
571 curstash = gv_stashsv(linear_sv, FALSE);
572
573 if (!curstash) {
574 if (ckWARN(WARN_SYNTAX))
575 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
576 (void*)linear_sv, hvname);
577 continue;
578 }
579
580 assert(curstash);
581
582 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
583 if (!gvp) continue;
584
585 candidate = *gvp;
586 assert(candidate);
587
588 if (SvTYPE(candidate) != SVt_PVGV)
589 gv_init(candidate, curstash, subname, subname_len, TRUE);
590
591 /* Notably, we only look for real entries, not method cache
592 entries, because in C3 the method cache of a parent is not
593 valid for the child */
594 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
595 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
596 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
597 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
598 XSRETURN(1);
599 }
600 }
601 }
602
603 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
604 if(throw_nomethod)
605 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
606 XSRETURN_EMPTY;
607
608BOOT:
609 Perl_mro_register(aTHX_ &c3_alg);