X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fre-engine-Hooks.git;a=blobdiff_plain;f=src%2F5021001%2Fregexec.c;fp=src%2F5019001%2Fregexec.c;h=5a3b4a301c1586fdde422160734b76346dadd1cf;hp=f29d0d421622920f539ed3c7c585f77fded8a57a;hb=819b78c9396701a0ef5fe7334e4054dd53c7ef93;hpb=5f4fe0b63e7d03e713a655997310a3875c40b7a8 diff --git a/src/5019001/regexec.c b/src/5021001/regexec.c similarity index 78% rename from src/5019001/regexec.c rename to src/5021001/regexec.c index f29d0d4..5a3b4a3 100644 --- a/src/5019001/regexec.c +++ b/src/5021001/regexec.c @@ -37,16 +37,6 @@ #include "re_top.h" #endif -/* At least one required character in the target string is expressible only in - * UTF-8. */ -static const char* const non_utf8_target_but_utf8_required - = "Can't match, because target string needs to be in UTF-8\n"; - -#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\ - goto target; \ -} STMT_END - /* * pregcomp and pregexec -- regsub and regerror are not used in perl * @@ -94,16 +84,28 @@ static const char* const non_utf8_target_but_utf8_required #include "inline_invlist.c" #include "unicode_constants.h" +#ifdef DEBUGGING +/* At least one required character in the target string is expressible only in + * UTF-8. */ +static const char* const non_utf8_target_but_utf8_required + = "Can't match, because target string needs to be in UTF-8\n"; +#endif + +#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\ + goto target; \ +} STMT_END + #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i) #ifndef STATIC #define STATIC static #endif -/* Valid for non-utf8 strings: avoids the reginclass +/* Valid only for non-utf8 strings: avoids the reginclass * call if there are no complications: i.e., if everything matchable is * straight forward in the bitmap */ -#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0) \ +#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,c+1,0) \ : ANYOF_BITMAP_TEST(p,*(c))) /* @@ -118,6 +120,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)) \ @@ -128,6 +131,24 @@ 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 \ + ? reghop3((U8*)(pos), off, (U8*)(lim)) \ + : (U8*)((pos + off) > lim ? lim : (pos + off))) + +#define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \ + ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \ + : (U8*)(pos + off)) +#define HOP4c(pos,off,llim, rlim) ((char*)HOP4(pos,off,llim, rlim)) #define NEXTCHR_EOS -10 /* nextchr has fallen off the end */ #define NEXTCHR_IS_EOS (nextchr < 0) @@ -140,11 +161,11 @@ static const char* const non_utf8_target_but_utf8_required SET_nextchr -#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name) STMT_START { \ +#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) STMT_START { \ if (!swash_ptr) { \ U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; \ swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \ - 1, 0, NULL, &flags); \ + 1, 0, invlist, &flags); \ assert(swash_ptr); \ } \ } STMT_END @@ -153,28 +174,33 @@ static const char* const non_utf8_target_but_utf8_required #ifdef DEBUGGING # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \ property_name, \ + invlist, \ utf8_char_in_property) \ - LOAD_UTF8_CHARCLASS(swash_ptr, property_name); \ + LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist); \ assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE)); #else # define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \ property_name, \ + invlist, \ utf8_char_in_property) \ - LOAD_UTF8_CHARCLASS(swash_ptr, property_name) + LOAD_UTF8_CHARCLASS(swash_ptr, property_name, invlist) #endif #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST( \ PL_utf8_swash_ptrs[_CC_WORDCHAR], \ - swash_property_names[_CC_WORDCHAR], \ - GREEK_SMALL_LETTER_IOTA_UTF8) + "", \ + PL_XPosix_ptrs[_CC_WORDCHAR], \ + LATIN_CAPITAL_LETTER_SHARP_S_UTF8); #define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \ STMT_START { \ LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_regular_begin, \ "_X_regular_begin", \ - GREEK_SMALL_LETTER_IOTA_UTF8); \ + NULL, \ + LATIN_CAPITAL_LETTER_SHARP_S_UTF8); \ LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_extend, \ "_X_extend", \ + NULL, \ COMBINING_GRAVE_ACCENT_UTF8); \ } STMT_END @@ -191,14 +217,14 @@ static const char* const non_utf8_target_but_utf8_required * although it may be done at run time beause of the REF possibility - more * investigation required. -- demerphq */ -#define JUMPABLE(rn) ( \ - OP(rn) == OPEN || \ +#define JUMPABLE(rn) ( \ + OP(rn) == OPEN || \ (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \ - OP(rn) == EVAL || \ - OP(rn) == SUSPEND || OP(rn) == IFMATCH || \ - OP(rn) == PLUS || OP(rn) == MINMOD || \ - OP(rn) == KEEPS || \ - (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \ + OP(rn) == EVAL || \ + OP(rn) == SUSPEND || OP(rn) == IFMATCH || \ + OP(rn) == PLUS || OP(rn) == MINMOD || \ + OP(rn) == KEEPS || \ + (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \ ) #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT) @@ -208,13 +234,13 @@ static const char* const non_utf8_target_but_utf8_required /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so we don't need this definition. */ #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF ) -#define IS_TEXTF(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn)==EXACTFA || OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF ) +#define IS_TEXTF(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFA || OP(rn)==EXACTFA_NO_TRIE || OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF ) #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL ) #else /* ... so we use this as its faster. */ #define IS_TEXT(rn) ( OP(rn)==EXACT ) -#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn) == EXACTFA) +#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn) == EXACTFA || OP(rn) == EXACTFA_NO_TRIE) #define IS_TEXTF(rn) ( OP(rn)==EXACTF ) #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL ) @@ -224,7 +250,7 @@ static const char* const non_utf8_target_but_utf8_required Search for mandatory following text node; for lookahead, the text must follow but for lookbehind (rn->flags != 0) we skip to the next step. */ -#define FIND_NEXT_IMPT(rn) STMT_START { \ +#define FIND_NEXT_IMPT(rn) STMT_START { \ while (JUMPABLE(rn)) { \ const OPCODE type = OP(rn); \ if (type == SUSPEND || PL_regkind[type] == CURLY) \ @@ -275,8 +301,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 @@ -297,8 +324,8 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) ); for (p = parenfloor+1; p <= (I32)maxopenparen; p++) { /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */ - SSPUSHINT(rex->offs[p].end); - SSPUSHINT(rex->offs[p].start); + SSPUSHIV(rex->offs[p].end); + SSPUSHIV(rex->offs[p].start); SSPUSHINT(rex->offs[p].start_tmp); DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n", @@ -370,10 +397,10 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) ); paren = *maxopenparen_p; for ( ; i > 0; i -= REGCP_PAREN_ELEMS) { - I32 tmps; + SSize_t tmps; rex->offs[paren].start_tmp = SSPOPINT; - rex->offs[paren].start = SSPOPINT; - tmps = SSPOPINT; + rex->offs[paren].start = SSPOPIV; + tmps = SSPOPIV; if (paren <= rex->lastparen) rex->offs[paren].end = tmps; DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log, @@ -485,7 +512,7 @@ S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) } else if (UTF8_IS_DOWNGRADEABLE_START(*character)) { return isFOO_lc(classnum, - TWO_BYTE_UTF8_TO_UNI(*character, *(character + 1))); + TWO_BYTE_UTF8_TO_NATIVE(*character, *(character + 1))); } if (classnum < _FIRST_NON_SWASH_CC) { @@ -493,8 +520,11 @@ S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) /* Initialize the swash unless done already */ if (! PL_utf8_swash_ptrs[classnum]) { U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; - PL_utf8_swash_ptrs[classnum] = _core_swash_init("utf8", - swash_property_names[classnum], &PL_sv_undef, 1, 0, NULL, &flags); + PL_utf8_swash_ptrs[classnum] = + _core_swash_init("utf8", + "", + &PL_sv_undef, 1, 0, + PL_XPosix_ptrs[classnum], &flags); } return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *) @@ -527,7 +557,7 @@ S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) */ I32 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, - char *strbeg, I32 minend, SV *screamer, U32 nosave) + char *strbeg, SSize_t minend, SV *screamer, U32 nosave) /* stringarg: the point in the string at which to begin matching */ /* strend: pointer to null at end of string */ /* strbeg: real beginning of string */ @@ -544,68 +574,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). - */ - -/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */ -/* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend. - Otherwise, only SvCUR(sv) is used to get strbeg. */ - -/* XXXX We assume that strpos is strbeg unless sv. */ - -/* 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 * @@ -620,34 +652,60 @@ Perl_re_intuit_start(pTHX_ { dVAR; struct regexp *const prog = ReANY(rx); - I32 start_shift = 0; + SSize_t start_shift = prog->check_offset_min; /* Should be nonnegative! */ - I32 end_shift = 0; - char *s; + SSize_t end_shift = 0; + /* current lowest pos in string where the regex can start matching */ + char *rx_origin = strpos; SV *check; - char *t; const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */ - I32 ml_anch; - char *other_last = NULL; /* other substr checked before this */ + U8 other_ix = 1 - prog->substrs->check_ix; + 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 */ regmatch_info *const reginfo = ®info_buf; -#ifdef DEBUGGING - const char * const i_strpos = strpos; -#endif GET_RE_DEBUG_FLAGS_DECL; PERL_ARGS_ASSERT_RE_INTUIT_START; PERL_UNUSED_ARG(flags); PERL_UNUSED_ARG(data); - /* CHR_DIST() would be more correct here but it makes things slow. */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + "Intuit: trying to determine minimum start position...\n")); + + /* for now, assume that all substr offsets are positive. If at some point + * in the future someone wants to do clever things with look-behind and + * -ve offsets, they'll need to fix up any code in this function + * which uses these offsets. See the thread beginning + * <20140113145929.GF27210@iabyn.com> + */ + assert(prog->substrs->data[0].min_offset >= 0); + assert(prog->substrs->data[0].max_offset >= 0); + assert(prog->substrs->data[1].min_offset >= 0); + assert(prog->substrs->data[1].max_offset >= 0); + assert(prog->substrs->data[2].min_offset >= 0); + assert(prog->substrs->data[2].max_offset >= 0); + + /* 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... [re_intuit_start]\n")); + " String too short...\n")); goto fail; } @@ -672,551 +730,702 @@ Perl_re_intuit_start(pTHX_ } check = prog->check_substr; } - if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */ - ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE) - || ( (prog->extflags & RXf_ANCH_BOL) - && !multiline ) ); /* Check after \n? */ - - if (!ml_anch) { - if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */ - && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */ - && (strpos != strbeg)) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); - goto fail; + + /* dump the various substring data */ + DEBUG_OPTIMISE_MORE_r({ + int i; + for (i=0; i<=2; i++) { + SV *sv = (utf8_target ? prog->substrs->data[i].utf8_substr + : prog->substrs->data[i].substr); + if (!sv) + continue; + + PerlIO_printf(Perl_debug_log, + " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf + " useful=%"IVdf" utf8=%d [%s]\n", + i, + (IV)prog->substrs->data[i].min_offset, + (IV)prog->substrs->data[i].max_offset, + (IV)prog->substrs->data[i].end_shift, + BmUSEFUL(sv), + utf8_target ? 1 : 0, + SvPEEK(sv)); } - if (prog->check_offset_min == prog->check_offset_max - && !(prog->extflags & RXf_CANY_SEEN) - && ! multiline) /* /m can cause \n's to match that aren't - accounted for in the string max length. - See [perl #115242] */ - { - /* Substring at constant offset from beg-of-str... */ - I32 slen; + }); - s = HOP3c(strpos, prog->check_offset_min, strend); + if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */ - if (SvTAIL(check)) { - slen = SvCUR(check); /* >= 1 */ + /* 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 ( 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")); - goto fail_finish; + 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. + * + * 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 ( strpos != strbeg + && (prog->intflags & (PREGf_ANCH_BOL|PREGf_ANCH_SBOL))) + { + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + " Not at start...\n")); + goto fail; + } + + /* 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. + * 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)) + { + /* Substring at constant offset from beg-of-str... */ + SSize_t slen = SvCUR(check); + 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. + * 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")); + goto fail_finish; + } + /* Now should match s[0..slen-2] */ + slen--; } - /* Now should match s[0..slen-2] */ - slen--; if (slen && (*SvPVX_const(check) != *s - || (slen > 1 - && memNE(SvPVX_const(check), s, slen)))) { - report_neq: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n")); + || (slen > 1 && memNE(SvPVX_const(check), s, slen)))) + { + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + " String not equal...\n")); goto fail_finish; } + + check_at = s; + goto success_at_start; } - else if (*SvPVX_const(check) != *s - || ((slen = SvCUR(check)) > 1 - && memNE(SvPVX_const(check), s, slen))) - goto report_neq; - check_at = s; - goto success_at_start; - } - } - /* Match is anchored, but substr is not anchored wrt beg-of-str. */ - s = strpos; - start_shift = prog->check_offset_min; /* okay to underestimate on CC */ - end_shift = prog->check_end_shift; - - if (!ml_anch) { - const I32 end = prog->check_offset_max + CHR_SVLEN(check) - - (SvTAIL(check) != 0); - const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end; - - if (end_shift < eshift) - end_shift = eshift; } } - else { /* Can match at random position */ - ml_anch = 0; - s = strpos; - start_shift = prog->check_offset_min; /* okay to underestimate on CC */ - end_shift = prog->check_end_shift; - /* end shift should be non negative here */ - } + end_shift = prog->check_end_shift; -#ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */ +#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ if (end_shift < 0) Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ", (IV)end_shift, RX_PRECOMP(prog)); #endif restart: - /* Find a possible match in the region s..strend by looking for - the "check" substring in the 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 */ { - I32 srch_start_shift = start_shift; - I32 srch_end_shift = end_shift; U8* start_point; U8* end_point; - if (srch_start_shift < 0 && strbeg - s > srch_start_shift) { - srch_end_shift -= ((strbeg - s) - srch_start_shift); - srch_start_shift = strbeg - s; - } - DEBUG_OPTIMISE_MORE_r({ - PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n", - (IV)prog->check_offset_min, - (IV)srch_start_shift, - (IV)srch_end_shift, - (IV)prog->check_end_shift); - }); - if (prog->extflags & RXf_CANY_SEEN) { - start_point= (U8*)(s + srch_start_shift); - end_point= (U8*)(strend - srch_end_shift); + DEBUG_OPTIMISE_MORE_r({ + PerlIO_printf(Perl_debug_log, + " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf + " Start shift: %"IVdf" End shift %"IVdf + " Real end Shift: %"IVdf"\n", + (IV)(rx_origin - strpos), + (IV)prog->check_offset_min, + (IV)start_shift, + (IV)end_shift, + (IV)prog->check_end_shift); + }); + + 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(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend); - end_point= HOP3(strend, -srch_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 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) + { + SSize_t len = SvCUR(check) - !!SvTAIL(check); + 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({ - PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n", + PerlIO_printf(Perl_debug_log, " fbm_instr len=%d str=<%.*s>\n", (int)(end_point - start_point), (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point), start_point); }); - s = fbm_instr( start_point, end_point, + 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", - (s ? "Found" : "Did not find"), - (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) - ? "anchored" : "floating"), - quoted, - RE_SV_TAIL(check), - (s ? " at offset " : "...\n") ); - }); - if (!s) - goto fail_finish; - /* Finish the diagnostic message */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) ); + /* Update the count-of-usability, remove useless subpatterns, + unshift s. */ - /* 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. :-( - */ + 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") ); + }); + if (!check_at) + goto fail_finish; + /* Finish the diagnostic message */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(check_at - strpos)) ); + /* 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. + */ - check_at=s; + if (check_at - rx_origin > prog->check_offset_max) + rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin); + } - /* 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->float_utf8 && prog->anchored_utf8) - : (prog->float_substr && prog->anchored_substr)) + if (utf8_target ? prog->substrs->data[other_ix].utf8_substr + : prog->substrs->data[other_ix].substr) { /* Take into account the "other" substring. */ - /* XXXX May be hopelessly wrong for UTF... */ - if (!other_last) - other_last = strpos; - if (check == (utf8_target ? prog->float_utf8 : prog->float_substr)) { - do_other_anchored: - { - char * const last = HOP3c(s, -start_shift, strbeg); - char *last1, *last2; - char * const saved_s = s; - SV* must; - - t = s - prog->check_offset_max; - if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ - && (!utf8_target - || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos)) - && t > strpos))) - NOOP; - else - t = strpos; - t = HOP3c(t, prog->anchored_offset, strend); - if (t < other_last) /* These positions already checked */ - t = other_last; - last2 = last1 = HOP3c(strend, -prog->minlen, strbeg); - if (last < last1) - last1 = last; - /* XXXX It is not documented what units *_offsets are in. - We assume bytes, but this is clearly wrong. - Meaning this code needs to be carefully reviewed for errors. - dmq. - */ + char *last, *last1; + char *s; + SV* must; + struct reg_substr_datum *other; + + do_other_substr: + other = &prog->substrs->data[other_ix]; + + /* if "other" is anchored: + * we've previously found a floating substr starting at check_at. + * This means that the regex origin must lie somewhere + * between min (rx_origin): HOP3(check_at, -check_offset_max) + * and max: HOP3(check_at, -check_offset_min) + * (except that min will be >= strpos) + * So the fixed substr must lie somewhere between + * HOP3(min, anchored_offset) + * HOP3(max, anchored_offset) + SvCUR(substr) + */ - /* On end-of-str: see comment below. */ - must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr; - if (must == &PL_sv_undef) { - s = (char*)NULL; - DEBUG_r(must = prog->anchored_utf8); /* for debug */ - } - else - s = fbm_instr( - (unsigned char*)t, - HOP3(HOP3(last1, prog->anchored_offset, strend) - + SvCUR(must), -(SvTAIL(must)!=0), strbeg), - must, - multiline ? FBMrf_MULTILINE : 0 - ); - DEBUG_EXECUTE_r({ - RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), - SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s", - (s ? "Found" : "Contradicts"), - quoted, RE_SV_TAIL(must)); - }); + /* if "other" is floating + * Calculate last1, the absolute latest point where the + * floating substr could start in the string, ignoring any + * constraints from the earlier fixed match. It is calculated + * as follows: + * + * strend - prog->minlen (in chars) is the absolute latest + * position within the string where the origin of the regex + * could appear. The latest start point for the floating + * substr is float_min_offset(*) on from the start of the + * regex. last1 simply combines thee two offsets. + * + * (*) You might think the latest start point should be + * float_max_offset from the regex origin, and technically + * you'd be correct. However, consider + * /a\d{2,4}bcd\w/ + * Here, float min, max are 3,5 and minlen is 7. + * This can match either + * /a\d\dbcd\w/ + * /a\d\d\dbcd\w/ + * /a\d\d\d\dbcd\w/ + * In the first case, the regex matches minlen chars; in the + * second, minlen+1, in the third, minlen+2. + * In the first case, the floating offset is 3 (which equals + * float_min), in the second, 4, and in the third, 5 (which + * equals float_max). In all cases, the floating string bcd + * can never start more than 4 chars from the end of the + * string, which equals minlen - float_min. As the substring + * starts to match more than float_min from the start of the + * regex, it makes the regex match more than minlen chars, + * and the two cancel each other out. So we can always use + * float_min - minlen, rather than float_max - minlen for the + * latest position in the string. + * + * Note that -minlen + float_min_offset is equivalent (AFAIKT) + * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift + */ + assert(prog->minlen >= other->min_offset); + last1 = HOP3c(strend, + other->min_offset - prog->minlen, strbeg); - if (!s) { - if (last1 >= last2) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - ", giving up...\n")); - goto fail_finish; - } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - ", trying floating at offset %ld...\n", - (long)(HOP3c(saved_s, 1, strend) - i_strpos))); - other_last = HOP3c(last1, prog->anchored_offset+1, strend); - s = HOP3c(last, 1, strend); - goto restart; - } - else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", - (long)(s - i_strpos))); - t = HOP3c(s, -prog->anchored_offset, strbeg); - other_last = HOP3c(s, 1, strend); - s = saved_s; - if (t == strpos) - goto try_at_start; - goto try_at_offset; - } - } + 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 + * <= float_max_offset chars from the regex origin (rx_origin). + * If this value is less than last1, use it instead. + */ + assert(rx_origin <= last1); + last = + /* this condition handles the offset==infinity case, and + * is a short-cut otherwise. Although it's comparing a + * byte offset to a char length, it does so in a safe way, + * since 1 char always occupies 1 or more bytes, + * so if a string range is (last1 - rx_origin) bytes, + * it will be less than or equal to (last1 - rx_origin) + * chars; meaning it errs towards doing the accurate HOP3 + * rather than just using last1 as a short-cut */ + (last1 - rx_origin) < other->max_offset + ? last1 + : (char*)HOP3lim(rx_origin, other->max_offset, last1); } - else { /* Take into account the floating substring. */ - char *last, *last1; - char * const saved_s = s; - SV* must; - - t = HOP3c(s, -start_shift, strbeg); - last1 = last = - HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg); - if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset) - last = HOP3c(t, prog->float_max_offset, strend); - s = HOP3c(t, prog->float_min_offset, strend); - if (s < other_last) - s = other_last; - /* XXXX It is not documented what units *_offsets are in. Assume bytes. */ - must = utf8_target ? prog->float_utf8 : prog->float_substr; - /* fbm_instr() takes into account exact value of end-of-str - if the check is SvTAIL(ed). Since false positives are OK, - and end-of-str is not later than strend we are OK. */ - if (must == &PL_sv_undef) { - s = (char*)NULL; - DEBUG_r(must = prog->float_utf8); /* for debug message */ - } - else - s = fbm_instr((unsigned char*)s, - (unsigned char*)last + SvCUR(must) - - (SvTAIL(must)!=0), - must, multiline ? FBMrf_MULTILINE : 0); - DEBUG_EXECUTE_r({ - RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), - SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, "%s floating substr %s%s", - (s ? "Found" : "Contradicts"), - quoted, RE_SV_TAIL(must)); - }); - if (!s) { - if (last1 == last) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - ", giving up...\n")); - goto fail_finish; - } + else { + assert(strpos + start_shift <= check_at); + last = HOP4c(check_at, other->min_offset - start_shift, + strbeg, strend); + } + + s = HOP3c(rx_origin, other->min_offset, strend); + if (s < other_last) /* These positions already checked */ + s = other_last; + + must = utf8_target ? other->utf8_substr : other->substr; + assert(SvPOK(must)); + s = fbm_instr( + (unsigned char*)s, + (unsigned char*)last + SvCUR(must) - (SvTAIL(must)!=0), + must, + multiline ? FBMrf_MULTILINE : 0 + ); + DEBUG_EXECUTE_r({ + RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), + SvPVX_const(must), RE_SV_DUMPLEN(must), 30); + PerlIO_printf(Perl_debug_log, " %s %s substr %s%s", + s ? "Found" : "Contradicts", + other_ix ? "floating" : "anchored", + quoted, RE_SV_TAIL(must)); + }); + + + if (!s) { + /* last1 is latest possible substr location. If we didn't + * find it before there, we never will */ + if (last >= last1) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - ", trying anchored starting at offset %ld...\n", - (long)(saved_s + 1 - i_strpos))); - other_last = last; - s = HOP3c(t, 1, strend); - goto restart; + ", giving up...\n")); + goto fail_finish; + } + + /* try to find the check substr again at a later + * position. Maybe next time we'll find the "other" substr + * in range too */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + ", trying %s at offset %ld...\n", + (other_ix ? "floating" : "anchored"), + (long)(HOP3c(check_at, 1, strend) - strpos))); + + other_last = HOP3c(last, 1, strend) /* highest failure */; + rx_origin = + other_ix /* i.e. if other-is-float */ + ? HOP3c(rx_origin, 1, strend) + : HOP4c(last, 1 - other->min_offset, strbeg, strend); + goto restart; + } + else { + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", + (long)(s - strpos))); + + 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.: + * "-AB--AABZ" =~ /\wAB\d*Z/ + * The first time round, anchored and float match at + * "-(AB)--AAB(Z)" then fail on the initial \w character + * class. Second time round, they match at "-AB--A(AB)(Z)". + */ + other_last = s; } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n", - (long)(s - i_strpos))); - other_last = s; /* Fix this later. --Hugo */ - s = saved_s; - if (t == strpos) - goto try_at_start; - goto try_at_offset; + rx_origin = HOP3c(s, -other->min_offset, strbeg); + other_last = HOP3c(s, 1, strend); } } } + else { + DEBUG_OPTIMISE_MORE_r( + PerlIO_printf(Perl_debug_log, + " Check-only match: offset min:%"IVdf" max:%"IVdf + " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf + " strend-strpos:%"IVdf"\n", + (IV)prog->check_offset_min, + (IV)prog->check_offset_max, + (IV)(check_at-strpos), + (IV)(rx_origin-strpos), + (IV)(rx_origin-check_at), + (IV)(strend-strpos) + ) + ); + } + postprocess_substr_matches: - t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos); + /* handle the extra constraint of /^.../m if present */ - DEBUG_OPTIMISE_MORE_r( - PerlIO_printf(Perl_debug_log, - "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n", - (IV)prog->check_offset_min, - (IV)prog->check_offset_max, - (IV)(s-strpos), - (IV)(t-strpos), - (IV)(t-s), - (IV)(strend-strpos) - ) - ); + if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') { + char *s; - if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */ - && (!utf8_target - || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos))) - && t > strpos))) - { - /* Fixed substring is found far enough so that the match - cannot start at strpos. */ - try_at_offset: - if (ml_anch && t[-1] != '\n') { - /* 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. */ - find_anchor: - while (t < strend - prog->minlen) { - if (*t == '\n') { - if (t < check_at - prog->check_offset_min) { - if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) { - /* 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 - is float. Redo checking for "other"=="fixed". - */ - strpos = t + 1; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n", - 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_EXECUTE_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; - } - /* Position contradicts check-string */ - /* XXXX probably better to look for check-string - than for "\n", so one should lower the limit for t? */ - 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 - i_strpos))); - other_last = strpos = s = t + 1; - goto restart; - } - t++; - } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n", - PL_colors[0], PL_colors[1])); + 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, 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 + */ + + 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; } - else { - DEBUG_EXECUTE_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(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. */ - 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 && (strpos != strbeg) && strpos[-1] != '\n' - /* May be due to an implicit anchor of m{.*foo} */ - && !(prog->intflags & PREGf_IMPLICIT)) + + /* 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 (prog->substrs->check_ix == 0 /* check is anchored */ + || rx_origin >= HOP3c(check_at, - prog->check_offset_min, strpos)) { - t = strpos; - goto find_anchor; + /* Position contradicts check-string; either because + * check was anchored (and thus has no wiggle room), + * 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)(rx_origin - strpos))); + goto restart; } - DEBUG_EXECUTE_r( if (ml_anch) - 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->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 */ - s = strpos; - /* 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->extflags &= ~RXf_ANCH_MBOL; - /* 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 get here, the check substr must have been float, + * 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 */ + + if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) { + /* whoops, the anchored "other" substr exists, so we still + * contradict. On the other hand, the float "check" substr + * didn't contradict, so just retry the anchored "other" + * substr */ + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + " Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n", + PL_colors[0], PL_colors[1], + (long)(rx_origin - strpos), + (long)(rx_origin - strpos + prog->anchored_offset))); + goto do_other_substr; } - else - s = strpos; + + /* success: we don't contradict the found floating substring + * (and there's no anchored substr). */ + 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, + " (multiline anchor test skipped)\n")); + } + + success_at_start: + + + /* 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, s+1 is before strend; - accidentally, minlen >= 1 guaranties no false positives at s + 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); + + /* XXX this value could be pre-computed */ const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT - ? CHR_DIST(str+STR_LEN(progi->regstclass), str) + ? (reginfo->is_utf8_pat + ? utf8_distance(str + STR_LEN(progi->regstclass), str) + : STR_LEN(progi->regstclass)) : 1); char * endpos; + 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, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n", - (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg))); + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + " looking for class: start_shift: %"IVdf" check_at: %"IVdf + " rx_origin: %"IVdf" endpos: %"IVdf"\n", + (IV)start_shift, (IV)(check_at - 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") ); + " Could not match STCLASS...\n") ); goto fail; } DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "This position contradicts STCLASS...\n") ); - if ((prog->extflags & RXf_ANCH) && !ml_anch) + " This position contradicts STCLASS...\n") ); + 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? */ + 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, - "Could not match STCLASS...\n") ); - goto fail; + " Looking for anchored substr starting at offset %ld...\n", + (long)(other_last - strpos)) ); + goto do_other_substr; } - if (!check) - goto giveup; + } + } + 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 substr starting at offset %ld...\n", - what, (long)(s + start_shift - i_strpos)) ); - goto restart; + " Looking for /%s^%s/m starting at offset %ld...\n", + PL_colors[0], PL_colors[1], + (long)(rx_origin - strpos)) ); + goto postprocess_substr_matches; } - /* 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... */ - s = check_at; - if (!check) - goto giveup; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "Looking for anchored substr starting at offset %ld...\n", - (long)(other_last - i_strpos)) ); - goto do_other_anchored; - } - /* Another way we could have checked stclass at the - current position only: */ - if (ml_anch) { - s = t = 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)(t - i_strpos)) ); - goto try_at_offset; + + /* 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; } - if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */ + + /* 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; - /* Check is floating substring. */ - retry_floating_check: - t = check_at - start_shift; - DEBUG_EXECUTE_r( what = "floating" ); - goto hop_and_restart; + } + 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 - i_strpos), (long)(s - i_strpos)) + " By STCLASS: moving %ld --> %ld\n", + (long)(rx_origin - strpos), (long)(s - strpos)) ); } else { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "Does not contradict STCLASS...\n"); + " Does not contradict STCLASS...\n"); ); } } - giveup: - DEBUG_EXECUTE_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; + + /* 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 */ if (prog->check_substr || prog->check_utf8) /* could be removed already */ @@ -1227,46 +1436,57 @@ 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 } \ + const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold, \ + trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold } \ trie_type = ((scan->flags == EXACT) \ ? (utf8_target ? trie_utf8 : trie_plain) \ - : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold)) + : (scan->flags == EXACTFA) \ + ? (utf8_target ? trie_utf8_exactfa_fold : trie_latin_utf8_exactfa_fold) \ + : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold)) #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \ -STMT_START { \ +STMT_START { \ STRLEN skiplen; \ + U8 flags = FOLD_FLAGS_FULL; \ switch (trie_type) { \ + case trie_utf8_exactfa_fold: \ + flags |= FOLD_FLAGS_NOMIX_ASCII; \ + /* FALLTHROUGH */ \ case trie_utf8_fold: \ if ( foldlen>0 ) { \ - uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ + uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ foldlen -= len; \ uscan += len; \ len=0; \ } else { \ - uvc = to_utf8_fold( (const U8*) uc, foldbuf, &foldlen ); \ + uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags); \ len = UTF8SKIP(uc); \ skiplen = UNISKIP( uvc ); \ foldlen -= skiplen; \ uscan = foldbuf + skiplen; \ } \ break; \ + case trie_latin_utf8_exactfa_fold: \ + flags |= FOLD_FLAGS_NOMIX_ASCII; \ + /* FALLTHROUGH */ \ case trie_latin_utf8_fold: \ if ( foldlen>0 ) { \ - uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ + uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \ foldlen -= len; \ uscan += len; \ len=0; \ } else { \ len = 1; \ - uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, FOLD_FLAGS_FULL); \ + uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags); \ skiplen = UNISKIP( uvc ); \ foldlen -= skiplen; \ uscan = foldbuf + skiplen; \ } \ break; \ case trie_utf8: \ - uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags ); \ + uvc = utf8n_to_uvchr( (const U8*) uc, UTF8_MAXLEN, &len, uniflags ); \ break; \ case trie_plain: \ uvc = (UV)*uc; \ @@ -1337,28 +1557,28 @@ REXEC_FBC_SCAN( \ tmp = 1; \ ) -#define REXEC_FBC_TRYIT \ +#define REXEC_FBC_TRYIT \ if ((reginfo->intuit || regtry(reginfo, &s))) \ goto got_it #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \ - if (utf8_target) { \ + if (utf8_target) { \ REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \ } \ else { \ REXEC_FBC_CLASS_SCAN(CoNd); \ } -#define DUMP_EXEC_POS(li,s,doutf8) \ +#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) \ +#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)) { \ + if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ tmp = !tmp; \ IF_SUCCESS; \ } \ @@ -1367,18 +1587,19 @@ if ((reginfo->intuit || regtry(reginfo, &s))) \ } \ ); \ -#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, 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, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT); \ + tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, \ + 0, UTF8_ALLOW_DEFAULT); \ } \ tmp = TeSt1_UtF8; \ - LOAD_UTF8_CHARCLASS_ALNUM(); \ + LOAD_UTF8_CHARCLASS_ALNUM(); \ REXEC_FBC_UTF8_SCAN( \ - if (tmp == ! (TeSt2_UtF8)) { \ + if (tmp == ! (TeSt2_UtF8)) { \ tmp = !tmp; \ IF_SUCCESS; \ } \ @@ -1413,9 +1634,9 @@ if ((reginfo->intuit || regtry(reginfo, &s))) \ * 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 */ -#define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ +#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'; \ @@ -1430,7 +1651,7 @@ if ((reginfo->intuit || regtry(reginfo, &s))) \ } \ ); \ } \ - if ((!prog->minlen && tmp) && (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... */ @@ -1469,11 +1690,9 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, /* We know what class it must start with. */ switch (OP(c)) { case ANYOF: - case ANYOF_SYNTHETIC: - case ANYOF_WARN_SUPER: if (utf8_target) { REXEC_FBC_UTF8_CLASS_SCAN( - reginclass(prog, c, (U8*)s, utf8_target)); + reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target)); } else { REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s)); @@ -1488,6 +1707,9 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, ); break; + case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ + assert(! is_utf8_pat); + /* FALLTHROUGH */ case EXACTFA: if (is_utf8_pat || utf8_target) { utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; @@ -1497,10 +1719,9 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, folder = foldEQ_latin1; /* /a, except the sharp s one which */ goto do_exactf_non_utf8; /* isn't dealt with by these */ - case EXACTF: + case EXACTF: /* This node only generated for non-utf8 patterns */ + assert(! is_utf8_pat); if (utf8_target) { - - /* regcomp.c already folded this if pattern is in UTF-8 */ utf8_fold_flags = 0; goto do_exactf_utf8; } @@ -1509,8 +1730,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, goto do_exactf_non_utf8; case EXACTFL: - if (is_utf8_pat || utf8_target) { - utf8_fold_flags = FOLDEQ_UTF8_LOCALE; + if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) { + utf8_fold_flags = FOLDEQ_LOCALE; goto do_exactf_utf8; } fold_array = PL_fold_locale; @@ -1523,7 +1744,6 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, } goto do_exactf_utf8; - case EXACTFU_TRICKYFOLD: case EXACTFU: if (is_utf8_pat || utf8_target) { utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0; @@ -1536,7 +1756,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 @@ -1556,7 +1776,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, * characters, and there are only 2 availabe, we know without * trying that it will fail; so don't start a match past the * required minimum number from the far end */ - e = HOP3c(strend, -((I32)ln), s); + e = HOP3c(strend, -((SSize_t)ln), s); if (reginfo->intuit && e < s) { e = s; /* Due to minlen logic of intuit() */ @@ -1602,7 +1822,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, * only 2 are left, it's guaranteed to fail, so don't start a * match that would require us to go beyond the end of the string */ - e = HOP3c(strend, -((I32)lnc), s); + e = HOP3c(strend, -((SSize_t)lnc), s); if (reginfo->intuit && e < s) { e = s; /* Due to minlen logic of intuit() */ @@ -1628,15 +1848,13 @@ 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(UNI_TO_NATIVE(tmp)), + isWORDCHAR_LC_uvchr(tmp), isWORDCHAR_LC_utf8((U8*)s)); break; case NBOUNDL: - RXp_MATCH_TAINTED_on(prog); FBC_NBOUND(isWORDCHAR_LC, - isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(tmp)), + isWORDCHAR_LC_uvchr(tmp), isWORDCHAR_LC_utf8((U8*)s)); break; case BOUND: @@ -1683,7 +1901,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; @@ -1701,9 +1918,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; } @@ -1747,7 +1963,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, classnum))) || (UTF8_IS_DOWNGRADEABLE_START(*s) && to_complement ^ cBOOL( - _generic_isCC(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1)), + _generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(*s, + *(s + 1)), classnum)))) { if (tmp && (reginfo->intuit || regtry(reginfo, &s))) @@ -1766,7 +1983,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( @@ -1805,8 +2022,10 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, if (! PL_utf8_swash_ptrs[classnum]) { U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; PL_utf8_swash_ptrs[classnum] = - _core_swash_init("utf8", swash_property_names[classnum], - &PL_sv_undef, 1, 0, NULL, &flags); + _core_swash_init("utf8", + "", + &PL_sv_undef, 1, 0, + PL_XPosix_ptrs[classnum], &flags); } /* This is a copy of the loop above for swash classes, though using the @@ -2041,20 +2260,169 @@ 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: return s; } +/* set RX_SAVED_COPY, RX_SUBBEG etc. + * flags have same meanings as with regexec_flags() */ + +static void +S_reg_set_capture_string(pTHX_ REGEXP * const rx, + char *strbeg, + char *strend, + SV *sv, + U32 flags, + bool utf8_target) +{ + struct regexp *const prog = ReANY(rx); + + if (flags & REXEC_COPY_STR) { +#ifdef PERL_ANY_COW + if (SvCANCOW(sv)) { + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, + "Copy on write: regexp capture, type %d\n", + (int) SvTYPE(sv)); + } + /* Create a new COW SV to share the match string and store + * in saved_copy, unless the current COW SV in saved_copy + * is valid and suitable for our purpose */ + if (( prog->saved_copy + && SvIsCOW(prog->saved_copy) + && SvPOKp(prog->saved_copy) + && SvIsCOW(sv) + && SvPOKp(sv) + && SvPVX(sv) == SvPVX(prog->saved_copy))) + { + /* just reuse saved_copy SV */ + if (RXp_MATCH_COPIED(prog)) { + Safefree(prog->subbeg); + RXp_MATCH_COPIED_off(prog); + } + } + else { + /* create new COW SV to share string */ + RX_MATCH_COPY_FREE(rx); + prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv); + } + prog->subbeg = (char *)SvPVX_const(prog->saved_copy); + assert (SvPOKp(prog->saved_copy)); + prog->sublen = strend - strbeg; + prog->suboffset = 0; + prog->subcoffset = 0; + } else +#endif + { + SSize_t min = 0; + SSize_t max = strend - strbeg; + SSize_t sublen; + + if ( (flags & REXEC_COPY_SKIP_POST) + && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */ + && !(PL_sawampersand & SAWAMPERSAND_RIGHT) + ) { /* don't copy $' part of string */ + U32 n = 0; + max = -1; + /* calculate the right-most part of the string covered + * by a capture. Due to look-ahead, this may be to + * the right of $&, so we have to scan all captures */ + while (n <= prog->lastparen) { + if (prog->offs[n].end > max) + max = prog->offs[n].end; + n++; + } + if (max == -1) + max = (PL_sawampersand & SAWAMPERSAND_LEFT) + ? prog->offs[0].start + : 0; + assert(max >= 0 && max <= strend - strbeg); + } + + if ( (flags & REXEC_COPY_SKIP_PRE) + && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */ + && !(PL_sawampersand & SAWAMPERSAND_LEFT) + ) { /* don't copy $` part of string */ + U32 n = 0; + min = max; + /* calculate the left-most part of the string covered + * by a capture. Due to look-behind, this may be to + * the left of $&, so we have to scan all captures */ + while (min && n <= prog->lastparen) { + if ( prog->offs[n].start != -1 + && prog->offs[n].start < min) + { + min = prog->offs[n].start; + } + n++; + } + if ((PL_sawampersand & SAWAMPERSAND_RIGHT) + && min > prog->offs[0].end + ) + min = prog->offs[0].end; + + } + + assert(min >= 0 && min <= max && min <= strend - strbeg); + sublen = max - min; + + if (RX_MATCH_COPIED(rx)) { + if (sublen > prog->sublen) + prog->subbeg = + (char*)saferealloc(prog->subbeg, sublen+1); + } + else + prog->subbeg = (char*)safemalloc(sublen+1); + Copy(strbeg + min, prog->subbeg, sublen, char); + prog->subbeg[sublen] = '\0'; + prog->suboffset = min; + prog->sublen = sublen; + RX_MATCH_COPIED_on(rx); + } + prog->subcoffset = prog->suboffset; + if (prog->suboffset && utf8_target) { + /* Convert byte offset to chars. + * XXX ideally should only compute this if @-/@+ + * has been seen, a la PL_sawampersand ??? */ + + /* If there's a direct correspondence between the + * string which we're matching and the original SV, + * then we can use the utf8 len cache associated with + * the SV. In particular, it means that under //g, + * sv_pos_b2u() will use the previously cached + * position to speed up working out the new length of + * subcoffset, rather than counting from the start of + * the string each time. This stops + * $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g; + * from going quadratic */ + if (SvPOKp(sv) && SvPVX(sv) == strbeg) + prog->subcoffset = sv_pos_b2u_flags(sv, prog->subcoffset, + SV_GMAGIC|SV_CONST_RETURN); + else + prog->subcoffset = utf8_length((U8*)strbeg, + (U8*)(strbeg+prog->suboffset)); + } + } + else { + RX_MATCH_COPY_FREE(rx); + prog->subbeg = strbeg; + prog->suboffset = 0; + prog->subcoffset = 0; + prog->sublen = strend - strbeg; + } +} + + + /* - regexec_flags - match a regexp against a string */ I32 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, - char *strbeg, I32 minend, SV *sv, void *data, U32 flags) + char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags) /* stringarg: the point in the string at which to begin matching */ /* strend: pointer to null at end of string */ /* strbeg: real beginning of string */ @@ -2062,21 +2430,17 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* sv: SV being matched: only used for utf8 flag, pos() etc; string * itself is accessed via the pointers above */ /* data: May be used for some additional optimizations. - Currently its only used, with a U32 cast, for transmitting - the ganch offset when doing a /g match. This will change */ -/* nosave: For optimizations. */ + Currently unused. */ +/* flags: For optimizations. See REXEC_* in regexp.h */ { dVAR; struct regexp *const prog = ReANY(rx); char *s; regnode *c; - char *startpos = stringarg; - I32 minlen; /* must match at least this many chars */ - I32 dontbother = 0; /* how many characters not to try at end */ - I32 end_shift = 0; /* Same for the end. */ /* CC */ - I32 scream_pos = -1; /* Internal iterator of scream. */ - char *scream_olds = NULL; + char *startpos; + SSize_t minlen; /* must match at least this many chars */ + SSize_t dontbother = 0; /* how many characters not to try at end */ const bool utf8_target = cBOOL(DO_UTF8(sv)); I32 multiline; RXi_GET_DECL(prog,progi); @@ -2090,16 +2454,69 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, PERL_UNUSED_ARG(data); /* Be paranoid... */ - if (prog == NULL || startpos == NULL) { + if (prog == NULL || stringarg == NULL) { Perl_croak(aTHX_ "NULL regexp parameter"); - return 0; } DEBUG_EXECUTE_r( - debug_start_match(rx, utf8_target, startpos, strend, + debug_start_match(rx, utf8_target, stringarg, strend, "Matching"); ); + startpos = stringarg; + + if (prog->intflags & PREGf_GPOS_SEEN) { + MAGIC *mg; + + /* set reginfo->ganch, the position where \G can match */ + + reginfo->ganch = + (flags & REXEC_IGNOREPOS) + ? stringarg /* use start pos rather than pos() */ + : (sv && (mg = mg_find_mglob(sv)) && mg->mg_len >= 0) + /* Defined pos(): */ + ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg) + : strbeg; /* pos() not defined; use start of string */ + + DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, + "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg))); + + /* in the presence of \G, we may need to start looking earlier in + * the string than the suggested start point of stringarg: + * if prog->gofs is set, then that's a known, fixed minimum + * offset, such as + * /..\G/: gofs = 2 + * /ab|c\G/: gofs = 1 + * or if the minimum offset isn't known, then we have to go back + * to the start of the string, e.g. /w+\G/ + */ + + if (prog->intflags & PREGf_ANCH_GPOS) { + startpos = reginfo->ganch - prog->gofs; + if (startpos < + ((flags & REXEC_FAIL_ON_UNDERFLOW) ? stringarg : strbeg)) + { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "fail: ganch-gofs before earliest possible start\n")); + return 0; + } + } + else if (prog->gofs) { + if (startpos - prog->gofs < strbeg) + startpos = strbeg; + else + startpos -= prog->gofs; + } + else if (prog->intflags & PREGf_GPOS_FLOAT) + startpos = strbeg; + } + + minlen = prog->minlen; + if ((startpos + minlen) > strend || startpos < strbeg) { + DEBUG_r(PerlIO_printf(Perl_debug_log, + "Regex match can't succeed, so not even tried\n")); + return 0; + } /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave), * which will call destuctors to reset PL_regmatch_state, free higher @@ -2108,10 +2525,54 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, oldsave = PL_savestack_ix; + s = startpos; + + if ((prog->extflags & RXf_USE_INTUIT) + && !(flags & REXEC_CHECKED)) + { + s = re_intuit_start(rx, sv, strbeg, startpos, strend, + flags, NULL); + if (!s) + return 0; + + if (prog->extflags & RXf_CHECK_ALL) { + /* we can match based purely on the result of INTUIT. + * Set up captures etc just for $& and $-[0] + * (an intuit-only match wont have $1,$2,..) */ + assert(!prog->nparens); + + /* s/// doesn't like it if $& is earlier than where we asked it to + * start searching (which can happen on something like /.\G/) */ + if ( (flags & REXEC_FAIL_ON_UNDERFLOW) + && (s < stringarg)) + { + /* this should only be possible under \G */ + assert(prog->intflags & PREGf_GPOS_SEEN); + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); + goto phooey; + } + + /* match via INTUIT shouldn't have any captures. + * Let @-, @+, $^N know */ + prog->lastparen = prog->lastcloseparen = 0; + RX_MATCH_UTF8_set(rx, utf8_target); + prog->offs[0].start = s - strbeg; + prog->offs[0].end = utf8_target + ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg + : s - strbeg + prog->minlenret; + if ( !(flags & REXEC_NOT_FIRST) ) + S_reg_set_capture_string(aTHX_ rx, + strbeg, strend, + sv, flags, utf8_target); + + return 1; + } + } + multiline = prog->extflags & RXf_PMf_MULTILINE; - minlen = prog->minlen; - if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) { + if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too short [regexec_flags]...\n")); goto phooey; @@ -2134,7 +2595,20 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, reginfo->poscache_maxiter = 0; /* not yet started a countdown */ reginfo->strend = strend; /* see how far we have to get to not match where we matched before */ - reginfo->till = startpos+minend; + reginfo->till = stringarg + minend; + + 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); + } /* reserve next 2 or 3 slots in PL_regmatch_state: * slot N+0: may currently be in use: skip it @@ -2187,43 +2661,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } /* If there is a "must appear" string, look for it. */ - s = startpos; - if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */ - MAGIC *mg; - if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */ - reginfo->ganch = startpos + prog->gofs; - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS IGNOREPOS: reginfo->ganch = startpos + %"UVxf"\n",(UV)prog->gofs)); - } else if (sv && SvTYPE(sv) >= SVt_PVMG - && SvMAGIC(sv) - && (mg = mg_find(sv, PERL_MAGIC_regex_global)) - && mg->mg_len >= 0) { - reginfo->ganch = strbeg + mg->mg_len; /* Defined pos() */ - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS MAGIC: reginfo->ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len)); - - if (prog->extflags & RXf_ANCH_GPOS) { - if (s > reginfo->ganch) - goto phooey; - s = reginfo->ganch - prog->gofs; - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs)); - if (s < strbeg) - goto phooey; - } - } - else if (data) { - reginfo->ganch = strbeg + PTR2UV(data); - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS DATA: reginfo->ganch= strbeg + %"UVxf"\n",PTR2UV(data))); - - } else { /* pos() not defined */ - reginfo->ganch = strbeg; - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS: reginfo->ganch = strbeg\n")); - } - } if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) { /* We have to be careful. If the previous successful match was from this regex we don't want a subsequent partially @@ -2242,27 +2680,13 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, PTR2UV(prog->offs) )); } - if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) { - re_scream_pos_data d; - - d.scream_olds = &scream_olds; - d.scream_pos = &scream_pos; - s = re_intuit_start(rx, sv, strbeg, s, strend, flags, &d); - if (!s) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n")); - goto phooey; /* not present */ - } - } - - /* Simplest case: anchored match need be tried only once. */ /* [unless only anchor is BOL and multiline is set] */ - if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) { - if (s == startpos && regtry(reginfo, &startpos)) + if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) { + if (s == startpos && regtry(reginfo, &s)) goto got_it; - else if (multiline || (prog->intflags & PREGf_IMPLICIT) - || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */ + else if (multiline || (prog->intflags & (PREGf_IMPLICIT | PREGf_ANCH_MBOL))) /* XXXX SBOL? */ { char *end; @@ -2336,14 +2760,15 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } /* end search for newline */ } /* end anchored/multiline check string search */ goto phooey; - } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) + } else if (prog->intflags & PREGf_ANCH_GPOS) { - /* the warning about reginfo->ganch being used without initialization - is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN - and we only enter this block when the same bit is set. */ - char *tmp_s = reginfo->ganch - prog->gofs; - - if (tmp_s >= strbeg && regtry(reginfo, &tmp_s)) + /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */ + assert(prog->intflags & PREGf_GPOS_SEEN); + /* For anchored \G, the only position it can match from is + * (ganch-gofs); we already set startpos to this above; if intuit + * moved us on from there, we can't possibly succeed */ + assert(startpos == reginfo->ganch - prog->gofs); + if (s == startpos && regtry(reginfo, &s)) goto got_it; goto phooey; } @@ -2399,8 +2824,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, || ((prog->float_substr != NULL || prog->float_utf8 != NULL) && prog->float_max_offset < strend - s)) { SV *must; - I32 back_max; - I32 back_min; + SSize_t back_max; + SSize_t back_min; char *last; char *last1; /* Last position checked before */ #ifdef DEBUGGING @@ -2445,7 +2870,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, last = strend; } else { last = HOP3c(strend, /* Cannot start after this */ - -(I32)(CHR_SVLEN(must) + -(SSize_t)(CHR_SVLEN(must) - (SvTAIL(must) != 0) + back_min), strbeg); } if (s > reginfo->strbeg) @@ -2455,11 +2880,10 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* XXXX check_substr already used to find "s", can optimize if check_substr==must. */ - scream_pos = -1; - dontbother = end_shift; + dontbother = 0; strend = HOPc(strend, -dontbother); while ( (s <= last) && - (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)), + (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg, strend), (unsigned char*)strend, must, multiline ? FBMrf_MULTILINE : 0)) ) { DEBUG_EXECUTE_r( did_match = 1 ); @@ -2512,7 +2936,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); @@ -2649,6 +3073,18 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, goto phooey; got_it: + /* s/// doesn't like it if $& is earlier than where we asked it to + * start searching (which can happen on something like /.\G/) */ + if ( (flags & REXEC_FAIL_ON_UNDERFLOW) + && (prog->offs[0].start < stringarg - strbeg)) + { + /* this should only be possible under \G */ + assert(prog->intflags & PREGf_GPOS_SEEN); + DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); + goto phooey; + } + DEBUG_BUFFERS_r( if (swap) PerlIO_printf(Perl_debug_log, @@ -2671,123 +3107,10 @@ got_it: RX_MATCH_UTF8_set(rx, utf8_target); /* make sure $`, $&, $', and $digit will work later */ - if ( !(flags & REXEC_NOT_FIRST) ) { - if (flags & REXEC_COPY_STR) { -#ifdef PERL_ANY_COW - if (SvCANCOW(sv)) { - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, - "Copy on write: regexp capture, type %d\n", - (int) SvTYPE(sv)); - } - RX_MATCH_COPY_FREE(rx); - prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv); - prog->subbeg = (char *)SvPVX_const(prog->saved_copy); - assert (SvPOKp(prog->saved_copy)); - prog->sublen = reginfo->strend - strbeg; - prog->suboffset = 0; - prog->subcoffset = 0; - } else -#endif - { - I32 min = 0; - I32 max = reginfo->strend - strbeg; - I32 sublen; - - if ( (flags & REXEC_COPY_SKIP_POST) - && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */ - && !(PL_sawampersand & SAWAMPERSAND_RIGHT) - ) { /* don't copy $' part of string */ - U32 n = 0; - max = -1; - /* calculate the right-most part of the string covered - * by a capture. Due to look-ahead, this may be to - * the right of $&, so we have to scan all captures */ - while (n <= prog->lastparen) { - if (prog->offs[n].end > max) - max = prog->offs[n].end; - n++; - } - if (max == -1) - max = (PL_sawampersand & SAWAMPERSAND_LEFT) - ? prog->offs[0].start - : 0; - assert(max >= 0 && max <= reginfo->strend - strbeg); - } - - if ( (flags & REXEC_COPY_SKIP_PRE) - && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */ - && !(PL_sawampersand & SAWAMPERSAND_LEFT) - ) { /* don't copy $` part of string */ - U32 n = 0; - min = max; - /* calculate the left-most part of the string covered - * by a capture. Due to look-behind, this may be to - * the left of $&, so we have to scan all captures */ - while (min && n <= prog->lastparen) { - if ( prog->offs[n].start != -1 - && prog->offs[n].start < min) - { - min = prog->offs[n].start; - } - n++; - } - if ((PL_sawampersand & SAWAMPERSAND_RIGHT) - && min > prog->offs[0].end - ) - min = prog->offs[0].end; - - } - - assert(min >= 0 && min <= max - && min <= reginfo->strend - strbeg); - sublen = max - min; - - if (RX_MATCH_COPIED(rx)) { - if (sublen > prog->sublen) - prog->subbeg = - (char*)saferealloc(prog->subbeg, sublen+1); - } - else - prog->subbeg = (char*)safemalloc(sublen+1); - Copy(strbeg + min, prog->subbeg, sublen, char); - prog->subbeg[sublen] = '\0'; - prog->suboffset = min; - prog->sublen = sublen; - RX_MATCH_COPIED_on(rx); - } - prog->subcoffset = prog->suboffset; - if (prog->suboffset && utf8_target) { - /* Convert byte offset to chars. - * XXX ideally should only compute this if @-/@+ - * has been seen, a la PL_sawampersand ??? */ - - /* If there's a direct correspondence between the - * string which we're matching and the original SV, - * then we can use the utf8 len cache associated with - * the SV. In particular, it means that under //g, - * sv_pos_b2u() will use the previously cached - * position to speed up working out the new length of - * subcoffset, rather than counting from the start of - * the string each time. This stops - * $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g; - * from going quadratic */ - if (SvPOKp(sv) && SvPVX(sv) == strbeg) - sv_pos_b2u(sv, &(prog->subcoffset)); - else - prog->subcoffset = utf8_length((U8*)strbeg, - (U8*)(strbeg+prog->suboffset)); - } - } - else { - RX_MATCH_COPY_FREE(rx); - prog->subbeg = strbeg; - prog->suboffset = 0; - prog->subcoffset = 0; - /* use reginfo->strend, as strend may have been modified */ - prog->sublen = reginfo->strend - strbeg; - } - } + if ( !(flags & REXEC_NOT_FIRST) ) + S_reg_set_capture_string(aTHX_ rx, + strbeg, reginfo->strend, + sv, flags, utf8_target); return 1; @@ -2818,7 +3141,7 @@ phooey: /* Set which rex is pointed to by PL_reg_curpm, handling ref counting. * Do inc before dec, in case old and new rex are the same */ -#define SET_reg_curpm(Re2) \ +#define SET_reg_curpm(Re2) \ if (reginfo->info_aux_eval) { \ (void)ReREFCNT_inc(Re2); \ ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \ @@ -2836,7 +3159,7 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) CHECKPOINT lastcp; REGEXP *const rx = reginfo->prog; regexp *const prog = ReANY(rx); - I32 result; + SSize_t result; RXi_GET_DECL(prog,progi); GET_RE_DEBUG_FLAGS_DECL; @@ -3083,11 +3406,11 @@ regmatch(), slabs allocated since entry are freed. #define DEBUG_STATE_pp(pp) \ DEBUG_STATE_r({ \ - DUMP_EXEC_POS(locinput, scan, utf8_target); \ + DUMP_EXEC_POS(locinput, scan, utf8_target); \ PerlIO_printf(Perl_debug_log, \ " %*s"pp" %s%s%s%s%s\n", \ depth*2, "", \ - PL_reg_name[st->resume_state], \ + PL_reg_name[st->resume_state], \ ((st==yes_state||st==mark_state) ? "[" : ""), \ ((st==yes_state) ? "Y" : ""), \ ((st==mark_state) ? "M" : ""), \ @@ -3203,7 +3526,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); @@ -3291,6 +3614,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] = { '\0' }; if (OP(text_node) == EXACT) { @@ -3310,136 +3634,186 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, c2 = c1 = valid_utf8_to_uvchr(pat, NULL); } } - else /* an EXACTFish node */ - if ((is_utf8_pat - && is_MULTI_CHAR_FOLD_utf8_safe(pat, - pat + STR_LEN(text_node))) - || (!is_utf8_pat - && is_MULTI_CHAR_FOLD_latin1_safe(pat, - pat + STR_LEN(text_node)))) - { - /* Multi-character folds require more context to sort out. Also - * PL_utf8_foldclosures used below doesn't handle them, so have to be - * handled outside this routine */ - use_chrtest_void = TRUE; - } - 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) { - /* Load the folds hash, if not already done */ - SV** listp; - if (! PL_utf8_foldclosures) { - if (! PL_utf8_tofold) { - U8 dummy[UTF8_MAXBYTES+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 */ + else { /* an EXACTFish node */ + U8 *pat_end = pat + STR_LEN(text_node); + + /* An EXACTFL node has at least some characters unfolded, because what + * they match is not known until now. So, now is the time to fold + * the first few of them, as many as are needed to determine 'c1' and + * 'c2' later in the routine. If the pattern isn't UTF-8, we only need + * to fold if in a UTF-8 locale, and then only the Sharp S; everything + * else is 1-1 and isn't assumed to be folded. In a UTF-8 pattern, we + * need to fold as many characters as a single character can fold to, + * so that later we can check if the first ones are such a multi-char + * fold. But, in such a pattern only locale-problematic characters + * aren't folded, so we can skip this completely if the first character + * in the node isn't one of the tricky ones */ + if (OP(text_node) == EXACTFL) { + + if (! is_utf8_pat) { + if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S) + { + folded[0] = folded[1] = 's'; + pat = folded; + pat_end = folded + 2; } - PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold); - } - - /* The fold closures data structure is a hash with the keys being - * the UTF-8 of every character that is folded to, like 'k', and - * the values each an array of all code points that fold to its - * key. e.g. [ 'k', 'K', KELVIN_SIGN ]. Multi-character folds are - * not included */ - if ((! (listp = hv_fetch(PL_utf8_foldclosures, - (char *) pat, - UTF8SKIP(pat), - FALSE)))) - { - /* Not found in the hash, therefore there are no folds - * containing it, so there is only a single character that - * could match */ - c2 = c1; } - else { /* Does participate in folds */ - AV* list = (AV*) *listp; - if (av_len(list) != 1) { + else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) { + U8 *s = pat; + U8 *d = folded; + int i; - /* If there aren't exactly two folds to this, it is outside - * the scope of this function */ - use_chrtest_void = TRUE; - } - else { /* There are two. Get them */ - SV** c_p = av_fetch(list, 0, FALSE); - if (c_p == NULL) { - Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); + for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) { + if (isASCII(*s)) { + *(d++) = (U8) toFOLD_LC(*s); + s++; + } + else { + STRLEN len; + _to_utf8_fold_flags(s, + d, + &len, + FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE); + d += len; + s += UTF8SKIP(s); } - c1 = SvUV(*c_p); + } + + pat = folded; + pat_end = d; + } + } + + 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 + * be handled outside this routine */ + use_chrtest_void = TRUE; + } + 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 > 255) { + /* Load the folds hash, if not already done */ + SV** listp; + if (! PL_utf8_foldclosures) { + _load_PL_utf8_foldclosures(); + } + + /* The fold closures data structure is a hash with the keys + * being the UTF-8 of every character that is folded to, like + * 'k', and the values each an array of all code points that + * fold to its key. e.g. [ 'k', 'K', KELVIN_SIGN ]. + * Multi-character folds are not included */ + if ((! (listp = hv_fetch(PL_utf8_foldclosures, + (char *) pat, + UTF8SKIP(pat), + FALSE)))) + { + /* Not found in the hash, therefore there are no folds + * containing it, so there is only a single character that + * could match */ + c2 = c1; + } + else { /* Does participate in folds */ + AV* list = (AV*) *listp; + if (av_tindex(list) != 1) { - c_p = av_fetch(list, 1, FALSE); - if (c_p == NULL) { - Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); + /* If there aren't exactly two folds to this, it is + * outside the scope of this function */ + use_chrtest_void = TRUE; } - c2 = SvUV(*c_p); - - /* Folds that cross the 255/256 boundary are forbidden if - * EXACTFL, or EXACTFA and one is ASCIII. Since the - * pattern character is above 256, 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 */ - if ((c1 < 256) != (c2 < 256)) { - if (OP(text_node) == EXACTFL - || (OP(text_node) == EXACTFA - && (isASCII(c1) || isASCII(c2)))) - { - if (c1 < 256) { - c1 = c2; - } - else { - c2 = c1; + else { /* There are two. Get them */ + SV** c_p = av_fetch(list, 0, FALSE); + if (c_p == NULL) { + Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); + } + c1 = SvUV(*c_p); + + c_p = av_fetch(list, 1, FALSE); + if (c_p == NULL) { + Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure"); + } + c2 = SvUV(*c_p); + + /* 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 + * 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. */ + if ((c1 < 256) != (c2 < 256)) { + if ((OP(text_node) == EXACTFL + && ! IN_UTF8_CTYPE_LOCALE) + || ((OP(text_node) == EXACTFA + || OP(text_node) == EXACTFA_NO_TRIE) + && (isASCII(c1) || isASCII(c2)))) + { + if (c1 < 256) { + c1 = c2; + } + else { + c2 = c1; + } } } } } } - } - else /* Here, c1 is < 255 */ - if (utf8_target - && HAS_NONLATIN1_FOLD_CLOSURE(c1) - && OP(text_node) != EXACTFL - && (OP(text_node) != EXACTFA || ! isASCII(c1))) - { - /* Here, there could be something above Latin1 in the target which - * folds to this character in the pattern. All such cases except - * LATIN SMALL LETTER Y WITH DIAERESIS have more than two characters - * involved in their folds, so are outside the scope of this - * function */ - if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { - c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS; - } - else { - use_chrtest_void = TRUE; + else /* Here, c1 is <= 255 */ + if (utf8_target + && HAS_NONLATIN1_FOLD_CLOSURE(c1) + && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE)) + && ((OP(text_node) != EXACTFA + && OP(text_node) != EXACTFA_NO_TRIE) + || ! isASCII(c1))) + { + /* Here, there could be something above Latin1 in the target + * which folds to this character in the pattern. All such + * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more + * than two characters involved in their folds, so are outside + * the scope of this function */ + if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { + c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS; + } + else { + use_chrtest_void = TRUE; + } } - } - else { /* Here nothing above Latin1 can fold to the pattern character */ - switch (OP(text_node)) { + else { /* Here nothing above Latin1 can fold to the pattern + character */ + switch (OP(text_node)) { - case EXACTFL: /* /l rules */ - c2 = PL_fold_locale[c1]; - break; + case EXACTFL: /* /l rules */ + c2 = PL_fold_locale[c1]; + break; - case EXACTF: - if (! utf8_target) { /* /d rules */ - c2 = PL_fold[c1]; + case EXACTF: /* This node only generated for non-utf8 + patterns */ + assert(! is_utf8_pat); + if (! utf8_target) { /* /d rules */ + c2 = PL_fold[c1]; + break; + } + /* FALLTHROUGH */ + /* /u rules for all these. This happens to work for + * EXACTFA as nothing in Latin1 folds to ASCII */ + case EXACTFA_NO_TRIE: /* This node only generated for + non-utf8 patterns */ + assert(! is_utf8_pat); + /* FALLTHROUGH */ + case EXACTFA: + case EXACTFU_SS: + case EXACTFU: + c2 = PL_fold_latin1[c1]; break; - } - /* FALLTHROUGH */ - /* /u rules for all these. This happens to work for - * EXACTFA as nothing in Latin1 folds to ASCII */ - case EXACTFA: - case EXACTFU_TRICKYFOLD: - case EXACTFU_SS: - case EXACTFU: - c2 = PL_fold_latin1[c1]; - break; - default: - Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node)); - assert(0); /* NOTREACHED */ + default: + Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node)); + assert(0); /* NOTREACHED */ + } } } } @@ -3481,7 +3855,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } /* returns -1 on failure, $+[0] on success */ -STATIC I32 +STATIC SSize_t S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) { #if PERL_VERSION < 9 && !defined(PERL_CORE) @@ -3499,7 +3873,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) regnode *scan; regnode *next; U32 n = 0; /* general value; init to avoid compiler warning */ - I32 ln = 0; /* len or last; init to avoid compiler warning */ + SSize_t ln = 0; /* len or last; init to avoid compiler warning */ char *locinput = startpos; char *pushinput; /* where to continue after a PUSH */ I32 nextchr; /* is always set to UCHARAT(locinput) */ @@ -3527,7 +3901,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) during a successful match */ U32 lastopen = 0; /* last open we saw */ bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0; - SV* const oreplsv = GvSV(PL_replgv); + SV* const oreplsv = GvSVn(PL_replgv); /* these three flags are set by various ops to signal information to * the very next op. They have a useful lifetime of exactly one loop * iteration, and are not preserved or restored by state pushes/pops @@ -3557,6 +3931,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) GET_RE_DEBUG_FLAGS_DECL; #endif + /* protect against undef(*^R) */ + SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv)); + /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */ multicall_oldcatch = 0; multicall_cv = NULL; @@ -3582,7 +3959,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", @@ -3605,7 +3982,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; @@ -3618,11 +3996,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; @@ -3640,16 +4013,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sayNO_SILENT; assert(0); /*NOTREACHED*/ - case EOL: /* /..$/ */ - goto seol; - case MEOL: /* /..$/m */ if (!NEXTCHR_IS_EOS && nextchr != '\n') sayNO; break; + case EOL: /* /..$/ */ + /* FALLTHROUGH */ case SEOL: /* /..$/s */ - seol: if (!NEXTCHR_IS_EOS && nextchr != '\n') sayNO; if (reginfo->strend - locinput > 1) @@ -3693,7 +4064,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 @@ -3947,7 +4318,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) while (chars) { if (utf8_target) { - uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len, + uvc = utf8n_to_uvchr((U8*)uc, UTF8_MAXLEN, &len, uniflags); uc += len; } @@ -3960,7 +4331,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) while (foldlen) { if (!--chars) break; - uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len, + uvc = utf8n_to_uvchr(uscan, UTF8_MAXLEN, &len, uniflags); uscan += len; foldlen -= len; @@ -4051,7 +4422,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) l++; } else { - if (TWO_BYTE_UTF8_TO_UNI(*l, *(l+1)) != * (U8*) s) { + if (TWO_BYTE_UTF8_TO_NATIVE(*l, *(l+1)) != * (U8*) s) + { sayNO; } l += 2; @@ -4074,7 +4446,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) s++; } else { - if (TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)) != * (U8*) l) { + if (TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)) != * (U8*) l) + { sayNO; } s += 2; @@ -4104,27 +4477,31 @@ 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_UTF8_LOCALE; + fold_utf8_flags = FOLDEQ_LOCALE; goto do_exactf; case EXACTFU_SS: /* /\x{df}/iu */ - case EXACTFU_TRICKYFOLD: /* /\x{390}/iu */ case EXACTFU: /* /abc/iu */ folder = foldEQ_latin1; fold_array = PL_fold_latin1; fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0; goto do_exactf; + case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 + patterns */ + assert(! is_utf8_pat); + /* FALLTHROUGH */ case EXACTFA: /* /abc/iaa */ folder = foldEQ_latin1; fold_array = PL_fold_latin1; fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII; goto do_exactf; - case EXACTF: /* /abc/i */ + case EXACTF: /* /abc/i This node only generated for + non-utf8 patterns */ + assert(! is_utf8_pat); folder = foldEQ; fold_array = PL_fold; fold_utf8_flags = 0; @@ -4133,7 +4510,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - if (utf8_target || is_utf8_pat || state_num == EXACTFU_SS) { + if (utf8_target + || is_utf8_pat + || state_num == EXACTFU_SS + || (state_num == EXACTFL && IN_UTF8_CTYPE_LOCALE)) + { /* Either target or the pattern are utf8, or has the issue where * the fold lengths may differ. */ const char * const l = locinput; @@ -4168,8 +4549,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 */ @@ -4187,7 +4566,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) const U8 * const r = reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg)); - ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags); + ln = utf8n_to_uvchr(r, (U8*) reginfo->strend - r, + 0, uniflags); } if (FLAGS(scan) != REGEX_LOCALE_CHARSET) { ln = isWORDCHAR_uni(ln); @@ -4200,7 +4580,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } } else { - ln = isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(ln)); + ln = isWORDCHAR_LC_uvchr(ln); n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC_utf8((U8*)locinput); } } @@ -4239,7 +4619,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 @@ -4249,11 +4628,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) break; case ANYOF: /* /[abc]/ */ - case ANYOF_WARN_SUPER: if (NEXTCHR_IS_EOS) sayNO; if (utf8_target) { - if (!reginclass(rex, scan, (U8*)locinput, utf8_target)) + if (!reginclass(rex, scan, (U8*)locinput, (U8*)reginfo->strend, + utf8_target)) sayNO; locinput += UTF8SKIP(locinput); } @@ -4275,10 +4654,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) */ @@ -4289,7 +4664,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), - (U8) TWO_BYTE_UTF8_TO_UNI(nextchr, + (U8) TWO_BYTE_UTF8_TO_NATIVE(nextchr, *(locinput + 1)))))) { sayNO; @@ -4370,7 +4745,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { if (! (to_complement - ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(nextchr, + ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(nextchr, *(locinput + 1)), FLAGS(scan))))) { @@ -4388,8 +4763,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; PL_utf8_swash_ptrs[classnum] = _core_swash_init("utf8", - swash_property_names[classnum], - &PL_sv_undef, 1, 0, NULL, &flags); + "", + &PL_sv_undef, 1, 0, + PL_XPosix_ptrs[classnum], &flags); } if (! (to_complement ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], @@ -4651,11 +5027,10 @@ 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; - utf8_fold_flags = FOLDEQ_UTF8_LOCALE; + utf8_fold_flags = FOLDEQ_LOCALE; goto do_nref; case NREFFA: /* /\g{name}/iaa */ @@ -4696,10 +5071,9 @@ 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_UTF8_LOCALE; + utf8_fold_flags = FOLDEQ_LOCALE; goto do_ref; case REFFA: /* /\1/iaa */ @@ -4739,8 +5113,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) s = reginfo->strbeg + ln; if (type != REF /* REF can do byte comparison */ - && (utf8_target || type == REFFU)) - { /* XXX handle REFFL better */ + && (utf8_target || type == REFFU || type == REFFL)) + { char * limit = reginfo->strend; /* This call case insensitively compares the entire buffer @@ -4814,7 +5188,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/ */ @@ -4926,8 +5307,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) rex->offs[0].end = locinput - reginfo->strbeg; if (reginfo->info_aux_eval->pos_magic) - reginfo->info_aux_eval->pos_magic->mg_len - = locinput - reginfo->strbeg; + MgBYTEPOS_set(reginfo->info_aux_eval->pos_magic, + reginfo->sv, reginfo->strbeg, + locinput - reginfo->strbeg); if (sv_yes_mark) { SV *sv_mrk = get_sv("REGMARK", 1); @@ -4965,20 +5347,22 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) else { /* /(??{}) */ /* if its overloaded, let the regex compiler handle * it; otherwise extract regex, or stringify */ + if (SvGMAGICAL(ret)) + ret = sv_mortalcopy(ret); if (!SvAMAGIC(ret)) { SV *sv = ret; if (SvROK(sv)) sv = SvRV(sv); if (SvTYPE(sv) == SVt_REGEXP) re_sv = (REGEXP*) sv; - else if (SvSMAGICAL(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); + else if (SvSMAGICAL(ret)) { + MAGIC *mg = mg_find(ret, PERL_MAGIC_qr); if (mg) re_sv = (REGEXP *) mg->mg_obj; } - /* force any magic, undef warnings here */ - if (!re_sv) { + /* force any undef warnings here */ + if (!re_sv && !SvPOK(ret) && !SvNIOK(ret)) { ret = sv_mortalcopy(ret); (void) SvPV_force_nolen(ret); } @@ -4993,6 +5377,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) PL_op = oop; PL_curcop = ocurcop; S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen); + PL_curpm = PL_reg_curpm; if (logical != 2) break; @@ -5031,17 +5416,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) pm_flags); if (!(SvFLAGS(ret) - & (SVs_TEMP | SVs_PADTMP | SVf_READONLY - | SVs_GMG))) { + & (SVs_TEMP | SVs_GMG | SVf_ROK)) + && (!SvPADTMP(ret) || SvREADONLY(ret))) { /* This isn't a first class regexp. Instead, it's caching a regexp onto an existing, Perl visible scalar. */ sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0); } - /* safe to do now that any $1 etc has been - * interpolated into the new pattern string and - * compiled */ - S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen); } SAVEFREESV(re_sv); re = ReANY(re_sv); @@ -5051,6 +5432,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, @@ -5058,18 +5441,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) ); startpoint = rei->program + 1; ST.close_paren = 0; /* only used for GOSUB */ - - eval_recurse_doit: /* Share code with GOSUB below this line */ - /* run the pattern returned from (??{...}) */ - - /* Save *all* the positions. */ + /* Save all the seen positions so far. */ ST.cp = regcppush(rex, 0, maxopenparen); REGCP_SET(ST.lastcp); - - re->lastparen = 0; - re->lastcloseparen = 0; - + /* 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 + * 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 @@ -5081,6 +5462,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; @@ -5105,7 +5487,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SET_reg_curpm(rex_sv); rex = ReANY(rex_sv); rexi = RXi_GET(rex); - regcpblow(ST.cp); + { + /* preserve $^R across LEAVE's. See Bug 121070. */ + SV *save_sv= GvSV(PL_replgv); + SvREFCNT_inc(save_sv); + regcpblow(ST.cp); /* LEAVE in disguise */ + sv_setsv(GvSV(PL_replgv), save_sv); + SvREFCNT_dec(save_sv); + } cur_eval = ST.prev_eval; cur_curlyx = ST.prev_curlyx; @@ -5455,10 +5844,10 @@ NULL if (reginfo->poscache_iter-- == 0) { /* initialise cache */ - const I32 size = (reginfo->poscache_maxiter + 7)/8; + const SSize_t size = (reginfo->poscache_maxiter + 7)/8; regmatch_info_aux *const aux = reginfo->info_aux; if (aux->poscache) { - if ((I32)reginfo->poscache_size < size) { + if ((SSize_t)reginfo->poscache_size < size) { Renew(aux->poscache, size, char); reginfo->poscache_size = size; } @@ -5476,7 +5865,7 @@ NULL if (reginfo->poscache_iter < 0) { /* have we already failed at this position? */ - I32 offset, mask; + SSize_t offset, mask; reginfo->poscache_iter = -1; /* stop eventual underflow */ offset = (scan->flags & 0xf) - 1 @@ -5537,7 +5926,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); @@ -5614,7 +6003,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 */ @@ -5801,7 +6190,7 @@ NULL /* simulate B failing */ DEBUG_OPTIMISE_r( PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=U+%"UVXf" c1=U+%"UVXf" c2=U+%"UVXf"\n", + "%*s CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n", (int)(REPORT_CODE_OFF+(depth*2)),"", valid_utf8_to_uvchr((U8 *) locinput, NULL), valid_utf8_to_uvchr(ST.c1_utf8, NULL), @@ -5815,7 +6204,7 @@ NULL /* simulate B failing */ DEBUG_OPTIMISE_r( PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=U+%X c1=U+%X c2=U+%X\n", + "%*s CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n", (int)(REPORT_CODE_OFF+(depth*2)),"", (int) nextchr, ST.c1, ST.c2) ); @@ -6169,7 +6558,7 @@ NULL assert(0); /* NOTREACHED */ } } - /* FALL THROUGH */ + /* FALLTHROUGH */ case CURLY_B_max_fail: /* failed to find B in a greedy match */ @@ -6290,7 +6679,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) { @@ -6454,7 +6843,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 */ { @@ -6554,6 +6943,10 @@ yes: * When popping the save stack, all these locals would be undone; * bypass this by setting the outermost saved $^R to the latest * value */ + /* I dont know if this is needed or works properly now. + * see code related to PL_replgv elsewhere in this file. + * Yves + */ if (oreplsv != GvSV(PL_replgv)) sv_setsv(oreplsv, GvSV(PL_replgv)); } @@ -6609,6 +7002,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); } @@ -6756,7 +7151,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* Target isn't utf8; convert the character in the UTF-8 * pattern to non-UTF8, and do a simple loop */ - c = TWO_BYTE_UTF8_TO_UNI(c, *(STRING(p) + 1)); + c = TWO_BYTE_UTF8_TO_NATIVE(c, *(STRING(p) + 1)); while (scan < loceol && UCHARAT(scan) == c) { scan++; } @@ -6783,21 +7178,23 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } break; + case EXACTFA_NO_TRIE: /* This node only generated for non-utf8 patterns */ + assert(! reginfo->is_utf8_pat); + /* FALLTHROUGH */ case EXACTFA: utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII; goto do_exactf; case EXACTFL: - RXp_MATCH_TAINTED_on(prog); - utf8_flags = FOLDEQ_UTF8_LOCALE; + utf8_flags = FOLDEQ_LOCALE; goto do_exactf; - case EXACTF: - utf8_flags = 0; - goto do_exactf; + case EXACTF: /* This node only generated for non-utf8 patterns */ + assert(! reginfo->is_utf8_pat); + utf8_flags = 0; + goto do_exactf; case EXACTFU_SS: - case EXACTFU_TRICKYFOLD: case EXACTFU: utf8_flags = reginfo->is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0; @@ -6861,11 +7258,10 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, break; } case ANYOF: - case ANYOF_WARN_SUPER: if (utf8_target) { while (hardcount < max && scan < loceol - && reginclass(prog, p, (U8*)scan, utf8_target)) + && reginclass(prog, p, (U8*)scan, (U8*) loceol, utf8_target)) { scan += UTF8SKIP(scan); hardcount++; @@ -6883,7 +7279,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))) @@ -6925,7 +7320,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) { @@ -6936,10 +7331,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); @@ -6983,8 +7377,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) { if (! (to_complement - ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(*scan, - *(scan + 1)), + ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(*scan, + *(scan + 1)), classnum)))) { break; @@ -7007,7 +7401,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 @@ -7066,8 +7460,10 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, if (! PL_utf8_swash_ptrs[classnum]) { U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; PL_utf8_swash_ptrs[classnum] = _core_swash_init( - "utf8", swash_property_names[classnum], - &PL_sv_undef, 1, 0, NULL, &flags); + "utf8", + "", + &PL_sv_undef, 1, 0, + PL_XPosix_ptrs[classnum], &flags); } while (hardcount < max && scan < loceol @@ -7135,7 +7531,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); @@ -7161,31 +7557,39 @@ 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'. - * If is true, will attempt to create the swash if not already + /* 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 swash initialization string in - * it. + * If is non-null, will return the printable contents of the + * swash. This can be used to get debugging information even before the + * swash exists, by calling this function with 'doinit' set to false, in + * which case the components that will be used to eventually create the + * 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; + SV *si = NULL; /* Input swash initialization string */ SV* invlist = NULL; 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); @@ -7198,26 +7602,40 @@ 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, * return it; if not, create it and store it there */ - if (SvROK(ary[1])) { + 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, @@ -7230,16 +7648,18 @@ 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(""); - /* Use the swash, if any, which has to have incorporated into it all - * possibilities */ + /* The swash should be used, if possible, to get the data, as it + * contains the resolved data. But this function can be called at + * compile-time, before everything gets resolved, in which case we + * return the currently best available information, which is the string + * that will eventually be used to do that resolving, 'si' */ if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL) && (si && si != &PL_sv_undef)) { - - /* If no swash, use the input initialization string, if available */ sv_catsv(matches_string, si); } @@ -7253,12 +7673,14 @@ 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 n is the ANYOF regnode p is the target string + p_end points to one byte beyond the end of the target string utf8_target tells whether p is in UTF-8. Returns true if matched; false otherwise. @@ -7270,7 +7692,7 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit */ STATIC bool -S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const bool utf8_target) +S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const U8* const p_end, const bool utf8_target) { dVAR; const char flags = ANYOF_FLAGS(n); @@ -7283,7 +7705,7 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const * UTF8_IS_INVARIANT() works even if not in UTF-8 */ if (! UTF8_IS_INVARIANT(c) && utf8_target) { STRLEN c_len = 0; - c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len, + c = utf8n_to_uvchr(p, p_end - p, &c_len, (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY); /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for @@ -7296,21 +7718,19 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const if (c < 256) { if (ANYOF_BITMAP_TEST(n, c)) match = TRUE; - else if (flags & ANYOF_NON_UTF8_LATIN1_ALL + else if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL && ! utf8_target && ! isASCII(c)) { match = TRUE; } - else if (flags & ANYOF_LOCALE) { - RXp_MATCH_TAINTED_on(prog); - - if ((flags & ANYOF_LOC_FOLD) - && ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) - { - match = TRUE; + else if (flags & ANYOF_LOCALE_FLAGS) { + if (flags & ANYOF_LOC_FOLD) { + if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) { + match = TRUE; + } } - else if (ANYOF_CLASS_TEST_ANY_SET(n)) { + if (! match && ANYOF_POSIXL_TEST_ANY_SET(n)) { /* The data structure is arranged so bits 0, 2, 4, ... are set * if the class includes the Posix character class given by @@ -7344,8 +7764,9 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const int count = 0; int to_complement = 0; + while (count < ANYOF_MAX) { - if (ANYOF_CLASS_TEST(n, count) + if (ANYOF_POSIXL_TEST(n, count) && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c))) { match = TRUE; @@ -7358,60 +7779,63 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const } } + /* 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 (utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256) { + 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)) - || OP(n) == ANYOF_SYNTHETIC)))) + 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 * const sw = core_regclass_swash(prog, n, TRUE, 0); + 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) - && OP(n) == ANYOF_WARN_SUPER + && (flags & ANYOF_WARN_SUPER) && ckWARN_d(WARN_NON_UNICODE)) { Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), - "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", c); + "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c); } } +#if ANYOF_INVERT != 1 + /* Depending on compiler optimization cBOOL takes time, so if don't have to + * use it, don't */ +# error ANYOF_INVERT needs to be set to 1, or guarded with cBOOL below, +#endif + /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */ - return cBOOL(flags & ANYOF_INVERT) ^ match; + return (flags & ANYOF_INVERT) ^ match; } STATIC U8 * -S_reghop3(U8 *s, I32 off, const U8* lim) +S_reghop3(U8 *s, SSize_t off, const U8* lim) { /* return the position 'off' UTF-8 characters away from 's', forward if * 'off' >= 0, backwards if negative. But don't go outside of position @@ -7440,13 +7864,8 @@ S_reghop3(U8 *s, I32 off, const U8* lim) return s; } -#ifdef XXX_dmq -/* there are a bunch of places where we use two reghop3's that should - be replaced with this routine. but since thats not done yet - we ifdef it out - dmq -*/ STATIC U8 * -S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim) +S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) { dVAR; @@ -7470,10 +7889,12 @@ S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim) } return s; } -#endif + +/* like reghop3, but returns NULL on overrun, rather than returning last + * char pos */ STATIC U8 * -S_reghopmaybe3(U8* s, I32 off, const U8* lim) +S_reghopmaybe3(U8* s, SSize_t off, const U8* lim) { dVAR; @@ -7534,19 +7955,14 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) DEFSV_set(reginfo->sv); } - if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv) - && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) { + if (!(mg = mg_find_mglob(reginfo->sv))) { /* prepare for quick setting of pos */ -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(reginfo->sv)) - sv_force_normal_flags(reginfo->sv, 0); -#endif - mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, NULL, 0); + mg = sv_magicext_mglob(reginfo->sv); mg->mg_len = -1; } eval_state->pos_magic = mg; eval_state->pos = mg->mg_len; + eval_state->pos_flags = mg->mg_flags; } else eval_state->pos_magic = NULL; @@ -7563,7 +7979,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 @@ -7621,7 +8037,12 @@ S_cleanup_regmatch_info_aux(pTHX_ void *arg) RXp_MATCH_COPIED_on(rex); } if (eval_state->pos_magic) + { eval_state->pos_magic->mg_len = eval_state->pos; + eval_state->pos_magic->mg_flags = + (eval_state->pos_magic->mg_flags & ~MGf_BYTES) + | (eval_state->pos_flags & MGf_BYTES); + } PL_curpm = eval_state->curpm; }