From 62c1e33fbe385549e958f7699d17bfc9e0cd1ca2 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 12 Oct 2010 22:07:17 -0700
Subject: [PATCH] [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.
---
 embed.fnc               |  2 +-
 mro.c                   | 31 +++++++++++++++++++++++++------
 proto.h                 |  2 +-
 t/mro/package_aliases.t |  9 ++++++++-
 4 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index e111448..ee596d1 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 84626a5..830ef5a 100644
--- 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
--- 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
--- 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");
-- 
2.7.4