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