From: Andrey Rachitskiy Date: Mon, 3 Aug 2026 20:06:01 +0000 Subject: [PATCH] Fix crash on recursively tied Perl return values Perl's leave_adjust_stacks() invokes get-magic on magical subroutine return values. When a tied scalar's FETCH returns another tied scalar, that recurses without bound and SIGSEGVs inside call_sv(), before PL/Perl can copy the return value. Patch OP_LEAVESUB in the callee's op tree while call_sv() runs, so tied scalar returns are resolved under check_stack_depth() before leave_adjust_stacks() sees them. FETCH methods are patched the same way when first invoked from that path. Bug: #19601 Author: Andrey Rachitskiy Reported-by: Yuelin Wang <1217816127@qq.com> Discussion: https://www.postgresql.org/message-id/19601-92d59d2242c00966%40postgresql.org --- contrib/bool_plperl/expected/bool_plperl.out | 41 ++++- contrib/bool_plperl/expected/bool_plperlu.out | 41 ++++- contrib/bool_plperl/sql/bool_plperl.sql | 31 ++++ contrib/bool_plperl/sql/bool_plperlu.sql | 31 ++++ src/pl/plperl/plperl.c | 210 ++++++++++++++++++++++++-- 5 files changed, 343 insertions(+), 11 deletions(-) diff --git a/contrib/bool_plperl/expected/bool_plperl.out b/contrib/bool_plperl/expected/bool_plperl.out index 183dc07b3fb..9e354dc6b3b 100644 --- a/contrib/bool_plperl/expected/bool_plperl.out +++ b/contrib/bool_plperl/expected/bool_plperl.out @@ -102,11 +102,50 @@ SELECT spi_test(); (1 row) +-- Tied scalar whose FETCH returns a plain value. +CREATE FUNCTION perl_tie_ok() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperl +AS $perl$ + package BoolTieOk; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { return 1; } + package main; + tie my $y, 'BoolTieOk'; + return $y; +$perl$; +SELECT perl_tie_ok(); + perl_tie_ok +------------- + t +(1 row) + +-- Tied scalar whose FETCH returns another tied scalar. +CREATE FUNCTION perl_tie_recurse() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperl +AS $perl$ + package BoolTieRecurse; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { my $x; tie $x, 'BoolTieRecurse'; return $x; } + package main; + tie my $y, 'BoolTieRecurse'; + return $y; +$perl$; +-- Pin the limit so the HINT does not depend on the installation default. +SET max_stack_depth = '100kB'; +SELECT perl_tie_recurse(); +ERROR: stack depth limit exceeded +HINT: Increase the configuration parameter "max_stack_depth" (currently 100kB), after ensuring the platform's stack depth limit is adequate. +CONTEXT: PL/Perl function "perl_tie_recurse" +RESET max_stack_depth; DROP EXTENSION plperl CASCADE; -NOTICE: drop cascades to 6 other objects +NOTICE: drop cascades to 8 other objects DETAIL: drop cascades to extension bool_plperl drop cascades to function perl2int(integer) drop cascades to function perl2text(text) drop cascades to function perl2undef() drop cascades to function bool2perl(boolean,boolean,boolean) drop cascades to function spi_test() +drop cascades to function perl_tie_ok() +drop cascades to function perl_tie_recurse() diff --git a/contrib/bool_plperl/expected/bool_plperlu.out b/contrib/bool_plperl/expected/bool_plperlu.out index 1496bbafac8..d16349d5960 100644 --- a/contrib/bool_plperl/expected/bool_plperlu.out +++ b/contrib/bool_plperl/expected/bool_plperlu.out @@ -102,11 +102,50 @@ SELECT spi_test(); (1 row) +-- Tied scalar whose FETCH returns a plain value. +CREATE FUNCTION perl_tie_ok() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperlu +AS $perl$ + package BoolTieOk; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { return 1; } + package main; + tie my $y, 'BoolTieOk'; + return $y; +$perl$; +SELECT perl_tie_ok(); + perl_tie_ok +------------- + t +(1 row) + +-- Tied scalar whose FETCH returns another tied scalar. +CREATE FUNCTION perl_tie_recurse() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperlu +AS $perl$ + package BoolTieRecurse; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { my $x; tie $x, 'BoolTieRecurse'; return $x; } + package main; + tie my $y, 'BoolTieRecurse'; + return $y; +$perl$; +-- Pin the limit so the HINT does not depend on the installation default. +SET max_stack_depth = '100kB'; +SELECT perl_tie_recurse(); +ERROR: stack depth limit exceeded +HINT: Increase the configuration parameter "max_stack_depth" (currently 100kB), after ensuring the platform's stack depth limit is adequate. +CONTEXT: PL/Perl function "perl_tie_recurse" +RESET max_stack_depth; DROP EXTENSION plperlu CASCADE; -NOTICE: drop cascades to 6 other objects +NOTICE: drop cascades to 8 other objects DETAIL: drop cascades to extension bool_plperlu drop cascades to function perl2int(integer) drop cascades to function perl2text(text) drop cascades to function perl2undef() drop cascades to function bool2perl(boolean,boolean,boolean) drop cascades to function spi_test() +drop cascades to function perl_tie_ok() +drop cascades to function perl_tie_recurse() diff --git a/contrib/bool_plperl/sql/bool_plperl.sql b/contrib/bool_plperl/sql/bool_plperl.sql index b7f570862ce..17d1f15045c 100644 --- a/contrib/bool_plperl/sql/bool_plperl.sql +++ b/contrib/bool_plperl/sql/bool_plperl.sql @@ -67,4 +67,35 @@ $$; SELECT spi_test(); +-- Tied scalar whose FETCH returns a plain value. +CREATE FUNCTION perl_tie_ok() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperl +AS $perl$ + package BoolTieOk; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { return 1; } + package main; + tie my $y, 'BoolTieOk'; + return $y; +$perl$; +SELECT perl_tie_ok(); + +-- Tied scalar whose FETCH returns another tied scalar. +CREATE FUNCTION perl_tie_recurse() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperl +AS $perl$ + package BoolTieRecurse; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { my $x; tie $x, 'BoolTieRecurse'; return $x; } + package main; + tie my $y, 'BoolTieRecurse'; + return $y; +$perl$; +-- Pin the limit so the HINT does not depend on the installation default. +SET max_stack_depth = '100kB'; +SELECT perl_tie_recurse(); +RESET max_stack_depth; + DROP EXTENSION plperl CASCADE; diff --git a/contrib/bool_plperl/sql/bool_plperlu.sql b/contrib/bool_plperl/sql/bool_plperlu.sql index 1480a043306..7247f8adc6e 100644 --- a/contrib/bool_plperl/sql/bool_plperlu.sql +++ b/contrib/bool_plperl/sql/bool_plperlu.sql @@ -67,4 +67,35 @@ $$; SELECT spi_test(); +-- Tied scalar whose FETCH returns a plain value. +CREATE FUNCTION perl_tie_ok() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperlu +AS $perl$ + package BoolTieOk; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { return 1; } + package main; + tie my $y, 'BoolTieOk'; + return $y; +$perl$; +SELECT perl_tie_ok(); + +-- Tied scalar whose FETCH returns another tied scalar. +CREATE FUNCTION perl_tie_recurse() RETURNS bool +TRANSFORM FOR TYPE bool +LANGUAGE plperlu +AS $perl$ + package BoolTieRecurse; + sub TIESCALAR { return bless {}, shift; } + sub FETCH { my $x; tie $x, 'BoolTieRecurse'; return $x; } + package main; + tie my $y, 'BoolTieRecurse'; + return $y; +$perl$; +-- Pin the limit so the HINT does not depend on the installation default. +SET max_stack_depth = '100kB'; +SELECT perl_tie_recurse(); +RESET max_stack_depth; + DROP EXTENSION plperlu CASCADE; diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index 9ddb81d42b9..cfd86961a79 100644 --- a/src/pl/plperl/plperl.c +++ b/src/pl/plperl/plperl.c @@ -299,6 +299,9 @@ static void plperl_exec_callback(void *arg); static void plperl_inline_callback(void *arg); static char *strip_trailing_ws(const char *msg); static OP *pp_require_safe(pTHX); +static OP *pp_leavesub_resolve_ties(pTHX); +static void plperl_enter_tie_guard(SV *fn); +static void plperl_leave_tie_guard(SV *fn); static void activate_interpreter(plperl_interp_desc *interp_desc); #if defined(WIN32) && PERL_VERSION_LT(5, 28, 0) @@ -913,6 +916,158 @@ pp_require_safe(pTHX) return NULL; } +/* + * Perl's leave_adjust_stacks() runs get-magic on magical return values. + * If a tied scalar's FETCH returns another tied scalar, that recurses + * without bound inside call_sv() and can SIGSEGV. + * + * PL_ppaddr[OP_LEAVESUB] is not enough: compiled ops keep their own + * op_ppaddr. While call_sv() runs, patch OP_LEAVESUB(LV) in the callee + * (and in FETCH CVs we reach) so tied returns are resolved under + * check_stack_depth() before leave_adjust_stacks() sees them. + */ +static Perl_ppaddr_t plperl_pp_leavesub_orig = NULL; + +static void +plperl_walk_patch_leavesub(OP *o, bool install) +{ + if (o == NULL) + return; + + if (o->op_type == OP_LEAVESUB || o->op_type == OP_LEAVESUBLV) + { + if (install) + o->op_ppaddr = pp_leavesub_resolve_ties; + else + o->op_ppaddr = plperl_pp_leavesub_orig; + } + + if (o->op_flags & OPf_KIDS) + { + OP *kid; + + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) + plperl_walk_patch_leavesub(kid, install); + } +} + +static void +plperl_patch_cv_leavesubs(CV *cv, bool install) +{ + if (cv == NULL || CvISXSUB(cv) || CvROOT(cv) == NULL) + return; + plperl_walk_patch_leavesub(CvROOT(cv), install); +} + +static void +plperl_enter_tie_guard(SV *fn) +{ + dTHX; + HV *stash = NULL; + GV *gv = NULL; + CV *cv; + + if (plperl_pp_leavesub_orig == NULL) + plperl_pp_leavesub_orig = PL_ppaddr[OP_LEAVESUB]; + + cv = sv_2cv(fn, &stash, &gv, 0); + plperl_patch_cv_leavesubs(cv, true); +} + +static void +plperl_leave_tie_guard(SV *fn) +{ + dTHX; + HV *stash = NULL; + GV *gv = NULL; + CV *cv; + + cv = sv_2cv(fn, &stash, &gv, 0); + plperl_patch_cv_leavesubs(cv, false); +} + +static OP * +pp_leavesub_resolve_ties(pTHX) +{ + PERL_CONTEXT *cx = CX_CUR(); + + /* + * Before the real leavesub runs leave_adjust_stacks() (which does + * SvGETMAGIC and can recurse unbound on tied FETCH returns), unwrap + * tied scalars under check_stack_depth(). + * + * Do not touch MULTICALL frames. For those, pp_leavesub returns + * immediately and the multicall macros own the context. Mutating + * the stack or calling FETCH here would break that protocol. + */ + if (CxTYPE(cx) == CXt_SUB && + !CxMULTICALL(cx) && + cx->blk_gimme == G_SCALAR) + { + dSP; + SV **oldsp = PL_stack_base + cx->blk_oldsp; + + while (SP > oldsp && + TOPs && + SvGMAGICAL(TOPs) && + mg_find(TOPs, PERL_MAGIC_tiedscalar) != NULL) + { + MAGIC *mg; + SV *obj; + SV *ret; + HV *stash; + GV *gv; + CV *fetchcv; + int count; + + check_stack_depth(); + CHECK_FOR_INTERRUPTS(); + + mg = mg_find(TOPs, PERL_MAGIC_tiedscalar); + obj = SvTIED_obj(TOPs, mg); + stash = SvSTASH(SvRV(obj)); + gv = gv_fetchmethod_autoload(stash, "FETCH", TRUE); + fetchcv = (gv && isGV(gv)) ? GvCV(gv) : NULL; + + /* + * FETCH lives in its own CV. Patch it so a tied FETCH return + * takes this path too. + */ + plperl_patch_cv_leavesubs(fetchcv, true); + + ENTER; + SAVETMPS; + PUSHMARK(SP); + PUSHs(obj); + PUTBACK; + count = call_method("FETCH", G_SCALAR | G_EVAL); + SPAGAIN; + + if (SvTRUE(ERRSV)) + { + char *msg = SvPV_nolen(ERRSV); + + PUTBACK; + FREETMPS; + LEAVE; + croak("%s", msg); + } + + ret = (count == 1) ? POPs : &PL_sv_undef; + SvREFCNT_inc(ret); /* protect across FREETMPS */ + PUTBACK; + FREETMPS; + LEAVE; + SPAGAIN; + /* Copy without get-magic. Result may still be tied. */ + SETs(sv_2mortal(newSVsv_flags(ret, SV_NOSTEAL))); + SvREFCNT_dec(ret); + } + } + + return plperl_pp_leavesub_orig(aTHX); +} + /* * Destroy one Perl interpreter ... actually we just run END blocks. @@ -2239,8 +2394,19 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) } PUTBACK; - /* Do NOT use G_KEEPERR here */ - count = call_sv(desc->reference, G_SCALAR | G_EVAL); + plperl_enter_tie_guard(desc->reference); + PG_TRY(); + { + /* Do NOT use G_KEEPERR here */ + count = call_sv(desc->reference, G_SCALAR | G_EVAL); + } + PG_CATCH(); + { + plperl_leave_tie_guard(desc->reference); + PG_RE_THROW(); + } + PG_END_TRY(); + plperl_leave_tie_guard(desc->reference); SPAGAIN; @@ -2266,7 +2432,11 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); } - retval = newSVsv(POPs); + /* + * Tied FETCH was already resolved under the leavesub guard. Copy + * without get-magic as defense in depth. + */ + retval = newSVsv_flags(POPs, SV_NOSTEAL); PUTBACK; FREETMPS; @@ -2307,8 +2477,19 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i]))); PUTBACK; - /* Do NOT use G_KEEPERR here */ - count = call_sv(desc->reference, G_SCALAR | G_EVAL); + plperl_enter_tie_guard(desc->reference); + PG_TRY(); + { + /* Do NOT use G_KEEPERR here */ + count = call_sv(desc->reference, G_SCALAR | G_EVAL); + } + PG_CATCH(); + { + plperl_leave_tie_guard(desc->reference); + PG_RE_THROW(); + } + PG_END_TRY(); + plperl_leave_tie_guard(desc->reference); SPAGAIN; @@ -2334,7 +2515,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); } - retval = newSVsv(POPs); + retval = newSVsv_flags(POPs, SV_NOSTEAL); PUTBACK; FREETMPS; @@ -2370,8 +2551,19 @@ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, PUSHMARK(sp); PUTBACK; - /* Do NOT use G_KEEPERR here */ - count = call_sv(desc->reference, G_SCALAR | G_EVAL); + plperl_enter_tie_guard(desc->reference); + PG_TRY(); + { + /* Do NOT use G_KEEPERR here */ + count = call_sv(desc->reference, G_SCALAR | G_EVAL); + } + PG_CATCH(); + { + plperl_leave_tie_guard(desc->reference); + PG_RE_THROW(); + } + PG_END_TRY(); + plperl_leave_tie_guard(desc->reference); SPAGAIN; @@ -2397,7 +2589,7 @@ plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); } - retval = newSVsv(POPs); + retval = newSVsv_flags(POPs, SV_NOSTEAL); (void) retval; /* silence compiler warning */ PUTBACK;