1 2#include "EXTERN.h" 3#include "perl.h" 4#include "XSUB.h" 5 6/* *********** ppport stuff */ 7 8#ifndef PERL_UNUSED_VAR 9# define PERL_UNUSED_VAR(x) ((void)x) 10#endif 11 12#if defined(PERL_GCC_PEDANTIC) 13# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN 14# define PERL_GCC_BRACE_GROUPS_FORBIDDEN 15# endif 16#endif 17 18#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) 19# ifndef PERL_USE_GCC_BRACE_GROUPS 20# define PERL_USE_GCC_BRACE_GROUPS 21# endif 22#endif 23 24#ifndef SvREFCNT_inc 25# ifdef PERL_USE_GCC_BRACE_GROUPS 26# define SvREFCNT_inc(sv) \ 27 ({ \ 28 SV * const _sv = (SV*)(sv); \ 29 if (_sv) \ 30 (SvREFCNT(_sv))++; \ 31 _sv; \ 32 }) 33# else 34# define SvREFCNT_inc(sv) \ 35 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) 36# endif 37#endif 38 39#ifndef dAX 40# define dAX I32 ax = MARK - PL_stack_base + 1 41#endif 42 43#ifndef dVAR 44# define dVAR dNOOP 45#endif 46 47#ifndef packWARN 48# define packWARN(a) (a) 49#endif 50 51/* *********** end ppport.h stuff */ 52 53/* Most of this code is backported from the bleadperl patch's 54 mro.c, and then modified to work with Class::C3's 55 internals. 56*/ 57 58AV* 59__mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) 60{ 61 AV* retval; 62 GV** gvp; 63 GV* gv; 64 AV* isa; 65 const char* stashname; 66 STRLEN stashname_len; 67 I32 made_mortal_cache = 0; 68 69 assert(stash); 70 71 stashname = HvNAME(stash); 72 stashname_len = strlen(stashname); 73 if (!stashname) 74 Perl_croak(aTHX_ 75 "Can't linearize anonymous symbol table"); 76 77 if (level > 100) 78 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", 79 stashname); 80 81 if(!cache) { 82 cache = (HV*)sv_2mortal((SV*)newHV()); 83 made_mortal_cache = 1; 84 } 85 else { 86 SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0); 87 if(cache_entry) 88 return (AV*)SvREFCNT_inc(*cache_entry); 89 } 90 91 /* not in cache, make a new one */ 92 93 gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); 94 isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; 95 if(isa && AvFILLp(isa) >= 0) { 96 SV** seqs_ptr; 97 I32 seqs_items; 98 HV* const tails = (HV*)sv_2mortal((SV*)newHV()); 99 AV* const seqs = (AV*)sv_2mortal((SV*)newAV()); 100 I32* heads; 101 102 /* This builds @seqs, which is an array of arrays. 103 The members of @seqs are the MROs of 104 the members of @ISA, followed by @ISA itself. 105 */ 106 I32 items = AvFILLp(isa) + 1; 107 SV** isa_ptr = AvARRAY(isa); 108 while(items--) { 109 SV* const isa_item = *isa_ptr++; 110 HV* const isa_item_stash = gv_stashsv(isa_item, 0); 111 if(!isa_item_stash) { 112 /* if no stash, make a temporary fake MRO 113 containing just itself */ 114 AV* const isa_lin = newAV(); 115 av_push(isa_lin, newSVsv(isa_item)); 116 av_push(seqs, (SV*)isa_lin); 117 } 118 else { 119 /* recursion */ 120 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1); 121 av_push(seqs, (SV*)isa_lin); 122 } 123 } 124 av_push(seqs, SvREFCNT_inc((SV*)isa)); 125 126 /* This builds "heads", which as an array of integer array 127 indices, one per seq, which point at the virtual "head" 128 of the seq (initially zero) */ 129 Newz(0xdead, heads, AvFILLp(seqs)+1, I32); 130 131 /* This builds %tails, which has one key for every class 132 mentioned in the tail of any sequence in @seqs (tail meaning 133 everything after the first class, the "head"). The value 134 is how many times this key appears in the tails of @seqs. 135 */ 136 seqs_ptr = AvARRAY(seqs); 137 seqs_items = AvFILLp(seqs) + 1; 138 while(seqs_items--) { 139 AV* const seq = (AV*)*seqs_ptr++; 140 I32 seq_items = AvFILLp(seq); 141 if(seq_items > 0) { 142 SV** seq_ptr = AvARRAY(seq) + 1; 143 while(seq_items--) { 144 SV* const seqitem = *seq_ptr++; 145 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0); 146 if(!he) { 147 hv_store_ent(tails, seqitem, newSViv(1), 0); 148 } 149 else { 150 SV* const val = HeVAL(he); 151 sv_inc(val); 152 } 153 } 154 } 155 } 156 157 /* Initialize retval to build the return value in */ 158 retval = newAV(); 159 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ 160 161 /* This loop won't terminate until we either finish building 162 the MRO, or get an exception. */ 163 while(1) { 164 SV* cand = NULL; 165 SV* winner = NULL; 166 int s; 167 168 /* "foreach $seq (@seqs)" */ 169 SV** const avptr = AvARRAY(seqs); 170 for(s = 0; s <= AvFILLp(seqs); s++) { 171 SV** svp; 172 AV * const seq = (AV*)(avptr[s]); 173 SV* seqhead; 174 if(!seq) continue; /* skip empty seqs */ 175 svp = av_fetch(seq, heads[s], 0); 176 seqhead = *svp; /* seqhead = head of this seq */ 177 if(!winner) { 178 HE* tail_entry; 179 SV* val; 180 /* if we haven't found a winner for this round yet, 181 and this seqhead is not in tails (or the count 182 for it in tails has dropped to zero), then this 183 seqhead is our new winner, and is added to the 184 final MRO immediately */ 185 cand = seqhead; 186 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) 187 && (val = HeVAL(tail_entry)) 188 && (SvIVX(val) > 0)) 189 continue; 190 winner = newSVsv(cand); 191 av_push(retval, winner); 192 /* note however that even when we find a winner, 193 we continue looping over @seqs to do housekeeping */ 194 } 195 if(!sv_cmp(seqhead, winner)) { 196 /* Once we have a winner (including the iteration 197 where we first found him), inc the head ptr 198 for any seq which had the winner as a head, 199 NULL out any seq which is now empty, 200 and adjust tails for consistency */ 201 202 const int new_head = ++heads[s]; 203 if(new_head > AvFILLp(seq)) { 204 SvREFCNT_dec(avptr[s]); 205 avptr[s] = NULL; 206 } 207 else { 208 HE* tail_entry; 209 SV* val; 210 /* Because we know this new seqhead used to be 211 a tail, we can assume it is in tails and has 212 a positive value, which we need to dec */ 213 svp = av_fetch(seq, new_head, 0); 214 seqhead = *svp; 215 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); 216 val = HeVAL(tail_entry); 217 sv_dec(val); 218 } 219 } 220 } 221 222 /* if we found no candidates, we are done building the MRO. 223 !cand means no seqs have any entries left to check */ 224 if(!cand) { 225 Safefree(heads); 226 break; 227 } 228 229 /* If we had candidates, but nobody won, then the @ISA 230 hierarchy is not C3-incompatible */ 231 if(!winner) { 232 /* we have to do some cleanup before we croak */ 233 234 SvREFCNT_dec(retval); 235 Safefree(heads); 236 237 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': " 238 "merging failed on parent '%s'", stashname, SvPV_nolen(cand)); 239 } 240 } 241 } 242 else { /* @ISA was undefined or empty */ 243 /* build a retval containing only ourselves */ 244 retval = newAV(); 245 av_push(retval, newSVpvn(stashname, stashname_len)); 246 } 247 248 /* we don't want anyone modifying the cache entry but us, 249 and we do so by replacing it completely */ 250 SvREADONLY_on(retval); 251 252 if(!made_mortal_cache) { 253 SvREFCNT_inc(retval); 254 hv_store(cache, stashname, stashname_len, (SV*)retval, 0); 255 } 256 257 return retval; 258} 259 260STATIC I32 261__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { 262 I32 i; 263 for (i = startingblock; i >= 0; i--) { 264 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i; 265 } 266 return i; 267} 268 269XS(XS_Class_C3_XS_nextcan); 270XS(XS_Class_C3_XS_nextcan) 271{ 272 dVAR; dXSARGS; 273 274 SV* self = ST(0); 275 const I32 throw_nomethod = SvIVX(ST(1)); 276 register I32 cxix = cxstack_ix; 277 register const PERL_CONTEXT *ccstack = cxstack; 278 const PERL_SI *top_si = PL_curstackinfo; 279 HV* selfstash; 280 GV* cvgv; 281 SV *stashname; 282 const char *fq_subname; 283 const char *subname; 284 STRLEN fq_subname_len; 285 STRLEN stashname_len; 286 STRLEN subname_len; 287 SV* sv; 288 GV** gvp; 289 AV* linear_av; 290 SV** linear_svp; 291 HV* cstash; 292 GV* candidate = NULL; 293 CV* cand_cv = NULL; 294 const char *hvname; 295 I32 entries; 296 HV* nmcache; 297 HE* cache_entry; 298 SV* cachekey; 299 int i; 300 301 SP -= items; 302 303 if(sv_isobject(self)) 304 selfstash = SvSTASH(SvRV(self)); 305 else 306 selfstash = gv_stashsv(self, 0); 307 308 assert(selfstash); 309 310 hvname = HvNAME(selfstash); 311 if (!hvname) 312 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); 313 314 /* This block finds the contextually-enclosing fully-qualified subname, 315 much like looking at (caller($i))[3] until you find a real sub that 316 isn't ANON, etc (also skips over pureperl next::method, etc) */ 317 for(i = 0; i < 2; i++) { 318 cxix = __dopoptosub_at(ccstack, cxix); 319 for (;;) { 320 /* we may be in a higher stacklevel, so dig down deeper */ 321 while (cxix < 0) { 322 if(top_si->si_type == PERLSI_MAIN) 323 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); 324 top_si = top_si->si_prev; 325 ccstack = top_si->si_cxstack; 326 cxix = __dopoptosub_at(ccstack, top_si->si_cxix); 327 } 328 329 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB 330 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { 331 cxix = __dopoptosub_at(ccstack, cxix - 1); 332 continue; 333 } 334 335 { 336 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); 337 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { 338 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { 339 cxix = dbcxix; 340 continue; 341 } 342 } 343 } 344 345 cvgv = CvGV(ccstack[cxix].blk_sub.cv); 346 347 if(!isGV(cvgv)) { 348 cxix = __dopoptosub_at(ccstack, cxix - 1); 349 continue; 350 } 351 352 /* we found a real sub here */ 353 sv = sv_2mortal(newSV(0)); 354 355 gv_efullname3(sv, cvgv, NULL); 356 357 fq_subname = SvPVX(sv); 358 fq_subname_len = SvCUR(sv); 359 360 subname = strrchr(fq_subname, ':'); 361 if(!subname) 362 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); 363 364 subname++; 365 subname_len = fq_subname_len - (subname - fq_subname); 366 if(subname_len == 8 && strEQ(subname, "__ANON__")) { 367 cxix = __dopoptosub_at(ccstack, cxix - 1); 368 continue; 369 } 370 break; 371 } 372 cxix--; 373 } 374 375 /* If we made it to here, we found our context */ 376 377 /* cachekey = "objpkg|context::method::name" */ 378 cachekey = sv_2mortal(newSVpv(hvname, 0)); 379 sv_catpvn(cachekey, "|", 1); 380 sv_catsv(cachekey, sv); 381 382 nmcache = get_hv("next::METHOD_CACHE", 1); 383 if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) { 384 SV* val = HeVAL(cache_entry); 385 if(val == &PL_sv_undef) { 386 if(throw_nomethod) 387 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); 388 XSRETURN_EMPTY; 389 } 390 XPUSHs(sv_2mortal(newRV_inc(val))); 391 XSRETURN(1); 392 } 393 394 /* beyond here is just for cache misses, so perf isn't as critical */ 395 396 stashname_len = subname - fq_subname - 2; 397 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); 398 399 linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0); 400 401 linear_svp = AvARRAY(linear_av); 402 entries = AvFILLp(linear_av) + 1; 403 404 while (entries--) { 405 SV* const linear_sv = *linear_svp++; 406 assert(linear_sv); 407 if(sv_eq(linear_sv, stashname)) 408 break; 409 } 410 411 if(entries > 0) { 412 SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len)); 413 HV* cc3_mro = get_hv("Class::C3::MRO", 0); 414 415 while (entries--) { 416 SV* const linear_sv = *linear_svp++; 417 assert(linear_sv); 418 419 if(cc3_mro) { 420 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0); 421 if(he_cc3_mro_class) { 422 SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class); 423 if(SvROK(cc3_mro_class_sv)) { 424 HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv); 425 SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0); 426 if(svp_cc3_mro_class_methods) { 427 SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods; 428 if(SvROK(cc3_mro_class_methods_sv)) { 429 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv); 430 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0)) 431 continue; 432 } 433 } 434 } 435 } 436 } 437 438 cstash = gv_stashsv(linear_sv, FALSE); 439 440 if (!cstash) { 441 if (ckWARN(WARN_MISC)) 442 Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", 443 (void*)linear_sv, hvname); 444 continue; 445 } 446 447 assert(cstash); 448 449 gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0); 450 if (!gvp) continue; 451 452 candidate = *gvp; 453 assert(candidate); 454 455 if (SvTYPE(candidate) != SVt_PVGV) 456 gv_init(candidate, cstash, subname, subname_len, TRUE); 457 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { 458 SvREFCNT_dec(linear_av); 459 SvREFCNT_inc((SV*)cand_cv); 460 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0); 461 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); 462 XSRETURN(1); 463 } 464 } 465 } 466 467 SvREFCNT_dec(linear_av); 468 hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0); 469 if(throw_nomethod) 470 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); 471 XSRETURN_EMPTY; 472} 473 474XS(XS_Class_C3_XS_calculateMRO); 475XS(XS_Class_C3_XS_calculateMRO) 476{ 477 dVAR; dXSARGS; 478 479 SV* classname; 480 HV* class_stash; 481 HV* cache = NULL; 482 AV* res; 483 I32 res_items; 484 I32 ret_items; 485 SV** res_ptr; 486 487 if(items < 1 || items > 2) 488 croak("Usage: calculateMRO(classname[, cache])"); 489 490 classname = ST(0); 491 if(items == 2) cache = (HV*)SvRV(ST(1)); 492 493 class_stash = gv_stashsv(classname, 0); 494 if(!class_stash) 495 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); 496 497 res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); 498 499 res_items = ret_items = AvFILLp(res) + 1; 500 res_ptr = AvARRAY(res); 501 502 SP -= items; 503 504 while(res_items--) { 505 SV* res_item = *res_ptr++; 506 XPUSHs(sv_2mortal(newSVsv(res_item))); 507 } 508 SvREFCNT_dec(res); 509 510 PUTBACK; 511 512 return; 513} 514 515XS(XS_Class_C3_XS_plsubgen); 516XS(XS_Class_C3_XS_plsubgen) 517{ 518 dVAR; dXSARGS; 519 520 SP -= items; 521 XPUSHs(sv_2mortal(newSViv(PL_sub_generation))); 522 PUTBACK; 523 return; 524} 525 526XS(XS_Class_C3_XS_calc_mdt); 527XS(XS_Class_C3_XS_calc_mdt) 528{ 529 dVAR; dXSARGS; 530 531 SV* classname; 532 HV* cache; 533 HV* class_stash; 534 AV* class_mro; 535 HV* our_c3mro; /* $Class::C3::MRO{classname} */ 536 SV* has_ovf = NULL; 537 HV* methods; 538 I32 mroitems; 539 540 /* temps */ 541 HV* hv; 542 HE* he; 543 SV** svp; 544 545 if(items < 1 || items > 2) 546 croak("Usage: calculate_method_dispatch_table(classname[, cache])"); 547 548 classname = ST(0); 549 class_stash = gv_stashsv(classname, 0); 550 if(!class_stash) 551 Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); 552 553 if(items == 2) cache = (HV*)SvRV(ST(1)); 554 555 class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); 556 557 our_c3mro = newHV(); 558 hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0); 559 560 hv = get_hv("Class::C3::MRO", 1); 561 hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0); 562 563 methods = newHV(); 564 565 /* skip first entry */ 566 mroitems = AvFILLp(class_mro); 567 svp = AvARRAY(class_mro) + 1; 568 while(mroitems--) { 569 SV* mro_class = *svp++; 570 HV* mro_stash = gv_stashsv(mro_class, 0); 571 572 if(!mro_stash) continue; 573 574 if(!has_ovf) { 575 SV** ovfp = hv_fetch(mro_stash, "()", 2, 0); 576 if(ovfp) has_ovf = *ovfp; 577 } 578 579 hv_iterinit(mro_stash); 580 while(he = hv_iternext(mro_stash)) { 581 CV* code; 582 SV* mskey; 583 SV* msval; 584 HE* ourent; 585 HV* meth_hash; 586 SV* orig; 587 588 mskey = hv_iterkeysv(he); 589 if(hv_exists_ent(methods, mskey, 0)) continue; 590 591 msval = hv_iterval(mro_stash, he); 592 if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval))) 593 continue; 594 595 if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) { 596 SV* val = HeVAL(ourent); 597 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val)) 598 continue; 599 } 600 601 meth_hash = newHV(); 602 orig = newSVsv(mro_class); 603 sv_catpvn(orig, "::", 2); 604 sv_catsv(orig, mskey); 605 hv_store(meth_hash, "orig", 4, orig, 0); 606 hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0); 607 hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0); 608 } 609 } 610 611 hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0); 612 if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0); 613 XSRETURN_EMPTY; 614} 615 616MODULE = Class::C3::XS PACKAGE = Class::C3::XS 617 618BOOT: 619 newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__); 620 newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__); 621 newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__); 622 newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__); 623 624