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