diff --git a/op.c b/op.c index 62bb4c3b9b91..5685fb26c837 100644 --- a/op.c +++ b/op.c @@ -5011,6 +5011,38 @@ 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) + ck_warner(packWARN(WARN_MISC), "Unrealistically large string repetition value"); + if (SvUVX(constsv) > arbitrary) + goto nope; + } else { + if (SvIVX(constsv) > (IV)(SIZE_MAX >> 2)) + ck_warner(packWARN(WARN_MISC), "Unrealistically large string repetition value"); + if (SvIVX(constsv) > (IV)arbitrary) + goto nope; + } + } else { + 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; + } + } 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..7f92714712d0 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 + +(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. + +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..285fc94dfbf1 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( + 'use warnings; my $x = "A" x (2**99)', + qr/Unrealistically large string repetition/, + {stderr => 1}, + 'Warn 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();