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