Skip to content

Commit

Permalink
sv_setsv_cow: apply the same tests we do for a normal COW copy
Browse files Browse the repository at this point in the history
Previously if you had a successful match against an SV with a
SvLEN() large relative to the SvCUR() the regexp engine would
use sv_setsv_cow() to make a COW copy of the matched SV,
extending the life of the large allocation buffer.

A normal sv_setsv() normally didn't do such a COW copy, but the above
also marked the source SV as COW, so further copies of the SV
could even further extend the lifetime of the buffer, eg:

  while (<>) { # readline tends to make large SvLEN()
    /something/; # some sort of match
    push @save, $_; # with a successful match, the large $_ buffer
                    # survives until @save is released
  }

Fixes part of Perl#21877
  • Loading branch information
tonycoz committed Apr 4, 2024
1 parent f71cf50 commit 89553a3
Show file tree
Hide file tree
Showing 2 changed files with 8 additions and 1 deletion.
2 changes: 1 addition & 1 deletion regexec.c
Original file line number Diff line number Diff line change
Expand Up @@ -3547,7 +3547,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx,
#endif
{
#ifdef PERL_ANY_COW
didnt_cow:
didnt_cow: ;
#endif
SSize_t min = 0;
SSize_t max = strend - strbeg;
Expand Down
7 changes: 7 additions & 0 deletions sv.c
Original file line number Diff line number Diff line change
Expand Up @@ -4912,6 +4912,13 @@ Perl_sv_setsv_cow(pTHX_ SV **pdsv, SV *ssv)
sv_dump(dsv);
}
#endif
if (!SvIsCOW(ssv) &&
(!CHECK_COWBUF_THRESHOLD(cur, len)
|| ! CHECK_COW_THRESHOLD(cur, len))) {
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Fast copy on write: Sizes not appropriate to COW\n"));
return FALSE;
}
if (dsv) {
if (SvTHINKFIRST(dsv))
sv_force_normal_flags(dsv, SV_COW_DROP_PV);
Expand Down

0 comments on commit 89553a3

Please sign in to comment.