In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f1905e1b1b0d9cd2c673369524247d7a0280d166?hp=5ef88e32837b528ef762bb5bdc3074489cf43a85>
- Log ----------------------------------------------------------------- commit f1905e1b1b0d9cd2c673369524247d7a0280d166 Author: Nicholas Clark <[email protected]> Date: Thu Jun 30 13:00:47 2011 +0200 The regex engine can't assume that SvSCREAM() remains set on its target. Callers to the engine set REXEC_SCREAM in the flags when the target scalar is studied, and the engine should use the study data. It's possible for embedded code blocks to cause the target scalar to stop being studied. Hence the engine needs to check for this, instead of simply assuming that the study data is present and valid to read. This resolves #92696. ----------------------------------------------------------------------- Summary of changes: regexec.c | 6 +++--- t/op/study.t | 52 +++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 54 insertions(+), 4 deletions(-) diff --git a/regexec.c b/regexec.c index 3dd7ba5..6ae2770 100644 --- a/regexec.c +++ b/regexec.c @@ -692,7 +692,7 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, (IV)prog->check_end_shift); }); - if (flags & REXEC_SCREAM) { + if ((flags & REXEC_SCREAM) && SvSCREAM(sv)) { I32 p = -1; /* Internal iterator of scream. */ I32 * const pp = data ? data->scream_pos : &p; @@ -2289,7 +2289,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *stre dontbother = end_shift; strend = HOPc(strend, -dontbother); while ( (s <= last) && - ((flags & REXEC_SCREAM) + ((flags & REXEC_SCREAM) && SvSCREAM(sv) ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg, end_shift, &scream_pos, 0)) : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)), @@ -2368,7 +2368,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *stre utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog); float_real = utf8_target ? prog->float_utf8 : prog->float_substr; - if (flags & REXEC_SCREAM) { + if ((flags & REXEC_SCREAM) && SvSCREAM(sv)) { last = screaminstr(sv, float_real, s - strbeg, end_shift, &scream_pos, 1); /* last one */ if (!last) diff --git a/t/op/study.t b/t/op/study.t index 3733849..906aba9 100644 --- a/t/op/study.t +++ b/t/op/study.t @@ -7,7 +7,7 @@ BEGIN { } watchdog(10); -plan(tests => 36); +plan(tests => 43); use strict; use vars '$x'; @@ -109,3 +109,53 @@ TODO: { is($2, undef); is($_, 'A1A1'); } + +{ + my @got; + $a = "ydydydyd"; + $b = "xdx"; + push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 control'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + study $a; + push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 study $a'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + study $b; + push @got, $_ foreach $a =~ /[^x]d(?{})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 study $b'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), nothing studied'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + my $c = 'zz'; + study $c; + push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), $c studied'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + study $a; + push @got, $_ foreach $a =~ /[^x]d(?{study $b})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 study $b inside (?{}), $a studied'); + + @got = (); + $a = "ydydydyd"; + $b = "xdx"; + study $a; + push @got, $_ foreach $a =~ /[^x]d(?{$a .= ''})[^x]d/g; + is("@got", 'ydyd ydyd', '#92696 $a .= \'\' inside (?{}), $a studied'); +} -- Perl5 Master Repository
