This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Better handling of magic methods freeing the SV
authorDavid Mitchell <davem@iabyn.com>
Thu, 30 Dec 2010 10:32:44 +0000 (10:32 +0000)
committerDavid Mitchell <davem@iabyn.com>
Thu, 30 Dec 2010 10:51:45 +0000 (10:51 +0000)
This is a fix for RT #81230 (and more). Currently, mg_get() works around
the case where the called magic (e.g. FETCH) frees the magic SV. It does
this by unconditionally pushing the SV on the tmps stack before invoking
the method.

There are two issues with this. Firstly, it may artificially extend the
life of the SV. This was the root of the problem with #81230. There, the
DB_File code, under -T, created a tainted tied object. Accessing the
object (within FETCH as it happens), caused mg_get() to be invoked on the
object (due to the taint magic), and thus extend the life of the object.
This then caused c<untie %h if $h{k}> to give the warning
    untie attempted while 1 inner references still exist.
This only became noticeable after efaf36747029c85b4d8825318cb4d485a0bb350e,
which stopped wrapping magic method calls in SAVETMPS/FREETMPS.

The second issue issue that this protection only applies to mg_get();
functions like mg_set() can still segfault if the SV is deleted.

This commit fixes both problems as follows:

First, the protection mechanism is moved out of mg_get() and into
save_magic() / restore_magic(), so that it protects more things.
Secondly, the protection is now:

* in save_magic(), SvREFCNT_inc() the SV, thus protecting it from being
  freed during FETCH (or whatever)

* in restore_magic(), SvREFCNT_dec() the SV, undoing the protection
  without extending the life of the SV, *except* if the refcount is
  1 (ie FETCH tried to free it), then push it on the mortals stack
  to extend it life a bit so our callers wont choke on it.

mg.c
t/op/taint.t
t/op/tie.t

diff --git a/mg.c b/mg.c
index 8053bf1..a6912a0 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -95,6 +95,10 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 
     PERL_ARGS_ASSERT_SAVE_MAGIC;
 
+    /* guard against sv having being freed midway by holding a private
+       reference. */
+    SvREFCNT_inc_simple_void_NN(sv);
+
     assert(SvMAGICAL(sv));
     /* Turning READONLY off for a copy-on-write scalar (including shared
        hash keys) is a bad idea.  */
@@ -199,23 +203,11 @@ Perl_mg_get(pTHX_ SV *sv)
 {
     dVAR;
     const I32 mgs_ix = SSNEW(sizeof(MGS));
-    const bool was_temp = cBOOL(SvTEMP(sv));
     bool have_new = 0;
     MAGIC *newmg, *head, *cur, *mg;
-    /* guard against sv having being freed midway by holding a private
-       reference. */
 
     PERL_ARGS_ASSERT_MG_GET;
 
-    /* sv_2mortal has this side effect of turning on the TEMP flag, which can
-       cause the SV's buffer to get stolen (and maybe other stuff).
-       So restore it.
-    */
-    sv_2mortal(SvREFCNT_inc_simple_NN(sv));
-    if (!was_temp) {
-       SvTEMP_off(sv);
-    }
-
     save_magic(mgs_ix, sv);
 
     /* We must call svt_get(sv, mg) for each valid entry in the linked
@@ -264,12 +256,6 @@ Perl_mg_get(pTHX_ SV *sv)
     }
 
     restore_magic(INT2PTR(void *, (IV)mgs_ix));
-
-    if (SvREFCNT(sv) == 1) {
-       /* We hold the last reference to this SV, which implies that the
-          SV was deleted as a side effect of the routines we called.  */
-       SvOK_off(sv);
-    }
     return 0;
 }
 
@@ -3168,7 +3154,21 @@ S_restore_magic(pTHX_ const void *p)
         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
     }
-
+    if (SvREFCNT(sv) == 1) {
+       /* We hold the last reference to this SV, which implies that the
+          SV was deleted as a side effect of the routines we called.
+          So artificially keep it alive a bit longer.
+          We avoid turning on the TEMP flag, which can cause the SV's
+          buffer to get stolen (and maybe other stuff). */
+       int was_temp = SvTEMP(sv);
+       sv_2mortal(sv);
+       if (!was_temp) {
+           SvTEMP_off(sv);
+       }
+       SvOK_off(sv);
+    }
+    else
+       SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
 }
 
 /* clean up the mess created by Perl_sighandler().
index 78b3d55..fc2fcd7 100644 (file)
@@ -17,7 +17,7 @@ use Config;
 use File::Spec::Functions;
 
 BEGIN { require './test.pl'; }
-plan tests => 338;
+plan tests => 339;
 
 $| = 1;
 
@@ -1445,6 +1445,32 @@ end
     ok(! tainted($b), "regex optimization of single char /[]/i doesn't taint");
 }
 
+{
+    # RT 81230: tainted value during FETCH created extra ref to tied obj
+
+    package P81230;
+    use warnings;
+
+    my %h;
+
+    sub TIEHASH {
+       my $x = $^X; # tainted
+       bless  \$x;
+    }
+    sub FETCH { my $x = $_[0]; $$x . "" }
+
+    tie %h, 'P81230';
+
+    my $w = "";
+    local $SIG{__WARN__} = sub { $w .= "@_" };
+
+    untie %h if $h{"k"};
+
+    ::is($w, "", "RT 81230");
+}
+
+
+
 # This may bomb out with the alarm signal so keep it last
 SKIP: {
     skip "No alarm()"  unless $Config{d_alarm};
index b68102e..98f4279 100644 (file)
@@ -962,3 +962,36 @@ EXPECT
 ok tie
 ok tied
 ok untie
+########
+#
+# STORE freeing tie'd AV
+sub TIEARRAY  { bless [] }
+sub STORE     { *a = []; 1 }
+sub STORESIZE { }
+sub EXTEND    { }
+tie @a, 'main';
+$a[0] = 1;
+EXPECT
+########
+#
+# CLEAR freeing tie'd AV
+sub TIEARRAY  { bless [] }
+sub CLEAR     { *a = []; 1 }
+sub STORESIZE { }
+sub EXTEND    { }
+sub STORE     { }
+tie @a, 'main';
+@a = (1,2,3);
+EXPECT
+########
+#
+# FETCHSIZE freeing tie'd AV
+sub TIEARRAY  { bless [] }
+sub FETCHSIZE { *a = []; 100 }
+sub STORESIZE { }
+sub EXTEND    { }
+sub STORE     { }
+tie @a, 'main';
+print $#a,"\n"
+EXPECT
+99