In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e8fe1b7c7ff6b3263ab2423a9a3f63ad85ea3aff?hp=b3b27d017bd3d61f6cbc3eaf8465b8d98d86a024>
- Log ----------------------------------------------------------------- commit e8fe1b7c7ff6b3263ab2423a9a3f63ad85ea3aff Author: David Mitchell <[email protected]> Date: Wed Mar 18 17:06:49 2015 +0000 smartmatch: handle stack realloc When smartmatch is matching a pattern against something, it was failing to do appropriate PUTBACK and SPAGAIN's before calling matcher_matches_sv() (which pushes an arg an calls pp_match()). If the stack was almost full, the extra push in matcher_matches_sv() could cause a stack realloc, which would then be ignored when pp_smartmatch() returned, setting PL_stack_sp to point to the old (freed) stack. Adding SPAGAIN ensures that PL_stack_sp points to the new stack, while PUTBACK causes PL_stack_sp to no longer see the two args to pp_smartmatch, so the PUSH in matcher_matches_sv() pushes the SV us9ng ones of two two reclaimed slots, so the stack won't re-alloc anyway. Thus by doing the "right thing" with both PUTBACK and SPAGAIN, we doubly ensure that PL_stack_sp will always be right. M pp_ctl.c M t/op/smartmatch.t commit 72e5fb6312b534c67eb2da0525dd3c09b5f9222b Author: Tony Cook <[email protected]> Date: Thu Feb 19 15:03:58 2015 +1100 update PL_stack_sp when we exit matcher_matches_sv() M pp_ctl.c M t/op/smartmatch.t commit b1741c2a17ce2a6a029d3c316c75e44569dfe66e Author: Tony Cook <[email protected]> Date: Thu Feb 19 15:02:49 2015 +1100 TODO test for smartmatch stack issue M t/op/smartmatch.t ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 21 ++++++++++++++++----- t/op/smartmatch.t | 53 ++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 6 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index f7cb216..ac0f1bc 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -4507,6 +4507,7 @@ STATIC bool S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) { dSP; + bool result; PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; @@ -4515,7 +4516,10 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) PUTBACK; (void) Perl_pp_match(aTHX); SPAGAIN; - return (SvTRUEx(POPs)); + result = SvTRUEx(POPs); + PUTBACK; + + return result; } STATIC void @@ -4577,7 +4581,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } SP -= 2; /* Pop the values */ - + PUTBACK; /* ~~ undef */ if (!SvOK(e)) { @@ -4774,11 +4778,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) (void) hv_iterinit(hv); while ( (he = hv_iternext(hv)) ) { DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + PUTBACK; if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + SPAGAIN; (void) hv_iterinit(hv); destroy_matcher(matcher); RETPUSHYES; } + SPAGAIN; } destroy_matcher(matcher); RETPUSHNO; @@ -4883,10 +4890,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) for(i = 0; i <= this_len; ++i) { SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + PUTBACK; if (svp && matcher_matches_sv(matcher, *svp)) { + SPAGAIN; destroy_matcher(matcher); RETPUSHYES; } + SPAGAIN; } destroy_matcher(matcher); RETPUSHNO; @@ -4947,12 +4957,13 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) } else { PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + bool result; DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); PUTBACK; - PUSHs(matcher_matches_sv(matcher, d) - ? &PL_sv_yes - : &PL_sv_no); + result = matcher_matches_sv(matcher, d); + SPAGAIN; + PUSHs(result ? &PL_sv_yes : &PL_sv_no); destroy_matcher(matcher); RETURN; } diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t index a5f6373..ca019fd 100644 --- a/t/op/smartmatch.t +++ b/t/op/smartmatch.t @@ -10,6 +10,8 @@ use warnings; no warnings 'uninitialized'; no warnings 'experimental::smartmatch'; +++$|; + use Tie::Array; use Tie::Hash; @@ -74,7 +76,7 @@ my %keyandmore = map { $_ => 0 } @keyandmore; my %fooormore = map { $_ => 0 } @fooormore; # Load and run the tests -plan tests => 349; +plan tests => 349+2; while (<DATA>) { SKIP: { @@ -131,6 +133,55 @@ sub FALSE() { 0 } sub TRUE() { 1 } sub NOT_DEF() { undef } +{ + # [perl #123860] + # this can but might not crash + # This can but might not crash + # + # The second smartmatch would leave a &PL_sv_no on the stack for + # each key it checked in %!, this could then cause various types of + # crash or assertion failure. + # + # This isn't guaranteed to crash, but if the stack issue is + # re-introduced it will probably crash in one of the many smoke + # builds. + fresh_perl_is('print (q(x) ~~ q(x)) | (/x/ ~~ %!)', "1", + { switches => [ "-MErrno", "-M-warnings=experimental::smartmatch" ] }, + "don't fill the stack with rubbish"); +} + +{ + # [perl #123860] continued; + # smartmatch was failing to SPAGAIN after pushing an SV and calling + # pp_match, which may have resulted in the stack being realloced + # in the meantime. Test this by filling the stack with pregressively + # larger amounts of data. At some point the stack will get realloced. + my @a = qw(x); + my %h = qw(x 1); + my @args; + my $x = 1; + my $bad = -1; + for (1..1000) { + push @args, $_; + my $exp_n = join '-', (@args, $x == 0); + my $exp_y = join '-', (@args, $x == 1); + + my $got_an = join '-', (@args, (/X/ ~~ @a)); + my $got_ay = join '-', (@args, (/x/ ~~ @a)); + my $got_hn = join '-', (@args, (/X/ ~~ %h)); + my $got_hy = join '-', (@args, (/x/ ~~ %h)); + + if ( $exp_n ne $got_an || $exp_n ne $got_hn + || $exp_y ne $got_ay || $exp_y ne $got_hy + ) { + $bad = $_; + last; + } + } + is($bad, -1, "RT 123860: stack realloc"); +} + + # Prefix character : # - expected to match # ! - expected to not match -- Perl5 Master Repository
