[perl #115440] Fix various leaks with fatal FETCH

Various pieces of code were creating an SV and then assigning to it
from a value that might be magical.  If the source scalar is magical,
it could die when magic is called, leaking the scalar that would have
been assigned to.

So we call get-magic before creating the new scalar, and then use a
non-magical assignment.

Also, anonhash and anonlist were doing nothing to protect the aggre-
gate if an argument should die on FETCH, resulting in a leak.

diff --git a/av.c b/av.c
index e9215f9..b707059 100644 (file)
--- a/av.c
+++ b/av.c
@@ -412,7 +412,10 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp)
        Newx(ary,size,SV*);
        AvALLOC(av) = ary;
        AvARRAY(av) = ary;
-       AvFILLp(av) = AvMAX(av) = size - 1;
+       AvMAX(av) = size - 1;
+       AvFILLp(av) = -1;
+       ENTER;
+       SAVEFREESV(av);
        for (i = 0; i < size; i++) {
            assert (*strp);
 
@@ -420,11 +423,15 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp)
               have multiple references to the same temp scalar (e.g.
               from a list slice) */
 
+           SvGETMAGIC(*strp); /* before newSV, in case it dies */
+           AvFILLp(av)++;
            ary[i] = newSV(0);
            sv_setsv_flags(ary[i], *strp,
-                          SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL);
+                          SV_DO_COW_SVSETSV|SV_NOSTEAL);
            strp++;
        }
+       SvREFCNT_inc_simple_void_NN(av);
+       LEAVE;
     }
     return av;
 }

diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index 04a1dd0..cdb3276 100644 (file)
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -241,7 +241,7 @@ do_test('reference to hash',
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 1
+    REFCNT = [12]
     FLAGS = \\(SHAREKEYS\\)
     IV = 1                                     # $] < 5.009
     NV = $FLOAT                                        # $] < 5.009
@@ -390,7 +390,7 @@ do_test('reference to blessed hash',
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 1
+    REFCNT = [12]
     FLAGS = \\(OBJECT,SHAREKEYS\\)
     IV = 0                                     # $] < 5.009
     NV = 0                                     # $] < 5.009
@@ -466,7 +466,7 @@ do_test('reference to hash containing Unicode',
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 1
+    REFCNT = [12]
     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
     UV = 1                                     # $] < 5.009
     NV = $FLOAT                                        # $] < 5.009
@@ -497,7 +497,7 @@ do_test('reference to hash containing Unicode',
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 1
+    REFCNT = [12]
     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
     UV = 1                                     # $] < 5.009
     NV = 0                                     # $] < 5.009
@@ -710,7 +710,7 @@ do_test('blessing to a class with embedded NUL characters',
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 1
+    REFCNT = [12]
     FLAGS = \\(OBJECT,SHAREKEYS\\)
     IV = 0                                     # $] < 5.009
     NV = 0                                     # $] < 5.009

diff --git a/mathoms.c b/mathoms.c
index e8d8105..e19b24c 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -804,8 +804,10 @@ Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg)
     PERL_ARGS_ASSERT_SAVE_LIST;
 
     for (i = 1; i <= maxsarg; i++) {
-       SV * const sv = newSV(0);
-       sv_setsv(sv,sarg[i]);
+       SV *sv;
+       SvGETMAGIC(sarg[i]);
+       sv = newSV(0);
+       sv_setsv_nomg(sv,sarg[i]);
        SSCHECK(3);
        SSPUSHPTR(sarg[i]);             /* remember the pointer */
        SSPUSHPTR(sv);                  /* remember the value */

diff --git a/pp.c b/pp.c
index 1c68e5a..d1cac93 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4804,20 +4804,30 @@ PP(pp_anonlist)
 PP(pp_anonhash)
 {
     dVAR; dSP; dMARK; dORIGMARK;
-    HV* const hv = newHV();
+    HV* const hv = (HV *)sv_2mortal((SV *)newHV());
 
     while (MARK < SP) {
-       SV * const key = *++MARK;
-       SV * const val = newSV(0);
+       SV * const key =
+           (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
+       SV *val;
        if (MARK < SP)
-           sv_setsv(val, *++MARK);
+       {
+           MARK++;
+           SvGETMAGIC(*MARK);
+           val = newSV(0);
+           sv_setsv(val, *MARK);
+       }
        else
+       {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
+           val = newSV(0);
+       }
        (void)hv_store_ent(hv,key,val,0);
     }
     SP = ORIGMARK;
-    mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
-           ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
+    if (PL_op->op_flags & OPf_SPECIAL)
+       mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
+    else XPUSHs(MUTABLE_SV(hv));
     RETURN;
 }
 
@@ -5072,9 +5082,11 @@ PP(pp_push)
     else {
        PL_delaymagic = DM_DELAY;
        for (++MARK; MARK <= SP; MARK++) {
-           SV * const sv = newSV(0);
+           SV *sv;
+           if (*MARK) SvGETMAGIC(*MARK);
+           sv = newSV(0);
            if (*MARK)
-               sv_setsv(sv, *MARK);
+               sv_setsv_nomg(sv, *MARK);
            av_store(ary, AvFILLp(ary)+1, sv);
        }
        if (PL_delaymagic & DM_ARRAY_ISA)

diff --git a/sv.c b/sv.c
index bcf3e6d..1bebb81 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8230,8 +8230,10 @@ Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
     dVAR;
     SV *sv;
 
+    if (flags & SV_GMAGIC)
+       SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
     new_SV(sv);
-    sv_setsv_flags(sv,oldstr,flags);
+    sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
     PUSH_EXTEND_MORTAL__SV_C(sv);
     SvTEMP_on(sv);
     return sv;

diff --git a/t/op/svleak.t b/t/op/svleak.t
index 07d9125..b5bd1c1 100644 (file)
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 37;
+plan tests => 38;
 
 # 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
@@ -275,6 +275,10 @@ leak(2, 0, sub {
 }, 'building anon hash with explosives does not leak');
 
 leak(2, 0, sub {
+    my $res = eval { [$die_on_fetch] };
+}, 'building anon array with explosives does not leak');
+
+leak(2, 0, sub {
     my @a;
     eval { push @a, $die_on_fetch };
 }, 'pushing exploding scalar does not leak');