1#define PERL_NO_GET_CONTEXT 2 3#include "EXTERN.h" 4#include "perl.h" 5#include "XSUB.h" 6 7static AV* 8S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level); 9 10static 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 16Returns the C3 linearization of C<@ISA> 17the given stash. The return value is a read-only AV* 18whose values are string SVs giving class names. 19C<level> should be 0 (it is used internally in this 20function's recursion). 21 22You are responsible for C<SvREFCNT_inc()> on the 23return value if you plan to store it anywhere 24semi-permanently (otherwise it might be deleted 25out from under you the next time the cache is 26invalidated). 27 28=cut 29*/ 30 31static AV* 32S_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 = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); 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(); 93 av_push(isa_lin, newSVsv(isa_item)); 94 av_push(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(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin))); 139 } 140 } 141 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa))); 142 tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); 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(); 175 av_push(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(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(); 273 av_push(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 291static I32 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 300MODULE = mro PACKAGE = mro PREFIX = mro_ 301 302void 303mro_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(); 319 av_push(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 336void 337mro_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 356void 357mro_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 379void 380mro_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(ret_array, newSVsv(hv_iterkeysv(iter))); 402 } 403 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); 404 405 PUTBACK; 406 407void 408mro_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 434void 435mro_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 445void 446mro_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 463void 464mro__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 = sv_newmortal(); 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 667BOOT: 668 Perl_mro_register(aTHX_ &c3_alg); 669