X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d0880ea774e2c5aa93b0328c7fdb39c2dbd8e239..05bd126c48b39587e20b91b96de34551883e663e:/regexec.c diff --git a/regexec.c b/regexec.c index 4862b7f..f71c28a 100644 --- a/regexec.c +++ b/regexec.c @@ -119,6 +119,7 @@ static const char* const non_utf8_target_but_utf8_required ? reghop3((U8*)pos, off, \ (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ : (U8*)(pos + off)) + #define HOPBACKc(pos, off) \ (char*)(reginfo->is_utf8_target \ ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \ @@ -129,6 +130,14 @@ static const char* const non_utf8_target_but_utf8_required #define HOP3(pos,off,lim) (reginfo->is_utf8_target ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off)) #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim)) +/* lim must be +ve. Returns NULL on overshoot */ +#define HOPMAYBE3(pos,off,lim) \ + (reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, off, (U8*)(lim)) \ + : ((U8*)pos + off <= lim) \ + ? (U8*)pos + off \ + : NULL) + /* like HOP3, but limits the result to <= lim even for the non-utf8 case. * off must be >=0; args should be vars rather than expressions */ #define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \ @@ -279,7 +288,6 @@ static regmatch_state * S_push_slab(pTHX); STATIC CHECKPOINT S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) { - dVAR; const int retval = PL_savestack_ix; const int paren_elems_to_push = (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS; @@ -291,8 +299,9 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) PERL_ARGS_ASSERT_REGCPPUSH; if (paren_elems_to_push < 0) - Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0", - paren_elems_to_push); + Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0, maxopenparen: %i parenfloor: %i REGCP_PAREN_ELEMS: %u", + (int)paren_elems_to_push, (int)maxopenparen, + (int)parenfloor, (unsigned)REGCP_PAREN_ELEMS); if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems) Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf @@ -359,7 +368,6 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) STATIC void S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) { - dVAR; UV i; U32 paren; GET_RE_DEBUG_FLAGS_DECL; @@ -563,64 +571,70 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, } #endif -/* - * Need to implement the following flags for reg_anch: - * - * USE_INTUIT_NOML - Useful to call re_intuit_start() first - * USE_INTUIT_ML - * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer - * INTUIT_AUTORITATIVE_ML - * INTUIT_ONCE_NOML - Intuit can match in one location only. - * INTUIT_ONCE_ML - * - * Another flag for this function: SECOND_TIME (so that float substrs - * with giant delta may be not rechecked). - */ - -/* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend. - Otherwise, only SvCUR(sv) is used to get strbeg. */ - -/* XXXX Some places assume that there is a fixed substring. - An update may be needed if optimizer marks as "INTUITable" - RExen without fixed substrings. Similarly, it is assumed that - lengths of all the strings are no more than minlen, thus they - cannot come from lookahead. - (Or minlen should take into account lookahead.) - NOTE: Some of this comment is not correct. minlen does now take account - of lookahead/behind. Further research is required. -- demerphq -*/ - -/* A failure to find a constant substring means that there is no need to make - an expensive call to REx engine, thus we celebrate a failure. Similarly, - finding a substring too deep into the string means that fewer calls to - regtry() should be needed. - - REx compiler's optimizer found 4 possible hints: - a) Anchored substring; - b) Fixed substring; - c) Whether we are anchored (beginning-of-line or \G); - d) First node (of those at offset 0) which may distinguish positions; - We use a)b)d) and multiline-part of c), and try to find a position in the - string which does not contradict any of them. - */ -/* Most of decisions we do here should have been done at compile time. - The nodes of the REx which we used for the search should have been - deleted from the finite automaton. */ - -/* args: - * rx: the regex to match against - * sv: the SV being matched: only used for utf8 flag; the string - * itself is accessed via the pointers below. Note that on - * something like an overloaded SV, SvPOK(sv) may be false - * and the string pointers may point to something unrelated to - * the SV itself. - * strbeg: real beginning of string - * strpos: the point in the string at which to begin matching - * strend: pointer to the byte following the last char of the string - * flags currently unused; set to 0 - * data: currently unused; set to NULL +/* re_intuit_start(): + * + * Based on some optimiser hints, try to find the earliest position in the + * string where the regex could match. + * + * rx: the regex to match against + * sv: the SV being matched: only used for utf8 flag; the string + * itself is accessed via the pointers below. Note that on + * something like an overloaded SV, SvPOK(sv) may be false + * and the string pointers may point to something unrelated to + * the SV itself. + * strbeg: real beginning of string + * strpos: the point in the string at which to begin matching + * strend: pointer to the byte following the last char of the string + * flags currently unused; set to 0 + * data: currently unused; set to NULL + * + * The basic idea of re_intuit_start() is to use some known information + * about the pattern, namely: + * + * a) the longest known anchored substring (i.e. one that's at a + * constant offset from the beginning of the pattern; but not + * necessarily at a fixed offset from the beginning of the + * string); + * b) the longest floating substring (i.e. one that's not at a constant + * offset from the beginning of the pattern); + * c) Whether the pattern is anchored to the string; either + * an absolute anchor: /^../, or anchored to \n: /^.../m, + * or anchored to pos(): /\G/; + * d) A start class: a real or synthetic character class which + * represents which characters are legal at the start of the pattern; + * + * to either quickly reject the match, or to find the earliest position + * within the string at which the pattern might match, thus avoiding + * running the full NFA engine at those earlier locations, only to + * eventually fail and retry further along. + * + * Returns NULL if the pattern can't match, or returns the address within + * the string which is the earliest place the match could occur. + * + * The longest of the anchored and floating substrings is called 'check' + * and is checked first. The other is called 'other' and is checked + * second. The 'other' substring may not be present. For example, + * + * /(abc|xyz)ABC\d{0,3}DEFG/ + * + * will have + * + * check substr (float) = "DEFG", offset 6..9 chars + * other substr (anchored) = "ABC", offset 3..3 chars + * stclass = [ax] + * + * Be aware that during the course of this function, sometimes 'anchored' + * refers to a substring being anchored relative to the start of the + * pattern, and sometimes to the pattern itself being anchored relative to + * the string. For example: + * + * /\dabc/: "abc" is anchored to the pattern; + * /^\dabc/: "abc" is anchored to the pattern and the string; + * /\d+abc/: "abc" is anchored to neither the pattern nor the string; + * /^\d+abc/: "abc" is anchored to neither the pattern nor the string, + * but the pattern is anchored to the string. */ char * @@ -633,9 +647,8 @@ Perl_re_intuit_start(pTHX_ const U32 flags, re_scream_pos_data *data) { - dVAR; struct regexp *const prog = ReANY(rx); - SSize_t start_shift = 0; + SSize_t start_shift = prog->check_offset_min; /* Should be nonnegative! */ SSize_t end_shift = 0; /* current lowest pos in string where the regex can start matching */ @@ -646,7 +659,6 @@ Perl_re_intuit_start(pTHX_ bool ml_anch = 0; char *other_last = strpos;/* latest pos 'other' substr already checked to */ char *check_at = NULL; /* check substr found at this pos */ - char *checked_upto = NULL; /* how far into the string we have already checked using find_byclass*/ const I32 multiline = prog->extflags & RXf_PMf_MULTILINE; RXi_GET_DECL(prog,progi); regmatch_info reginfo_buf; /* create some info to pass to find_byclass */ @@ -673,7 +685,20 @@ Perl_re_intuit_start(pTHX_ assert(prog->substrs->data[2].min_offset >= 0); assert(prog->substrs->data[2].max_offset >= 0); - /* CHR_DIST() would be more correct here but it makes things slow. */ + /* for now, assume that if both present, that the floating substring + * doesn't start before the anchored substring. + * If you break this assumption (e.g. doing better optimisations + * with lookahead/behind), then you'll need to audit the code in this + * function carefully first + */ + assert( + ! ( (prog->anchored_utf8 || prog->anchored_substr) + && (prog->float_utf8 || prog->float_substr)) + || (prog->float_min_offset >= prog->anchored_offset)); + + /* byte rather than char calculation for efficiency. It fails + * to quickly reject some cases that can't match, but will reject + * them later after doing full char arithmetic */ if (prog->minlen > strend - strpos) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " String too short...\n")); @@ -725,21 +750,31 @@ Perl_re_intuit_start(pTHX_ }); if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */ - /* Check after \n? */ - ml_anch = ( (prog->intflags & PREGf_ANCH_MBOL) - || ((prog->intflags & PREGf_ANCH_BOL) && multiline)); - if (!ml_anch) { + /* ml_anch: check after \n? + * + * A note about IMPLICIT: on an un-anchored pattern beginning + * with /.*.../, these flags will have been added by the + * compiler: + * /.*abc/, /.*abc/m: PREGf_IMPLICIT | PREGf_ANCH_MBOL + * /.*abc/s: PREGf_IMPLICIT | PREGf_ANCH_SBOL + */ + ml_anch = (prog->intflags & PREGf_ANCH_MBOL) + && !(prog->intflags & PREGf_IMPLICIT); + + if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) { /* we are only allowed to match at BOS or \G */ /* trivially reject if there's a BOS anchor and we're not at BOS. - * In the case of \G, we hope(!) that the caller has already - * set strpos to pos()-gofs, and will already have checked - * that this anchor position is legal. So we can skip it here. + * + * Note that we don't try to do a similar quick reject for + * \G, since generally the caller will have calculated strpos + * based on pos() and gofs, so the string is already correctly + * anchored by definition; and handling the exceptions would + * be too fiddly (e.g. REXEC_IGNOREPOS). */ - if ( !(prog->intflags & PREGf_ANCH_GPOS) - && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */ - && (strpos != strbeg)) + if ( strpos != strbeg + && (prog->intflags & (PREGf_ANCH_BOL|PREGf_ANCH_SBOL))) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Not at start...\n")); @@ -748,30 +783,34 @@ Perl_re_intuit_start(pTHX_ /* in the presence of an anchor, the anchored (relative to the * start of the regex) substr must also be anchored relative - * to strpos. So quickly reject if substr isn't found there */ + * to strpos. So quickly reject if substr isn't found there. + * This works for \G too, because the caller will already have + * subtracted gofs from pos, and gofs is the offset from the + * \G to the start of the regex. For example, in /.abc\Gdef/, + * where substr="abcdef", pos()=3, gofs=4, offset_min=1: + * caller will have set strpos=pos()-4; we look for the substr + * at position pos()-4+1, which lines up with the "a" */ if (prog->check_offset_min == prog->check_offset_max - && !(prog->intflags & PREGf_CANY_SEEN) - && ! multiline) /* /m can cause \n's to match that aren't - accounted for in the string max length. - See [perl #115242] */ + && !(prog->intflags & PREGf_CANY_SEEN)) { /* Substring at constant offset from beg-of-str... */ SSize_t slen = SvCUR(check); - char *s; - - s = HOP3c(strpos, prog->check_offset_min, strend); + char *s = HOP3c(strpos, prog->check_offset_min, strend); DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Looking for check substr at fixed offset %"IVdf"...\n", (IV)prog->check_offset_min)); if (SvTAIL(check)) { - /* In this case, the regex is anchored at the end too, - * so the lengths must match exactly, give or take a \n. - * NB: slen >= 1 since the last char of check is \n */ - if ( strend - s > slen || strend - s < slen - 1 - || (strend - s == slen && strend[-1] != '\n')) + /* In this case, the regex is anchored at the end too. + * Unless it's a multiline match, the lengths must match + * exactly, give or take a \n. NB: slen >= 1 since + * the last char of check is \n */ + if (!multiline + && ( strend - s > slen + || strend - s < slen - 1 + || (strend - s == slen && strend[-1] != '\n'))) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " String too long...\n")); @@ -794,7 +833,6 @@ Perl_re_intuit_start(pTHX_ } } - start_shift = prog->check_offset_min; /* okay to underestimate on CC */ end_shift = prog->check_end_shift; #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ @@ -804,11 +842,32 @@ Perl_re_intuit_start(pTHX_ #endif restart: - /* Find a candidate regex origin in the region rx_origin..strend - * by looking for the "check" substring in that region, corrected by - * start/end_shift. - */ + /* This is the (re)entry point of the main loop in this function. + * The goal of this loop is to: + * 1) find the "check" substring in the region rx_origin..strend + * (adjusted by start_shift / end_shift). If not found, reject + * immediately. + * 2) If it exists, look for the "other" substr too if defined; for + * example, if the check substr maps to the anchored substr, then + * check the floating substr, and vice-versa. If not found, go + * back to (1) with rx_origin suitably incremented. + * 3) If we find an rx_origin position that doesn't contradict + * either of the substrings, then check the possible additional + * constraints on rx_origin of /^.../m or a known start class. + * If these fail, then depending on which constraints fail, jump + * back to here, or to various other re-entry points further along + * that skip some of the first steps. + * 4) If we pass all those tests, update the BmUSEFUL() count on the + * substring. If the start position was determined to be at the + * beginning of the string - so, not rejected, but not optimised, + * since we have to run regmatch from position 0 - decrement the + * BmUSEFUL() count. Otherwise increment it. + */ + + + /* first, look for the 'check' substring */ + { U8* start_point; U8* end_point; @@ -828,24 +887,42 @@ Perl_re_intuit_start(pTHX_ if (prog->intflags & PREGf_CANY_SEEN) { start_point= (U8*)(rx_origin + start_shift); end_point= (U8*)(strend - end_shift); + if (start_point > end_point) + goto fail_finish; } else { - start_point= HOP3(rx_origin, start_shift, strend); - end_point= HOP3(strend, -end_shift, strbeg); + end_point = HOP3(strend, -end_shift, strbeg); + start_point = HOPMAYBE3(rx_origin, start_shift, end_point); + if (!start_point) + goto fail_finish; } - /* if the regex is absolutely anchored to the start of the string, - * then check_offset_max represents an upper bound on the string - * where the substr could start */ + + /* If the regex is absolutely anchored to either the start of the + * string (BOL,SBOL) or to pos() (ANCH_GPOS), then + * check_offset_max represents an upper bound on the string where + * the substr could start. For the ANCH_GPOS case, we assume that + * the caller of intuit will have already set strpos to + * pos()-gofs, so in this case strpos + offset_max will still be + * an upper bound on the substr. + */ if (!ml_anch && prog->intflags & PREGf_ANCH - && prog->check_offset_max != SSize_t_MAX - && start_shift < prog->check_offset_max) + && prog->check_offset_max != SSize_t_MAX) { SSize_t len = SvCUR(check) - !!SvTAIL(check); - end_point = HOP3lim(start_point, - prog->check_offset_max - start_shift, - end_point -len) - + len; + const char * const anchor = + (prog->intflags & PREGf_ANCH_GPOS ? strpos : strbeg); + + /* do a bytes rather than chars comparison. It's conservative; + * so it skips doing the HOP if the result can't possibly end + * up earlier than the old value of end_point. + */ + if ((char*)end_point - anchor > prog->check_offset_max) { + end_point = HOP3lim((U8*)anchor, + prog->check_offset_max, + end_point -len) + + len; + } } DEBUG_OPTIMISE_MORE_r({ @@ -857,50 +934,38 @@ Perl_re_intuit_start(pTHX_ check_at = fbm_instr( start_point, end_point, check, multiline ? FBMrf_MULTILINE : 0); - } - /* Update the count-of-usability, remove useless subpatterns, - unshift s. */ - - DEBUG_EXECUTE_r({ - RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), - SvPVX_const(check), RE_SV_DUMPLEN(check), 30); - PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s", - (check_at ? "Found" : "Did not find"), - (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) - ? "anchored" : "floating"), - quoted, - RE_SV_TAIL(check), - (check_at ? " at offset " : "...\n") ); - }); + /* Update the count-of-usability, remove useless subpatterns, + unshift s. */ - if (!check_at) - goto fail_finish; - /* Finish the diagnostic message */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(check_at - strpos)) ); + DEBUG_EXECUTE_r({ + RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), + SvPVX_const(check), RE_SV_DUMPLEN(check), 30); + PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s", + (check_at ? "Found" : "Did not find"), + (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) + ? "anchored" : "floating"), + quoted, + RE_SV_TAIL(check), + (check_at ? " at offset " : "...\n") ); + }); - /* set rx_origin to the minimum position where the regex could start - * matching, given the constraint of the just-matched check substring. - * But don't set it lower than previously. - */ + if (!check_at) + goto fail_finish; + /* Finish the diagnostic message */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(check_at - strpos)) ); - if (check_at - rx_origin > prog->check_offset_max) - rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin); + /* set rx_origin to the minimum position where the regex could start + * matching, given the constraint of the just-matched check substring. + * But don't set it lower than previously. + */ + if (check_at - rx_origin > prog->check_offset_max) + rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin); + } - /* XXX dmq: first branch is for positive lookbehind... - Our check string is offset from the beginning of the pattern. - So we need to do any stclass tests offset forward from that - point. I think. :-( - */ - - /* Got a candidate. Check MBOL anchoring, and the *other* substr. - Start with the other substr. - XXXX no SCREAM optimization yet - and a very coarse implementation - XXXX /ttx+/ results in anchored="ttx", floating="x". floating will - *always* match. Probably should be marked during compile... - Probably it is right to do no SCREAM here... - */ + + /* now look for the 'other' substring if defined */ if (utf8_target ? prog->substrs->data[other_ix].utf8_substr : prog->substrs->data[other_ix].substr) @@ -963,13 +1028,11 @@ Perl_re_intuit_start(pTHX_ * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift */ - if (!other_ix) - assert(prog->minlen > other->min_offset); - + assert(prog->minlen >= other->min_offset); last1 = HOP3c(strend, other->min_offset - prog->minlen, strbeg); - if (other_ix) { + if (other_ix) {/* i.e. if (other-is-float) */ /* last is the latest point where the floating substr could * start, *given* any constraints from the earlier fixed * match. This constraint is that the floating string starts @@ -1037,7 +1100,7 @@ Perl_re_intuit_start(pTHX_ other_last = HOP3c(last, 1, strend) /* highest failure */; rx_origin = - other_ix + other_ix /* i.e. if other-is-float */ ? HOP3c(rx_origin, 1, strend) : HOP4c(last, 1 - other->min_offset, strbeg, strend); goto restart; @@ -1046,7 +1109,7 @@ Perl_re_intuit_start(pTHX_ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", (long)(s - strpos))); - if (other_ix) { + if (other_ix) { /* if (other-is-float) */ /* other_last is set to s, not s+1, since its possible for * a floating substr to fail first time, then succeed * second time at the same floating position; e.g.: @@ -1081,53 +1144,56 @@ Perl_re_intuit_start(pTHX_ postprocess_substr_matches: - /* handle the extra constraint of /^/m */ + /* handle the extra constraint of /^.../m if present */ + + if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') { + char *s; - if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n' - /* May be due to an implicit anchor of m{.*foo} */ - && !(prog->intflags & PREGf_IMPLICIT)) - { - char *t; - - /* Eventually fbm_*() should handle this, but often - anchored_offset is not 0, so this check will not be wasted. */ - /* XXXX In the code below we prefer to look for "^" even in - presence of anchored substrings. And we search even - beyond the found float position. These pessimizations - are historical artefacts only. */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " looking for /^/m anchor")); /* we have failed the constraint of a \n before rx_origin. - * Find the next \n, if any ... */ + * Find the next \n, if any, even if it's beyond the current + * anchored and/or floating substrings. Whether we should be + * scanning ahead for the next \n or the next substr is debatable. + * On the one hand you'd expect rare substrings to appear less + * often than \n's. On the other hand, searching for \n means + * we're effectively flipping been check_substr and "\n" on each + * iteration as the current "rarest" string candidate, which + * means for example that we'll quickly reject the whole string if + * hasn't got a \n, rather than trying every substr position + * first + */ - t = (char *)memchr(rx_origin, '\n', - (strend - prog->minlen) - rx_origin); - if (!t) { + s = HOP3c(strend, - prog->minlen, strpos); + if (s <= rx_origin || + ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin))) + { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Did not find /%s^%s/m...\n", PL_colors[0], PL_colors[1])); goto fail_finish; } - rx_origin = t + 1; /* earliest possible origin is after the \n */ + /* earliest possible origin is 1 char after the \n. + * (since *rx_origin == '\n', it's safe to ++ here rather than + * HOP(rx_origin, 1)) */ + rx_origin++; - if (t >= check_at - prog->check_offset_min) { + if (prog->substrs->check_ix == 0 /* check is anchored */ + || rx_origin >= HOP3c(check_at, - prog->check_offset_min, strpos)) + { /* Position contradicts check-string; either because * check was anchored (and thus has no wiggle room), - * or check was float and t is above the float range */ - - /* XXXX probably better to look for check-string - than for "\n", so one should lower the limit for t? */ + * or check was float and rx_origin is above the float range */ DEBUG_EXECUTE_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 - strpos))); - other_last = rx_origin; + PL_colors[0], PL_colors[1], (long)(rx_origin - strpos))); goto restart; } /* if we get here, the check substr must have been float, - * is in range, and we may or may not have have an anchored + * is in range, and we may or may not have had an anchored * "other" substr which still contradicts */ assert(prog->substrs->check_ix); /* check is float */ @@ -1146,82 +1212,24 @@ Perl_re_intuit_start(pTHX_ /* success: we don't contradict the found floating substring * (and there's no anchored substr). */ - /* XXXX Why not check for STCLASS? */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Found /%s^%s/m at offset %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strpos))); } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Starting position does not contradict /%s^%s/m...\n", - PL_colors[0], PL_colors[1])); + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + " (multiline anchor test skipped)\n")); } + success_at_start: - /* Decide whether using the substrings helped */ - if (rx_origin != strpos) { - /* Fixed substring is found far enough so that the match - cannot start at strpos. */ - - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n")); - ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ - } - else { - /* 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, - or a future STCLASS check will fail this. */ - success_at_start: - if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */ - && (utf8_target ? ( - prog->check_utf8 /* Could be deleted already */ - && --BmUSEFUL(prog->check_utf8) < 0 - && (prog->check_utf8 == prog->float_utf8) - ) : ( - prog->check_substr /* Could be deleted already */ - && --BmUSEFUL(prog->check_substr) < 0 - && (prog->check_substr == prog->float_substr) - ))) - { - /* If flags & SOMETHING - do not do it many times on the same match */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n")); - /* XXX Does the destruction order has to change with utf8_target? */ - SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); - SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); - prog->check_substr = prog->check_utf8 = NULL; /* disable */ - prog->float_substr = prog->float_utf8 = NULL; /* clear */ - check = NULL; /* abort */ - /* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag - see http://bugs.activestate.com/show_bug.cgi?id=87173 */ - if (prog->intflags & PREGf_IMPLICIT) { - prog->intflags &= ~PREGf_ANCH_MBOL; - /* maybe we have no anchors left after this... */ - if (!(prog->intflags & PREGf_ANCH)) - prog->extflags &= ~RXf_IS_ANCHORED; - } - /* XXXX This is a remnant of the old implementation. It - looks wasteful, since now INTUIT can use many - other heuristics. */ - prog->extflags &= ~RXf_USE_INTUIT; - /* XXXX What other flags might need to be cleared in this branch? */ - } - } + /* if we have a starting character class, then test that extra constraint. + * (trie stclasses are too expensive to use here, we are better off to + * leave it to regmatch itself) */ - /* Last resort... */ - /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */ - /* trie stclasses are too expensive to use here, we are better off to - leave it to regmatch itself */ if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) { - /* minlen == 0 is possible if regstclass is \b or \B, - and the fixed substr is ''$. - Since minlen is already taken into account, rx_origin+1 is before strend; - accidentally, minlen >= 1 guaranties no false positives at rx_origin + 1 - even for \b or \B. But (minlen? 1 : 0) below assumes that - regstclass does not come from lookahead... */ - /* If regstclass takes bytelength more than 1: If charlength==1, OK. - This leaves EXACTF-ish only, which are dealt with in find_byclass(). */ const U8* const str = (U8*)STRING(progi->regstclass); - char *t; /* XXX this value could be pre-computed */ const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT @@ -1230,32 +1238,52 @@ Perl_re_intuit_start(pTHX_ : STR_LEN(progi->regstclass)) : 1); char * endpos; - char *s = rx_origin; + char *s; + /* latest pos that a matching float substr constrains rx start to */ + char *rx_max_float = NULL; + + /* if the current rx_origin is anchored, either by satisfying an + * anchored substring constraint, or a /^.../m constraint, then we + * can reject the current origin if the start class isn't found + * at the current position. If we have a float-only match, then + * rx_origin is constrained to a range; so look for the start class + * in that range. if neither, then look for the start class in the + * whole rest of the string */ + + /* XXX DAPM it's not clear what the minlen test is for, and why + * it's not used in the floating case. Nothing in the test suite + * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>. + * Here are some old comments, which may or may not be correct: + * + * minlen == 0 is possible if regstclass is \b or \B, + * and the fixed substr is ''$. + * Since minlen is already taken into account, rx_origin+1 is + * before strend; accidentally, minlen >= 1 guaranties no false + * positives at rx_origin + 1 even for \b or \B. But (minlen? 1 : + * 0) below assumes that regstclass does not come from lookahead... + * If regstclass takes bytelength more than 1: If charlength==1, OK. + * This leaves EXACTF-ish only, which are dealt with in + * find_byclass(). + */ + if (prog->anchored_substr || prog->anchored_utf8 || ml_anch) - endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend); - else if (prog->float_substr || prog->float_utf8) - endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend); + endpos= HOP3c(rx_origin, (prog->minlen ? cl_l : 0), strend); + else if (prog->float_substr || prog->float_utf8) { + rx_max_float = HOP3c(check_at, -start_shift, strbeg); + endpos= HOP3c(rx_max_float, cl_l, strend); + } else endpos= strend; - if (checked_upto < s) - checked_upto = s; DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " looking for class: start_shift: %"IVdf" check_at: %"IVdf - " s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n", + " rx_origin: %"IVdf" endpos: %"IVdf"\n", (IV)start_shift, (IV)(check_at - strbeg), - (IV)(s - strbeg), (IV)(endpos - strbeg), - (IV)(checked_upto- strbeg))); + (IV)(rx_origin - strbeg), (IV)(endpos - strbeg))); - t = s; - s = find_byclass(prog, progi->regstclass, checked_upto, endpos, + s = find_byclass(prog, progi->regstclass, rx_origin, endpos, reginfo); - if (s) { - checked_upto = s; - } else { -#ifdef DEBUGGING - const char *what = NULL; -#endif + if (!s) { if (endpos == strend) { DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " Could not match STCLASS...\n") ); @@ -1263,72 +1291,83 @@ Perl_re_intuit_start(pTHX_ } DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " This position contradicts STCLASS...\n") ); - if ((prog->intflags & PREGf_ANCH) && !ml_anch) + if ((prog->intflags & PREGf_ANCH) && !ml_anch + && !(prog->intflags & PREGf_IMPLICIT)) goto fail; - checked_upto = HOPBACKc(endpos, start_shift); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n", - (IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg))); + /* Contradict one of substrings */ if (prog->anchored_substr || prog->anchored_utf8) { - if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) { - DEBUG_EXECUTE_r( what = "anchored" ); - hop_and_restart: - s = HOP3c(t, 1, strend); - if (s + start_shift + end_shift > strend) { - /* XXXX Should be taken into account earlier? */ - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " Could not match STCLASS...\n") ); - goto fail; - } - rx_origin = s; - if (!check) - goto giveup; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " Looking for %s substr starting at offset %ld...\n", - what, (long)(rx_origin + start_shift - strpos)) ); - goto restart; - } - /* Have both, check_string is floating */ - if (t + start_shift >= check_at) /* Contradicts floating=check */ - goto retry_floating_check; - /* Recheck anchored substring, but not floating... */ - if (!check) { - rx_origin = NULL; - goto giveup; + if (prog->substrs->check_ix == 1) { /* check is float */ + /* Have both, check_string is floating */ + assert(rx_origin + start_shift <= check_at); + if (rx_origin + start_shift != check_at) { + /* not at latest position float substr could match: + * Recheck anchored substring, but not floating. + * The condition above is in bytes rather than + * chars for efficiency. It's conservative, in + * that it errs on the side of doing 'goto + * do_other_substr', where a more accurate + * char-based calculation will be done */ + DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + " Looking for anchored substr starting at offset %ld...\n", + (long)(other_last - strpos)) ); + goto do_other_substr; + } } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " Looking for anchored substr starting at offset %ld...\n", - (long)(other_last - strpos)) ); - assert(prog->substrs->check_ix); /* other is float */ - goto do_other_substr; - } - /* Another way we could have checked stclass at the - current position only: */ - if (ml_anch) { - s = rx_origin = t + 1; - if (!check) - goto giveup; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " Looking for /%s^%s/m starting at offset %ld...\n", - PL_colors[0], PL_colors[1], - (long)(rx_origin - strpos)) ); - /* XXX DAPM I don't yet know why this is true, but the code - * assumed it when it used to do goto try_at_offset */ - assert(rx_origin != strpos); - goto postprocess_substr_matches; - } - if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */ - goto fail; - /* Check is floating substring. */ - retry_floating_check: - t = check_at - start_shift; - DEBUG_EXECUTE_r( what = "floating" ); - goto hop_and_restart; + } + else { + /* float-only */ + + if (ml_anch) { + /* In the presence of ml_anch, we might be able to + * find another \n without breaking the current float + * constraint. */ + + /* strictly speaking this should be HOP3c(..., 1, ...), + * but since we goto a block of code that's going to + * search for the next \n if any, its safe here */ + rx_origin++; + DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + " Looking for /%s^%s/m starting at offset %ld...\n", + PL_colors[0], PL_colors[1], + (long)(rx_origin - strpos)) ); + goto postprocess_substr_matches; + } + + /* strictly speaking this can never be true; but might + * be if we ever allow intuit without substrings */ + if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) + goto fail; + + rx_origin = rx_max_float; + } + + /* at this point, any matching substrings have been + * contradicted. Start again... */ + + rx_origin = HOP3c(rx_origin, 1, strend); + + /* uses bytes rather than char calculations for efficiency. + * It's conservative: it errs on the side of doing 'goto restart', + * where there is code that does a proper char-based test */ + if (rx_origin + start_shift + end_shift > strend) { + DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + " Could not match STCLASS...\n") ); + goto fail; + } + DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + " Looking for %s substr starting at offset %ld...\n", + (prog->substrs->check_ix ? "floating" : "anchored"), + (long)(rx_origin + start_shift - strpos)) ); + goto restart; } - if (t != s) { + + /* Success !!! */ + + if (rx_origin != s) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " By STCLASS: moving %ld --> %ld\n", - (long)(t - strpos), (long)(s - strpos)) + (long)(rx_origin - strpos), (long)(s - strpos)) ); } else { @@ -1337,10 +1376,51 @@ Perl_re_intuit_start(pTHX_ ); } } - giveup: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Intuit: %s%s:%s match at offset %ld\n", - PL_colors[4], (check ? "Successfully guessed" : "Giving up"), - PL_colors[5], (long)(rx_origin - strpos)) ); + + /* Decide whether using the substrings helped */ + + if (rx_origin != strpos) { + /* Fixed substring is found far enough so that the match + cannot start at strpos. */ + + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n")); + ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ + } + else { + /* The found rx_origin position does not prohibit matching at + * strpos, so calling intuit didn't gain us anything. Decrement + * the BmUSEFUL() count on the check substring, and if we reach + * zero, free it. */ + if (!(prog->intflags & PREGf_NAUGHTY) + && (utf8_target ? ( + prog->check_utf8 /* Could be deleted already */ + && --BmUSEFUL(prog->check_utf8) < 0 + && (prog->check_utf8 == prog->float_utf8) + ) : ( + prog->check_substr /* Could be deleted already */ + && --BmUSEFUL(prog->check_substr) < 0 + && (prog->check_substr == prog->float_substr) + ))) + { + /* If flags & SOMETHING - do not do it many times on the same match */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n")); + /* XXX Does the destruction order has to change with utf8_target? */ + SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); + SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); + prog->check_substr = prog->check_utf8 = NULL; /* disable */ + prog->float_substr = prog->float_utf8 = NULL; /* clear */ + check = NULL; /* abort */ + /* XXXX This is a remnant of the old implementation. It + looks wasteful, since now INTUIT can use many + other heuristics. */ + prog->extflags &= ~RXf_USE_INTUIT; + } + } + + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + "Intuit: %sSuccessfully guessed:%s match at offset %ld\n", + PL_colors[4], PL_colors[5], (long)(rx_origin - strpos)) ); + return rx_origin; fail_finish: /* Substring not found */ @@ -1352,6 +1432,7 @@ Perl_re_intuit_start(pTHX_ return NULL; } + #define DECL_TRIE_TYPE(scan) \ const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold, \ trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold } \ @@ -1368,7 +1449,7 @@ STMT_START { switch (trie_type) { \ case trie_utf8_exactfa_fold: \ flags |= FOLD_FLAGS_NOMIX_ASCII; \ - /* FALL THROUGH */ \ + /* FALLTHROUGH */ \ case trie_utf8_fold: \ if ( foldlen>0 ) { \ uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ @@ -1385,7 +1466,7 @@ STMT_START { break; \ case trie_latin_utf8_exactfa_fold: \ flags |= FOLD_FLAGS_NOMIX_ASCII; \ - /* FALL THROUGH */ \ + /* FALLTHROUGH */ \ case trie_latin_utf8_fold: \ if ( foldlen>0 ) { \ uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ @@ -1421,10 +1502,10 @@ STMT_START { } \ } STMT_END -#define REXEC_FBC_EXACTISH_SCAN(CoNd) \ +#define REXEC_FBC_EXACTISH_SCAN(COND) \ STMT_START { \ while (s <= e) { \ - if ( (CoNd) \ + if ( (COND) \ && (ln == 1 || folder(s, pat_string, ln)) \ && (reginfo->intuit || regtry(reginfo, &s)) )\ goto got_it; \ @@ -1432,134 +1513,179 @@ STMT_START { \ } \ } STMT_END -#define REXEC_FBC_UTF8_SCAN(CoDe) \ +#define REXEC_FBC_UTF8_SCAN(CODE) \ STMT_START { \ while (s < strend) { \ - CoDe \ + CODE \ s += UTF8SKIP(s); \ } \ } STMT_END -#define REXEC_FBC_SCAN(CoDe) \ +#define REXEC_FBC_SCAN(CODE) \ STMT_START { \ while (s < strend) { \ - CoDe \ + CODE \ s++; \ } \ } STMT_END -#define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \ -REXEC_FBC_UTF8_SCAN( \ - if (CoNd) { \ - if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it; \ - else \ - tmp = doevery; \ - } \ - else \ - tmp = 1; \ +#define REXEC_FBC_UTF8_CLASS_SCAN(COND) \ +REXEC_FBC_UTF8_SCAN( /* Loops while (s < strend) */ \ + if (COND) { \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it; \ + else \ + tmp = doevery; \ + } \ + else \ + tmp = 1; \ ) -#define REXEC_FBC_CLASS_SCAN(CoNd) \ -REXEC_FBC_SCAN( \ - if (CoNd) { \ - if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it; \ - else \ - tmp = doevery; \ - } \ - else \ - tmp = 1; \ +#define REXEC_FBC_CLASS_SCAN(COND) \ +REXEC_FBC_SCAN( /* Loops while (s < strend) */ \ + if (COND) { \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it; \ + else \ + tmp = doevery; \ + } \ + else \ + tmp = 1; \ ) -#define REXEC_FBC_TRYIT \ -if ((reginfo->intuit || regtry(reginfo, &s))) \ - goto got_it +/* This is the macro to use when we want to see if something that looks like it + * could match, actually does, and if so exits the loop */ +#define REXEC_FBC_TRYIT \ + if ((reginfo->intuit || regtry(reginfo, &s))) \ + goto got_it -#define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \ +#define REXEC_FBC_CSCAN(CONDUTF8,COND) \ if (utf8_target) { \ - REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \ + REXEC_FBC_UTF8_CLASS_SCAN(CONDUTF8); \ } \ else { \ - REXEC_FBC_CLASS_SCAN(CoNd); \ + REXEC_FBC_CLASS_SCAN(COND); \ } - + #define DUMP_EXEC_POS(li,s,doutf8) \ dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ startpos, doutf8) - -#define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ - tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ - tmp = TEST_NON_UTF8(tmp); \ - REXEC_FBC_UTF8_SCAN( \ - if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ - tmp = !tmp; \ - IF_SUCCESS; \ - } \ - else { \ - IF_FAIL; \ - } \ - ); \ - -#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \ - if (s == reginfo->strbeg) { \ - tmp = '\n'; \ - } \ - else { \ - U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \ - tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \ +/* The three macros below are slightly different versions of the same logic. + * + * The first is for /a and /aa when the target string is UTF-8. This can only + * match ascii, but it must advance based on UTF-8. The other two handle the + * non-UTF-8 and the more generic UTF-8 cases. In all three, we are looking + * for the boundary (or non-boundary) between a word and non-word character. + * The utf8 and non-utf8 cases have the same logic, but the details must be + * different. Find the "wordness" of the character just prior to this one, and + * compare it with the wordness of this one. If they differ, we have a + * boundary. At the beginning of the string, pretend that the previous + * character was a new-line. + * + * All these macros uncleanly have side-effects with each other and outside + * variables. So far it's been too much trouble to clean-up + * + * TEST_NON_UTF8 is the macro or function to call to test if its byte input is + * a word character or not. + * IF_SUCCESS is code to do if it finds that we are at a boundary between + * word/non-word + * IF_FAIL is code to do if we aren't at a boundary between word/non-word + * + * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we + * are looking for a boundary or for a non-boundary. If we are looking for a + * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and + * see if this tentative match actually works, and if so, to quit the loop + * here. And vice-versa if we are looking for a non-boundary. + * + * 'tmp' below in the next three macros in the REXEC_FBC_SCAN and + * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of + * TEST_NON_UTF8(s-1). To see this, note that that's what it is defined to be + * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal + * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that + * complement. But in that branch we complement tmp, meaning that at the + * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s), + * which means at the top of the loop in the next iteration, it is + * TEST_NON_UTF8(s-1) */ +#define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ + tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ + tmp = TEST_NON_UTF8(tmp); \ + REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \ + if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ + tmp = !tmp; \ + IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */ \ + } \ + else { \ + IF_FAIL; \ + } \ + ); \ + +/* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and + * TEST_UTF8 is a macro that for the same input code points returns identically + * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead */ +#define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL) \ + if (s == reginfo->strbeg) { \ + tmp = '\n'; \ + } \ + else { /* Back-up to the start of the previous character */ \ + U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \ + tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \ 0, UTF8_ALLOW_DEFAULT); \ - } \ - tmp = TeSt1_UtF8; \ - LOAD_UTF8_CHARCLASS_ALNUM(); \ - REXEC_FBC_UTF8_SCAN( \ - if (tmp == ! (TeSt2_UtF8)) { \ - tmp = !tmp; \ - IF_SUCCESS; \ - } \ - else { \ - IF_FAIL; \ - } \ - ); \ + } \ + tmp = TEST_UV(tmp); \ + LOAD_UTF8_CHARCLASS_ALNUM(); \ + REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \ + if (tmp == ! (TEST_UTF8((U8 *) s))) { \ + tmp = !tmp; \ + IF_SUCCESS; \ + } \ + else { \ + IF_FAIL; \ + } \ + ); /* The only difference between the BOUND and NBOUND cases is that * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in - * NBOUND. This is accomplished by passing it in either the if or else clause, - * with the other one being empty */ -#define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) - -#define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) - -#define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) - -#define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \ - FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) - - -/* Common to the BOUND and NBOUND cases. Unfortunately the UTF8 tests need to - * be passed in completely with the variable name being tested, which isn't - * such a clean interface, but this is easier to read than it was before. We - * are looking for the boundary (or non-boundary between a word and non-word - * character. The utf8 and non-utf8 cases have the same logic, but the details - * must be different. Find the "wordness" of the character just prior to this - * one, and compare it with the wordness of this one. If they differ, we have - * a boundary. At the beginning of the string, pretend that the previous - * character was a new-line */ + * NBOUND. This is accomplished by passing it as either the if or else clause, + * with the other one being empty (PLACEHOLDER is defined as empty). + * + * The TEST_FOO parameters are for operating on different forms of input, but + * all should be ones that return identically for the same underlying code + * points */ +#define FBC_BOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \ + TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) + +#define FBC_BOUND_A(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), \ + TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER) + +#define FBC_NBOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \ + TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) + +#define FBC_NBOUND_A(TEST_NON_UTF8, TEST_UV, TEST_UTF8) \ + FBC_BOUND_COMMON( \ + FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \ + TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) + +/* Like the above two macros. UTF8_CODE is the complete code for handling + * UTF-8. Common to the BOUND and NBOUND cases, set-up by the FBC_BOUND, etc + * macros below */ #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ if (utf8_target) { \ - UTF8_CODE \ + UTF8_CODE \ } \ else { /* Not utf8 */ \ tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ tmp = TEST_NON_UTF8(tmp); \ - REXEC_FBC_SCAN( \ + REXEC_FBC_SCAN( /* advances s while s < strend */ \ if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ - tmp = !tmp; \ IF_SUCCESS; \ + tmp = !tmp; \ } \ else { \ IF_FAIL; \ @@ -1569,11 +1695,11 @@ if ((reginfo->intuit || regtry(reginfo, &s))) \ if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s))) \ goto got_it; + /* We know what class REx starts with. Try to find this position... */ /* if reginfo->intuit, its a dryrun */ /* annoyingly all the vars in this routine have different names from their counterparts in regmatch. /grrr */ - STATIC char * S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo) @@ -1624,7 +1750,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ assert(! is_utf8_pat); - /* FALL THROUGH */ + /* FALLTHROUGH */ case EXACTFA: if (is_utf8_pat || utf8_target) { utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; @@ -1671,7 +1797,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, fold_array = PL_fold_latin1; folder = foldEQ_latin1; - /* FALL THROUGH */ + /* FALLTHROUGH */ do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there are no glitches with fold-length differences @@ -1762,47 +1888,30 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, } break; } + case BOUNDL: - RXp_MATCH_TAINTED_on(prog); - FBC_BOUND(isWORDCHAR_LC, - isWORDCHAR_LC_uvchr(tmp), - isWORDCHAR_LC_utf8((U8*)s)); + FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); break; case NBOUNDL: - RXp_MATCH_TAINTED_on(prog); - FBC_NBOUND(isWORDCHAR_LC, - isWORDCHAR_LC_uvchr(tmp), - isWORDCHAR_LC_utf8((U8*)s)); + FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); break; case BOUND: - FBC_BOUND(isWORDCHAR, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); break; case BOUNDA: - FBC_BOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); + FBC_BOUND_A(isWORDCHAR_A, isWORDCHAR_A, isWORDCHAR_A); break; case NBOUND: - FBC_NBOUND(isWORDCHAR, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); break; case NBOUNDA: - FBC_NBOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); + FBC_NBOUND_A(isWORDCHAR_A, isWORDCHAR_A, isWORDCHAR_A); break; case BOUNDU: - FBC_BOUND(isWORDCHAR_L1, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); break; case NBOUNDU: - FBC_NBOUND(isWORDCHAR_L1, - isWORDCHAR_uni(tmp), - cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); break; case LNBREAK: REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend), @@ -1818,7 +1927,6 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, /* FALLTHROUGH */ case POSIXL: - RXp_MATCH_TAINTED_on(prog); REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)), to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s))); break; @@ -1836,9 +1944,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, case NPOSIXA: if (utf8_target) { /* The complement of something that matches only ASCII matches all - * UTF-8 variant code points, plus everything in ASCII that isn't - * in the class */ - REXEC_FBC_UTF8_CLASS_SCAN(! UTF8_IS_INVARIANT(*s) + * non-ASCII, plus everything in ASCII that isn't in the class. */ + REXEC_FBC_UTF8_CLASS_SCAN(! isASCII_utf8(s) || ! _generic_isCC_A(*s, FLAGS(c))); break; } @@ -1902,7 +2009,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, macros */ case _CC_ENUM_SPACE: /* XXX would require separate code if we revert the change of \v matching this */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case _CC_ENUM_PSXSPC: REXEC_FBC_UTF8_CLASS_SCAN( @@ -2179,7 +2286,6 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, break; default: Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c)); - break; } return 0; got_it: @@ -2354,7 +2460,6 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* flags: For optimizations. See REXEC_* in regexp.h */ { - dVAR; struct regexp *const prog = ReANY(rx); char *s; regnode *c; @@ -2376,7 +2481,6 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* Be paranoid... */ if (prog == NULL || stringarg == NULL) { Perl_croak(aTHX_ "NULL regexp parameter"); - return 0; } DEBUG_EXECUTE_r( @@ -2518,13 +2622,14 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* see how far we have to get to not match where we matched before */ reginfo->till = stringarg + minend; - if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv) && !IS_PADGV(sv)) { + if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv)) { /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after S_cleanup_regmatch_info_aux has executed (registered by SAVEDESTRUCTOR_X below). S_cleanup_regmatch_info_aux modifies magic belonging to this SV. Not newSVsv, either, as it does not COW. */ + assert(!IS_PADGV(sv)); reginfo->sv = newSV(0); SvSetSV_nosteal(reginfo->sv, sv); SAVEFREESV(reginfo->sv); @@ -2856,7 +2961,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } DEBUG_EXECUTE_r({ SV * const prop = sv_newmortal(); - regprop(prog, prop, c); + regprop(prog, prop, c, reginfo); { RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1), s,strend-s,60); @@ -3075,7 +3180,6 @@ phooey: STATIC I32 /* 0 failure, 1 success */ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) { - dVAR; CHECKPOINT lastcp; REGEXP *const rx = reginfo->prog; regexp *const prog = ReANY(rx); @@ -3446,7 +3550,7 @@ S_dump_exec_pos(pTHX_ const char *locinput, * or 0 if non of the buffers matched. */ STATIC I32 -S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) +S_reg_check_named_buff_matched(const regexp *rex, const regnode *scan) { I32 n; RXi_GET_DECL(rex,rexi); @@ -3534,7 +3638,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, dVAR; U8 *pat = (U8*)STRING(text_node); - U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1]; + U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' }; if (OP(text_node) == EXACT) { @@ -3604,8 +3708,8 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } } - if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8(pat)) - || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1(pat))) + if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8_safe(pat, pat_end)) + || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1_safe(pat, pat_end))) { /* Multi-character folds require more context to sort out. Also * PL_utf8_foldclosures used below doesn't handle them, so have to @@ -3614,18 +3718,11 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } else { /* an EXACTFish node which doesn't begin with a multi-char fold */ c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat; - if (c1 > 256) { + if (c1 > 255) { /* Load the folds hash, if not already done */ SV** listp; if (! PL_utf8_foldclosures) { - if (! PL_utf8_tofold) { - U8 dummy[UTF8_MAXBYTES_CASE+1]; - - /* Force loading this by folding an above-Latin1 char */ - to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL); - assert(PL_utf8_tofold); /* Verify that worked */ - } - PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold); + _load_PL_utf8_foldclosures(); } /* The fold closures data structure is a hash with the keys @@ -3645,7 +3742,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } else { /* Does participate in folds */ AV* list = (AV*) *listp; - if (av_len(list) != 1) { + if (av_tindex(list) != 1) { /* If there aren't exactly two folds to this, it is * outside the scope of this function */ @@ -3667,10 +3764,10 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, /* Folds that cross the 255/256 boundary are forbidden * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and * one is ASCIII. Since the pattern character is above - * 256, and its only other match is below 256, the only + * 255, and its only other match is below 256, the only * legal match will be to itself. We have thrown away * the original, so have to compute which is the one - * above 255 */ + * above 255. */ if ((c1 < 256) != (c2 < 256)) { if ((OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE) @@ -3689,7 +3786,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } } } - else /* Here, c1 is < 255 */ + else /* Here, c1 is <= 255 */ if (utf8_target && HAS_NONLATIN1_FOLD_CLOSURE(c1) && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE)) @@ -3730,7 +3827,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ assert(! is_utf8_pat); - /* FALL THROUGH */ + /* FALLTHROUGH */ case EXACTFA: case EXACTFU_SS: case EXACTFU: @@ -3886,7 +3983,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SV * const prop = sv_newmortal(); regnode *rnext=regnext(scan); DUMP_EXEC_POS( locinput, scan, utf8_target ); - regprop(rex, prop, scan); + regprop(rex, prop, scan, reginfo); PerlIO_printf(Perl_debug_log, "%3"IVdf":%*s%s(%"IVdf")\n", @@ -3908,7 +4005,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS)); switch (state_num) { - case BOL: /* /^../ */ + case BOL: /* /^../ */ + case SBOL: /* /^../s */ if (locinput == reginfo->strbeg) break; sayNO; @@ -3921,11 +4019,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } sayNO; - case SBOL: /* /^../s */ - if (locinput == reginfo->strbeg) - break; - sayNO; - case GPOS: /* \G */ if (locinput == reginfo->ganch) break; @@ -3949,7 +4042,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) break; case EOL: /* /..$/ */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case SEOL: /* /..$/s */ if (!NEXTCHR_IS_EOS && nextchr != '\n') sayNO; @@ -3994,7 +4087,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sayNO_SILENT; assert(0); /* NOTREACHED */ } - /* FALL THROUGH */ + /* FALLTHROUGH */ case TRIE: /* (ab|cd) */ /* the basic plan of execution of the trie is: * At the beginning, run though all the states, and @@ -4407,7 +4500,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) const char * s; U32 fold_utf8_flags; - RX_MATCH_TAINTED_on(reginfo->prog); folder = foldEQ_locale; fold_array = PL_fold_locale; fold_utf8_flags = FOLDEQ_LOCALE; @@ -4423,7 +4515,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ assert(! is_utf8_pat); - /* FALL THROUGH */ + /* FALLTHROUGH */ case EXACTFA: /* /abc/iaa */ folder = foldEQ_latin1; fold_array = PL_fold_latin1; @@ -4480,8 +4572,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * have to set the FLAGS fields of these */ case BOUNDL: /* /\b/l */ case NBOUNDL: /* /\B/l */ - RX_MATCH_TAINTED_on(reginfo->prog); - /* FALL THROUGH */ case BOUND: /* /\b/ */ case BOUNDU: /* /\b/u */ case BOUNDA: /* /\b/a */ @@ -4552,7 +4642,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) break; default: Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan)); - break; } } /* Note requires that all BOUNDs be lower than all NBOUNDs in @@ -4588,10 +4677,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (NEXTCHR_IS_EOS) sayNO; - /* The locale hasn't influenced the outcome before this, so defer - * tainting until now */ - RX_MATCH_TAINTED_on(reginfo->prog); - /* Use isFOO_lc() for characters within Latin1. (Note that * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else * wouldn't be invariant) */ @@ -4965,7 +5050,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) const U8 *fold_array; UV utf8_fold_flags; - RX_MATCH_TAINTED_on(reginfo->prog); folder = foldEQ_locale; fold_array = PL_fold_locale; type = REFFL; @@ -5010,7 +5094,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) goto do_nref_ref_common; case REFFL: /* /\1/il */ - RX_MATCH_TAINTED_on(reginfo->prog); folder = foldEQ_locale; fold_array = PL_fold_locale; utf8_fold_flags = FOLDEQ_LOCALE; @@ -5128,7 +5211,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) startpoint = rei->program+1; ST.close_paren = 0; } + + /* Save all the positions seen so far. */ + ST.cp = regcppush(rex, 0, maxopenparen); + REGCP_SET(ST.lastcp); + + /* and then jump to the code we share with EVAL */ goto eval_recurse_doit; + assert(0); /* NOTREACHED */ case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */ @@ -5365,6 +5455,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) re->sublen = rex->sublen; re->suboffset = rex->suboffset; re->subcoffset = rex->subcoffset; + re->lastparen = 0; + re->lastcloseparen = 0; rei = RXi_GET(re); DEBUG_EXECUTE_r( debug_start_match(re_sv, utf8_target, locinput, @@ -5372,18 +5464,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) ); startpoint = rei->program + 1; ST.close_paren = 0; /* only used for GOSUB */ + /* Save all the seen positions so far. */ + ST.cp = regcppush(rex, 0, maxopenparen); + REGCP_SET(ST.lastcp); + /* and set maxopenparen to 0, since we are starting a "fresh" match */ + maxopenparen = 0; + /* run the pattern returned from (??{...}) */ - eval_recurse_doit: /* Share code with GOSUB below this line */ - /* run the pattern returned from (??{...}) */ - - /* Save *all* the positions. */ - ST.cp = regcppush(rex, 0, maxopenparen); - REGCP_SET(ST.lastcp); - - re->lastparen = 0; - re->lastcloseparen = 0; - - maxopenparen = 0; + eval_recurse_doit: /* Share code with GOSUB below this line + * At this point we expect the stack context to be + * set up correctly */ /* invalidate the S-L poscache. We're now executing a * different set of WHILEM ops (and their associated @@ -5395,6 +5485,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * pattern again */ reginfo->poscache_maxiter = 0; + /* the new regexp might have a different is_utf8_pat than we do */ is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(re_sv)); ST.prev_rex = rex_sv; @@ -5858,7 +5949,7 @@ NULL assert(0); /* NOTREACHED */ case WHILEM_A_min_fail: /* just failed to match A in a minimal match */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case WHILEM_A_pre_fail: /* just failed to match even minimal A */ REGCP_UNWIND(ST.lastcp); regcppop(rex, &maxopenparen); @@ -5935,7 +6026,7 @@ NULL if (next == scan) next = NULL; scan = NEXTOPER(scan); - /* FALL THROUGH */ + /* FALLTHROUGH */ case BRANCH: /* /(...|A|...)/ */ scan = NEXTOPER(scan); /* scan now points to inner node */ @@ -6490,7 +6581,7 @@ NULL assert(0); /* NOTREACHED */ } } - /* FALL THROUGH */ + /* FALLTHROUGH */ case CURLY_B_max_fail: /* failed to find B in a greedy match */ @@ -6611,7 +6702,7 @@ NULL case IFMATCH_A_fail: /* body of (?...A) failed */ ST.wanted = !ST.wanted; - /* FALL THROUGH */ + /* FALLTHROUGH */ case IFMATCH_A: /* body of (?...A) succeeded */ if (ST.logical) { @@ -6775,7 +6866,7 @@ NULL /* push a state that backtracks on success */ st->u.yes.prev_yes_state = yes_state; yes_state = st; - /* FALL THROUGH */ + /* FALLTHROUGH */ push_state: /* push a new regex state, then continue at scan */ { @@ -6934,6 +7025,8 @@ no_silent: sv_commit = &PL_sv_yes; sv_yes_mark = &PL_sv_no; } + assert(sv_err); + assert(sv_mrk); sv_setsv(sv_err, sv_commit); sv_setsv(sv_mrk, sv_yes_mark); } @@ -6967,7 +7060,6 @@ STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, regmatch_info *const reginfo, I32 max, int depth) { - dVAR; char *scan; /* Pointer to current position in target string */ I32 c; char *loceol = reginfo->strend; /* local version */ @@ -7110,13 +7202,12 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ assert(! reginfo->is_utf8_pat); - /* FALL THROUGH */ + /* FALLTHROUGH */ case EXACTFA: utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII; goto do_exactf; case EXACTFL: - RXp_MATCH_TAINTED_on(prog); utf8_flags = FOLDEQ_LOCALE; goto do_exactf; @@ -7210,7 +7301,6 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* FALLTHROUGH */ case POSIXL: - RXp_MATCH_TAINTED_on(prog); if (! utf8_target) { while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p), *scan))) @@ -7252,7 +7342,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, to_complement = 1; goto utf8_posix; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case NPOSIXA: if (! utf8_target) { @@ -7263,10 +7353,9 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, else { /* The complement of something that matches only ASCII matches all - * UTF-8 variant code points, plus everything in ASCII that isn't - * in the class. */ + * non-ASCII, plus everything in ASCII that isn't in the class. */ while (hardcount < max && scan < loceol - && (! UTF8_IS_INVARIANT(*scan) + && (! isASCII_utf8(scan) || ! _generic_isCC_A((U8) *scan, FLAGS(p)))) { scan += UTF8SKIP(scan); @@ -7334,7 +7423,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_SPACE: /* XXX would require separate code if we revert the change of \v matching this */ - /* FALL THROUGH */ + /* FALLTHROUGH */ case _CC_ENUM_PSXSPC: while (hardcount < max && scan < loceol @@ -7464,7 +7553,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, GET_RE_DEBUG_FLAGS_DECL; DEBUG_EXECUTE_r({ SV * const prop = sv_newmortal(); - regprop(prog, prop, p); + regprop(prog, prop, p, reginfo); PerlIO_printf(Perl_debug_log, "%*s %s can match %"IVdf" times out of %"IVdf"...\n", REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max); @@ -7490,14 +7579,18 @@ Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, *altsvp = NULL; } - return newSVsv(core_regclass_swash(prog, node, doinit, listsvp)); + return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL)); } -#endif -STATIC SV * -S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp) +SV * +Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, + const regnode* node, + bool doinit, + SV** listsvp, + SV** only_utf8_locale_ptr) { - /* Returns the swash for the input 'node' in the regex 'prog'. + /* For internal core use only. + * Returns the swash for the input 'node' in the regex 'prog'. * If is 'true', will attempt to create the swash if not already * done. * If is non-null, will return the printable contents of the @@ -7507,7 +7600,6 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit * swash are returned (in a printable form). * Tied intimately to how regcomp.c sets up the data structure */ - dVAR; SV *sw = NULL; SV *si = NULL; /* Input swash initialization string */ SV* invlist = NULL; @@ -7515,9 +7607,10 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit RXi_GET_DECL(prog,progi); const struct reg_data * const data = prog ? progi->data : NULL; - PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH; + PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA; - assert(ANYOF_NONBITMAP(node)); + assert(ANYOF_FLAGS(node) + & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD)); if (data && data->count) { const U32 n = ARG(node); @@ -7530,17 +7623,30 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit si = *ary; /* ary[0] = the string to initialize the swash with */ - /* Elements 2 and 3 are either both present or both absent. [2] is - * any inversion list generated at compile time; [3] indicates if + /* Elements 3 and 4 are either both present or both absent. [3] is + * any inversion list generated at compile time; [4] indicates if * that inversion list has any user-defined properties in it. */ - if (av_len(av) >= 2) { - invlist = ary[2]; - if (SvUV(ary[3])) { - swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY; + if (av_tindex(av) >= 2) { + if (only_utf8_locale_ptr + && ary[2] + && ary[2] != &PL_sv_undef) + { + *only_utf8_locale_ptr = ary[2]; + } + else { + assert(only_utf8_locale_ptr); + *only_utf8_locale_ptr = NULL; + } + + if (av_tindex(av) >= 3) { + invlist = ary[3]; + if (SvUV(ary[4])) { + swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY; + } + } + else { + invlist = NULL; } - } - else { - invlist = NULL; } /* Element [1] is reserved for the set-up swash. If already there, @@ -7548,8 +7654,9 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit if (ary[1] && SvROK(ary[1])) { sw = ary[1]; } - else if (si && doinit) { - + else if (doinit && ((si && si != &PL_sv_undef) + || (invlist && invlist != &PL_sv_undef))) { + assert(si); sw = _core_swash_init("utf8", /* the utf8 package */ "", /* nameless */ si, @@ -7564,7 +7671,7 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit /* If requested, return a printable version of what this swash matches */ if (listsvp) { - SV* matches_string = newSVpvn("", 0); + SV* matches_string = newSVpvs(""); /* The swash should be used, if possible, to get the data, as it * contains the resolved data. But this function can be called at @@ -7587,6 +7694,7 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit return sw; } +#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */ /* - reginclass - determine if a character falls into a character class @@ -7637,9 +7745,8 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const { match = TRUE; } - else if (flags & ANYOF_LOCALE) { + else if (flags & ANYOF_LOCALE_FLAGS) { if (flags & ANYOF_LOC_FOLD) { - RXp_MATCH_TAINTED_on(prog); if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) { match = TRUE; } @@ -7679,7 +7786,6 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const int count = 0; int to_complement = 0; - RXp_MATCH_TAINTED_on(prog); while (count < ANYOF_MAX) { if (ANYOF_POSIXL_TEST(n, count) && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c))) @@ -7694,53 +7800,40 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const } } - /* For /li matching and the current locale is a UTF-8 one, look at the - * special list, valid for just these circumstances. */ - if (! match - && (flags & ANYOF_LOC_FOLD) - && IN_UTF8_CTYPE_LOCALE - && ANYOF_UTF8_LOCALE_INVLIST(n)) - { - match = _invlist_contains_cp(ANYOF_UTF8_LOCALE_INVLIST(n), c); - } /* If the bitmap didn't (or couldn't) match, and something outside the - * bitmap could match, try that. Locale nodes specify completely the - * behavior of code points in the bit map (otherwise, a utf8 target would - * cause them to be treated as Unicode and not locale), except in - * the very unlikely event when this node is a synthetic start class, which - * could be a combination of locale and non-locale nodes. So allow locale - * to match for the synthetic start class, which will give a false - * positive that will be resolved when the match is done again as not part - * of the synthetic start class */ + * bitmap could match, try that. */ if (!match) { if (c >= 256 && (flags & ANYOF_ABOVE_LATIN1_ALL)) { match = TRUE; /* Everything above 255 matches */ } - else if (ANYOF_NONBITMAP(n) - && ((flags & ANYOF_NONBITMAP_NON_UTF8) - || (utf8_target - && (c >=256 - || (! (flags & ANYOF_LOCALE)) - || is_ANYOF_SYNTHETIC(n))))) - { - SV * const sw = core_regclass_swash(prog, n, TRUE, 0); + else if ((flags & ANYOF_NONBITMAP_NON_UTF8) + || (utf8_target && (flags & ANYOF_UTF8)) + || ((flags & ANYOF_LOC_FOLD) + && IN_UTF8_CTYPE_LOCALE + && ARG(n) != ANYOF_NONBITMAP_EMPTY)) + { + SV* only_utf8_locale = NULL; + SV * const sw = _get_regclass_nonbitmap_data(prog, n, TRUE, 0, + &only_utf8_locale); if (sw) { + U8 utf8_buffer[2]; U8 * utf8_p; if (utf8_target) { utf8_p = (U8 *) p; } else { /* Convert to utf8 */ - STRLEN len = 1; - utf8_p = bytes_to_utf8(p, &len); + utf8_p = utf8_buffer; + append_utf8_from_native_byte(*p, &utf8_p); + utf8_p = utf8_buffer; } if (swash_fetch(sw, utf8_p, TRUE)) { match = TRUE; } - - /* If we allocated a string above, free it */ - if (! utf8_target) Safefree(utf8_p); } + if (! match && only_utf8_locale && IN_UTF8_CTYPE_LOCALE) { + match = _invlist_contains_cp(only_utf8_locale, c); + } } if (UNICODE_IS_SUPER(c) @@ -7769,8 +7862,6 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) * 'off' >= 0, backwards if negative. But don't go outside of position * 'lim', which better be < s if off < 0 */ - dVAR; - PERL_ARGS_ASSERT_REGHOP3; if (off >= 0) { @@ -7795,8 +7886,6 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) STATIC U8 * S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) { - dVAR; - PERL_ARGS_ASSERT_REGHOP4; if (off >= 0) { @@ -7818,11 +7907,12 @@ S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) return s; } +/* like reghop3, but returns NULL on overrun, rather than returning last + * char pos */ + STATIC U8 * S_reghopmaybe3(U8* s, SSize_t off, const U8* lim) { - dVAR; - PERL_ARGS_ASSERT_REGHOPMAYBE3; if (off >= 0) { @@ -7904,7 +7994,7 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) /* this regexp is also owned by the new PL_reg_curpm, which will try to free it. */ av_push(PL_regex_padav, repointer); - PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav); + PL_reg_curpm->op_pmoffset = av_tindex(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } #endif @@ -7939,7 +8029,6 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) static void S_cleanup_regmatch_info_aux(pTHX_ void *arg) { - dVAR; regmatch_info_aux *aux = (regmatch_info_aux *) arg; regmatch_info_aux_eval *eval_state = aux->info_aux_eval; regmatch_slab *s; @@ -8031,7 +8120,6 @@ S_to_byte_substr(pTHX_ regexp *prog) /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile * on the converted value; returns FALSE if can't be converted. */ - dVAR; int i = 1; PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;