From ff55a0191f195519f46838f62b3cd22a95056579 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 1 Sep 2011 16:16:32 -0700
Subject: Fix two \&$tied regressions
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

If the tied variable holds a reference, but changes to something else
when FETCH is called, perl crashes, as of commit 9d0f7ed75
(5.10.1/5.12.0):

sub ::72 { 73 };
sub TIESCALAR {bless[]}
sub STORE{}
sub FETCH { 72 }
tie my $x, "main";
$x = \$y;
\&$x;

That’s because commit 7a5fd60d4 caused double magic for one branch of
an if/else chain in sv_2cv (by using gv_fetchsv), so commit 9d0f7ed75
removed the SvGETMAGIC preceding the if/else, putting it inside each
branch.  That meant that the type would be checked before get-magic
was called.  So the type could change unexpectedly.

Due to another bug, this did not affect globs returned from tied array
elements, which got stringified, and hence worked in sv_2cv.  But that
bug was fixed in 5.14.0 by commit 13be902ce, which allowed typeglobs
to be returned unflattened through elements of tied aggregates, caus-
ing this to stop working (‘Not a CODE reference’ instead of 73):

sub ::72 { 73 };
sub TIEARRAY {bless[]}
sub STORE{}
sub FETCH { 72 }
tie my @x, "main";
my $elem = \$x[0];
$$elem = *bar;
print &{\&$$elem}, "\n";

This commit fixes both issues by putting the SvGETMAGIC call
back where it belongs, above the if/else chain, and by using
SvPV_nomg_const and gv_fetchpvn_flags instead of gv_fetchsv, to avoid
an extra magic call.
---
 sv.c       | 12 ++++++++----
 t/op/tie.t | 26 ++++++++++++++++++++++++++
 2 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/sv.c b/sv.c
index 2acfafc683..ed3e264d03 100644
--- a/sv.c
+++ b/sv.c
@@ -8847,8 +8847,8 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
 	/* FALL THROUGH */
 
     default:
+	SvGETMAGIC(sv);
 	if (SvROK(sv)) {
-	    SvGETMAGIC(sv);
 	    if (SvAMAGIC(sv))
 		sv = amagic_deref_call(sv, to_cv_amg);
 	    /* At this point I'd like to do SPAGAIN, but really I need to
@@ -8867,11 +8867,15 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
 		Perl_croak(aTHX_ "Not a subroutine reference");
 	}
 	else if (isGV_with_GP(sv)) {
-	    SvGETMAGIC(sv);
 	    gv = MUTABLE_GV(sv);
 	}
-	else
-	    gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
+	else {
+	    STRLEN len;
+	    const char * const nambeg = SvPV_nomg_const(sv, len);
+	    gv = gv_fetchpvn_flags(
+		nambeg, len, lref | SvUTF8(sv), SVt_PVCV
+	    );
+	}
 	*gvp = gv;
 	if (!gv) {
 	    *st = NULL;
diff --git a/t/op/tie.t b/t/op/tie.t
index 081379128f..d7a24540bd 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -1072,3 +1072,29 @@ tiehandle
 before print
 print()
 Can't find label FOO at - line 4.
+########
+
+# \&$tied with $tied holding a reference before the fetch (but not after)
+sub ::72 { 73 };
+sub TIESCALAR {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my $x, "main";
+$x = \$y;
+\&$x;
+print "ok\n";
+EXPECT
+ok
+########
+
+# \&$tied with $tied holding a PVLV glob before the fetch (but not after)
+sub ::72 { 73 };
+sub TIEARRAY {bless[]}
+sub STORE{}
+sub FETCH { 72 }
+tie my @x, "main";
+my $elem = \$x[0];
+$$elem = *bar;
+print &{\&$$elem}, "\n";
+EXPECT
+73
-- 
cgit v1.2.1