From 0afba48f17ab3a5f576fdfaf4e4fc8671acde2bd Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 12 Aug 2012 17:57:35 -0700
Subject: [PATCH] Fix up outside pointers for my subs
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

I had not yet fixed Perl_pad_fixup_inner_anons to account for the
fact that my sub prototype CVs are stored in magic attached to
the SV slot in the pad, rather than directly in the pad.  It also
did not like & entries that close over subs defined in outer
or inner subs (‘my sub foo; sub bar; sub bar { &foo } }’ and
‘sub bar; sub bar { my sub foo; sub { sub foo { } } }’ respectively).

This was resulting in assertion failures, unsurprisingly.

Some of the tests I added, which were causing assertion failures, are
now failing for other reasons, and are marked as to-do.
---
 pad.c          | 13 +++++++++----
 t/cmd/lexsub.t | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 60 insertions(+), 5 deletions(-)

diff --git a/pad.c b/pad.c
index afd6389..960d725 100644
--- a/pad.c
+++ b/pad.c
@@ -2213,10 +2213,15 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 	    && *SvPVX_const(namesv) == '&')
 	{
 	  if (SvTYPE(curpad[ix]) == SVt_PVCV) {
-	    CV * const innercv = MUTABLE_CV(curpad[ix]);
-	    assert(CvWEAKOUTSIDE(innercv));
-	    assert(CvOUTSIDE(innercv) == old_cv);
-	    CvOUTSIDE(innercv) = new_cv;
+	    MAGIC * const mg =
+		SvMAGICAL(curpad[ix])
+		    ? mg_find(curpad[ix], PERL_MAGIC_proto)
+		    : NULL;
+	    CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
+	    if (CvOUTSIDE(innercv) == old_cv) {
+		assert(CvWEAKOUTSIDE(innercv));
+		CvOUTSIDE(innercv) = new_cv;
+	    }
 	  }
 	  else { /* format reference */
 	    SV * const rv = curpad[ix];
diff --git a/t/cmd/lexsub.t b/t/cmd/lexsub.t
index 348facf..f17eee0 100644
--- a/t/cmd/lexsub.t
+++ b/t/cmd/lexsub.t
@@ -8,7 +8,7 @@ BEGIN {
     *bar::like = *like;
 }
 no warnings 'deprecated';
-plan 107;
+plan 111;
 
 # -------------------- our -------------------- #
 
@@ -453,6 +453,19 @@ sub make_anon_with_my_sub{
     is eval{s2},eval{\&s1}, 'my sub in anon closure closing over sibling my sub';
   }
 }
+
+# Test my subs inside predeclared my subs
+{
+  my sub s2;
+  sub s2 {
+    my $x = 3;
+    my sub s3 { eval '$x' }
+    s3;
+  }
+  local $::TODO = 'closure problem?';
+  is s2, 3, 'my sub inside predeclared my sub';
+}
+
 {
   my $s = make_anon_with_my_sub;
   &$s;
@@ -488,3 +501,40 @@ is sub {
     s1
   }->()(), 3, 'state sub inside my sub closing over my sub uncle';
 
+{
+  my sub s2 { 3 };
+  sub not_lexical { state sub foo { \&s2 } foo }
+  is not_lexical->(), 3, 'state subs that reference my sub from outside';
+}
+
+# Test my subs inside predeclared package subs
+# This test also checks that CvOUTSIDE pointers are not mangled when the
+# inner sub’s CvOUTSIDE points to another sub.
+sub not_lexical2;
+sub not_lexical2 {
+  my $x = 23;
+  my sub bar;
+  sub not_lexical3 {
+    not_lexical2();
+    sub bar { $x }
+  };
+  bar
+}
+$::TODO = 'closing over wrong sub';
+is not_lexical3, 23, 'my subs inside predeclared package subs';
+
+# Test my subs inside predeclared package sub, where the lexical sub is
+# declared outside the package sub.
+# This checks that CvOUTSIDE pointers are fixed up even when the sub is
+# not declared inside the sub that its CvOUTSIDE points to.
+{
+  my sub foo;
+  sub not_lexical4;
+  sub not_lexical4 {
+    my $x = 234;
+    sub foo { $x }
+    foo
+  }
+  is not_lexical4, 234,
+    'my sub defined in predeclared pkg sub but declared outside';
+}
-- 
2.7.4