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 @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* 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 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((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) 435 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) 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; 481 const char *subname; 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(subname_len == 8 && strEQ(subname, "__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