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

2 files changed, 87 insertions, 0 deletions

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;