diff --git a/embed.fnc b/embed.fnc index e11144892b77..ee596d1a3eb1 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2362,7 +2362,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV* stash|U32 level md |void |mro_isa_changed_in|NN HV* stash pd |void |mro_isa_changed_in3|NULLOK HV* stash|NULLOK const char *stashname|STRLEN stashname_len Apd |void |mro_method_changed_in |NN HV* stash -pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK const HV * const oldstash|NULLOK const GV * const gv|NULLOK const char *newname|STRLEN newname_len +pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK const HV * const oldstash|NULLOK const GV * const gv|NULLOK const char *newname|I32 newname_len : Only used in perl.c p |void |boot_core_mro Apon |void |sys_init |NN int* argc|NN char*** argv diff --git a/mro.c b/mro.c index 84626a5122e1..830ef5a154c5 100644 --- a/mro.c +++ b/mro.c @@ -589,26 +589,35 @@ non-existent packages that have corresponding entries in C. void Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, const GV * const gv, const char *newname, - STRLEN newname_len) + I32 newname_len) { register XPVHV* xhv; register HE *entry; I32 riter = -1; HV *seen = NULL; + /* If newname_len is negative, it is actually the call depth (negated). + */ + const I32 level = newname_len < 0 ? newname_len : 0; assert(stash || oldstash); assert(oldstash || gv || newname); + if(level < -100) return; + if(!newname && oldstash) { newname = HvNAME_get(oldstash); newname_len = HvNAMELEN_get(oldstash); } if(!newname && gv) { SV * const namesv = sv_newmortal(); + STRLEN len; gv_fullname4(namesv, gv, NULL, 0); - newname = SvPV_const(namesv, newname_len); - newname_len -= 2; /* skip trailing :: */ + newname = SvPV_const(namesv, len); + newname_len = len - 2; /* skip trailing :: */ } + /* XXX This relies on the fact that package names cannot contain nulls. + */ + if(newname_len < 0) newname_len = strlen(newname); mro_isa_changed_in3((HV *)oldstash, newname, newname_len); @@ -649,13 +658,17 @@ Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, SV ** const stashentry = stash ? hv_fetch(stash, key, len, 0) : NULL; HV *substash; + + /* Avoid main::main::main::... */ + if(oldsubstash == oldstash) continue; + if( stashentry && *stashentry && (substash = GvHV(*stashentry)) && HvNAME(substash) ) mro_package_moved( - substash, oldsubstash, NULL, NULL, 0 + substash, oldsubstash, NULL, NULL, level-1 ); else if(oldsubstash && HvNAME(oldsubstash)) mro_isa_changed_in(oldsubstash); @@ -697,15 +710,21 @@ Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, substash = GvHV(HeVAL(entry)); if(substash && HvNAME(substash)) { + SV *namesv; + + /* Avoid checking main::main::main::... */ + if(substash == stash) continue; + /* Add :: and the key (minus the trailing ::) to newname. */ - SV *namesv + namesv = newSVpvn_flags(newname, newname_len, SVs_TEMP); sv_catpvs(namesv, "::"); sv_catpvn(namesv, key, len-2); mro_package_moved( substash, NULL, NULL, - SvPV_nolen_const(namesv), newname_len+len + SvPV_nolen_const(namesv), + level-1 ); } } diff --git a/proto.h b/proto.h index aff9574dfc75..23577f9c9019 100644 --- a/proto.h +++ b/proto.h @@ -2256,7 +2256,7 @@ PERL_CALLCONV void Perl_mro_method_changed_in(pTHX_ HV* stash) #define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \ assert(stash) -PERL_CALLCONV void Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, const GV * const gv, const char *newname, STRLEN newname_len); +PERL_CALLCONV void Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash, const GV * const gv, const char *newname, I32 newname_len); PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_MRO_REGISTER \ diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t index 3f13a7650d09..8b54ebda2563 100644 --- a/t/mro/package_aliases.t +++ b/t/mro/package_aliases.t @@ -10,7 +10,7 @@ BEGIN { use strict; use warnings; -plan(tests => 15); +plan(tests => 16); { package New; @@ -192,3 +192,10 @@ for( is $pet->speak, 'Woof!', 'the deleted stash is gone completely when freed'; } + +# mro_package_moved needs to check for self-referential packages. +# This broke Text::Template [perl #78362]. +watchdog 3; +*foo:: = \%::; +*Acme::META::Acme:: = \*Acme::; # indirect self-reference +pass("mro_package_moved and self-referential packages");