From: David Mitchell <davem@iabyn.com>
Date: Fri, 4 Jun 2010 22:09:21 +0000 (+0100)
Subject: fix for RT #8438: $tied->() doesn't call FETCH
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7c75014e4b3bd5ebe368b5d6b981f310525d1389;p=p5sagit%2Fp5-mst-13.2.git

fix for RT #8438: $tied->() doesn't call FETCH

pp_entersub checked for ROK *before* calling magic. If the tied scalar
already had ROK set (perhaps from a previous time), then get magic (and
hence FETCH) wasn't called.
---

diff --git a/lib/overload.t b/lib/overload.t
index 2b28c5a..ca58619 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -1747,7 +1747,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 		'', 1, 2, 0 ];
 
 	$subs{'&{}'} = '%s';
-	push @terms, [ sub {99}, '&{%s}', '&{}', '', 1, 2, 0 ];
+	push @terms, [ sub {99}, 'do {&{%s} for 1,2}', '&{})(&{}', '', 2, 4, 0 ];
 
 	our $RT57012A = 88;
 	our $RT57012B;
diff --git a/pp_hot.c b/pp_hot.c
index 1a7c13f..dc2c442 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2726,29 +2726,20 @@ PP(pp_entersub)
 	}
 	break;
     default:
-	if (!SvROK(sv)) {
+	if (sv == &PL_sv_yes) {		/* unfound import, ignore */
+	    if (hasargs)
+		SP = PL_stack_base + POPMARK;
+	    RETURN;
+	}
+	SvGETMAGIC(sv);
+	if (SvROK(sv)) {
+	    SV * const * sp = &sv;	/* Used in tryAMAGICunDEREF macro. */
+	    tryAMAGICunDEREF(to_cv);
+	}
+	else {
 	    const char *sym;
 	    STRLEN len;
-	    if (sv == &PL_sv_yes) {		/* unfound import, ignore */
-		if (hasargs)
-		    SP = PL_stack_base + POPMARK;
-		RETURN;
-	    }
-	    if (SvGMAGICAL(sv)) {
-		mg_get(sv);
-		if (SvROK(sv))
-		    goto got_rv;
-		if (SvPOKp(sv)) {
-		    sym = SvPVX_const(sv);
-		    len = SvCUR(sv);
-		} else {
-		    sym = NULL;
-		    len = 0;
-		}
-	    }
-	    else {
-		sym = SvPV_const(sv, len);
-            }
+	    sym = SvPV_nomg_const(sv, len);
 	    if (!sym)
 		DIE(aTHX_ PL_no_usym, "a subroutine");
 	    if (PL_op->op_private & HINT_STRICT_REFS)
@@ -2756,11 +2747,6 @@ PP(pp_entersub)
 	    cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
 	    break;
 	}
-  got_rv:
-	{
-	    SV * const * sp = &sv;		/* Used in tryAMAGICunDEREF macro. */
-	    tryAMAGICunDEREF(to_cv);
-	}	
 	cv = MUTABLE_CV(SvRV(sv));
 	if (SvTYPE(cv) == SVt_PVCV)
 	    break;
diff --git a/t/op/tie.t b/t/op/tie.t
index ad3031a..38c5cff 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -913,3 +913,19 @@ sub EXTEND   { }
 
 EXPECT
 ok
+########
+# RT 8438: Tied scalars don't call FETCH when subref is dereferenced
+
+sub TIESCALAR { bless {} }
+
+my $fetch = 0;
+my $called = 0;
+sub FETCH { $fetch++; sub { $called++ } }
+
+tie my $f, 'main';
+$f->(1) for 1,2;
+print "fetch=$fetch\ncalled=$called\n";
+
+EXPECT
+fetch=2
+called=2