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