From 2e9c7c448d234fba91c5bc097476f4622408b945 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 2 Jul 2024 15:11:22 +1000
Subject: [PATCH] Perl_call_argv(): clean up the temps it creates when
 G_DISCARD is set

We can only do this clean up for G_DISCARD since otherwise we might
free the return values on the stack.

Fixes #22255
---
 ext/XS-APItest/APItest.pm |  2 +-
 ext/XS-APItest/APItest.xs | 12 ++++++++++++
 ext/XS-APItest/t/call.t   |  9 ++++++++-
 perl.c                    | 20 +++++++++++++++++++-
 4 files changed, 40 insertions(+), 3 deletions(-)

diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 763b20731696..e356c5a3b169 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.36';
+our $VERSION = '1.37';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 4034312c8dd1..455bdf67d632 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -2820,6 +2820,18 @@ call_argv(subname, flags, ...)
         EXTEND(SP, 1);
         PUSHs(sv_2mortal(newSViv(i)));
 
+bool
+call_argv_cleanup()
+  CODE:
+    IV old_count = PL_sv_count;
+    char one[] = "one"; /* non const strings */
+    char two[] = "two";
+    char *args[] = { one, two, NULL };
+    Perl_call_argv(aTHX_ "called_by_argv_cleanup", G_DISCARD | G_LIST, args);
+    RETVAL = PL_sv_count == old_count;
+  OUTPUT:
+    RETVAL
+
 void
 call_method(methname, flags, ...)
     char* methname
diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 04a6d8c3aba4..d17d67c96209 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -11,7 +11,7 @@ use strict;
 
 BEGIN {
     require '../../t/test.pl';
-    plan(542);
+    plan(544);
     use_ok('XS::APItest')
 };
 use Config;
@@ -35,6 +35,13 @@ sub i {
 call_sv_C();
 is($call_sv_count, 7, "call_sv_C passes");
 
+my $did_argv;
+sub called_by_argv_cleanup {
+    $did_argv++ if @_;
+}
+ok(call_argv_cleanup(), "call_argv() cleans up temps if asked to");
+ok($did_argv, "call_argv_cleanup() did the actual call with arguments");
+
 sub d {
     die "its_dead_jim\n";
 }
diff --git a/perl.c b/perl.c
index 0f1872dd177b..4183e2ce046e 100644
--- a/perl.c
+++ b/perl.c
@@ -3040,6 +3040,16 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
 #else
                 0;
 #endif
+    /* For a reference counted stack the arguments are cleaned up
+     * when the stack is popped.
+     */
+    if (!is_rc && (flags & G_DISCARD) != 0) {
+        ENTER;
+        SAVETMPS;
+        /* leave G_DISCARD on to clean up any return values
+         * from the stack in call_sv().
+         */
+    }
     PUSHMARK(PL_stack_sp);
     while (*argv) {
         SV *newsv = newSVpv(*argv,0);
@@ -3049,7 +3059,15 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv)
             sv_2mortal(newsv);
         argv++;
     }
-    return call_pv(sub_name, flags);
+
+    SSize_t count = call_pv(sub_name, flags);
+
+    if (!is_rc && (flags & G_DISCARD) != 0) {
+        FREETMPS;
+        LEAVE;
+    }
+
+    return count;
 }
 
 /*