From 3725af995eaaab805f69a0d7188b5defbec4b186 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Mon, 12 Dec 2022 16:15:10 +0000 Subject: [PATCH 1/2] Add limits to the size of the string repetition multiplier Historically, given a statement like `my $x = "A" x SOMECONSTANT;`, no examination of the size of the multiplier (`SOMECONSTANT` in this example) was done at compile time. Depending upon the constant folding behaviour, this might mean: * The buffer allocation needed at runtime could be clearly bigger than the system can support, but Perl would happily compile the statement and let the author find this out at runtime. * Constants resulting from folding could be very large and the memory taken up undesirable, especially in cases where the constant resides in cold code. This commit adds some compile time checking such that: * A string size beyond or close to the likely limit of support triggers a fatal error. * Strings above a certain static size do not get constant folded. --- op.c | 33 +++++++++++++++++++++++++++++++++ pod/perldiag.pod | 12 ++++++++++++ t/op/repeat.t | 10 +++++++++- t/perf/opcount.t | 7 +++++++ 4 files changed, 61 insertions(+), 1 deletion(-) diff --git a/op.c b/op.c index 62bb4c3b9b91..0ce9649c0c65 100644 --- a/op.c +++ b/op.c @@ -5011,6 +5011,39 @@ S_fold_constants(pTHX_ OP *const o) break; case OP_REPEAT: if (o->op_private & OPpREPEAT_DOLIST) goto nope; + /* Croak if the string is going to be unrealistically + * large. (GH#13324) Otherwise, don't constant fold + * above a certain threshold. (GH#13793 & GH#20586) + * + * Implementation note: pp_pow returns powers of 2 as an NV + * e.g. my $x = "A" x (2**3); + */ + if (OP_TYPE_IS(cBINOPo->op_last, OP_CONST)) { + SV *constsv = cSVOPx_sv(cBINOPo->op_last); + UV arbitrary = 1024 * 1024; + + if (SvIOKp(constsv)) { + if (SvIOK_UV(constsv)) { + if (SvUVX(constsv) > SIZE_MAX >> 2) + goto repetition_die; + if (SvUVX(constsv) > arbitrary) + goto nope; + } else { + if (SvIVX(constsv) > (IV)(SIZE_MAX >> 2)) + goto repetition_die; + if (SvIVX(constsv) > (IV)arbitrary) + goto nope; + } + } else { + NV rhs = SvNV_nomg(constsv); + if (rhs > (NV)(SIZE_MAX >> 2)) { + repetition_die: + DIE(aTHX_ "Unrealistically large string repetition value"); + } + if (rhs > (NV)arbitrary) + goto nope; + } + } break; case OP_SREFGEN: if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 082391b65b2e..c780d299212a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -7385,6 +7385,18 @@ reserved word. It's best to put such a word in quotes, or capitalize it somehow, or insert an underbar into it. You might also declare it as a subroutine. +=item Unrealistically large string repetition value + +The value of the right operand in the string repetition operator is +likely close to or will exceed the maximum memory allocation that +your system can provide. + +Even if an allocation of this size does succeed, subsequent string +copies may still result in an out-of-memory condition. + +Note that a smaller memory constraint might be imposed on your +application under C, if containerized, or other local configuration. + =item Unrecognized character %s; marked by S<<-- HERE> after %s near column %d diff --git a/t/op/repeat.t b/t/op/repeat.t index fa7ce0690433..ff282e676f84 100644 --- a/t/op/repeat.t +++ b/t/op/repeat.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc( '../lib' ); } -plan(tests => 50); +plan(tests => 51); # compile time @@ -193,6 +193,14 @@ fresh_perl_like( eval q{() = (() or ((0) x 0)); 1}; is($@, "", "RT #130247"); +# [GH #13324] Perl croaks if a string repetition seems unsupportable +fresh_perl_like( + 'my $x = "A" x (2**99)', + qr/Unrealistically large string repetition/, + { }, + 'Croak on unrealistically large string repetition', +); + # yes, the newlines matter fresh_perl_is(<<'PERL', "", { stderr => 1 }, "(perl #133778) MARK mishandling"); map{s[][];eval;0}__END__ diff --git a/t/perf/opcount.t b/t/perf/opcount.t index dd16447bae1c..4b6ae3de1a0f 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1245,4 +1245,11 @@ test_opcount(0, "Empty else{} blocks are optimised away", stub => 0 }); +# GH #13793, GH #20586 +test_opcount(0, "Don't fold string repetition once deeemed too large", + sub { my $x = "A" x (2**22) }, + { + repeat => 1, + }); + done_testing(); From 8fa7f8ed20e01effa8a4aa086317b64d5291fef5 Mon Sep 17 00:00:00 2001 From: Richard Leach Date: Mon, 11 Aug 2025 22:40:20 +0000 Subject: [PATCH 2/2] Warn instead of DIE when a repetition would exhaust RAM For discussions on #23561. perl -e 'use warnings; my $x = ($_) ? "A" x (2**62) : "Z"' gives this on blead for me: ``` Out of memory! panic: fold_constants JMPENV_PUSH returned 2 at -e line 1. ``` on the previous commit, it would die: ``` Unrealistically large string repetition value" ``` With this commit, it just warns: ``` Unrealistically large string repetition value at -e line 1. ``` but will blow up if the repetition OP does get executed: ``` Out of memory in perl:util:safesysrealloc ``` --- op.c | 11 +++++------ pod/perldiag.pod | 2 +- t/op/repeat.t | 6 +++--- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/op.c b/op.c index 0ce9649c0c65..5685fb26c837 100644 --- a/op.c +++ b/op.c @@ -5025,20 +5025,19 @@ S_fold_constants(pTHX_ OP *const o) if (SvIOKp(constsv)) { if (SvIOK_UV(constsv)) { if (SvUVX(constsv) > SIZE_MAX >> 2) - goto repetition_die; + ck_warner(packWARN(WARN_MISC), "Unrealistically large string repetition value"); if (SvUVX(constsv) > arbitrary) goto nope; } else { if (SvIVX(constsv) > (IV)(SIZE_MAX >> 2)) - goto repetition_die; + ck_warner(packWARN(WARN_MISC), "Unrealistically large string repetition value"); if (SvIVX(constsv) > (IV)arbitrary) goto nope; } } else { - NV rhs = SvNV_nomg(constsv); - if (rhs > (NV)(SIZE_MAX >> 2)) { - repetition_die: - DIE(aTHX_ "Unrealistically large string repetition value"); + NV rhs = 0.0; rhs = SvNV_nomg(constsv); + if (rhs >= (NV)((SIZE_MAX >> 2) +1) ) { + ck_warner(packWARN(WARN_MISC), "Unrealistically large string repetition value"); } if (rhs > (NV)arbitrary) goto nope; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index c780d299212a..7f92714712d0 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -7387,7 +7387,7 @@ subroutine. =item Unrealistically large string repetition value -The value of the right operand in the string repetition operator is +(W misc) The value of the right operand in the string repetition operator is likely close to or will exceed the maximum memory allocation that your system can provide. diff --git a/t/op/repeat.t b/t/op/repeat.t index ff282e676f84..285fc94dfbf1 100644 --- a/t/op/repeat.t +++ b/t/op/repeat.t @@ -195,10 +195,10 @@ is($@, "", "RT #130247"); # [GH #13324] Perl croaks if a string repetition seems unsupportable fresh_perl_like( - 'my $x = "A" x (2**99)', + 'use warnings; my $x = "A" x (2**99)', qr/Unrealistically large string repetition/, - { }, - 'Croak on unrealistically large string repetition', + {stderr => 1}, + 'Warn on unrealistically large string repetition', ); # yes, the newlines matter