Skip to content

Commit

Permalink
Perl_call_argv(): clean up the temps it creates when G_DISCARD is set
Browse files Browse the repository at this point in the history
We can only do this clean up for G_DISCARD since otherwise we might
free the return values on the stack.

Fixes Perl#22255
  • Loading branch information
tonycoz committed Jul 2, 2024
1 parent 4c99243 commit af9beff
Show file tree
Hide file tree
Showing 3 changed files with 39 additions and 2 deletions.
12 changes: 12 additions & 0 deletions ext/XS-APItest/APItest.xs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
9 changes: 8 additions & 1 deletion ext/XS-APItest/t/call.t
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@ use strict;

BEGIN {
require '../../t/test.pl';
plan(542);
plan(544);
use_ok('XS::APItest')
};
use Config;
Expand All @@ -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";
}
Expand Down
20 changes: 19 additions & 1 deletion perl.c
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand All @@ -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;
}

/*
Expand Down

0 comments on commit af9beff

Please sign in to comment.