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