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 (file)
--- 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 (file)
--- 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 (file)
--- 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