av.c - av_store() do the refcount dance around magic av's

The api for av_store() says it is the callers responsibility to call
SvREFCNT_inc() on the stored item after the store is successful.

However inside of av_store() we store the item in the C level array before we
trigger magic. To a certain extent this is required because mg_set(av) needs
to be able to see the newly stored item.

But if the mg_set() or other magic associated with the av_store() operation
fails, we would end up with a double free situation, as we will long jump up
the stack above and out of the call to av_store(), freeing the mortal as we go
(via Perl_croak()), but leaving the reference to the now freed pointer in the
array. When the next SV is allocated the reference will be reused, and then we
are in a double free scenario.

I see comments in pp_aassign talking about defusing the temps stack for the
parameters it is passing in, and things like this, which at first looked
related. But that commentary doesn't seem that relevant to me, as this bug
could happen any time a scalar owned by one data structure was copied into an
array with set magic which could die. Eg, I can easily imagine XS code that
expected code like this (assume it handles magic properly) to work:

    SV **svp = av_fetch(av1,0,1);
    if (av_store(av2,0,*svp))
        SvREFCNT_inc(*svp);

but if av2 has set magic and it dies the end result will be that both av1 and
av2 contain a visible reference to *svp, but its refcount will be 1. So I think
this is a bug regardless of what pp_aassign does.

This fixes https://github.com/Perl/perl5/issues/20675

3 files changed, 128 insertions, 0 deletions

diff --git a/av.c b/av.c
index ae902dd3ec..d9868f4407 100644
--- a/av.c
+++ b/av.c
@@ -373,10 +373,47 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
     }
     else if (AvREAL(av))
         SvREFCNT_dec(ary[key]);
+
+    /* store the val into the AV before we call magic so that the magic can
+     * "see" the new value. Especially set magic on the AV itself. */
     ary[key] = val;
+
     if (SvSMAGICAL(av)) {
         const MAGIC *mg = SvMAGIC(av);
         bool set = TRUE;
+        /* We have to increment the refcount on val before we call any magic,
+         * as it is now stored in the AV (just before this block), we will
+         * then call the magic handlers which might die/Perl_croak, and
+         * longjmp up the stack to the most recent exception trap. Which means
+         * the caller code that would be expected to handle the refcount
+         * increment likely would never be executed, leading to a double free.
+         * This can happen in a case like
+         *
+         * @ary = (1);
+         *
+         * or this:
+         *
+         * if (av_store(av,n,sv)) SvREFCNT_inc(sv);
+         *
+         * where @ary/av has set magic applied to it which can die. In the
+         * first case the sv representing 1 would be mortalized, so when the
+         * set magic threw an exception it would be freed as part of the
+         * normal stack unwind. However this leaves the av structure still
+         * holding a valid visible pointer to the now freed value. In practice
+         * the next SV created will reuse the same reference, but without the
+         * refcount to account for the previous ownership and we end up with
+         * warnings about a totally different variable being double freed in
+         * the form of "attempt to free unreferenced variable"
+         * warnings/errors.
+         *
+         * https://github.com/Perl/perl5/issues/20675
+         *
+         * Arguably the API for av_store is broken in the face of magic. Instead
+         * av_store should be responsible for the refcount increment, and only
+         * not do it when specifically told to do so (eg, when storing an
+         * otherwise unreferenced scalar into an AV).
+         */
+        SvREFCNT_inc(val);  /* see comment above */
         for (; mg; mg = mg->mg_moremagic) {
           if (!isUPPER(mg->mg_type)) continue;
           if (val) {
@@ -389,6 +426,10 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val)
         }
         if (set)
            mg_set(MUTABLE_SV(av));
+        /* And now we are done the magic, we have to decrement it back as the av_store() api
+         * says the caller is responsible for the refcount increment, assuming
+         * av_store returns true. */
+        SvREFCNT_dec(val);
     }
     return &ary[key];
 }
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 00fccb3654..ff7667b24a 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -125,8 +125,19 @@ S_myset_set(pTHX_ SV* sv, MAGIC* mg)
     return 0;
 }
 
+static int
+S_myset_set_dies(pTHX_ SV* sv, MAGIC* mg)
+{
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+    croak("in S_myset_set_dies");
+    return 0;
+}
+
+
 static MGVTBL vtbl_foo, vtbl_bar;
 static MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 };
+static MGVTBL vtbl_myset_dies = { 0, S_myset_set_dies, 0, 0, 0, 0, 0, 0 };
 
 static int
 S_mycopy_copy(pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *name, I32 namlen) {
@@ -4839,6 +4850,13 @@ test_get_vtbl()
     # where that magic's job is to increment thingy
 
 void
+sv_magic_myset_dies(SV *rsv, SV *thingy)
+CODE:
+    sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset_dies,
+        (const char *)thingy, 0);
+
+
+void
 sv_magic_myset(SV *rsv, SV *thingy)
 CODE:
     sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset,
@@ -4863,6 +4881,25 @@ sv_magic_mycopy_count(SV *rsv)
     OUTPUT:
         RETVAL
 
+int
+my_av_store(SV *rsv, IV i, SV *sv)
+    CODE:
+        if (av_store((AV*)SvRV(rsv), i, sv)) {
+            SvREFCNT_inc(sv);
+            RETVAL = 1;
+        } else {
+            RETVAL = 0;
+        }
+    OUTPUT:
+        RETVAL
+
+STRLEN
+sv_refcnt(SV *sv)
+    CODE:
+        RETVAL = SvREFCNT(sv);
+    OUTPUT:
+        RETVAL
+
 
 MODULE = XS::APItest            PACKAGE = XS::APItest
 
diff --git a/ext/XS-APItest/t/magic.t b/ext/XS-APItest/t/magic.t
index 165121d3e4..8189523dc1 100644
--- a/ext/XS-APItest/t/magic.t
+++ b/ext/XS-APItest/t/magic.t
@@ -76,4 +76,54 @@ is $@, "", 'PERL_MAGIC_ext is permitted on read-only things';
     is($i, 0, "hash () with set magic");
 }
 
+{
+    # check if set magic triggered by av_store() via aassign results in
+    # unreferenced scalars being freed. IOW, results in a double store
+    # without a corresponding refcount bump. If things work properly this
+    # should not warn. If there is an issue it will.
+    my @warn;
+    local $SIG{__WARN__}= sub { push @warn, $_[0] };
+    {
+        my (@a, $i);
+        sv_magic_myset_dies(\@a, $i);
+        eval {
+            $i = 0;
+            @a = (1);
+        };
+    }
+    is(0+@warn, 0,
+        "If AV set magic dies via aassign it should not warn about double free");
+    @warn = ();
+    {
+        my (@a, $i, $j);
+        sv_magic_myset_dies(\@a, $i);
+        eval {
+            $j = "blorp";
+            my_av_store(\@a,0,$j);
+        };
+        my $base_refcount = 2; # not sure where these come from.
+        if (\$a[0] == \$j) {
+            # in this case we expect to have an extra 2 refcounts,
+            # one from $a[0] and one from $j itself.
+            is( sv_refcnt($j), $base_refcount + 2,
+                "\$a[0] is \$j, so refcount(\$j) should be 4");
+        } else {
+            # Note this branch isn't exercised. Whether by design
+            # or not. I leave it here because it is a possible valid
+            # outcome. It is marked TODO so if we start going down
+            # this path we do so knowingly.
+            diag "av_store has changed behavior - please review this test";
+            TODO:{
+                local $TODO = "av_store bug stores even if it dies during magic";
+                # in this case we expect to have only 1 extra refcount,
+                # from $j itself.
+                is( sv_refcnt($j), $base_refcount + 1,
+                    "\$a[0] is not \$j, so refcount(\$j) should be 3");
+            }
+        }
+    }
+    is(0+@warn, 0,
+        "AV set magic that dies via av_store should not warn about double free");
+}
+
 done_testing;