X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=regexec.c;h=d3f2065cbc09e53f09a53fc016a3d234336b84a5;hb=9f07fdcd4d463e2090de7661b6a313c8ecc5278b;hp=3b6d8577a7b8431ef7cc3feb901c8f79fc0682ed;hpb=155aba94f677ac771761a1f510964fe5b21524ed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/regexec.c b/regexec.c index 3b6d857..d3f2065 100644 --- a/regexec.c +++ b/regexec.c @@ -221,6 +221,22 @@ typedef struct re_cc_state #define regcpblow(cp) LEAVE_SCOPE(cp) +#define TRYPAREN(paren, n, input) { \ + if (paren) { \ + if (n) { \ + PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \ + PL_regendp[paren] = input - PL_bostr; \ + } \ + else \ + PL_regendp[paren] = -1; \ + } \ + if (regmatch(next)) \ + sayYES; \ + if (paren && n) \ + PL_regendp[paren] = -1; \ +} + + /* * pregexec and friends */ @@ -341,15 +357,18 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, || ( (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 + SvCUR(sv) != strend)) { + 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 */ - && (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)) { @@ -375,6 +394,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; @@ -597,9 +617,10 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, find_anchor: while (t < strend - prog->minlen) { if (*t == '\n') { - if (t < s - prog->check_offset_min) { + if (t < check_at - prog->check_offset_min) { if (prog->anchored_substr) { - /* We definitely contradict the found anchored + /* Since we moved from the found position, + we definitely contradict the found anchored substr. Due to the above check we do not contradict "check" substr. Thus we can arrive here only if check substr @@ -610,14 +631,19 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset))); goto do_other_anchored; } + /* We don't contradict the found floating substring. */ + /* XXXX Why not check for STCLASS? */ s = t + 1; DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(s - i_strpos))); goto set_useful; } - DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n", + /* Position contradicts check-string */ + /* XXXX probably better to look for check-string + than for "\n", so one should lower the limit for t? */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n", PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos))); - strpos = s = t + 1; + other_last = strpos = s = t + 1; goto restart; } t++; @@ -626,19 +652,24 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, PL_colors[0],PL_colors[1])); goto fail_finish; } + else { + DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n", + PL_colors[0],PL_colors[1])); + } s = t; set_useful: ++BmUSEFUL(prog->check_substr); /* hooray/5 */ } else { PL_bostr = tmp; - /* The found string does not prohibit matching at beg-of-str + /* The found string does not prohibit matching at strpos, - no optimization of calling REx engine can be performed, - unless it was an MBOL and we are not after MBOL. */ + unless it was an MBOL and we are not after MBOL, + or a future STCLASS check will fail this. */ try_at_start: /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ - if (ml_anch && sv + if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ && (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->reganch & ROPT_IMPLICIT)) @@ -647,8 +678,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, goto find_anchor; } DEBUG_r( if (ml_anch) - PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n", - PL_colors[0],PL_colors[1]); + PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n", + (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]); ); success_at_start: if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */ @@ -657,9 +688,11 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos, && prog->check_substr == prog->float_substr) { /* If flags & SOMETHING - do not do it many times on the same match */ + DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n")); 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 @@ -722,8 +755,10 @@ 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, - "Trying %s substr starting at offset %ld...\n", + "Looking for %s substr starting at offset %ld...\n", what, (long)(s + start_shift - i_strpos)) ); goto restart; } @@ -732,8 +767,10 @@ 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, - "Trying anchored substr starting at offset %ld...\n", + "Looking for anchored substr starting at offset %ld...\n", (long)(other_last - i_strpos)) ); goto do_other_anchored; } @@ -741,9 +778,11 @@ 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, - "Trying /^/m starting at offset %ld...\n", - (long)(t - i_strpos)) ); + "Looking for /%s^%s/m starting at offset %ld...\n", + PL_colors[0],PL_colors[1], (long)(t - i_strpos)) ); goto try_at_offset; } if (!prog->float_substr) /* Could have been deleted */ @@ -762,8 +801,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 */ @@ -875,7 +916,7 @@ 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), 0, 0) : '\n'; tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == BOUNDUTF8 ? @@ -911,7 +952,7 @@ 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), 0, 0) : '\n'; tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0); while (s < strend) { if (tmp == !(OP(c) == NBOUNDUTF8 ? @@ -1432,9 +1473,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * /* we have /x+whatever/ */ /* it must be a one character string (XXXX Except UTF?) */ char ch = SvPVX(prog->anchored_substr)[0]; +#ifdef DEBUGGING + int did_match = 0; +#endif + if (UTF) { while (s < strend) { if (*s == ch) { + DEBUG_r( did_match = 1 ); if (regtry(prog, s)) goto got_it; s += UTF8SKIP(s); while (s < strend && *s == ch) @@ -1446,6 +1492,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * else { while (s < strend) { if (*s == ch) { + DEBUG_r( did_match = 1 ); if (regtry(prog, s)) goto got_it; s++; while (s < strend && *s == ch) @@ -1454,6 +1501,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * s++; } } + DEBUG_r(did_match || + PerlIO_printf(Perl_debug_log, + "Did not find anchored character...\n")); } /*SUPPRESS 560*/ else if (prog->anchored_substr != Nullsv @@ -1469,6 +1519,9 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * -(I32)(CHR_SVLEN(must) - (SvTAIL(must) != 0) + back_min)); char *last1; /* Last position checked before */ +#ifdef DEBUGGING + int did_match = 0; +#endif if (s > PL_bostr) last1 = HOPc(s, -1); @@ -1487,6 +1540,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * : (s = fbm_instr((unsigned char*)HOP(s, back_min), (unsigned char*)strend, must, PL_multiline ? FBMrf_MULTILINE : 0))) ) { + DEBUG_r( did_match = 1 ); if (HOPc(s, -back_max) > last1) { last1 = HOPc(s, -back_min); s = HOPc(s, -back_max); @@ -1512,6 +1566,14 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * } } } + DEBUG_r(did_match || + PerlIO_printf(Perl_debug_log, "Did not find %s substr `%s%.*s%s'%s...\n", + ((must == prog->anchored_substr) + ? "anchored" : "floating"), + PL_colors[0], + (int)(SvCUR(must) - (SvTAIL(must)!=0)), + SvPVX(must), + PL_colors[1], (SvTAIL(must) ? "$" : ""))); goto phooey; } else if ((c = prog->regstclass)) { @@ -1520,6 +1582,7 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * strend = HOPc(strend, -(minlen - 1)); if (find_byclass(prog, c, s, strend, startpos, 0)) goto got_it; + DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n")); } else { dontbother = 0; @@ -1552,7 +1615,12 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char * last = strend; /* matching `$' */ } } - if (last == NULL) goto phooey; /* Should not happen! */ + if (last == NULL) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "%sCan't trim the tail, match fails (should not happen)%s\n", + PL_colors[4],PL_colors[5])); + goto phooey; /* Should not happen! */ + } dontbother = strend - last + prog->float_min_offset; } if (minlen && (dontbother < minlen)) @@ -1614,6 +1682,8 @@ got_it: return 1; phooey: + DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", + PL_colors[4],PL_colors[5])); if (PL_reg_eval_set) restore_pos(aTHXo_ 0); return 0; @@ -1838,7 +1908,7 @@ S_regmatch(pTHX_ regnode *prog) } sayNO; case SBOL: - if (locinput == PL_regbol && PL_regprev == '\n') + if (locinput == PL_bostr) break; sayNO; case GPOS: @@ -1927,7 +1997,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, 0, 0) != (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l))) { @@ -2065,7 +2135,7 @@ 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), 0, 0) : PL_regprev; if (OP(scan) == BOUNDUTF8 || OP(scan) == NBOUNDUTF8) { ln = isALNUM_uni(ln); n = swash_fetch(PL_utf8_alnum, (U8*)locinput); @@ -2992,16 +3062,7 @@ S_regmatch(pTHX_ regnode *prog) sayNO; } /* PL_reginput == locinput now */ - if (paren) { - if (ln) { - PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; - PL_regendp[paren] = locinput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; + TRYPAREN(paren, ln, locinput); PL_reginput = locinput; /* Could be reset... */ REGCP_UNWIND; /* Couldn't or didn't -- move forward. */ @@ -3015,16 +3076,7 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (paren) { - if (n) { - PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr; - PL_regendp[paren] = PL_reginput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; + TRYPAREN(paren, n, PL_reginput); REGCP_UNWIND; } /* Couldn't or didn't -- move forward. */ @@ -3058,16 +3110,7 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (paren && n) { - if (n) { - PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr; - PL_regendp[paren] = PL_reginput - PL_bostr; - } - else - PL_regendp[paren] = -1; - } - if (regmatch(next)) - sayYES; + TRYPAREN(paren, n, PL_reginput); REGCP_UNWIND; } /* Couldn't or didn't -- back up. */ @@ -3082,8 +3125,7 @@ S_regmatch(pTHX_ regnode *prog) UCHARAT(PL_reginput) == c1 || UCHARAT(PL_reginput) == c2) { - if (regmatch(next)) - sayYES; + TRYPAREN(paren, n, PL_reginput); REGCP_UNWIND; } /* Couldn't or didn't -- back up. */ @@ -3585,7 +3627,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; @@ -3691,4 +3737,3 @@ restore_pos(pTHXo_ void *arg) PL_curpm = PL_reg_oldcurpm; } } -