From: David Mitchell <davem@iabyn.com>
Date: Sun, 25 Apr 2010 15:28:41 +0000 (+0100)
Subject: avoid multiple FETCHes
X-Git-Tag: v5.13.1~156
X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/39cf747a86645fde6898cd6d09d351d50755c2fa

avoid multiple FETCHes

The fix 2d961f6deff7 for RT #5475 included a mechanism for the early
calling of get magic on something like

    $tied[0];

so that even though the element is used in void context, we still call
FETCH. Some people seem to rely on this.

However, the call to mg_get() didn't distinguish between a tiedelem
member retrieved from a tied array/hash, and a tiedscalar element
retrieved from a plain array/hash. In the latter case, the S_GSKIP
protection mechanism doesn't apply and a simple $foo = $h{tiedelem}
generated two calls to FETCH.

Fix this by only calling mg_get() on the element if it came from a *tied*
array/hash.

A side-effect of this fix is that the following no longer calls FETCH:

    my @plain_array;
    tie $plain_array[0], ....; # element 0 is now a tied scalar
    $plain_array[0]; # void context:  no longer calls FETCH.

This required one test in op/tie.t to be fixed up, but in general I think
this is a reasonable compromise.
---

diff --git a/pp_hot.c b/pp_hot.c
index e1b1e8c..aa038d3 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -663,7 +663,7 @@ PP(pp_aelemfast)
     SV** const svp = av_fetch(av, PL_op->op_private, lval);
     SV *sv = (svp ? *svp : &PL_sv_undef);
     EXTEND(SP, 1);
-    if (!lval && SvGMAGICAL(sv))	/* see note in pp_helem() */
+    if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 	mg_get(sv);
     PUSHs(sv);
     RETURN;
@@ -1858,7 +1858,7 @@ PP(pp_helem)
      * meant the original regex may be out of scope by now. So as a
      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
      * being called too many times). */
-    if (!lval && SvGMAGICAL(sv))
+    if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
 	mg_get(sv);
     PUSHs(sv);
     RETURN;
@@ -2996,7 +2996,7 @@ PP(pp_aelem)
 	    vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
-    if (!lval && SvGMAGICAL(sv))	/* see note in pp_helem() */
+    if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
 	mg_get(sv);
     PUSHs(sv);
     RETURN;
diff --git a/t/op/tie.t b/t/op/tie.t
index 2ef7101..bd3f2e5 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -337,7 +337,7 @@ sub FETCH {
 }
 package main;
 tie $a->{foo}, "Foo", $a, "foo";
-$a->{foo}; # access once
+my $s = $a->{foo}; # access once
 # the hash element should not be tied anymore
 print defined tied $a->{foo} ? "not ok" : "ok";
 EXPECT
@@ -768,3 +768,25 @@ foreach ($a[0], $h{a}) {
 }
 # on failure, chucks up 'premature free' etc messages
 EXPECT
+########
+# RT 5475:
+# the initial fix for this bug caused tied scalar FETCH to be called
+# multiple times when that scalar was an element in an array. Check it
+# only gets called once now.
+
+sub TIESCALAR { bless [], $_[0] }
+my $c = 0;
+sub FETCH { $c++; 0 }
+sub FETCHSIZE { 1 }
+sub STORE { $c += 100; 0 }
+
+
+my (@a, %h);
+tie $a[0],   'main';
+tie $h{foo}, 'main';
+
+my $i = 0;
+my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
+print "x=$x c=$c\n";
+EXPECT
+x=0 c=4