X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=350f432145484220cde3b2e404235a459ee9f76b;hb=e2c57c3ea2e1fe3adabb752ab93e7f4b7746a103;hp=002b66ac85ae93dcd4f6bfffb835261e4dcfe546;hpb=0e41cd871c178c65afa4b4a7cea4d1df2def8588;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regexec.c b/regexec.c index 002b66a..350f432 100644 --- a/regexec.c +++ b/regexec.c @@ -325,6 +325,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, register I32 end_shift; register char *s; register SV *check; + char *strbeg; char *t; I32 ml_anch; char *tmp; @@ -351,23 +352,25 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n")); goto fail; } + strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos; check = prog->check_substr; if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */ ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE) || ( (prog->reganch & ROPT_ANCH_BOL) && !PL_multiline ) ); /* Check after \n? */ - if ((prog->check_offset_min == prog->check_offset_max) && !ml_anch) { + if (!ml_anch) { + if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ + /* SvCUR is not set on references: SvRV and SvPVX overlap */ + && sv && !SvROK(sv) + && (strpos != strbeg)) { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); + goto fail; + } + if (prog->check_offset_min == prog->check_offset_max) { /* Substring at constant offset from beg-of-str... */ I32 slen; - if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */ - /* SvCUR is not set on references: SvRV and SvPVX overlap */ - && sv && !SvROK(sv) - && (strpos + SvCUR(sv) != strend)) { - DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); - goto fail; - } PL_regeol = strend; /* Used in HOP() */ s = HOPc(strpos, prog->check_offset_min); if (SvTAIL(check)) { @@ -393,6 +396,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, && memNE(SvPVX(check), s, slen))) goto report_neq; goto success_at_start; + } } /* Match is anchored, but substr is not anchored wrt beg-of-str. */ s = strpos; @@ -426,7 +430,6 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Find a possible match in the region s..strend by looking for the "check" substring in the region corrected by start/end_shift. */ if (flags & REXEC_SCREAM) { - char *strbeg = SvPVX(sv); /* XXXX Assume PV_force() on SCREAM! */ I32 p = -1; /* Internal iterator of scream. */ I32 *pp = data ? data->scream_pos : &p; @@ -668,7 +671,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ - && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' + && (strpos != strbeg) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->reganch & ROPT_IMPLICIT)) { @@ -690,6 +693,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, SvREFCNT_dec(prog->check_substr); prog->check_substr = Nullsv; /* disable */ prog->float_substr = Nullsv; /* clear */ + check = Nullsv; /* abort */ s = strpos; /* XXXX This is a remnant of the old implementation. It looks wasteful, since now INTUIT can use many @@ -718,7 +722,7 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, ? s + (prog->minlen? cl_l : 0) : (prog->float_substr ? check_at - start_shift + cl_l : strend) ; - char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s; + char *startpos = strbeg; t = s; if (prog->reganch & ROPT_UTF8) { @@ -752,6 +756,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, "Could not match STCLASS...\n") ); goto fail; } + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, "Looking for %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); @@ -762,6 +768,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto retry_floating_check; /* Recheck anchored substring, but not floating... */ s = check_at; + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, "Looking for anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); @@ -771,6 +779,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, current position only: */ if (ml_anch) { s = t = t + 1; + if (!check) + goto giveup; DEBUG_r( PerlIO_printf(Perl_debug_log, "Looking for /%s^%s/m starting at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(t - i_strpos)) ); @@ -792,8 +802,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PerlIO_printf(Perl_debug_log, "Does not contradict STCLASS...\n") ); } - DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n", - PL_colors[4], PL_colors[5], (long)(s - i_strpos)) ); + giveup: + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n", + PL_colors[4], (check ? "Guessed" : "Giving up"), + PL_colors[5], (long)(s - i_strpos)) ); return s; fail_finish: /* Substring not found */ @@ -905,7 +917,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case BOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; + tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), + strend - s, + 0, 0) : '\n'; tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == BOUNDUTF8 ? @@ -941,7 +955,9 @@ S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *strend, char *sta PL_reg_flags |= RF_tainted; /* FALL THROUGH */ case NBOUNDUTF8: - tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n'; + tmp = (I32)(s != startpos) ? utf8_to_uv_chk(reghop((U8*)s, -1), + strend - s, + 0, 0) : '\n'; tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == NBOUNDUTF8 ? @@ -1986,7 +2002,7 @@ S_regmatch(pTHX_ regnode *prog) while (s < e) { if (l >= PL_regeol) sayNO; - if (utf8_to_uv((U8*)s, 0) != (c1 ? + if (utf8_to_uv_chk((U8*)s, e - s, 0, 0) != (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l))) { @@ -2124,7 +2140,8 @@ S_regmatch(pTHX_ regnode *prog) case NBOUNDUTF8: /* was last char in word? */ ln = (locinput != PL_regbol) - ? utf8_to_uv(reghop((U8*)locinput, -1), 0) : PL_regprev; + ? utf8_to_uv_chk(reghop((U8*)locinput, -1), + PL_regeol - locinput, 0, 0) : PL_regprev; if (OP(scan) == BOUNDUTF8 || OP(scan) == NBOUNDUTF8) { ln = isALNUM_uni(ln); n = swash_fetch(PL_utf8_alnum, (U8*)locinput); @@ -3616,7 +3633,11 @@ S_reginclass(pTHX_ register regnode *p, register I32 c) (ANYOF_CLASS_TEST(p, ANYOF_UPPER) && isUPPER_LC(c)) || (ANYOF_CLASS_TEST(p, ANYOF_NUPPER) && !isUPPER_LC(c)) || (ANYOF_CLASS_TEST(p, ANYOF_XDIGIT) && isXDIGIT(c)) || - (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c)) + (ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_PSXSPC) && isPSXSPC(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_NPSXSPC) && !isPSXSPC(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_BLANK) && isBLANK(c)) || + (ANYOF_CLASS_TEST(p, ANYOF_NBLANK) && !isBLANK(c)) ) /* How's that for a conditional? */ { match = TRUE; @@ -3722,4 +3743,3 @@ restore_pos(pTHXo_ void *arg) PL_curpm = PL_reg_oldcurpm; } } -