RT 8857: premature free in local of tied element

[The original bug report concerned local($_) remained tied, but while
looking at it, Nicholas found some related code that popped up premature
free errors. This commit fixes the freeing issue rather than the issue of
the original bug report ]

Background:

    local $a[0]

does, approximately:

    svp = av_fetch(av);
    SAVE(av,*svp);
    sv = newSV();
    *svp = sv;

This used to leak when av was tied, as the new sv only got embedded in
*svp, which for tied arrays is a temporary placeholder rather than
somewhere within AvARRAY. This leak was fixed in 2002 by adding the
following:

    if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
	sv_2mortal(sv);

which worked, except for the following:

    sub f { local $_[0] }
    f($_) for ($tied[0]);

Here, @_ is a real array not a tied one, yet its first element is a
PERL_MAGIC_tiedelem which trigged the test above. So the sv got
mortalised *and* stored in the array, so got freed twice. The fix is
to test the *array/hash* for tied-ness rather than the element.

diff --git a/scope.c b/scope.c
index 414f5b5..de7d205 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -619,7 +619,7 @@ Perl_save_aelem_flags(pTHX_ AV *av, I32 idx, SV **sptr, const U32 flags)
      * won't actually be stored in the array - so it won't get
      * reaped when the localize ends. Ensure it gets reaped by
      * mortifying it instead. DAPM */
-    if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+    if (SvTIED_mg(av, PERL_MAGIC_tied))
        sv_2mortal(sv);
 }
 
@@ -645,7 +645,7 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
      * won't actually be stored in the hash - so it won't get
      * reaped when the localize ends. Ensure it gets reaped by
      * mortifying it instead. DAPM */
-    if (SvTIED_mg(sv, PERL_MAGIC_tiedelem))
+    if (SvTIED_mg(hv, PERL_MAGIC_tied))
        sv_2mortal(sv);
 }
 

diff --git a/t/op/svleak.t b/t/op/svleak.t
index 028647a..669b00e 100644 (file)
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -13,7 +13,7 @@ BEGIN {
        or skip_all("XS::APItest not available");
 }
 
-plan tests => 3;
+plan tests => 4;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -35,3 +35,14 @@ my @a;
 leak(5, 0, sub {},                 "basic check 1 of leak test infrastructure");
 leak(5, 0, sub {push @a,1;pop @a}, "basic check 2 of leak test infrastructure");
 leak(5, 1, sub {push @a,1;},       "basic check 3 of leak test infrastructure");
+
+sub TIEARRAY   { bless [], $_[0] }
+sub FETCH      { $_[0]->[$_[1]] }
+sub STORE      { $_[0]->[$_[1]] = $_[2] }
+
+# local $tied_elem[..] leaks <20020502143736.N16831@dansat.data-plan.com>"
+{
+    tie my @a, 'main';
+    leak(5, 0, sub {local $a[0]}, "local \$tied[0]");
+}
+

diff --git a/t/op/tie.t b/t/op/tie.t
index 0ec8050..2ef7101 100644 (file)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -747,4 +747,24 @@ require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 require: s1=REQUIRE-0-RQ
 require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
 require: s3=REQUIRE-0-RQ
+########
+# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
+#          element
+
+sub TIEARRAY { bless [], $_[0] }
+sub TIEHASH  { bless [], $_[0] }
+sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+
+
+sub f {
+    local $_[0];
+}
+tie @a, 'main';
+tie %h, 'main';
 
+foreach ($a[0], $h{a}) {
+    f($_);
+}
+# on failure, chucks up 'premature free' etc messages
+EXPECT