Fix two \&$tied regressions

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.

diff --git a/sv.c b/sv.c
index 2acfafc..ed3e264 100644 (file)
--- 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 0813791..d7a2454 100644 (file)
--- 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