[perl #78362] Make mro_package_moved check for recursion

The existence of main::main::... caused mro_package_moved to break
Text::Template, and probably Acme::Meta as well.

diff --git a/embed.fnc b/embed.fnc
index e111448..ee596d1 100644 (file)
--- 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 84626a5..830ef5a 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -589,26 +589,35 @@ non-existent packages that have corresponding entries in C<stash>.
 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 aff9574..23577f9 100644 (file)
--- 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 3f13a76..8b54ebd 100644 (file)
--- 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");