1 /* mro_core.c 2 * 3 * Copyright (c) 2007 Brandon L Black 4 * Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 * This was 'mro.c', but changed because there is another mro.c in /ext, and 10 * the os390 loader can't cope with this situation (which involves the two 11 * files calling functions defined in the other) 12 */ 13 14 /* 15 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first? 16 * You'll be last either way, Master Peregrin.' 17 * 18 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"] 19 */ 20 21 /* 22 =head1 MRO 23 These functions are related to the method resolution order of perl classes 24 Also see L<perlmroapi>. 25 26 =cut 27 */ 28 29 #include "EXTERN.h" 30 #define PERL_IN_MRO_C 31 #define PERL_IN_MRO_CORE_C 32 #include "perl.h" 33 34 static const struct mro_alg dfs_alg = 35 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}; 36 37 SV * 38 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, 39 const struct mro_alg *const which) 40 { 41 SV **data; 42 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA; 43 44 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, 45 which->name, which->length, which->kflags, 46 HV_FETCH_JUST_SV, NULL, which->hash); 47 if (!data) 48 return NULL; 49 50 /* If we've been asked to look up the private data for the current MRO, then 51 cache it. */ 52 if (smeta->mro_which == which) 53 smeta->mro_linear_current = *data; 54 55 return *data; 56 } 57 58 SV * 59 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, 60 const struct mro_alg *const which, SV *const data) 61 { 62 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA; 63 64 if (!smeta->mro_linear_all) { 65 if (smeta->mro_which == which) { 66 /* If all we need to store is the current MRO's data, then don't use 67 memory on a hash with 1 element - store it direct, and signal 68 this by leaving the would-be-hash NULL. */ 69 smeta->mro_linear_current = data; 70 return data; 71 } else { 72 HV *const hv = newHV(); 73 /* Start with 2 buckets. It's unlikely we'll need more. */ 74 HvMAX(hv) = 1; 75 smeta->mro_linear_all = hv; 76 77 if (smeta->mro_linear_current) { 78 /* If we were storing something directly, put it in the hash 79 before we lose it. */ 80 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, 81 smeta->mro_linear_current); 82 } 83 } 84 } 85 86 /* We get here if we're storing more than one linearisation for this stash, 87 or the linearisation we are storing is not that if its current MRO. */ 88 89 if (smeta->mro_which == which) { 90 /* If we've been asked to store the private data for the current MRO, 91 then cache it. */ 92 smeta->mro_linear_current = data; 93 } 94 95 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, 96 which->name, which->length, which->kflags, 97 HV_FETCH_ISSTORE, data, which->hash)) { 98 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " 99 "for '%.*s' %d", (int) which->length, which->name, 100 which->kflags); 101 } 102 103 return data; 104 } 105 106 /* 107 =for apidoc mro_get_from_name 108 109 Returns the previously registered mro with the given C<name>, or NULL if not 110 registered. See L</C<mro_register>>. 111 112 =cut 113 */ 114 115 const struct mro_alg * 116 Perl_mro_get_from_name(pTHX_ SV *name) { 117 SV **data; 118 119 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME; 120 121 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0, 122 HV_FETCH_JUST_SV, NULL, 0); 123 if (!data) 124 return NULL; 125 assert(SvTYPE(*data) == SVt_IV); 126 assert(SvIOK(*data)); 127 return INT2PTR(const struct mro_alg *, SvUVX(*data)); 128 } 129 130 /* 131 =for apidoc mro_register 132 Registers a custom mro plugin. See L<perlmroapi> for details on this and other 133 mro functions. 134 135 =cut 136 */ 137 138 void 139 Perl_mro_register(pTHX_ const struct mro_alg *mro) { 140 SV *wrapper = newSVuv(PTR2UV(mro)); 141 142 PERL_ARGS_ASSERT_MRO_REGISTER; 143 144 145 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, 146 mro->name, mro->length, mro->kflags, 147 HV_FETCH_ISSTORE, wrapper, mro->hash)) { 148 SvREFCNT_dec_NN(wrapper); 149 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " 150 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); 151 } 152 } 153 154 struct mro_meta* 155 Perl_mro_meta_init(pTHX_ HV* stash) 156 { 157 struct mro_meta* newmeta; 158 159 PERL_ARGS_ASSERT_MRO_META_INIT; 160 PERL_UNUSED_CONTEXT; 161 assert(HvAUX(stash)); 162 assert(!(HvAUX(stash)->xhv_mro_meta)); 163 Newxz(newmeta, 1, struct mro_meta); 164 HvAUX(stash)->xhv_mro_meta = newmeta; 165 newmeta->cache_gen = 1; 166 newmeta->pkg_gen = 1; 167 newmeta->mro_which = &dfs_alg; 168 169 return newmeta; 170 } 171 172 #if defined(USE_ITHREADS) 173 174 /* for sv_dup on new threads */ 175 struct mro_meta* 176 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) 177 { 178 struct mro_meta* newmeta; 179 180 PERL_ARGS_ASSERT_MRO_META_DUP; 181 182 Newx(newmeta, 1, struct mro_meta); 183 Copy(smeta, newmeta, 1, struct mro_meta); 184 185 if (newmeta->mro_linear_all) { 186 newmeta->mro_linear_all 187 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); 188 /* This is just acting as a shortcut pointer, and will be automatically 189 updated on the first get. */ 190 newmeta->mro_linear_current = NULL; 191 } else if (newmeta->mro_linear_current) { 192 /* Only the current MRO is stored, so this owns the data. */ 193 newmeta->mro_linear_current 194 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); 195 } 196 197 if (newmeta->mro_nextmethod) 198 newmeta->mro_nextmethod 199 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); 200 if (newmeta->isa) 201 newmeta->isa 202 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); 203 204 newmeta->super = NULL; 205 206 /* clear the destructor cache */ 207 newmeta->destroy = NULL; 208 newmeta->destroy_gen = 0; 209 210 return newmeta; 211 } 212 213 #endif /* USE_ITHREADS */ 214 215 /* 216 =for apidoc mro_get_linear_isa_dfs 217 218 Returns the Depth-First Search linearization of C<@ISA> 219 the given stash. The return value is a read-only AV* 220 whose elements are string SVs giving class names. 221 C<level> should be 0 (it is used internally in this 222 function's recursion). 223 224 You are responsible for C<SvREFCNT_inc()> on the 225 return value if you plan to store it anywhere 226 semi-permanently (otherwise it might be deleted 227 out from under you the next time the cache is 228 invalidated). 229 230 =cut 231 */ 232 static AV* 233 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) 234 { 235 AV* retval; 236 GV** gvp; 237 GV* gv; 238 AV* av; 239 const HEK* stashhek; 240 struct mro_meta* meta; 241 SV *our_name; 242 HV *stored = NULL; 243 244 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; 245 assert(HvAUX(stash)); 246 247 stashhek 248 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash) 249 ? HvENAME_HEK_NN(stash) 250 : HvNAME_HEK(stash); 251 252 if (!stashhek) 253 Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); 254 255 if (level > 100) 256 Perl_croak(aTHX_ 257 "Recursive inheritance detected in package '%" HEKf "'", 258 HEKfARG(stashhek)); 259 260 meta = HvMROMETA(stash); 261 262 /* return cache if valid */ 263 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) { 264 return retval; 265 } 266 267 /* not in cache, make a new one */ 268 269 retval = newAV_mortal(); 270 /* We use this later in this function, but don't need a reference to it 271 beyond the end of this function, so reference count is fine. */ 272 our_name = newSVhek(stashhek); 273 av_push_simple(retval, our_name); /* add ourselves at the top */ 274 275 /* fetch our @ISA */ 276 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); 277 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; 278 279 /* "stored" is used to keep track of all of the classnames we have added to 280 the MRO so far, so we can do a quick exists check and avoid adding 281 duplicate classnames to the MRO as we go. 282 It's then retained to be re-used as a fast lookup for ->isa(), by adding 283 our own name and "UNIVERSAL" to it. */ 284 285 if(av && AvFILLp(av) >= 0) { 286 287 SV **svp = AvARRAY(av); 288 I32 items = AvFILLp(av) + 1; 289 290 /* foreach(@ISA) */ 291 while (items--) { 292 SV* const sv = *svp ? *svp : &PL_sv_undef; 293 HV* const basestash = gv_stashsv(sv, 0); 294 SV *const *subrv_p; 295 I32 subrv_items; 296 svp++; 297 298 if (!basestash) { 299 /* if no stash exists for this @ISA member, 300 simply add it to the MRO and move on */ 301 subrv_p = &sv; 302 subrv_items = 1; 303 } 304 else { 305 /* otherwise, recurse into ourselves for the MRO 306 of this @ISA member, and append their MRO to ours. 307 The recursive call could throw an exception, which 308 has memory management implications here, hence the use of 309 the mortal. */ 310 const AV *const subrv 311 = mro_get_linear_isa_dfs(basestash, level + 1); 312 313 subrv_p = AvARRAY(subrv); 314 subrv_items = AvFILLp(subrv) + 1; 315 } 316 if (stored) { 317 while(subrv_items--) { 318 SV *const subsv = *subrv_p++; 319 /* LVALUE fetch will create a new undefined SV if necessary 320 */ 321 HE *const he = hv_fetch_ent(stored, subsv, 1, 0); 322 assert(he); 323 if(HeVAL(he) != &PL_sv_undef) { 324 /* It was newly created. Steal it for our new SV, and 325 replace it in the hash with the "real" thing. */ 326 SV *const val = HeVAL(he); 327 HEK *const key = HeKEY_hek(he); 328 329 HeVAL(he) = &PL_sv_undef; 330 sv_sethek(val, key); 331 av_push_simple(retval, val); 332 } 333 } 334 } else { 335 /* We are the first (or only) parent. We can short cut the 336 complexity above, because our @ISA is simply us prepended 337 to our parent's @ISA, and our ->isa cache is simply our 338 parent's, with our name added. */ 339 /* newSVsv() is slow. This code is only faster if we can avoid 340 it by ensuring that SVs in the arrays are shared hash key 341 scalar SVs, because we can "copy" them very efficiently. 342 Although to be fair, we can't *ensure* this, as a reference 343 to the internal array is returned by mro::get_linear_isa(), 344 so we'll have to be defensive just in case someone faffed 345 with it. */ 346 if (basestash) { 347 SV **svp; 348 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); 349 av_extend(retval, subrv_items); 350 AvFILLp(retval) = subrv_items; 351 svp = AvARRAY(retval); 352 while(subrv_items--) { 353 SV *const val = *subrv_p++; 354 *++svp = SvIsCOW_shared_hash(val) 355 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) 356 : newSVsv(val); 357 } 358 } else { 359 /* They have no stash. So create ourselves an ->isa cache 360 as if we'd copied it from what theirs should be. */ 361 stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV)); 362 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); 363 av_push_simple(retval, 364 newSVhek(HeKEY_hek(hv_store_ent(stored, sv, 365 &PL_sv_undef, 0)))); 366 } 367 } 368 } 369 } else { 370 /* We have no parents. */ 371 stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV)); 372 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); 373 } 374 375 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); 376 377 SvREFCNT_inc_simple_void_NN(stored); 378 SvTEMP_off(stored); 379 SvREADONLY_on(stored); 380 381 meta->isa = stored; 382 383 /* now that we're past the exception dangers, grab our own reference to 384 the AV we're about to use for the result. The reference owned by the 385 mortals' stack will be released soon, so everything will balance. */ 386 SvREFCNT_inc_simple_void_NN(retval); 387 SvTEMP_off(retval); 388 389 /* we don't want anyone modifying the cache entry but us, 390 and we do so by replacing it completely */ 391 SvREADONLY_on(retval); 392 393 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, 394 MUTABLE_SV(retval))); 395 } 396 397 /* 398 =for apidoc mro_get_linear_isa 399 400 Returns the mro linearisation for the given stash. By default, this 401 will be whatever C<mro_get_linear_isa_dfs> returns unless some 402 other MRO is in effect for the stash. The return value is a 403 read-only AV* whose values are string SVs giving class names. 404 405 You are responsible for C<SvREFCNT_inc()> on the 406 return value if you plan to store it anywhere 407 semi-permanently (otherwise it might be deleted 408 out from under you the next time the cache is 409 invalidated). 410 411 =cut 412 */ 413 AV* 414 Perl_mro_get_linear_isa(pTHX_ HV *stash) 415 { 416 struct mro_meta* meta; 417 AV *isa; 418 419 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; 420 if(!HvHasAUX(stash)) 421 Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); 422 423 meta = HvMROMETA(stash); 424 if (!meta->mro_which) 425 Perl_croak(aTHX_ "panic: invalid MRO!"); 426 isa = meta->mro_which->resolve(aTHX_ stash, 0); 427 428 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */ 429 SV * const namesv = 430 (HvHasENAME_HEK(stash) || HvHasNAME(stash)) 431 ? newSVhek(HvHasENAME_HEK(stash) 432 ? HvENAME_HEK(stash) 433 : HvNAME_HEK(stash)) 434 : NULL; 435 436 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) 437 { 438 AV * const old = isa; 439 SV **svp; 440 SV **ovp = AvARRAY(old); 441 SV * const * const oend = ovp + AvFILLp(old) + 1; 442 isa = (AV *)newSV_type_mortal(SVt_PVAV); 443 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); 444 *AvARRAY(isa) = namesv; 445 svp = AvARRAY(isa)+1; 446 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); 447 } 448 else SvREFCNT_dec(namesv); 449 } 450 451 if (!meta->isa) { 452 HV *const isa_hash = newHV(); 453 /* Linearisation didn't build it for us, so do it here. */ 454 I32 count = AvFILLp(isa) + 1; 455 SV *const *svp = AvARRAY(isa); 456 SV *const *const svp_end = svp + count; 457 const HEK *canon_name = HvENAME_HEK(stash); 458 if (!canon_name) canon_name = HvNAME_HEK(stash); 459 460 if (count > PERL_HASH_DEFAULT_HvMAX) { 461 hv_ksplit(isa_hash, count); 462 } 463 464 while (svp < svp_end) { 465 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); 466 } 467 468 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), 469 HEK_LEN(canon_name), HEK_FLAGS(canon_name), 470 HV_FETCH_ISSTORE, &PL_sv_undef, 471 HEK_HASH(canon_name)); 472 (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef); 473 474 SvREADONLY_on(isa_hash); 475 476 meta->isa = isa_hash; 477 } 478 479 return isa; 480 } 481 482 /* 483 =for apidoc mro_isa_changed_in 484 485 Takes the necessary steps (cache invalidations, mostly) 486 when the C<@ISA> of the given package has changed. Invoked 487 by the C<setisa> magic, should not need to invoke directly. 488 489 =cut 490 */ 491 492 /* Macro to avoid repeating the code five times. */ 493 #define CLEAR_LINEAR(mEta) \ 494 if (mEta->mro_linear_all) { \ 495 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \ 496 mEta->mro_linear_all = NULL; \ 497 /* This is just acting as a shortcut pointer. */ \ 498 mEta->mro_linear_current = NULL; \ 499 } else if (mEta->mro_linear_current) { \ 500 /* Only the current MRO is stored, so this owns the data. */ \ 501 SvREFCNT_dec(mEta->mro_linear_current); \ 502 mEta->mro_linear_current = NULL; \ 503 } 504 505 void 506 Perl_mro_isa_changed_in(pTHX_ HV* stash) 507 { 508 HV* isarev; 509 AV* linear_mro; 510 HE* iter; 511 SV** svp; 512 I32 items; 513 bool is_universal; 514 struct mro_meta * meta; 515 HV *isa = NULL; 516 517 const HEK * const stashhek = HvENAME_HEK(stash); 518 const char * const stashname = HvENAME_get(stash); 519 const STRLEN stashname_len = HvENAMELEN_get(stash); 520 521 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; 522 523 if(!stashname) 524 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); 525 526 527 /* wipe out the cached linearizations for this stash */ 528 meta = HvMROMETA(stash); 529 CLEAR_LINEAR(meta); 530 if (meta->isa) { 531 /* Steal it for our own purposes. */ 532 isa = (HV *)sv_2mortal((SV *)meta->isa); 533 meta->isa = NULL; 534 } 535 536 /* Inc the package generation, since our @ISA changed */ 537 meta->pkg_gen++; 538 539 /* Wipe the global method cache if this package 540 is UNIVERSAL or one of its parents */ 541 542 svp = hv_fetchhek(PL_isarev, stashhek, 0); 543 isarev = svp ? MUTABLE_HV(*svp) : NULL; 544 545 if((memEQs(stashname, stashname_len, "UNIVERSAL")) 546 || (isarev && hv_existss(isarev, "UNIVERSAL"))) { 547 PL_sub_generation++; 548 is_universal = TRUE; 549 } 550 else { /* Wipe the local method cache otherwise */ 551 meta->cache_gen++; 552 is_universal = FALSE; 553 } 554 555 /* wipe next::method cache too */ 556 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); 557 558 /* Changes to @ISA might turn overloading on */ 559 HvAMAGIC_on(stash); 560 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ 561 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; 562 563 /* DESTROY can be cached in meta. */ 564 meta->destroy_gen = 0; 565 566 /* Iterate the isarev (classes that are our children), 567 wiping out their linearization, method and isa caches 568 and upating PL_isarev. */ 569 if(isarev) { 570 HV *isa_hashes = NULL; 571 572 /* We have to iterate through isarev twice to avoid a chicken and 573 * egg problem: if A inherits from B and both are in isarev, A might 574 * be processed before B and use B's previous linearisation. 575 */ 576 577 /* First iteration: Wipe everything, but stash away the isa hashes 578 * since we still need them for updating PL_isarev. 579 */ 580 581 if(hv_iterinit(isarev)) { 582 /* Only create the hash if we need it; i.e., if isarev has 583 any elements. */ 584 isa_hashes = (HV *)newSV_type_mortal(SVt_PVHV); 585 } 586 while((iter = hv_iternext(isarev))) { 587 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); 588 struct mro_meta* revmeta; 589 590 if(!revstash) continue; 591 revmeta = HvMROMETA(revstash); 592 CLEAR_LINEAR(revmeta); 593 if(!is_universal) 594 revmeta->cache_gen++; 595 if(revmeta->mro_nextmethod) 596 hv_clear(revmeta->mro_nextmethod); 597 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; 598 599 (void) 600 hv_store( 601 isa_hashes, (const char*)&revstash, sizeof(HV *), 602 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 603 ); 604 revmeta->isa = NULL; 605 } 606 607 /* Second pass: Update PL_isarev. We can just use isa_hashes to 608 * avoid another round of stash lookups. */ 609 610 /* isarev might be deleted from PL_isarev during this loop, so hang 611 * on to it. */ 612 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev)); 613 614 if(isa_hashes) { 615 hv_iterinit(isa_hashes); 616 while((iter = hv_iternext(isa_hashes))) { 617 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter)); 618 HV * const isa = (HV *)HeVAL(iter); 619 const HEK *namehek; 620 621 /* We're starting at the 2nd element, skipping revstash */ 622 linear_mro = mro_get_linear_isa(revstash); 623 svp = AvARRAY(linear_mro) + 1; 624 items = AvFILLp(linear_mro); 625 626 namehek = HvENAME_HEK(revstash); 627 if (!namehek) namehek = HvNAME_HEK(revstash); 628 629 while (items--) { 630 SV* const sv = *svp++; 631 HV* mroisarev; 632 633 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); 634 635 /* That fetch should not fail. But if it had to create 636 a new SV for us, then will need to upgrade it to an 637 HV (which sv_upgrade() can now do for us). */ 638 639 mroisarev = MUTABLE_HV(HeVAL(he)); 640 641 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); 642 643 /* This hash only ever contains PL_sv_yes. Storing it 644 over itself is almost as cheap as calling hv_exists, 645 so on aggregate we expect to save time by not making 646 two calls to the common HV code for the case where 647 it doesn't exist. */ 648 649 (void) 650 hv_storehek(mroisarev, namehek, &PL_sv_yes); 651 } 652 653 if ((SV *)isa != &PL_sv_undef && HvTOTALKEYS(isa)) { 654 assert(namehek); 655 mro_clean_isarev( 656 isa, HEK_KEY(namehek), HEK_LEN(namehek), 657 HvMROMETA(revstash)->isa, HEK_HASH(namehek), 658 HEK_UTF8(namehek) 659 ); 660 } 661 } 662 } 663 } 664 665 /* Now iterate our MRO (parents), adding ourselves and everything from 666 our isarev to their isarev. 667 */ 668 669 /* We're starting at the 2nd element, skipping ourselves here */ 670 linear_mro = mro_get_linear_isa(stash); 671 svp = AvARRAY(linear_mro) + 1; 672 items = AvFILLp(linear_mro); 673 674 while (items--) { 675 SV* const sv = *svp++; 676 HV* mroisarev; 677 678 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); 679 680 /* That fetch should not fail. But if it had to create a new SV for 681 us, then will need to upgrade it to an HV (which sv_upgrade() can 682 now do for us. */ 683 684 mroisarev = MUTABLE_HV(HeVAL(he)); 685 686 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); 687 688 /* This hash only ever contains PL_sv_yes. Storing it over itself is 689 almost as cheap as calling hv_exists, so on aggregate we expect to 690 save time by not making two calls to the common HV code for the 691 case where it doesn't exist. */ 692 693 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); 694 } 695 696 /* Delete our name from our former parents' isarevs. */ 697 if(isa && HvTOTALKEYS(isa)) 698 mro_clean_isarev(isa, stashname, stashname_len, meta->isa, 699 HEK_HASH(stashhek), HEK_UTF8(stashhek)); 700 } 701 702 /* Deletes name from all the isarev entries listed in isa. 703 Don't call this if isa is already empty. */ 704 STATIC void 705 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, 706 const STRLEN len, HV * const exceptions, U32 hash, 707 U32 flags) 708 { 709 HE* iter; 710 711 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV; 712 713 assert(HvTOTALKEYS(isa)); 714 /* Delete our name from our former parents' isarevs. */ 715 716 hv_iterinit(isa); 717 while((iter = hv_iternext(isa))) { 718 SV **svp; 719 HEK *key = HeKEY_hek(iter); 720 if(exceptions && hv_existshek(exceptions, key)) 721 continue; 722 svp = hv_fetchhek(PL_isarev, key, 0); 723 if(svp) { 724 HV * const isarev = (HV *)*svp; 725 (void)hv_common(isarev, NULL, name, len, flags, 726 G_DISCARD|HV_DELETE, NULL, hash); 727 if(!HvTOTALKEYS(isarev)) 728 (void)hv_deletehek(PL_isarev, key, G_DISCARD); 729 } 730 } 731 } 732 733 /* 734 =for apidoc mro_package_moved 735 736 Call this function to signal to a stash that it has been assigned to 737 another spot in the stash hierarchy. C<stash> is the stash that has been 738 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob 739 that is actually being assigned to. 740 741 This can also be called with a null first argument to 742 indicate that C<oldstash> has been deleted. 743 744 This function invalidates isa caches on the old stash, on all subpackages 745 nested inside it, and on the subclasses of all those, including 746 non-existent packages that have corresponding entries in C<stash>. 747 748 It also sets the effective names (C<HvENAME>) on all the stashes as 749 appropriate. 750 751 If the C<gv> is present and is not in the symbol table, then this function 752 simply returns. This checked will be skipped if C<flags & 1>. 753 754 =cut 755 */ 756 void 757 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, 758 const GV * const gv, U32 flags) 759 { 760 SV *namesv; 761 HEK **namep; 762 I32 name_count; 763 HV *stashes; 764 HE* iter; 765 766 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED; 767 assert(stash || oldstash); 768 769 /* Determine the name(s) of the location that stash was assigned to 770 * or from which oldstash was removed. 771 * 772 * We cannot reliably use the name in oldstash, because it may have 773 * been deleted from the location in the symbol table that its name 774 * suggests, as in this case: 775 * 776 * $globref = \*foo::bar::; 777 * Symbol::delete_package("foo"); 778 * *$globref = \%baz::; 779 * *$globref = *frelp::; 780 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0) 781 * 782 * So we get it from the gv. But, since the gv may no longer be in the 783 * symbol table, we check that first. The only reliable way to tell is 784 * to see whether its stash has an effective name and whether the gv 785 * resides in that stash under its name. That effective name may be 786 * different from what gv_fullname4 would use. 787 * If flags & 1, the caller has asked us to skip the check. 788 */ 789 if(!(flags & 1)) { 790 SV **svp; 791 if( 792 !GvSTASH(gv) || !HvHasENAME(GvSTASH(gv)) || 793 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || 794 *svp != (SV *)gv 795 ) return; 796 } 797 assert(HvHasAUX(GvSTASH(gv))); 798 assert(GvNAMELEN(gv)); 799 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':'); 800 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); 801 name_count = HvAUX(GvSTASH(gv))->xhv_name_count; 802 if (!name_count) { 803 name_count = 1; 804 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; 805 } 806 else { 807 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; 808 if (name_count < 0) ++namep, name_count = -name_count - 1; 809 } 810 if (name_count == 1) { 811 if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) { 812 namesv = GvNAMELEN(gv) == 1 813 ? newSVpvs_flags(":", SVs_TEMP) 814 : newSVpvs_flags("", SVs_TEMP); 815 } 816 else { 817 namesv = newSVhek_mortal(*namep); 818 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); 819 else sv_catpvs(namesv, "::"); 820 } 821 if (GvNAMELEN(gv) != 1) { 822 sv_catpvn_flags( 823 namesv, GvNAME(gv), GvNAMELEN(gv) - 2, 824 /* skip trailing :: */ 825 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES 826 ); 827 } 828 } 829 else { 830 SV *aname; 831 namesv = newSV_type_mortal(SVt_PVAV); 832 while (name_count--) { 833 if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){ 834 aname = GvNAMELEN(gv) == 1 835 ? newSVpvs(":") 836 : newSVpvs(""); 837 namep++; 838 } 839 else { 840 aname = newSVhek(*namep++); 841 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); 842 else sv_catpvs(aname, "::"); 843 } 844 if (GvNAMELEN(gv) != 1) { 845 sv_catpvn_flags( 846 aname, GvNAME(gv), GvNAMELEN(gv) - 2, 847 /* skip trailing :: */ 848 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES 849 ); 850 } 851 av_push_simple((AV *)namesv, aname); 852 } 853 } 854 855 /* Get a list of all the affected classes. */ 856 /* We cannot simply pass them all to mro_isa_changed_in to avoid 857 the list, as that function assumes that only one package has 858 changed. It does not work with: 859 860 @foo::ISA = qw( B B::B ); 861 *B:: = delete $::{"A::"}; 862 863 as neither B nor B::B can be updated before the other, since they 864 will reset caches on foo, which will see either B or B::B with the 865 wrong name. The names must be set on *all* affected stashes before 866 we do anything else. (And linearisations must be cleared, too.) 867 */ 868 stashes = (HV *) newSV_type_mortal(SVt_PVHV); 869 mro_gather_and_rename( 870 stashes, (HV *) newSV_type_mortal(SVt_PVHV), 871 stash, oldstash, namesv 872 ); 873 874 /* Once the caches have been wiped on all the classes, call 875 mro_isa_changed_in on each. */ 876 hv_iterinit(stashes); 877 while((iter = hv_iternext(stashes))) { 878 HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); 879 if(HvENAME(this_stash)) { 880 /* We have to restore the original meta->isa (that 881 mro_gather_and_rename set aside for us) this way, in case 882 one class in this list is a superclass of a another class 883 that we have already encountered. In such a case, meta->isa 884 will have been overwritten without old entries being deleted 885 from PL_isarev. */ 886 struct mro_meta * const meta = HvMROMETA(this_stash); 887 if(meta->isa != (HV *)HeVAL(iter)){ 888 SvREFCNT_dec(meta->isa); 889 meta->isa 890 = HeVAL(iter) == &PL_sv_yes 891 ? NULL 892 : (HV *)HeVAL(iter); 893 HeVAL(iter) = NULL; /* We donated our reference count. */ 894 } 895 mro_isa_changed_in(this_stash); 896 } 897 } 898 } 899 900 STATIC void 901 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, 902 HV *stash, HV *oldstash, SV *namesv) 903 { 904 XPVHV* xhv; 905 HE *entry; 906 I32 riter = -1; 907 I32 items = 0; 908 const bool stash_had_name = stash && HvHasENAME(stash); 909 bool fetched_isarev = FALSE; 910 HV *seen = NULL; 911 HV *isarev = NULL; 912 SV **svp = NULL; 913 914 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME; 915 916 /* We use the seen_stashes hash to keep track of which packages have 917 been encountered so far. This must be separate from the main list of 918 stashes, as we need to distinguish between stashes being assigned 919 and stashes being replaced/deleted. (A nested stash can be on both 920 sides of an assignment. We cannot simply skip iterating through a 921 stash on the right if we have seen it on the left, as it will not 922 get its ename assigned to it.) 923 924 To avoid allocating extra SVs, instead of a bitfield we can make 925 bizarre use of immortals: 926 927 &PL_sv_undef: seen on the left (oldstash) 928 &PL_sv_no : seen on the right (stash) 929 &PL_sv_yes : seen on both sides 930 931 */ 932 933 if(oldstash) { 934 /* Add to the big list. */ 935 struct mro_meta * meta; 936 HE * const entry 937 = (HE *) 938 hv_common( 939 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, 940 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 941 ); 942 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { 943 oldstash = NULL; 944 goto check_stash; 945 } 946 HeVAL(entry) 947 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; 948 meta = HvMROMETA(oldstash); 949 (void) 950 hv_store( 951 stashes, (const char *)&oldstash, sizeof(HV *), 952 meta->isa 953 ? SvREFCNT_inc_simple_NN((SV *)meta->isa) 954 : &PL_sv_yes, 955 0 956 ); 957 CLEAR_LINEAR(meta); 958 959 /* Update the effective name. */ 960 if(HvENAME_get(oldstash)) { 961 const HEK * const enamehek = HvENAME_HEK(oldstash); 962 if(SvTYPE(namesv) == SVt_PVAV) { 963 items = AvFILLp((AV *)namesv) + 1; 964 svp = AvARRAY((AV *)namesv); 965 } 966 else { 967 items = 1; 968 svp = &namesv; 969 } 970 while (items--) { 971 const U32 name_utf8 = SvUTF8(*svp); 972 STRLEN len; 973 const char *name = SvPVx_const(*svp, len); 974 if(PL_stashcache) { 975 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n", 976 SVfARG(*svp))); 977 (void)hv_delete_ent(PL_stashcache, *svp, G_DISCARD, 0); 978 } 979 hv_ename_delete(oldstash, name, len, name_utf8); 980 981 if (!fetched_isarev) { 982 /* If the name deletion caused a name change, then we 983 * are not going to call mro_isa_changed_in with this 984 * name (and not at all if it has become anonymous) so 985 * we need to delete old isarev entries here, both 986 * those in the superclasses and this class's own list 987 * of subclasses. We simply delete the latter from 988 * PL_isarev, since we still need it. hv_delete morti- 989 * fies it for us, so sv_2mortal is not necessary. */ 990 if(HvENAME_HEK(oldstash) != enamehek) { 991 if(meta->isa && HvTOTALKEYS(meta->isa)) 992 mro_clean_isarev(meta->isa, name, len, 0, 0, 993 name_utf8 ? HVhek_UTF8 : 0); 994 isarev = (HV *)hv_delete_ent(PL_isarev, *svp, 0, 0); 995 fetched_isarev=TRUE; 996 } 997 } 998 999 ++svp; 1000 } 1001 } 1002 } 1003 check_stash: 1004 if(stash) { 1005 if(SvTYPE(namesv) == SVt_PVAV) { 1006 items = AvFILLp((AV *)namesv) + 1; 1007 svp = AvARRAY((AV *)namesv); 1008 } 1009 else { 1010 items = 1; 1011 svp = &namesv; 1012 } 1013 while (items--) { 1014 const U32 name_utf8 = SvUTF8(*svp); 1015 STRLEN len; 1016 const char *name = SvPVx_const(*svp++, len); 1017 hv_ename_add(stash, name, len, name_utf8); 1018 } 1019 1020 /* Add it to the big list if it needs 1021 * mro_isa_changed_in called on it. That happens if it was 1022 * detached from the symbol table (so it had no HvENAME) before 1023 * being assigned to the spot named by the 'name' variable, because 1024 * its cached isa linearisation is now stale (the effective name 1025 * having changed), and subclasses will then use that cache when 1026 * mro_package_moved calls mro_isa_changed_in. (See 1027 * [perl #77358].) 1028 * 1029 * If it did have a name, then its previous name is still 1030 * used in isa caches, and there is no need for 1031 * mro_package_moved to call mro_isa_changed_in. 1032 */ 1033 1034 entry 1035 = (HE *) 1036 hv_common( 1037 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, 1038 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 1039 ); 1040 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) 1041 stash = NULL; 1042 else { 1043 HeVAL(entry) 1044 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; 1045 if(!stash_had_name) 1046 { 1047 struct mro_meta * const meta = HvMROMETA(stash); 1048 (void) 1049 hv_store( 1050 stashes, (const char *)&stash, sizeof(HV *), 1051 meta->isa 1052 ? SvREFCNT_inc_simple_NN((SV *)meta->isa) 1053 : &PL_sv_yes, 1054 0 1055 ); 1056 CLEAR_LINEAR(meta); 1057 } 1058 } 1059 } 1060 1061 if(!stash && !oldstash) 1062 /* Both stashes have been encountered already. */ 1063 return; 1064 1065 /* Add all the subclasses to the big list. */ 1066 if(!fetched_isarev) { 1067 /* If oldstash is not null, then we can use its HvENAME to look up 1068 the isarev hash, since all its subclasses will be listed there. 1069 It will always have an HvENAME. It the HvENAME was removed 1070 above, then fetch_isarev will be true, and this code will not be 1071 reached. 1072 1073 If oldstash is null, then this is an empty spot with no stash in 1074 it, so subclasses could be listed in isarev hashes belonging to 1075 any of the names, so we have to check all of them. 1076 */ 1077 assert(!oldstash || HvENAME(oldstash)); 1078 if (oldstash) { 1079 /* Extra variable to avoid a compiler warning */ 1080 const HEK * const hvename = HvENAME_HEK(oldstash); 1081 fetched_isarev = TRUE; 1082 svp = hv_fetchhek(PL_isarev, hvename, 0); 1083 if (svp) isarev = MUTABLE_HV(*svp); 1084 } 1085 else if(SvTYPE(namesv) == SVt_PVAV) { 1086 items = AvFILLp((AV *)namesv) + 1; 1087 svp = AvARRAY((AV *)namesv); 1088 } 1089 else { 1090 items = 1; 1091 svp = &namesv; 1092 } 1093 } 1094 if( 1095 isarev || !fetched_isarev 1096 ) { 1097 while (fetched_isarev || items--) { 1098 HE *iter; 1099 1100 if (!fetched_isarev) { 1101 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); 1102 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; 1103 } 1104 1105 hv_iterinit(isarev); 1106 while((iter = hv_iternext(isarev))) { 1107 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); 1108 struct mro_meta * meta; 1109 1110 if(!revstash) continue; 1111 meta = HvMROMETA(revstash); 1112 (void) 1113 hv_store( 1114 stashes, (const char *)&revstash, sizeof(HV *), 1115 meta->isa 1116 ? SvREFCNT_inc_simple_NN((SV *)meta->isa) 1117 : &PL_sv_yes, 1118 0 1119 ); 1120 CLEAR_LINEAR(meta); 1121 } 1122 1123 if (fetched_isarev) break; 1124 } 1125 } 1126 1127 /* This is partly based on code in hv_iternext_flags. We are not call- 1128 ing that here, as we want to avoid resetting the hash iterator. */ 1129 1130 /* Skip the entire loop if the hash is empty. */ 1131 if(oldstash && HvTOTALKEYS(oldstash)) { 1132 xhv = (XPVHV*)SvANY(oldstash); 1133 seen = (HV *) newSV_type_mortal(SVt_PVHV); 1134 1135 /* Iterate through entries in the oldstash, adding them to the 1136 list, meanwhile doing the equivalent of $seen{$key} = 1. 1137 */ 1138 1139 while (++riter <= (I32)xhv->xhv_max) { 1140 entry = (HvARRAY(oldstash))[riter]; 1141 1142 /* Iterate through the entries in this list */ 1143 for(; entry; entry = HeNEXT(entry)) { 1144 const char* key; 1145 I32 len; 1146 1147 /* If this entry is not a glob, ignore it. 1148 Try the next. */ 1149 if (!isGV(HeVAL(entry))) continue; 1150 1151 key = hv_iterkey(entry, &len); 1152 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') 1153 || (len == 1 && key[0] == ':')) { 1154 HV * const oldsubstash = GvHV(HeVAL(entry)); 1155 SV **stashentry; 1156 HV *substash = NULL; 1157 1158 /* Avoid main::main::main::... */ 1159 if(oldsubstash == oldstash) continue; 1160 1161 stashentry = stash ? hv_fetchhek(stash, HeKEY_hek(entry), 0) : NULL; 1162 1163 if( 1164 ( 1165 stashentry && *stashentry && isGV(*stashentry) 1166 && (substash = GvHV(*stashentry)) 1167 ) 1168 || (oldsubstash && HvHasENAME(oldsubstash)) 1169 ) 1170 { 1171 /* Add :: and the key (minus the trailing ::) 1172 to each name. */ 1173 SV *subname; 1174 if(SvTYPE(namesv) == SVt_PVAV) { 1175 SV *aname; 1176 items = AvFILLp((AV *)namesv) + 1; 1177 svp = AvARRAY((AV *)namesv); 1178 subname = newSV_type_mortal(SVt_PVAV); 1179 while (items--) { 1180 aname = newSVsv(*svp++); 1181 if (len == 1) 1182 sv_catpvs(aname, ":"); 1183 else { 1184 sv_catpvs(aname, "::"); 1185 sv_catpvn_flags( 1186 aname, key, len-2, 1187 HeUTF8(entry) 1188 ? SV_CATUTF8 : SV_CATBYTES 1189 ); 1190 } 1191 av_push_simple((AV *)subname, aname); 1192 } 1193 } 1194 else { 1195 subname = sv_2mortal(newSVsv(namesv)); 1196 if (len == 1) sv_catpvs(subname, ":"); 1197 else { 1198 sv_catpvs(subname, "::"); 1199 sv_catpvn_flags( 1200 subname, key, len-2, 1201 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES 1202 ); 1203 } 1204 } 1205 mro_gather_and_rename( 1206 stashes, seen_stashes, 1207 substash, oldsubstash, subname 1208 ); 1209 } 1210 1211 (void)hv_storehek(seen, HeKEY_hek(entry), &PL_sv_yes); 1212 } 1213 } 1214 } 1215 } 1216 1217 /* Skip the entire loop if the hash is empty. */ 1218 if (stash && HvTOTALKEYS(stash)) { 1219 xhv = (XPVHV*)SvANY(stash); 1220 riter = -1; 1221 1222 /* Iterate through the new stash, skipping $seen{$key} items, 1223 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ 1224 while (++riter <= (I32)xhv->xhv_max) { 1225 entry = (HvARRAY(stash))[riter]; 1226 1227 /* Iterate through the entries in this list */ 1228 for(; entry; entry = HeNEXT(entry)) { 1229 const char* key; 1230 I32 len; 1231 1232 /* If this entry is not a glob, ignore it. 1233 Try the next. */ 1234 if (!isGV(HeVAL(entry))) continue; 1235 1236 key = hv_iterkey(entry, &len); 1237 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') 1238 || (len == 1 && key[0] == ':')) { 1239 HV *substash; 1240 1241 /* If this entry was seen when we iterated through the 1242 oldstash, skip it. */ 1243 if(seen && hv_existshek(seen, HeKEY_hek(entry))) continue; 1244 1245 /* We get here only if this stash has no corresponding 1246 entry in the stash being replaced. */ 1247 1248 substash = GvHV(HeVAL(entry)); 1249 if(substash) { 1250 SV *subname; 1251 1252 /* Avoid checking main::main::main::... */ 1253 if(substash == stash) continue; 1254 1255 /* Add :: and the key (minus the trailing ::) 1256 to each name. */ 1257 if(SvTYPE(namesv) == SVt_PVAV) { 1258 SV *aname; 1259 items = AvFILLp((AV *)namesv) + 1; 1260 svp = AvARRAY((AV *)namesv); 1261 subname = newSV_type_mortal(SVt_PVAV); 1262 while (items--) { 1263 aname = newSVsv(*svp++); 1264 if (len == 1) 1265 sv_catpvs(aname, ":"); 1266 else { 1267 sv_catpvs(aname, "::"); 1268 sv_catpvn_flags( 1269 aname, key, len-2, 1270 HeUTF8(entry) 1271 ? SV_CATUTF8 : SV_CATBYTES 1272 ); 1273 } 1274 av_push_simple((AV *)subname, aname); 1275 } 1276 } 1277 else { 1278 subname = sv_2mortal(newSVsv(namesv)); 1279 if (len == 1) sv_catpvs(subname, ":"); 1280 else { 1281 sv_catpvs(subname, "::"); 1282 sv_catpvn_flags( 1283 subname, key, len-2, 1284 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES 1285 ); 1286 } 1287 } 1288 mro_gather_and_rename( 1289 stashes, seen_stashes, 1290 substash, NULL, subname 1291 ); 1292 } 1293 } 1294 } 1295 } 1296 } 1297 } 1298 1299 /* 1300 =for apidoc mro_method_changed_in 1301 1302 Invalidates method caching on any child classes 1303 of the given stash, so that they might notice 1304 the changes in this one. 1305 1306 Ideally, all instances of C<PL_sub_generation++> in 1307 perl source outside of F<mro.c> should be 1308 replaced by calls to this. 1309 1310 Perl automatically handles most of the common 1311 ways a method might be redefined. However, there 1312 are a few ways you could change a method in a stash 1313 without the cache code noticing, in which case you 1314 need to call this method afterwards: 1315 1316 1) Directly manipulating the stash HV entries from 1317 XS code. 1318 1319 2) Assigning a reference to a readonly scalar 1320 constant into a stash entry in order to create 1321 a constant subroutine (like F<constant.pm> 1322 does). 1323 1324 This same method is available from pure perl 1325 via, C<mro::method_changed_in(classname)>. 1326 1327 =cut 1328 */ 1329 void 1330 Perl_mro_method_changed_in(pTHX_ HV *stash) 1331 { 1332 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; 1333 1334 const char * const stashname = HvENAME_get(stash); 1335 1336 if(!stashname) 1337 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); 1338 1339 const STRLEN stashname_len = HvENAMELEN_get(stash); 1340 1341 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK_NN(stash), 0); 1342 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; 1343 1344 /* Inc the package generation, since a local method changed */ 1345 HvMROMETA(stash)->pkg_gen++; 1346 1347 /* DESTROY can be cached in meta */ 1348 HvMROMETA(stash)->destroy_gen = 0; 1349 1350 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, 1351 invalidate all method caches globally */ 1352 if((memEQs(stashname, stashname_len, "UNIVERSAL")) 1353 || (isarev && hv_existss(isarev, "UNIVERSAL"))) { 1354 PL_sub_generation++; 1355 return; 1356 } 1357 1358 /* else, invalidate the method caches of all child classes, 1359 but not itself */ 1360 if(isarev) { 1361 HE* iter; 1362 1363 hv_iterinit(isarev); 1364 while((iter = hv_iternext(isarev))) { 1365 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0); 1366 struct mro_meta* mrometa; 1367 1368 if(!revstash) continue; 1369 mrometa = HvMROMETA(revstash); 1370 mrometa->cache_gen++; 1371 if(mrometa->mro_nextmethod) 1372 hv_clear(mrometa->mro_nextmethod); 1373 mrometa->destroy_gen = 0; 1374 } 1375 } 1376 1377 /* The method change may be due to *{$package . "::()"} = \&nil; in 1378 overload.pm. */ 1379 HvAMAGIC_on(stash); 1380 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */ 1381 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; 1382 } 1383 1384 /* 1385 =for apidoc mro_set_mro 1386 1387 Set C<meta> to the value contained in the registered mro plugin whose name is 1388 C<name>. 1389 1390 Croaks if C<name> hasn't been registered 1391 1392 =cut 1393 */ 1394 1395 void 1396 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) 1397 { 1398 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name); 1399 1400 PERL_ARGS_ASSERT_MRO_SET_MRO; 1401 1402 if (!which) 1403 Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", name); 1404 1405 if(meta->mro_which != which) { 1406 if (meta->mro_linear_current && !meta->mro_linear_all) { 1407 /* If we were storing something directly, put it in the hash before 1408 we lose it. */ 1409 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 1410 MUTABLE_SV(meta->mro_linear_current)); 1411 } 1412 meta->mro_which = which; 1413 /* Scrub our cached pointer to the private data. */ 1414 meta->mro_linear_current = NULL; 1415 /* Only affects local method cache, not 1416 even child classes */ 1417 meta->cache_gen++; 1418 if(meta->mro_nextmethod) 1419 hv_clear(meta->mro_nextmethod); 1420 } 1421 } 1422 1423 #include "XSUB.h" 1424 1425 XS(XS_mro_method_changed_in); 1426 1427 void 1428 Perl_boot_core_mro(pTHX) 1429 { 1430 static const char file[] = __FILE__; 1431 1432 Perl_mro_register(aTHX_ &dfs_alg); 1433 1434 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); 1435 } 1436 1437 XS(XS_mro_method_changed_in) 1438 { 1439 dXSARGS; 1440 SV* classname; 1441 HV* class_stash; 1442 1443 if(items != 1) 1444 croak_xs_usage(cv, "classname"); 1445 1446 classname = ST(0); 1447 1448 class_stash = gv_stashsv(classname, 0); 1449 if(!class_stash) Perl_croak(aTHX_ "No such class: '%" SVf "'!", SVfARG(classname)); 1450 1451 mro_method_changed_in(class_stash); 1452 1453 XSRETURN_EMPTY; 1454 } 1455 1456 /* 1457 * ex: set ts=8 sts=4 sw=4 et: 1458 */ 1459