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