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