X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5aaab254c02795622bdf42e348ad8473aa1fc643..e322109a5f2971453e7404fd28ea1c8245701578:/regexec.c diff --git a/regexec.c b/regexec.c index 34941c1..5189aec 100644 --- a/regexec.c +++ b/regexec.c @@ -93,13 +93,6 @@ static const char* const non_utf8_target_but_utf8_required #include "inline_invlist.c" #include "unicode_constants.h" -#define RF_tainted 1 /* tainted information used? e.g. locale */ -#define RF_warned 2 /* warned about big count? */ - -#define RF_utf8 8 /* Pattern contains multibyte chars? */ - -#define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0) - #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i) #ifndef STATIC @@ -117,20 +110,21 @@ static const char* const non_utf8_target_but_utf8_required */ #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv)) -#define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b) +#define CHR_DIST(a,b) (reginfo->is_utf8_target ? utf8_distance(a,b) : a - b) #define HOPc(pos,off) \ - (char *)(PL_reg_match_utf8 \ - ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \ + (char *)(reginfo->is_utf8_target \ + ? reghop3((U8*)pos, off, \ + (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ : (U8*)(pos + off)) #define HOPBACKc(pos, off) \ - (char*)(PL_reg_match_utf8\ - ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \ - : (pos - off >= PL_bostr) \ + (char*)(reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \ + : (pos - off >= reginfo->strbeg) \ ? (U8*)pos - off \ : NULL) -#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off)) +#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)) @@ -138,138 +132,52 @@ static const char* const non_utf8_target_but_utf8_required #define NEXTCHR_IS_EOS (nextchr < 0) #define SET_nextchr \ - nextchr = ((locinput < PL_regeol) ? UCHARAT(locinput) : NEXTCHR_EOS) + nextchr = ((locinput < reginfo->strend) ? UCHARAT(locinput) : NEXTCHR_EOS) #define SET_locinput(p) \ locinput = (p); \ SET_nextchr -/* these are unrolled below in the CCC_TRY_XXX defined */ -#define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \ - if (!CAT2(PL_utf8_,class)) { \ - bool ok; \ - ENTER; save_re_context(); \ - ok=CAT2(is_utf8_,class)((const U8*)str); \ - PERL_UNUSED_VAR(ok); \ - assert(ok); assert(CAT2(PL_utf8_,class)); LEAVE; } } STMT_END -/* Doesn't do an assert to verify that is correct */ -#define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \ - if (!CAT2(PL_utf8_,class)) { \ - bool throw_away PERL_UNUSED_DECL; \ - ENTER; save_re_context(); \ - throw_away = CAT2(is_utf8_,class)((const U8*)" "); \ - PERL_UNUSED_VAR(throw_away); \ - LEAVE; } } STMT_END - -#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a") -#define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0") - -#define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \ - /* No asserts are done for some of these, in case called on a */ \ - /* Unicode version in which they map to nothing */ \ - LOAD_UTF8_CHARCLASS(X_regular_begin, HYPHEN_UTF8); \ - LOAD_UTF8_CHARCLASS(X_extend, COMBINING_GRAVE_ACCENT_UTF8); \ +#define LOAD_UTF8_CHARCLASS(swash_ptr, property_name) 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); \ + assert(swash_ptr); \ + } \ + } STMT_END -#define PLACEHOLDER /* Something for the preprocessor to grab onto */ +/* If in debug mode, we test that a known character properly matches */ +#ifdef DEBUGGING +# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \ + property_name, \ + utf8_char_in_property) \ + LOAD_UTF8_CHARCLASS(swash_ptr, property_name); \ + assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE)); +#else +# define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr, \ + property_name, \ + utf8_char_in_property) \ + LOAD_UTF8_CHARCLASS(swash_ptr, property_name) +#endif -/* The actual code for CCC_TRY, which uses several variables from the routine - * it's callable from. It is designed to be the bulk of a case statement. - * FUNC is the macro or function to call on non-utf8 targets that indicate if - * nextchr matches the class. - * UTF8_TEST is the whole test string to use for utf8 targets - * LOAD is what to use to test, and if not present to load in the swash for the - * class - * POS_OR_NEG is either empty or ! to complement the results of FUNC or - * UTF8_TEST test. - * The logic is: Fail if we're at the end-of-string; otherwise if the target is - * utf8 and a variant, load the swash if necessary and test using the utf8 - * test. Advance to the next character if test is ok, otherwise fail; If not - * utf8 or an invariant under utf8, use the non-utf8 test, and fail if it - * fails, or advance to the next character */ - -#define _CCC_TRY_CODE(POS_OR_NEG, FUNC, UTF8_TEST, CLASS, STR) \ - if (NEXTCHR_IS_EOS) { \ - sayNO; \ - } \ - if (utf8_target && UTF8_IS_CONTINUED(nextchr)) { \ - LOAD_UTF8_CHARCLASS(CLASS, STR); \ - if (POS_OR_NEG (UTF8_TEST)) { \ - sayNO; \ - } \ - } \ - else if (POS_OR_NEG (FUNC(nextchr))) { \ - sayNO; \ - } \ - goto increment_locinput; - -/* Handle the non-locale cases for a character class and its complement. It - * calls _CCC_TRY_CODE with a ! to complement the test for the character class. - * This is because that code fails when the test succeeds, so we want to have - * the test fail so that the code succeeds. The swash is stored in a - * predictable PL_ place */ -#define _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, \ - CLASS, STR) \ - case NAME: \ - _CCC_TRY_CODE( !, FUNC, \ - cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), \ - (U8*)locinput, TRUE)), \ - CLASS, STR) \ - case NNAME: \ - _CCC_TRY_CODE( PLACEHOLDER , FUNC, \ - cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), \ - (U8*)locinput, TRUE)), \ - CLASS, STR) \ - -/* Generate the case statements for both locale and non-locale character - * classes in regmatch for classes that don't have special unicode semantics. - * Locales don't use an immediate swash, but an intermediary special locale - * function that is called on the pointer to the current place in the input - * string. That function will resolve to needing the same swash. One might - * think that because we don't know what the locale will match, we shouldn't - * check with the swash loading function that it loaded properly; ie, that we - * should use LOAD_UTF8_CHARCLASS_NO_CHECK for those, but what is passed to the - * regular LOAD_UTF8_CHARCLASS is in non-locale terms, and so locale is - * irrelevant here */ -#define CCC_TRY(NAME, NNAME, FUNC, \ - NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \ - NAMEA, NNAMEA, FUNCA, \ - CLASS, STR) \ - case NAMEL: \ - PL_reg_flags |= RF_tainted; \ - _CCC_TRY_CODE( !, LCFUNC, LCFUNC_utf8((U8*)locinput), CLASS, STR) \ - case NNAMEL: \ - PL_reg_flags |= RF_tainted; \ - _CCC_TRY_CODE( PLACEHOLDER, LCFUNC, LCFUNC_utf8((U8*)locinput), \ - CLASS, STR) \ - case NAMEA: \ - if (NEXTCHR_IS_EOS || ! FUNCA(nextchr)) { \ - sayNO; \ - } \ - /* Matched a utf8-invariant, so don't have to worry about utf8 */ \ - locinput++; \ - break; \ - case NNAMEA: \ - if (NEXTCHR_IS_EOS || FUNCA(nextchr)) { \ - sayNO; \ - } \ - goto increment_locinput; \ - /* Generate the non-locale cases */ \ - _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, CLASS, STR) - -/* This is like CCC_TRY, but has an extra set of parameters for generating case - * statements to handle separate Unicode semantics nodes */ -#define CCC_TRY_U(NAME, NNAME, FUNC, \ - NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \ - NAMEU, NNAMEU, FUNCU, \ - NAMEA, NNAMEA, FUNCA, \ - CLASS, STR) \ - CCC_TRY(NAME, NNAME, FUNC, \ - NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8, \ - NAMEA, NNAMEA, FUNCA, \ - CLASS, STR) \ - _CCC_TRY_NONLOCALE(NAMEU, NNAMEU, FUNCU, CLASS, STR) +#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) + +#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); \ + LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_extend, \ + "_X_extend", \ + COMBINING_GRAVE_ACCENT_UTF8); \ + } STMT_END +#define PLACEHOLDER /* Something for the preprocessor to grab onto */ /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */ /* for use after a quantifier and before an EXACT-like node -- japhy */ @@ -328,8 +236,22 @@ static const char* const non_utf8_target_but_utf8_required } \ } STMT_END +/* These constants are for finding GCB=LV and GCB=LVT in the CLUMP regnode. + * These are for the pre-composed Hangul syllables, which are all in a + * contiguous block and arranged there in such a way so as to facilitate + * alorithmic determination of their characteristics. As such, they don't need + * a swash, but can be determined by simple arithmetic. Almost all are + * GCB=LVT, but every 28th one is a GCB=LV */ +#define SBASE 0xAC00 /* Start of block */ +#define SCount 11172 /* Length of block */ +#define TCount 28 + +#define SLAB_FIRST(s) (&(s)->states[0]) +#define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1]) -static void restore_pos(pTHX_ void *arg); +static void S_setup_eval_state(pTHX_ regmatch_info *const reginfo); +static void S_cleanup_regmatch_info_aux(pTHX_ void *arg); +static regmatch_state * S_push_slab(pTHX); #define REGCP_PAREN_ELEMS 3 #define REGCP_OTHER_ELEMS 3 @@ -338,11 +260,12 @@ static void restore_pos(pTHX_ void *arg); * are needed for the regexp context stack bookkeeping. */ STATIC CHECKPOINT -S_regcppush(pTHX_ const regexp *rex, I32 parenfloor) +S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) { dVAR; const int retval = PL_savestack_ix; - const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS; + const int paren_elems_to_push = + (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS; const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS; const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT; I32 p; @@ -357,19 +280,21 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor) if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems) Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf " out of range (%lu-%ld)", - total_elems, (unsigned long)PL_regsize, (long)parenfloor); + total_elems, + (unsigned long)maxopenparen, + (long)parenfloor); SSGROW(total_elems + REGCP_FRAME_ELEMS); DEBUG_BUFFERS_r( - if ((int)PL_regsize > (int)parenfloor) + if ((int)maxopenparen > (int)parenfloor) PerlIO_printf(Perl_debug_log, "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n", PTR2UV(rex), PTR2UV(rex->offs) ); ); - for (p = parenfloor+1; p <= (I32)PL_regsize; p++) { + 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); @@ -383,7 +308,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor) )); } /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */ - SSPUSHINT(PL_regsize); + SSPUSHINT(maxopenparen); SSPUSHINT(rex->lastparen); SSPUSHINT(rex->lastcloseparen); SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */ @@ -415,7 +340,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor) STATIC void -S_regcppop(pTHX_ regexp *rex) +S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) { dVAR; UV i; @@ -430,7 +355,7 @@ S_regcppop(pTHX_ regexp *rex) i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */ rex->lastcloseparen = SSPOPINT; rex->lastparen = SSPOPINT; - PL_regsize = SSPOPINT; + *maxopenparen_p = SSPOPINT; i -= REGCP_OTHER_ELEMS; /* Now restore the parentheses context. */ @@ -442,7 +367,7 @@ S_regcppop(pTHX_ regexp *rex) PTR2UV(rex->offs) ); ); - paren = PL_regsize; + paren = *maxopenparen_p; for ( ; i > 0; i -= REGCP_PAREN_ELEMS) { I32 tmps; rex->offs[paren].start_tmp = SSPOPINT; @@ -471,13 +396,13 @@ S_regcppop(pTHX_ regexp *rex) * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/ * --jhi updated by dapm */ for (i = rex->lastparen + 1; i <= rex->nparens; i++) { - if (i > PL_regsize) + if (i > *maxopenparen_p) rex->offs[i].start = -1; rex->offs[i].end = -1; DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log, " \\%"UVuf": %s ..-1 undeffing\n", (UV)i, - (i > PL_regsize) ? "-1" : " " + (i > *maxopenparen_p) ? "-1" : " " )); } #endif @@ -487,16 +412,110 @@ S_regcppop(pTHX_ regexp *rex) * but without popping the stack */ STATIC void -S_regcp_restore(pTHX_ regexp *rex, I32 ix) +S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p) { I32 tmpix = PL_savestack_ix; PL_savestack_ix = ix; - regcppop(rex); + regcppop(rex, maxopenparen_p); PL_savestack_ix = tmpix; } #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */ +STATIC bool +S_isFOO_lc(pTHX_ const U8 classnum, const U8 character) +{ + /* Returns a boolean as to whether or not 'character' is a member of the + * Posix character class given by 'classnum' that should be equivalent to a + * value in the typedef '_char_class_number'. + * + * Ideally this could be replaced by a just an array of function pointers + * to the C library functions that implement the macros this calls. + * However, to compile, the precise function signatures are required, and + * these may vary from platform to to platform. To avoid having to figure + * out what those all are on each platform, I (khw) am using this method, + * which adds an extra layer of function call overhead (unless the C + * optimizer strips it away). But we don't particularly care about + * performance with locales anyway. */ + + switch ((_char_class_number) classnum) { + case _CC_ENUM_ALPHANUMERIC: return isALPHANUMERIC_LC(character); + case _CC_ENUM_ALPHA: return isALPHA_LC(character); + case _CC_ENUM_ASCII: return isASCII_LC(character); + case _CC_ENUM_BLANK: return isBLANK_LC(character); + case _CC_ENUM_CASED: return isLOWER_LC(character) + || isUPPER_LC(character); + case _CC_ENUM_CNTRL: return isCNTRL_LC(character); + case _CC_ENUM_DIGIT: return isDIGIT_LC(character); + case _CC_ENUM_GRAPH: return isGRAPH_LC(character); + case _CC_ENUM_LOWER: return isLOWER_LC(character); + case _CC_ENUM_PRINT: return isPRINT_LC(character); + case _CC_ENUM_PSXSPC: return isPSXSPC_LC(character); + case _CC_ENUM_PUNCT: return isPUNCT_LC(character); + case _CC_ENUM_SPACE: return isSPACE_LC(character); + case _CC_ENUM_UPPER: return isUPPER_LC(character); + case _CC_ENUM_WORDCHAR: return isWORDCHAR_LC(character); + case _CC_ENUM_XDIGIT: return isXDIGIT_LC(character); + default: /* VERTSPACE should never occur in locales */ + Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum); + } + + assert(0); /* NOTREACHED */ + return FALSE; +} + +STATIC bool +S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) +{ + /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded + * 'character' is a member of the Posix character class given by 'classnum' + * that should be equivalent to a value in the typedef + * '_char_class_number'. + * + * This just calls isFOO_lc on the code point for the character if it is in + * the range 0-255. Outside that range, all characters avoid Unicode + * rules, ignoring any locale. So use the Unicode function if this class + * requires a swash, and use the Unicode macro otherwise. */ + + PERL_ARGS_ASSERT_ISFOO_UTF8_LC; + + if (UTF8_IS_INVARIANT(*character)) { + return isFOO_lc(classnum, *character); + } + else if (UTF8_IS_DOWNGRADEABLE_START(*character)) { + return isFOO_lc(classnum, + TWO_BYTE_UTF8_TO_UNI(*character, *(character + 1))); + } + + if (classnum < _FIRST_NON_SWASH_CC) { + + /* 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); + } + + return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *) + character, + TRUE /* is UTF */ )); + } + + switch ((_char_class_number) classnum) { + case _CC_ENUM_SPACE: + case _CC_ENUM_PSXSPC: return is_XPERLSPACE_high(character); + + case _CC_ENUM_BLANK: return is_HORIZWS_high(character); + case _CC_ENUM_XDIGIT: return is_XDIGIT_high(character); + case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character); + default: return 0; /* Things like CNTRL are always + below 256 */ + } + + assert(0); /* NOTREACHED */ + return FALSE; +} + /* * pregexec and friends */ @@ -538,13 +557,9 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, * 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 @@ -558,7 +573,7 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, /* 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 less calls to + 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: @@ -574,9 +589,29 @@ Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend, 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 + */ + char * -Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, - char *strend, const U32 flags, re_scream_pos_data *data) +Perl_re_intuit_start(pTHX_ + REGEXP * const rx, + SV *sv, + const char * const strbeg, + char *strpos, + char *strend, + const U32 flags, + re_scream_pos_data *data) { dVAR; struct regexp *const prog = ReANY(rx); @@ -585,7 +620,6 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, I32 end_shift = 0; char *s; SV *check; - char *strbeg; char *t; const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */ I32 ml_anch; @@ -594,6 +628,8 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, 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 @@ -603,40 +639,22 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, PERL_UNUSED_ARG(flags); PERL_UNUSED_ARG(data); - RX_MATCH_UTF8_set(rx,utf8_target); - - if (RX_UTF8(rx)) { - PL_reg_flags |= RF_utf8; - } - DEBUG_EXECUTE_r( - debug_start_match(rx, utf8_target, strpos, strend, - sv ? "Guessing start of match in sv for" - : "Guessing start of match in string for"); - ); - /* CHR_DIST() would be more correct here but it makes things slow. */ if (prog->minlen > strend - strpos) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too short... [re_intuit_start]\n")); goto fail; } - - /* XXX we need to pass strbeg as a separate arg: the following is - * guesswork and can be wrong... */ - if (sv && SvPOK(sv)) { - char * p = SvPVX(sv); - STRLEN cur = SvCUR(sv); - if (p <= strpos && strpos < p + cur) { - strbeg = p; - assert(p <= strend && strend <= p + cur); - } - else - strbeg = strend - cur; - } - else - strbeg = strpos; - PL_regeol = strend; + reginfo->is_utf8_target = cBOOL(utf8_target); + reginfo->info_aux = NULL; + reginfo->strbeg = strbeg; + reginfo->strend = strend; + reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx)); + reginfo->intuit = 1; + /* not actually used within intuit, but zero for safety anyway */ + reginfo->poscache_maxiter = 0; + if (utf8_target) { if (!prog->check_utf8 && prog->check_substr) to_utf8_substr(prog); @@ -649,16 +667,15 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, } check = prog->check_substr; } - if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */ - ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE) + if ((prog->extflags & RXf_ANCH) /* Match at beg-of-str or after \n */ + && !(prog->extflags & RXf_ANCH_GPOS)) /* \G isn't a BOS or \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 */ - /* SvCUR is not set on references: SvRV and SvPVX_const overlap */ - && sv && !SvROK(sv) + if ( !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */ && (strpos != strbeg)) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n")); goto fail; @@ -1032,8 +1049,7 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, try_at_start: /* Even in this situation we may use MBOL flag if strpos is offset wrt the start of the string. */ - if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */ - && (strpos != strbeg) && strpos[-1] != '\n' + if (ml_anch && (strpos != strbeg) && strpos[-1] != '\n' /* May be due to an implicit anchor of m{.*foo} */ && !(prog->intflags & PREGf_IMPLICIT)) { @@ -1093,8 +1109,11 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, /* 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; if (prog->anchored_substr || prog->anchored_utf8 || ml_anch) @@ -1110,7 +1129,8 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg))); t = s; - s = find_byclass(prog, progi->regstclass, checked_upto, endpos, NULL); + s = find_byclass(prog, progi->regstclass, checked_upto, endpos, + reginfo); if (s) { checked_upto = s; } else { @@ -1212,8 +1232,8 @@ Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos, ? (utf8_target ? trie_utf8 : trie_plain) \ : (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 { \ +#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \ +STMT_START { \ STRLEN skiplen; \ switch (trie_type) { \ case trie_utf8_fold: \ @@ -1238,7 +1258,7 @@ uvc, charid, foldlen, foldbuf, uniflags) STMT_START { len=0; \ } else { \ len = 1; \ - uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \ + uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, FOLD_FLAGS_FULL); \ skiplen = UNISKIP( uvc ); \ foldlen -= skiplen; \ uscan = foldbuf + skiplen; \ @@ -1270,7 +1290,7 @@ STMT_START { \ while (s <= e) { \ if ( (CoNd) \ && (ln == 1 || folder(s, pat_string, ln)) \ - && (!reginfo || regtry(reginfo, &s)) ) \ + && (reginfo->intuit || regtry(reginfo, &s)) )\ goto got_it; \ s++; \ } \ @@ -1278,9 +1298,9 @@ STMT_START { \ #define REXEC_FBC_UTF8_SCAN(CoDe) \ STMT_START { \ - while (s < strend && s + (uskip = UTF8SKIP(s)) <= strend) { \ + while (s < strend) { \ CoDe \ - s += uskip; \ + s += UTF8SKIP(s); \ } \ } STMT_END @@ -1295,7 +1315,7 @@ STMT_START { \ #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \ REXEC_FBC_UTF8_SCAN( \ if (CoNd) { \ - if (tmp && (!reginfo || regtry(reginfo, &s))) \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ goto got_it; \ else \ tmp = doevery; \ @@ -1307,7 +1327,7 @@ REXEC_FBC_UTF8_SCAN( \ #define REXEC_FBC_CLASS_SCAN(CoNd) \ REXEC_FBC_SCAN( \ if (CoNd) { \ - if (tmp && (!reginfo || regtry(reginfo, &s))) \ + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \ goto got_it; \ else \ tmp = doevery; \ @@ -1317,7 +1337,7 @@ REXEC_FBC_SCAN( \ ) #define REXEC_FBC_TRYIT \ -if ((!reginfo || regtry(reginfo, &s))) \ +if ((reginfo->intuit || regtry(reginfo, &s))) \ goto got_it #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \ @@ -1328,30 +1348,13 @@ if ((!reginfo || regtry(reginfo, &s))) \ REXEC_FBC_CLASS_SCAN(CoNd); \ } -#define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \ - if (utf8_target) { \ - UtFpReLoAd; \ - REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \ - } \ - else { \ - REXEC_FBC_CLASS_SCAN(CoNd); \ - } - -#define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \ - PL_reg_flags |= RF_tainted; \ - if (utf8_target) { \ - REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \ - } \ - else { \ - REXEC_FBC_CLASS_SCAN(CoNd); \ - } - #define DUMP_EXEC_POS(li,s,doutf8) \ - dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8) + dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ + startpos, doutf8) #define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \ - tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; \ + tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ tmp = TEST_NON_UTF8(tmp); \ REXEC_FBC_UTF8_SCAN( \ if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ @@ -1364,11 +1367,11 @@ if ((!reginfo || regtry(reginfo, &s))) \ ); \ #define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \ - if (s == PL_bostr) { \ + if (s == reginfo->strbeg) { \ tmp = '\n'; \ } \ else { \ - U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr); \ + U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg); \ tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT); \ } \ tmp = TeSt1_UtF8; \ @@ -1414,7 +1417,7 @@ if ((!reginfo || regtry(reginfo, &s))) \ UTF8_CODE \ } \ else { /* Not utf8 */ \ - tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; \ + tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n'; \ tmp = TEST_NON_UTF8(tmp); \ REXEC_FBC_SCAN( \ if (tmp == ! TEST_NON_UTF8((U8) *s)) { \ @@ -1426,11 +1429,11 @@ if ((!reginfo || regtry(reginfo, &s))) \ } \ ); \ } \ - if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s))) \ + if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s))) \ goto got_it; /* We know what class REx starts with. Try to find this position... */ -/* if reginfo is NULL, its a dryrun */ +/* if reginfo->intuit, its a dryrun */ /* annoyingly all the vars in this routine have different names from their counterparts in regmatch. /grrr */ @@ -1438,640 +1441,752 @@ STATIC char * S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, regmatch_info *reginfo) { - dVAR; - const I32 doevery = (prog->intflags & PREGf_SKIP) == 0; - char *pat_string; /* The pattern's exactish string */ - char *pat_end; /* ptr to end char of pat_string */ - re_fold_t folder; /* Function for computing non-utf8 folds */ - const U8 *fold_array; /* array for folding ords < 256 */ - STRLEN ln; - STRLEN lnc; - STRLEN uskip; - U8 c1; - U8 c2; - char *e; - I32 tmp = 1; /* Scratch variable? */ - const bool utf8_target = PL_reg_match_utf8; - UV utf8_fold_flags = 0; - RXi_GET_DECL(prog,progi); - - PERL_ARGS_ASSERT_FIND_BYCLASS; - - /* We know what class it must start with. */ - switch (OP(c)) { - case ANYOF: - if (utf8_target) { - REXEC_FBC_UTF8_CLASS_SCAN( - reginclass(prog, c, (U8*)s, utf8_target)); - } - else { - REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s)); - } - break; - case CANY: - REXEC_FBC_SCAN( - if (tmp && (!reginfo || regtry(reginfo, &s))) - goto got_it; - else - tmp = doevery; - ); - break; + dVAR; + const I32 doevery = (prog->intflags & PREGf_SKIP) == 0; + char *pat_string; /* The pattern's exactish string */ + char *pat_end; /* ptr to end char of pat_string */ + re_fold_t folder; /* Function for computing non-utf8 folds */ + const U8 *fold_array; /* array for folding ords < 256 */ + STRLEN ln; + STRLEN lnc; + U8 c1; + U8 c2; + char *e; + I32 tmp = 1; /* Scratch variable? */ + const bool utf8_target = reginfo->is_utf8_target; + UV utf8_fold_flags = 0; + const bool is_utf8_pat = reginfo->is_utf8_pat; + bool to_complement = FALSE; /* Invert the result? Taking the xor of this + with a result inverts that result, as 0^1 = + 1 and 1^1 = 0 */ + _char_class_number classnum; - case EXACTFA: - if (UTF_PATTERN || utf8_target) { - utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; - goto do_exactf_utf8; - } - fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */ - folder = foldEQ_latin1; /* /a, except the sharp s one which */ - goto do_exactf_non_utf8; /* isn't dealt with by these */ + RXi_GET_DECL(prog,progi); - case EXACTF: - if (utf8_target) { + PERL_ARGS_ASSERT_FIND_BYCLASS; - /* regcomp.c already folded this if pattern is in UTF-8 */ - utf8_fold_flags = 0; - goto do_exactf_utf8; - } - fold_array = PL_fold; - folder = foldEQ; - goto do_exactf_non_utf8; + /* 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)); + } + else { + REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s)); + } + break; + case CANY: + REXEC_FBC_SCAN( + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) + goto got_it; + else + tmp = doevery; + ); + break; - case EXACTFL: - if (UTF_PATTERN || utf8_target) { - utf8_fold_flags = FOLDEQ_UTF8_LOCALE; - goto do_exactf_utf8; - } - fold_array = PL_fold_locale; - folder = foldEQ_locale; - goto do_exactf_non_utf8; + case EXACTFA: + if (is_utf8_pat || utf8_target) { + utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII; + goto do_exactf_utf8; + } + fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */ + folder = foldEQ_latin1; /* /a, except the sharp s one which */ + goto do_exactf_non_utf8; /* isn't dealt with by these */ - case EXACTFU_SS: - if (UTF_PATTERN) { - utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED; - } - goto do_exactf_utf8; + case EXACTF: + if (utf8_target) { - case EXACTFU_TRICKYFOLD: - case EXACTFU: - if (UTF_PATTERN || utf8_target) { - utf8_fold_flags = (UTF_PATTERN) ? FOLDEQ_S2_ALREADY_FOLDED : 0; - goto do_exactf_utf8; - } + /* regcomp.c already folded this if pattern is in UTF-8 */ + utf8_fold_flags = 0; + goto do_exactf_utf8; + } + fold_array = PL_fold; + folder = foldEQ; + goto do_exactf_non_utf8; - /* Any 'ss' in the pattern should have been replaced by regcomp, - * so we don't have to worry here about this single special case - * in the Latin1 range */ - fold_array = PL_fold_latin1; - folder = foldEQ_latin1; + case EXACTFL: + if (is_utf8_pat || utf8_target) { + utf8_fold_flags = FOLDEQ_UTF8_LOCALE; + goto do_exactf_utf8; + } + fold_array = PL_fold_locale; + folder = foldEQ_locale; + goto do_exactf_non_utf8; - /* FALL THROUGH */ + case EXACTFU_SS: + if (is_utf8_pat) { + utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED; + } + goto do_exactf_utf8; - do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there - are no glitches with fold-length differences - between the target string and pattern */ - - /* The idea in the non-utf8 EXACTF* cases is to first find the - * first character of the EXACTF* node and then, if necessary, - * case-insensitively compare the full text of the node. c1 is the - * first character. c2 is its fold. This logic will not work for - * Unicode semantics and the german sharp ss, which hence should - * not be compiled into a node that gets here. */ - pat_string = STRING(c); - ln = STR_LEN(c); /* length to match in octets/bytes */ - - /* We know that we have to match at least 'ln' bytes (which is the - * same as characters, since not utf8). If we have to match 3 - * 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); - - if (!reginfo && e < s) { - e = s; /* Due to minlen logic of intuit() */ - } + case EXACTFU_TRICKYFOLD: + case EXACTFU: + if (is_utf8_pat || utf8_target) { + utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0; + goto do_exactf_utf8; + } - c1 = *pat_string; - c2 = fold_array[c1]; - if (c1 == c2) { /* If char and fold are the same */ - REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1); - } - else { - REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2); - } - break; + /* Any 'ss' in the pattern should have been replaced by regcomp, + * so we don't have to worry here about this single special case + * in the Latin1 range */ + fold_array = PL_fold_latin1; + folder = foldEQ_latin1; + + /* FALL THROUGH */ + + do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there + are no glitches with fold-length differences + between the target string and pattern */ + + /* The idea in the non-utf8 EXACTF* cases is to first find the + * first character of the EXACTF* node and then, if necessary, + * case-insensitively compare the full text of the node. c1 is the + * first character. c2 is its fold. This logic will not work for + * Unicode semantics and the german sharp ss, which hence should + * not be compiled into a node that gets here. */ + pat_string = STRING(c); + ln = STR_LEN(c); /* length to match in octets/bytes */ + + /* We know that we have to match at least 'ln' bytes (which is the + * same as characters, since not utf8). If we have to match 3 + * 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); + + if (reginfo->intuit && e < s) { + e = s; /* Due to minlen logic of intuit() */ + } - do_exactf_utf8: - { - unsigned expansion; - - - /* If one of the operands is in utf8, we can't use the simpler - * folding above, due to the fact that many different characters - * can have the same fold, or portion of a fold, or different- - * length fold */ - pat_string = STRING(c); - ln = STR_LEN(c); /* length to match in octets/bytes */ - pat_end = pat_string + ln; - lnc = (UTF_PATTERN) /* length to match in characters */ - ? utf8_length((U8 *) pat_string, (U8 *) pat_end) - : ln; - - /* We have 'lnc' characters to match in the pattern, but because of - * multi-character folding, each character in the target can match - * up to 3 characters (Unicode guarantees it will never exceed - * this) if it is utf8-encoded; and up to 2 if not (based on the - * fact that the Latin 1 folds are already determined, and the - * only multi-char fold in that range is the sharp-s folding to - * 'ss'. Thus, a pattern character can match as little as 1/3 of a - * string character. Adjust lnc accordingly, rounding up, so that - * if we need to match at least 4+1/3 chars, that really is 5. */ - expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2; - lnc = (lnc + expansion - 1) / expansion; - - /* As in the non-UTF8 case, if we have to match 3 characters, and - * 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); + c1 = *pat_string; + c2 = fold_array[c1]; + if (c1 == c2) { /* If char and fold are the same */ + REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1); + } + else { + REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2); + } + break; - if (!reginfo && e < s) { - e = s; /* Due to minlen logic of intuit() */ - } + do_exactf_utf8: + { + unsigned expansion; + + /* If one of the operands is in utf8, we can't use the simpler folding + * above, due to the fact that many different characters can have the + * same fold, or portion of a fold, or different- length fold */ + pat_string = STRING(c); + ln = STR_LEN(c); /* length to match in octets/bytes */ + pat_end = pat_string + ln; + lnc = is_utf8_pat /* length to match in characters */ + ? utf8_length((U8 *) pat_string, (U8 *) pat_end) + : ln; + + /* We have 'lnc' characters to match in the pattern, but because of + * multi-character folding, each character in the target can match + * up to 3 characters (Unicode guarantees it will never exceed + * this) if it is utf8-encoded; and up to 2 if not (based on the + * fact that the Latin 1 folds are already determined, and the + * only multi-char fold in that range is the sharp-s folding to + * 'ss'. Thus, a pattern character can match as little as 1/3 of a + * string character. Adjust lnc accordingly, rounding up, so that + * if we need to match at least 4+1/3 chars, that really is 5. */ + expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2; + lnc = (lnc + expansion - 1) / expansion; + + /* As in the non-UTF8 case, if we have to match 3 characters, and + * 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); + + if (reginfo->intuit && e < s) { + e = s; /* Due to minlen logic of intuit() */ + } - /* XXX Note that we could recalculate e to stop the loop earlier, - * as the worst case expansion above will rarely be met, and as we - * go along we would usually find that e moves further to the left. - * This would happen only after we reached the point in the loop - * where if there were no expansion we should fail. Unclear if - * worth the expense */ - - while (s <= e) { - char *my_strend= (char *)strend; - if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target, - pat_string, NULL, ln, cBOOL(UTF_PATTERN), utf8_fold_flags) - && (!reginfo || regtry(reginfo, &s)) ) - { - goto got_it; - } - s += (utf8_target) ? UTF8SKIP(s) : 1; - } - break; - } - case BOUNDL: - PL_reg_flags |= RF_tainted; - FBC_BOUND(isALNUM_LC, - isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)), - isALNUM_LC_utf8((U8*)s)); - break; - case NBOUNDL: - PL_reg_flags |= RF_tainted; - FBC_NBOUND(isALNUM_LC, - isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)), - isALNUM_LC_utf8((U8*)s)); - break; - case BOUND: - FBC_BOUND(isWORDCHAR, - isALNUM_uni(tmp), - cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target))); - break; - case BOUNDA: - FBC_BOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); - break; - case NBOUND: - FBC_NBOUND(isWORDCHAR, - isALNUM_uni(tmp), - cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target))); - break; - case NBOUNDA: - FBC_NBOUND_NOLOAD(isWORDCHAR_A, - isWORDCHAR_A(tmp), - isWORDCHAR_A((U8*)s)); - break; - case BOUNDU: - FBC_BOUND(isWORDCHAR_L1, - isALNUM_uni(tmp), - cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target))); - break; - case NBOUNDU: - FBC_NBOUND(isWORDCHAR_L1, - isALNUM_uni(tmp), - cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target))); - break; - case ALNUML: - REXEC_FBC_CSCAN_TAINT( - isALNUM_LC_utf8((U8*)s), - isALNUM_LC(*s) - ); - break; - case ALNUMU: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_ALNUM(), - swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target), - isWORDCHAR_L1((U8) *s) - ); - break; - case ALNUM: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_ALNUM(), - swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target), - isWORDCHAR((U8) *s) - ); - break; - case ALNUMA: - /* Don't need to worry about utf8, as it can match only a single - * byte invariant character */ - REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s)); - break; - case NALNUMU: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_ALNUM(), - !swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target), - ! isWORDCHAR_L1((U8) *s) - ); - break; - case NALNUM: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_ALNUM(), - !swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target), - ! isALNUM(*s) - ); - break; - case NALNUMA: - REXEC_FBC_CSCAN( - !isWORDCHAR_A(*s), - !isWORDCHAR_A(*s) - ); - break; - case NALNUML: - REXEC_FBC_CSCAN_TAINT( - !isALNUM_LC_utf8((U8*)s), - !isALNUM_LC(*s) - ); - break; - case SPACEU: - REXEC_FBC_CSCAN( - is_XPERLSPACE_utf8(s), - isSPACE_L1((U8) *s) - ); - break; - case SPACE: - REXEC_FBC_CSCAN( - is_XPERLSPACE_utf8(s), - isSPACE((U8) *s) - ); - break; - case SPACEA: - /* Don't need to worry about utf8, as it can match only a single - * byte invariant character */ - REXEC_FBC_CLASS_SCAN( isSPACE_A(*s)); - break; - case SPACEL: - REXEC_FBC_CSCAN_TAINT( - isSPACE_LC_utf8((U8*)s), - isSPACE_LC(*s) - ); - break; - case NSPACEU: - REXEC_FBC_CSCAN( - ! is_XPERLSPACE_utf8(s), - ! isSPACE_L1((U8) *s) - ); - break; - case NSPACE: - REXEC_FBC_CSCAN( - ! is_XPERLSPACE_utf8(s), - ! isSPACE((U8) *s) - ); - break; - case NSPACEA: - REXEC_FBC_CSCAN( - !isSPACE_A(*s), - !isSPACE_A(*s) - ); - break; - case NSPACEL: - REXEC_FBC_CSCAN_TAINT( - !isSPACE_LC_utf8((U8*)s), - !isSPACE_LC(*s) - ); - break; - case DIGIT: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_DIGIT(), - swash_fetch(PL_utf8_digit,(U8*)s, utf8_target), - isDIGIT(*s) - ); - break; - case DIGITA: - /* Don't need to worry about utf8, as it can match only a single - * byte invariant character */ - REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s)); - break; - case DIGITL: - REXEC_FBC_CSCAN_TAINT( - isDIGIT_LC_utf8((U8*)s), - isDIGIT_LC(*s) - ); - break; - case NDIGIT: - REXEC_FBC_CSCAN_PRELOAD( - LOAD_UTF8_CHARCLASS_DIGIT(), - !swash_fetch(PL_utf8_digit,(U8*)s, utf8_target), - !isDIGIT(*s) - ); - break; - case NDIGITA: - REXEC_FBC_CSCAN( - !isDIGIT_A(*s), - !isDIGIT_A(*s) - ); - break; - case NDIGITL: - REXEC_FBC_CSCAN_TAINT( - !isDIGIT_LC_utf8((U8*)s), - !isDIGIT_LC(*s) - ); - break; - case LNBREAK: - REXEC_FBC_CSCAN( - is_LNBREAK_utf8_safe(s, strend), - is_LNBREAK_latin1_safe(s, strend) - ); - break; - case VERTWS: - REXEC_FBC_CSCAN( - is_VERTWS_utf8_safe(s, strend), - is_VERTWS_latin1_safe(s, strend) - ); - break; - case NVERTWS: - REXEC_FBC_CSCAN( - !is_VERTWS_utf8_safe(s, strend), - !is_VERTWS_latin1_safe(s, strend) - ); - break; - case HORIZWS: - REXEC_FBC_CSCAN( - is_HORIZWS_utf8_safe(s, strend), - is_HORIZWS_latin1_safe(s, strend) - ); - break; - case NHORIZWS: - REXEC_FBC_CSCAN( - !is_HORIZWS_utf8_safe(s, strend), - !is_HORIZWS_latin1_safe(s, strend) - ); - break; - case POSIXA: - /* Don't need to worry about utf8, as it can match only a single - * byte invariant character. The flag in this node type is the - * class number to pass to _generic_isCC() to build a mask for - * searching in PL_charclass[] */ - REXEC_FBC_CLASS_SCAN( _generic_isCC_A(*s, FLAGS(c))); - break; - case NPOSIXA: - REXEC_FBC_CSCAN( - !_generic_isCC_A(*s, FLAGS(c)), - !_generic_isCC_A(*s, FLAGS(c)) - ); - break; + /* XXX Note that we could recalculate e to stop the loop earlier, + * as the worst case expansion above will rarely be met, and as we + * go along we would usually find that e moves further to the left. + * This would happen only after we reached the point in the loop + * where if there were no expansion we should fail. Unclear if + * worth the expense */ + + while (s <= e) { + char *my_strend= (char *)strend; + if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target, + pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags) + && (reginfo->intuit || regtry(reginfo, &s)) ) + { + goto got_it; + } + s += (utf8_target) ? UTF8SKIP(s) : 1; + } + break; + } + case BOUNDL: + RXp_MATCH_TAINTED_on(prog); + FBC_BOUND(isWORDCHAR_LC, + isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(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_utf8((U8*)s)); + break; + case BOUND: + FBC_BOUND(isWORDCHAR, + isWORDCHAR_uni(tmp), + cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + break; + case BOUNDA: + FBC_BOUND_NOLOAD(isWORDCHAR_A, + isWORDCHAR_A(tmp), + isWORDCHAR_A((U8*)s)); + break; + case NBOUND: + FBC_NBOUND(isWORDCHAR, + isWORDCHAR_uni(tmp), + cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + break; + case NBOUNDA: + FBC_NBOUND_NOLOAD(isWORDCHAR_A, + isWORDCHAR_A(tmp), + isWORDCHAR_A((U8*)s)); + break; + case BOUNDU: + FBC_BOUND(isWORDCHAR_L1, + isWORDCHAR_uni(tmp), + cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + break; + case NBOUNDU: + FBC_NBOUND(isWORDCHAR_L1, + isWORDCHAR_uni(tmp), + cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target))); + break; + case LNBREAK: + REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend), + is_LNBREAK_latin1_safe(s, strend) + ); + break; - case AHOCORASICKC: - case AHOCORASICK: - { - DECL_TRIE_TYPE(c); - /* what trie are we using right now */ - reg_ac_data *aho - = (reg_ac_data*)progi->data->data[ ARG( c ) ]; - reg_trie_data *trie - = (reg_trie_data*)progi->data->data[ aho->trie ]; - HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]); + /* The argument to all the POSIX node types is the class number to pass to + * _generic_isCC() to build a mask for searching in PL_charclass[] */ - const char *last_start = strend - trie->minlen; -#ifdef DEBUGGING - const char *real_start = s; -#endif - STRLEN maxlen = trie->maxlen; - SV *sv_points; - U8 **points; /* map of where we were in the input string - when reading a given char. For ASCII this - is unnecessary overhead as the relationship - is always 1:1, but for Unicode, especially - case folded Unicode this is not true. */ - U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; - U8 *bitmap=NULL; - - - GET_RE_DEBUG_FLAGS_DECL; - - /* We can't just allocate points here. We need to wrap it in - * an SV so it gets freed properly if there is a croak while - * running the match */ - ENTER; - SAVETMPS; - sv_points=newSV(maxlen * sizeof(U8 *)); - SvCUR_set(sv_points, - maxlen * sizeof(U8 *)); - SvPOK_on(sv_points); - sv_2mortal(sv_points); - points=(U8**)SvPV_nolen(sv_points ); - if ( trie_type != trie_utf8_fold - && (trie->bitmap || OP(c)==AHOCORASICKC) ) - { - if (trie->bitmap) - bitmap=(U8*)trie->bitmap; - else - bitmap=(U8*)ANYOF_BITMAP(c); - } - /* this is the Aho-Corasick algorithm modified a touch - to include special handling for long "unknown char" - sequences. The basic idea being that we use AC as long - as we are dealing with a possible matching char, when - we encounter an unknown char (and we have not encountered - an accepting state) we scan forward until we find a legal - starting char. - AC matching is basically that of trie matching, except - that when we encounter a failing transition, we fall back - to the current states "fail state", and try the current char - again, a process we repeat until we reach the root state, - state 1, or a legal transition. If we fail on the root state - then we can either terminate if we have reached an accepting - state previously, or restart the entire process from the beginning - if we have not. + case NPOSIXL: + to_complement = 1; + /* FALLTHROUGH */ - */ - while (s <= last_start) { - const U32 uniflags = UTF8_ALLOW_DEFAULT; - U8 *uc = (U8*)s; - U16 charid = 0; - U32 base = 1; - U32 state = 1; - UV uvc = 0; - STRLEN len = 0; - STRLEN foldlen = 0; - U8 *uscan = (U8*)NULL; - U8 *leftmost = NULL; -#ifdef DEBUGGING - U32 accepted_word= 0; -#endif - U32 pointpos = 0; + 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; - while ( state && uc <= (U8*)strend ) { - int failed=0; - U32 word = aho->states[ state ].wordnum; + case NPOSIXD: + to_complement = 1; + /* FALLTHROUGH */ - if( state==1 ) { - if ( bitmap ) { - DEBUG_TRIE_EXECUTE_r( - if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { - dump_exec_pos( (char *)uc, c, strend, real_start, - (char *)uc, utf8_target ); - PerlIO_printf( Perl_debug_log, - " Scanning for legal start char...\n"); - } - ); - if (utf8_target) { - while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { - uc += UTF8SKIP(uc); - } - } else { - while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { - uc++; - } - } - s= (char *)uc; - } - if (uc >(U8*)last_start) break; - } - - if ( word ) { - U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ]; - if (!leftmost || lpos < leftmost) { - DEBUG_r(accepted_word=word); - leftmost= lpos; - } - if (base==0) break; - - } - points[pointpos++ % maxlen]= uc; - if (foldlen || uc < (U8*)strend) { - REXEC_TRIE_READ_CHAR(trie_type, trie, - widecharmap, uc, - uscan, len, uvc, charid, foldlen, - foldbuf, uniflags); - DEBUG_TRIE_EXECUTE_r({ - dump_exec_pos( (char *)uc, c, strend, - real_start, s, utf8_target); - PerlIO_printf(Perl_debug_log, - " Charid:%3u CP:%4"UVxf" ", - charid, uvc); - }); - } - else { - len = 0; - charid = 0; - } + case POSIXD: + if (utf8_target) { + goto posix_utf8; + } + goto posixa; + 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) + || ! _generic_isCC_A(*s, FLAGS(c))); + break; + } - do { -#ifdef DEBUGGING - word = aho->states[ state ].wordnum; -#endif - base = aho->states[ state ].trans.base; - - DEBUG_TRIE_EXECUTE_r({ - if (failed) - dump_exec_pos( (char *)uc, c, strend, real_start, - s, utf8_target ); - PerlIO_printf( Perl_debug_log, - "%sState: %4"UVxf", word=%"UVxf, - failed ? " Fail transition to " : "", - (UV)state, (UV)word); - }); - if ( base ) { - U32 tmp; - I32 offset; - if (charid && - ( ((offset = base + charid - - 1 - trie->uniquecharcount)) >= 0) - && ((U32)offset < trie->lasttrans) - && trie->trans[offset].check == state - && (tmp=trie->trans[offset].next)) - { - DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - legal\n")); - state = tmp; - break; - } - else { - DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - fail\n")); - failed = 1; - state = aho->fail[state]; - } - } - else { - /* we must be accepting here */ - DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - accepting\n")); - failed = 1; - break; + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXA: + posixa: + /* Don't need to worry about utf8, as it can match only a single + * byte invariant character. */ + REXEC_FBC_CLASS_SCAN( + to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c)))); + break; + + case NPOSIXU: + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXU: + if (! utf8_target) { + REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s, + FLAGS(c)))); + } + else { + + posix_utf8: + classnum = (_char_class_number) FLAGS(c); + if (classnum < _FIRST_NON_SWASH_CC) { + while (s < strend) { + + /* We avoid loading in the swash as long as possible, but + * should we have to, we jump to a separate loop. This + * extra 'if' statement is what keeps this code from being + * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */ + if (UTF8_IS_ABOVE_LATIN1(*s)) { + goto found_above_latin1; + } + if ((UTF8_IS_INVARIANT(*s) + && to_complement ^ cBOOL(_generic_isCC((U8) *s, + classnum))) + || (UTF8_IS_DOWNGRADEABLE_START(*s) + && to_complement ^ cBOOL( + _generic_isCC(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1)), + classnum)))) + { + if (tmp && (reginfo->intuit || regtry(reginfo, &s))) + goto got_it; + else { + tmp = doevery; + } + } + else { + tmp = 1; + } + s += UTF8SKIP(s); + } + } + else switch (classnum) { /* These classes are implemented as + macros */ + case _CC_ENUM_SPACE: /* XXX would require separate code if we + revert the change of \v matching this */ + /* FALL THROUGH */ + + case _CC_ENUM_PSXSPC: + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(isSPACE_utf8(s))); + break; + + case _CC_ENUM_BLANK: + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(isBLANK_utf8(s))); + break; + + case _CC_ENUM_XDIGIT: + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(isXDIGIT_utf8(s))); + break; + + case _CC_ENUM_VERTSPACE: + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(isVERTWS_utf8(s))); + break; + + case _CC_ENUM_CNTRL: + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(isCNTRL_utf8(s))); + break; + + default: + Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum); + assert(0); /* NOTREACHED */ + } + } + break; + + found_above_latin1: /* Here we have to load a swash to get the result + for the current code point */ + 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); + } + + /* This is a copy of the loop above for swash classes, though using the + * FBC macro instead of being expanded out. Since we've loaded the + * swash, we don't have to check for that each time through the loop */ + REXEC_FBC_UTF8_CLASS_SCAN( + to_complement ^ cBOOL(_generic_utf8( + classnum, + s, + swash_fetch(PL_utf8_swash_ptrs[classnum], + (U8 *) s, TRUE)))); + break; + + case AHOCORASICKC: + case AHOCORASICK: + { + DECL_TRIE_TYPE(c); + /* what trie are we using right now */ + reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ]; + reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ]; + HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]); + + const char *last_start = strend - trie->minlen; +#ifdef DEBUGGING + const char *real_start = s; +#endif + STRLEN maxlen = trie->maxlen; + SV *sv_points; + U8 **points; /* map of where we were in the input string + when reading a given char. For ASCII this + is unnecessary overhead as the relationship + is always 1:1, but for Unicode, especially + case folded Unicode this is not true. */ + U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ]; + U8 *bitmap=NULL; + + + GET_RE_DEBUG_FLAGS_DECL; + + /* We can't just allocate points here. We need to wrap it in + * an SV so it gets freed properly if there is a croak while + * running the match */ + ENTER; + SAVETMPS; + sv_points=newSV(maxlen * sizeof(U8 *)); + SvCUR_set(sv_points, + maxlen * sizeof(U8 *)); + SvPOK_on(sv_points); + sv_2mortal(sv_points); + points=(U8**)SvPV_nolen(sv_points ); + if ( trie_type != trie_utf8_fold + && (trie->bitmap || OP(c)==AHOCORASICKC) ) + { + if (trie->bitmap) + bitmap=(U8*)trie->bitmap; + else + bitmap=(U8*)ANYOF_BITMAP(c); + } + /* this is the Aho-Corasick algorithm modified a touch + to include special handling for long "unknown char" sequences. + The basic idea being that we use AC as long as we are dealing + with a possible matching char, when we encounter an unknown char + (and we have not encountered an accepting state) we scan forward + until we find a legal starting char. + AC matching is basically that of trie matching, except that when + we encounter a failing transition, we fall back to the current + states "fail state", and try the current char again, a process + we repeat until we reach the root state, state 1, or a legal + transition. If we fail on the root state then we can either + terminate if we have reached an accepting state previously, or + restart the entire process from the beginning if we have not. + + */ + while (s <= last_start) { + const U32 uniflags = UTF8_ALLOW_DEFAULT; + U8 *uc = (U8*)s; + U16 charid = 0; + U32 base = 1; + U32 state = 1; + UV uvc = 0; + STRLEN len = 0; + STRLEN foldlen = 0; + U8 *uscan = (U8*)NULL; + U8 *leftmost = NULL; +#ifdef DEBUGGING + U32 accepted_word= 0; +#endif + U32 pointpos = 0; + + while ( state && uc <= (U8*)strend ) { + int failed=0; + U32 word = aho->states[ state ].wordnum; + + if( state==1 ) { + if ( bitmap ) { + DEBUG_TRIE_EXECUTE_r( + if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { + dump_exec_pos( (char *)uc, c, strend, real_start, + (char *)uc, utf8_target ); + PerlIO_printf( Perl_debug_log, + " Scanning for legal start char...\n"); + } + ); + if (utf8_target) { + while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { + uc += UTF8SKIP(uc); + } + } else { + while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) { + uc++; + } } - } while(state); - uc += len; - if (failed) { - if (leftmost) - break; - if (!state) state = 1; + s= (char *)uc; } + if (uc >(U8*)last_start) break; } - if ( aho->states[ state ].wordnum ) { - U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ]; + + if ( word ) { + U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ]; if (!leftmost || lpos < leftmost) { - DEBUG_r(accepted_word=aho->states[ state ].wordnum); - leftmost = lpos; + DEBUG_r(accepted_word=word); + leftmost= lpos; } + if (base==0) break; + } - if (leftmost) { - s = (char*)leftmost; + points[pointpos++ % maxlen]= uc; + if (foldlen || uc < (U8*)strend) { + REXEC_TRIE_READ_CHAR(trie_type, trie, + widecharmap, uc, + uscan, len, uvc, charid, foldlen, + foldbuf, uniflags); DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( - Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n", - (UV)accepted_word, (IV)(s - real_start) - ); + dump_exec_pos( (char *)uc, c, strend, + real_start, s, utf8_target); + PerlIO_printf(Perl_debug_log, + " Charid:%3u CP:%4"UVxf" ", + charid, uvc); }); - if (!reginfo || regtry(reginfo, &s)) { - FREETMPS; - LEAVE; - goto got_it; - } - s = HOPc(s,1); + } + else { + len = 0; + charid = 0; + } + + + do { +#ifdef DEBUGGING + word = aho->states[ state ].wordnum; +#endif + base = aho->states[ state ].trans.base; + DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n"); + if (failed) + dump_exec_pos( (char *)uc, c, strend, real_start, + s, utf8_target ); + PerlIO_printf( Perl_debug_log, + "%sState: %4"UVxf", word=%"UVxf, + failed ? " Fail transition to " : "", + (UV)state, (UV)word); }); - } else { - DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log,"No match.\n")); - break; + if ( base ) { + U32 tmp; + I32 offset; + if (charid && + ( ((offset = base + charid + - 1 - trie->uniquecharcount)) >= 0) + && ((U32)offset < trie->lasttrans) + && trie->trans[offset].check == state + && (tmp=trie->trans[offset].next)) + { + DEBUG_TRIE_EXECUTE_r( + PerlIO_printf( Perl_debug_log," - legal\n")); + state = tmp; + break; + } + else { + DEBUG_TRIE_EXECUTE_r( + PerlIO_printf( Perl_debug_log," - fail\n")); + failed = 1; + state = aho->fail[state]; + } + } + else { + /* we must be accepting here */ + DEBUG_TRIE_EXECUTE_r( + PerlIO_printf( Perl_debug_log," - accepting\n")); + failed = 1; + break; + } + } while(state); + uc += len; + if (failed) { + if (leftmost) + break; + if (!state) state = 1; } } - FREETMPS; - LEAVE; - } - break; - default: - Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c)); - break; - } - return 0; - got_it: - return s; + if ( aho->states[ state ].wordnum ) { + U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ]; + if (!leftmost || lpos < leftmost) { + DEBUG_r(accepted_word=aho->states[ state ].wordnum); + leftmost = lpos; + } + } + if (leftmost) { + s = (char*)leftmost; + DEBUG_TRIE_EXECUTE_r({ + PerlIO_printf( + Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n", + (UV)accepted_word, (IV)(s - real_start) + ); + }); + if (reginfo->intuit || regtry(reginfo, &s)) { + FREETMPS; + LEAVE; + goto got_it; + } + s = HOPc(s,1); + DEBUG_TRIE_EXECUTE_r({ + PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n"); + }); + } else { + DEBUG_TRIE_EXECUTE_r( + PerlIO_printf( Perl_debug_log,"No match.\n")); + break; + } + } + FREETMPS; + LEAVE; + } + 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)); + } + /* skip creating new COW SV if a valid one already exists */ + if (! ( prog->saved_copy + && SvIsCOW(sv) + && SvPOKp(sv) + && SvIsCOW(prog->saved_copy) + && SvPOKp(prog->saved_copy) + && SvPVX(sv) == SvPVX(prog->saved_copy))) + { + 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 + { + I32 min = 0; + I32 max = strend - strbeg; + I32 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) + 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; + prog->sublen = strend - strbeg; + } } + + /* - regexec_flags - match a regexp against a string */ @@ -2085,8 +2200,7 @@ 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 */ + Currently unused. */ /* nosave: For optimizations. */ { @@ -2094,114 +2208,227 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, struct regexp *const prog = ReANY(rx); char *s; regnode *c; - char *startpos = stringarg; + char *startpos; 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; const bool utf8_target = cBOOL(DO_UTF8(sv)); I32 multiline; RXi_GET_DECL(prog,progi); - regmatch_info reginfo; /* create some info to pass to regtry etc */ + regmatch_info reginfo_buf; /* create some info to pass to regtry etc */ + regmatch_info *const reginfo = ®info_buf; regexp_paren_pair *swap = NULL; + I32 oldsave; GET_RE_DEBUG_FLAGS_DECL; PERL_ARGS_ASSERT_REGEXEC_FLAGS; PERL_UNUSED_ARG(data); /* Be paranoid... */ - if (prog == NULL || startpos == NULL) { + if (prog == NULL || stringarg == NULL) { Perl_croak(aTHX_ "NULL regexp parameter"); return 0; } - multiline = prog->extflags & RXf_PMf_MULTILINE; - reginfo.prog = rx; /* Yes, sorry that this is confusing. */ - - RX_MATCH_UTF8_set(rx, utf8_target); - DEBUG_EXECUTE_r( - debug_start_match(rx, utf8_target, startpos, strend, + DEBUG_EXECUTE_r( + debug_start_match(rx, utf8_target, stringarg, strend, "Matching"); ); + startpos = stringarg; + + if (prog->extflags & RXf_GPOS_SEEN) { + MAGIC *mg; + + /* in the presence of \G, we may need to start looking earlier in + * the string than the suggested start point of stringarg: + * if gofs->prog 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->gofs) { + if (startpos - prog->gofs < strbeg) + startpos = strbeg; + else + startpos -= prog->gofs; + } + else if (prog->extflags & RXf_GPOS_FLOAT) + startpos = strbeg; + + /* 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) + ? strbeg + mg->mg_len /* Defined pos() */ + : strbeg; /* pos() not defined; use start of string */ + + DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, + "GPOS ganch set to strbeg[%"IVdf"]\n", reginfo->ganch - 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; + } + + 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->extflags & RXf_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); + if ( !(flags & REXEC_NOT_FIRST) ) + S_reg_set_capture_string(aTHX_ rx, + strbeg, strend, + sv, flags, 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; + return 1; + } + } + + + /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave), + * which will call destuctors to reset PL_regmatch_state, free higher + * PL_regmatch_slabs, and clean up regmatch_info_aux and + * regmatch_info_aux_eval */ + + oldsave = PL_savestack_ix; + + multiline = prog->extflags & RXf_PMf_MULTILINE; - 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; } - /* Check validity of program. */ if (UCHARAT(progi->program) != REG_MAGIC) { Perl_croak(aTHX_ "corrupted regexp program"); } - PL_reg_flags = 0; - PL_reg_state.re_state_eval_setup_done = FALSE; - PL_reg_maxiter = 0; + RX_MATCH_TAINTED_off(rx); + + reginfo->prog = rx; /* Yes, sorry that this is confusing. */ + reginfo->intuit = 0; + reginfo->is_utf8_target = cBOOL(utf8_target); + reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx)); + reginfo->warned = FALSE; + reginfo->strbeg = strbeg; + reginfo->sv = sv; + 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 = stringarg + minend; + + if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv) && !IS_PADGV(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. + */ + reginfo->sv = newSV(0); + sv_setsv(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 + * slot N+1: use for regmatch_info_aux struct + * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s + * slot N+3: ready for use by regmatch() + */ - if (RX_UTF8(rx)) - PL_reg_flags |= RF_utf8; + { + regmatch_state *old_regmatch_state; + regmatch_slab *old_regmatch_slab; + int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1; + + /* on first ever match, allocate first slab */ + if (!PL_regmatch_slab) { + Newx(PL_regmatch_slab, 1, regmatch_slab); + PL_regmatch_slab->prev = NULL; + PL_regmatch_slab->next = NULL; + PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab); + } - /* Mark beginning of line for ^ and lookbehind. */ - reginfo.bol = startpos; /* XXX not used ??? */ - PL_bostr = strbeg; - reginfo.sv = sv; + old_regmatch_state = PL_regmatch_state; + old_regmatch_slab = PL_regmatch_slab; - /* Mark end of line for $ (and such) */ - PL_regeol = strend; + for (i=0; i <= max; i++) { + if (i == 1) + reginfo->info_aux = &(PL_regmatch_state->u.info_aux); + else if (i ==2) + reginfo->info_aux_eval = + reginfo->info_aux->info_aux_eval = + &(PL_regmatch_state->u.info_aux_eval); - /* see how far we have to get to not match where we matched before */ - reginfo.till = startpos+minend; + if (++PL_regmatch_state > SLAB_LAST(PL_regmatch_slab)) + PL_regmatch_state = S_push_slab(aTHX); + } - /* If there is a "must appear" string, look for it. */ - s = startpos; + /* note initial PL_regmatch_state position; at end of match we'll + * pop back to there and free any higher slabs */ - 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")); - } + reginfo->info_aux->old_regmatch_state = old_regmatch_state; + reginfo->info_aux->old_regmatch_slab = old_regmatch_slab; + reginfo->info_aux->poscache = NULL; + + SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux); + + if ((prog->extflags & RXf_EVAL_SEEN)) + S_setup_eval_state(aTHX_ reginfo); + else + reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL; } + + /* If there is a "must appear" string, look for it. */ + 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 successful match to clobber the old results. So when we detect this possibility we add a swap buffer - to the re, and switch the buffer each match. If we fail - we switch it back, otherwise we leave it swapped. + to the re, and switch the buffer each match. If we fail, + we switch it back; otherwise we leave it swapped. */ swap = prog->offs; /* do we need a save destructor here for eval dies? */ @@ -2213,24 +2440,11 @@ 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, 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(®info, &startpos)) + if (s == startpos && regtry(reginfo, &s)) goto got_it; else if (multiline || (prog->intflags & PREGf_IMPLICIT) || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */ @@ -2248,7 +2462,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (s == startpos) goto after_try_utf8; while (1) { - if (regtry(®info, &s)) { + if (regtry(reginfo, &s)) { goto got_it; } after_try_utf8: @@ -2256,7 +2470,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, goto phooey; } if (prog->extflags & RXf_USE_INTUIT) { - s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL); + s = re_intuit_start(rx, sv, strbeg, + s + UTF8SKIP(s), strend, flags, NULL); if (!s) { goto phooey; } @@ -2271,7 +2486,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, goto after_try_latin; } while (1) { - if (regtry(®info, &s)) { + if (regtry(reginfo, &s)) { goto got_it; } after_try_latin: @@ -2279,7 +2494,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, goto phooey; } if (prog->extflags & RXf_USE_INTUIT) { - s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL); + s = re_intuit_start(rx, sv, strbeg, + s + 1, strend, flags, NULL); if (!s) { goto phooey; } @@ -2298,7 +2514,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* We can use a more efficient search as newlines are the same in unicode as they are in latin */ while (s <= end) { /* note it could be possible to match at the end of the string */ if (*s++ == '\n') { /* don't need PL_utf8skip here */ - if (regtry(®info, &s)) + if (regtry(reginfo, &s)) goto got_it; } } @@ -2307,12 +2523,12 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, goto phooey; } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) { - /* the warning about reginfo.ganch being used without initialization + /* 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; + char *tmp_s = reginfo->ganch - prog->gofs; - if (tmp_s >= strbeg && regtry(®info, &tmp_s)) + if (s <= tmp_s && regtry(reginfo, &tmp_s)) goto got_it; goto phooey; } @@ -2320,7 +2536,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* Messy cases: unanchored match. */ if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) { /* we have /x+whatever/ */ - /* it must be a one character string (XXXX Except UTF_PATTERN?) */ + /* it must be a one character string (XXXX Except is_utf8_pat?) */ char ch; #ifdef DEBUGGING int did_match = 0; @@ -2333,7 +2549,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, REXEC_FBC_SCAN( if (*s == ch) { DEBUG_EXECUTE_r( did_match = 1 ); - if (regtry(®info, &s)) goto got_it; + if (regtry(reginfo, &s)) goto got_it; s += UTF8SKIP(s); while (s < strend && *s == ch) s += UTF8SKIP(s); @@ -2351,7 +2567,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, REXEC_FBC_SCAN( if (*s == ch) { DEBUG_EXECUTE_r( did_match = 1 ); - if (regtry(®info, &s)) goto got_it; + if (regtry(reginfo, &s)) goto got_it; s++; while (s < strend && *s == ch) s++; @@ -2417,14 +2633,13 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, -(I32)(CHR_SVLEN(must) - (SvTAIL(must) != 0) + back_min), strbeg); } - if (s > PL_bostr) + if (s > reginfo->strbeg) last1 = HOPc(s, -1); else last1 = s - 1; /* bogus */ /* XXXX check_substr already used to find "s", can optimize if check_substr==must. */ - scream_pos = -1; dontbother = end_shift; strend = HOPc(strend, -dontbother); while ( (s <= last) && @@ -2437,14 +2652,15 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, s = HOPc(s, -back_max); } else { - char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1; + char * const t = (last1 >= reginfo->strbeg) + ? HOPc(last1, 1) : last1 + 1; last1 = HOPc(s, -back_min); s = t; } if (utf8_target) { while (s <= last1) { - if (regtry(®info, &s)) + if (regtry(reginfo, &s)) goto got_it; if (s >= last1) { s++; /* to break out of outer loop */ @@ -2455,7 +2671,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } else { while (s <= last1) { - if (regtry(®info, &s)) + if (regtry(reginfo, &s)) goto got_it; s++; } @@ -2490,7 +2706,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, quoted, (int)(strend - s)); } }); - if (find_byclass(prog, c, s, strend, ®info)) + if (find_byclass(prog, c, s, strend, reginfo)) goto got_it; DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n")); } @@ -2598,7 +2814,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* We don't know much -- general case. */ if (utf8_target) { for (;;) { - if (regtry(®info, &s)) + if (regtry(reginfo, &s)) goto got_it; if (s >= strend) break; @@ -2607,7 +2823,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } else { do { - if (regtry(®info, &s)) + if (regtry(reginfo, &s)) goto got_it; } while (s++ < strend); } @@ -2617,6 +2833,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->extflags & RXf_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, @@ -2626,138 +2854,36 @@ got_it: ); ); Safefree(swap); - RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted); - - if (PL_reg_state.re_state_eval_setup_done) - restore_pos(aTHX_ prog); - if (RXp_PAREN_NAMES(prog)) - (void)hv_iterinit(RXp_PAREN_NAMES(prog)); - /* make sure $`, $&, $', and $digit will work later */ - if ( !(flags & REXEC_NOT_FIRST) ) { - if (flags & REXEC_COPY_STR) { -#ifdef PERL_OLD_COPY_ON_WRITE - if ((SvIsCOW(sv) - || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) { - 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 = PL_regeol - strbeg; - prog->suboffset = 0; - prog->subcoffset = 0; - } else -#endif - { - I32 min = 0; - I32 max = PL_regeol - 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 <= PL_regeol - strbeg); - } + /* clean up; this will trigger destructors that will free all slabs + * above the current one, and cleanup the regmatch_info_aux + * and regmatch_info_aux_eval sructs */ - 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; + LEAVE_SCOPE(oldsave); - } + if (RXp_PAREN_NAMES(prog)) + (void)hv_iterinit(RXp_PAREN_NAMES(prog)); - assert(min >= 0 && min <= max && min <= PL_regeol - strbeg); - sublen = max - min; + RX_MATCH_UTF8_set(rx, utf8_target); - 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; - prog->sublen = PL_regeol - strbeg; /* strend may have been modified */ - } - } + /* make sure $`, $&, $', and $digit will work later */ + if ( !(flags & REXEC_NOT_FIRST) ) + S_reg_set_capture_string(aTHX_ rx, + strbeg, reginfo->strend, + sv, flags, utf8_target); return 1; phooey: DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", PL_colors[4], PL_colors[5])); - if (PL_reg_state.re_state_eval_setup_done) - restore_pos(aTHX_ prog); + + /* clean up; this will trigger destructors that will free all slabs + * above the current one, and cleanup the regmatch_info_aux + * and regmatch_info_aux_eval sructs */ + + LEAVE_SCOPE(oldsave); + if (swap) { /* we failed :-( roll it back */ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, @@ -2773,10 +2899,10 @@ phooey: } -/* Set which rex is pointed to by PL_reg_state, handling ref counting. +/* 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) \ - if (PL_reg_state.re_state_eval_setup_done) { \ + if (reginfo->info_aux_eval) { \ (void)ReREFCNT_inc(Re2); \ ReREFCNT_dec(PM_GETRE(PL_reg_curpm)); \ PM_SETRE((PL_reg_curpm), (Re2)); \ @@ -2801,77 +2927,9 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) reginfo->cutpoint=NULL; - if ((prog->extflags & RXf_EVAL_SEEN) - && !PL_reg_state.re_state_eval_setup_done) - { - MAGIC *mg; - - PL_reg_state.re_state_eval_setup_done = TRUE; - if (reginfo->sv) { - /* Make $_ available to executed code. */ - if (reginfo->sv != DEFSV) { - SAVE_DEFSV; - DEFSV_set(reginfo->sv); - } - - if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv) - && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) { - /* 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->mg_len = -1; - } - PL_reg_magic = mg; - PL_reg_oldpos = mg->mg_len; - SAVEDESTRUCTOR_X(restore_pos, prog); - } - if (!PL_reg_curpm) { - Newxz(PL_reg_curpm, 1, PMOP); -#ifdef USE_ITHREADS - { - SV* const repointer = &PL_sv_undef; - /* 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_regex_pad = AvARRAY(PL_regex_padav); - } -#endif - } - SET_reg_curpm(rx); - PL_reg_oldcurpm = PL_curpm; - PL_curpm = PL_reg_curpm; - if (RXp_MATCH_COPIED(prog)) { - /* Here is a serious problem: we cannot rewrite subbeg, - since it may be needed if this match fails. Thus - $` inside (?{}) could fail... */ - PL_reg_oldsaved = prog->subbeg; - PL_reg_oldsavedlen = prog->sublen; - PL_reg_oldsavedoffset = prog->suboffset; - PL_reg_oldsavedcoffset = prog->suboffset; -#ifdef PERL_OLD_COPY_ON_WRITE - PL_nrs = prog->saved_copy; -#endif - RXp_MATCH_COPIED_off(prog); - } - else - PL_reg_oldsaved = NULL; - prog->subbeg = PL_bostr; - prog->suboffset = 0; - prog->subcoffset = 0; - prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */ - } -#ifdef DEBUGGING - PL_reg_starttry = *startposp; -#endif - prog->offs[0].start = *startposp - PL_bostr; + prog->offs[0].start = *startposp - reginfo->strbeg; prog->lastparen = 0; prog->lastcloseparen = 0; - PL_regsize = 0; /* XXXX What this code is doing here?!!! There should be no need to do this again and again, prog->lastparen should take care of @@ -2918,7 +2976,7 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) "unreachable code" warnings, which are bogus, but distracting. */ #define CACHEsayNO \ if (ST.cache_mask) \ - PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \ + reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \ sayNO /* this is used to determine how far from the left messages like @@ -2933,9 +2991,6 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) #define CHRTEST_NOT_A_CP_1 -999 #define CHRTEST_NOT_A_CP_2 -998 -#define SLAB_FIRST(s) (&(s)->states[0]) -#define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1]) - /* grab a new slab and return the first slot in it */ STATIC regmatch_state * @@ -3251,25 +3306,9 @@ S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) } -/* free all slabs above current one - called during LEAVE_SCOPE */ - -STATIC void -S_clear_backtrack_stack(pTHX_ void *p) -{ - regmatch_slab *s = PL_regmatch_slab->next; - PERL_UNUSED_ARG(p); - - if (!s) - return; - PL_regmatch_slab->next = NULL; - while (s) { - regmatch_slab * const osl = s; - s = s->next; - Safefree(osl); - } -} static bool -S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c1_utf8, int *c2p, U8* c2_utf8) +S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, + U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo) { /* This function determines if there are one or two characters that match * the first character of the passed-in EXACTish node , and if @@ -3321,11 +3360,12 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c * point (unless inappropriately coerced to unsigned). * will equal * * if and only if and are the same. */ - const bool utf8_target = PL_reg_match_utf8; + const bool utf8_target = reginfo->is_utf8_target; UV c1 = CHRTEST_NOT_A_CP_1; UV c2 = CHRTEST_NOT_A_CP_2; bool use_chrtest_void = FALSE; + const bool is_utf8_pat = reginfo->is_utf8_pat; /* Used when we have both utf8 input and utf8 output, to avoid converting * to/from code points */ @@ -3341,7 +3381,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c * character. If both the pat and the target are UTF-8, we can just * copy the input to the output, avoiding finding the code point of * that character */ - if (! UTF_PATTERN) { + if (!is_utf8_pat) { c2 = c1 = *pat; } else if (utf8_target) { @@ -3354,10 +3394,10 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c } } else /* an EXACTFish node */ - if ((UTF_PATTERN + if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8_safe(pat, pat + STR_LEN(text_node))) - || (! UTF_PATTERN + || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1_safe(pat, pat + STR_LEN(text_node)))) { @@ -3367,7 +3407,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c use_chrtest_void = TRUE; } else { /* an EXACTFish node which doesn't begin with a multi-char fold */ - c1 = (UTF_PATTERN) ? valid_utf8_to_uvchr(pat, NULL) : *pat; + c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat; if (c1 > 256) { /* Load the folds hash, if not already done */ SV** listp; @@ -3531,12 +3571,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) dMY_CXT; #endif dVAR; - const bool utf8_target = PL_reg_match_utf8; + const bool utf8_target = reginfo->is_utf8_target; const U32 uniflags = UTF8_ALLOW_DEFAULT; REGEXP *rex_sv = reginfo->prog; regexp *rex = ReANY(rex_sv); RXi_GET_DECL(rex,rexi); - I32 oldsave; /* the current state. This is a cached copy of PL_regmatch_state */ regmatch_state *st; /* cache heavy used fields of st in registers */ @@ -3592,6 +3631,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) CV *caller_cv = NULL; /* who called us */ CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */ CHECKPOINT runops_cp; /* savestack position before executing EVAL */ + U32 maxopenparen = 0; /* max '(' index seen so far */ + int to_complement; /* Invert the result? */ + _char_class_number classnum; + bool is_utf8_pat = reginfo->is_utf8_pat; #ifdef DEBUGGING GET_RE_DEBUG_FLAGS_DECL; @@ -3610,23 +3653,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({ PerlIO_printf(Perl_debug_log,"regmatch start\n"); })); - /* on first ever call to regmatch, allocate first slab */ - if (!PL_regmatch_slab) { - Newx(PL_regmatch_slab, 1, regmatch_slab); - PL_regmatch_slab->prev = NULL; - PL_regmatch_slab->next = NULL; - PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab); - } - - oldsave = PL_savestack_ix; - SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL); - SAVEVPTR(PL_regmatch_slab); - SAVEVPTR(PL_regmatch_state); - /* grab next free state slot */ - st = ++PL_regmatch_state; - if (st > SLAB_LAST(PL_regmatch_slab)) - st = PL_regmatch_state = S_push_slab(aTHX); + st = PL_regmatch_state; /* Note that nextchr is a byte even in UTF */ SET_nextchr; @@ -3653,21 +3681,19 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) state_num = OP(scan); reenter_switch: + to_complement = 0; SET_nextchr; assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS)); switch (state_num) { case BOL: /* /^../ */ - if (locinput == PL_bostr) - { - /* reginfo->till = reginfo->bol; */ + if (locinput == reginfo->strbeg) break; - } sayNO; case MBOL: /* /^../m */ - if (locinput == PL_bostr || + if (locinput == reginfo->strbeg || (!NEXTCHR_IS_EOS && locinput[-1] == '\n')) { break; @@ -3675,7 +3701,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sayNO; case SBOL: /* /^../s */ - if (locinput == PL_bostr) + if (locinput == reginfo->strbeg) break; sayNO; @@ -3687,7 +3713,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case KEEPS: /* \K */ /* update the startpoint */ st->u.keeper.val = rex->offs[0].start; - rex->offs[0].start = locinput - PL_bostr; + rex->offs[0].start = locinput - reginfo->strbeg; PUSH_STATE_GOTO(KEEPS_next, next, locinput); assert(0); /*NOTREACHED*/ case KEEPS_next_fail: @@ -3708,7 +3734,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) seol: if (!NEXTCHR_IS_EOS && nextchr != '\n') sayNO; - if (PL_regeol - locinput > 1) + if (reginfo->strend - locinput > 1) sayNO; break; @@ -3846,7 +3872,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) shortest accept state and the wordnum of the longest accept state */ - while ( state && uc <= (U8*)PL_regeol ) { + while ( state && uc <= (U8*)(reginfo->strend) ) { U32 base = trie->states[ state ].trans.base; UV uvc = 0; U16 charid = 0; @@ -3880,7 +3906,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) }); /* read a char and goto next state */ - if ( base && (foldlen || uc < (U8*)PL_regeol)) { + if ( base && (foldlen || uc < (U8*)(reginfo->strend))) { I32 offset; REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, @@ -4079,7 +4105,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EXACT: { /* /abc/ */ char *s = STRING(scan); ln = STR_LEN(scan); - if (utf8_target != UTF_PATTERN) { + if (utf8_target != is_utf8_pat) { /* The target and the pattern have differing utf8ness. */ char *l = locinput; const char * const e = s + ln; @@ -4095,9 +4121,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * is an invariant, but there are tests in the test suite * dealing with (??{...}) which violate this) */ while (s < e) { - if (l >= PL_regeol) - sayNO; - if (UTF8_IS_ABOVE_LATIN1(* (U8*) l)) { + if (l >= reginfo->strend + || UTF8_IS_ABOVE_LATIN1(* (U8*) l)) + { sayNO; } if (UTF8_IS_INVARIANT(*(U8*)l)) { @@ -4118,7 +4144,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) else { /* The target is not utf8, the pattern is utf8. */ while (s < e) { - if (l >= PL_regeol || UTF8_IS_ABOVE_LATIN1(* (U8*) s)) + if (l >= reginfo->strend + || UTF8_IS_ABOVE_LATIN1(* (U8*) s)) { sayNO; } @@ -4138,17 +4165,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } } locinput = l; - break; } - /* The target and the pattern have the same utf8ness. */ - /* Inline the first character, for speed. */ - if (UCHARAT(s) != nextchr) - sayNO; - if (PL_regeol - locinput < ln) - sayNO; - if (ln > 1 && memNE(s, locinput, ln)) - sayNO; - locinput += ln; + else { + /* The target and the pattern have the same utf8ness. */ + /* Inline the first character, for speed. */ + if (reginfo->strend - locinput < ln + || UCHARAT(s) != nextchr + || (ln > 1 && memNE(s, locinput, ln))) + { + sayNO; + } + locinput += ln; + } break; } @@ -4158,9 +4186,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) const char * s; U32 fold_utf8_flags; - PL_reg_flags |= RF_tainted; - folder = foldEQ_locale; - fold_array = PL_fold_locale; + RX_MATCH_TAINTED_on(reginfo->prog); + folder = foldEQ_locale; + fold_array = PL_fold_locale; fold_utf8_flags = FOLDEQ_UTF8_LOCALE; goto do_exactf; @@ -4169,7 +4197,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EXACTFU: /* /abc/iu */ folder = foldEQ_latin1; fold_array = PL_fold_latin1; - fold_utf8_flags = (UTF_PATTERN) ? FOLDEQ_S1_ALREADY_FOLDED : 0; + fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0; goto do_exactf; case EXACTFA: /* /abc/iaa */ @@ -4187,13 +4215,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) s = STRING(scan); ln = STR_LEN(scan); - if (utf8_target || UTF_PATTERN || state_num == EXACTFU_SS) { + if (utf8_target || is_utf8_pat || state_num == EXACTFU_SS) { /* Either target or the pattern are utf8, or has the issue where * the fold lengths may differ. */ const char * const l = locinput; - char *e = PL_regeol; + char *e = reginfo->strend; - if (! foldEQ_utf8_flags(s, 0, ln, cBOOL(UTF_PATTERN), + if (! foldEQ_utf8_flags(s, 0, ln, is_utf8_pat, l, &e, 0, utf8_target, fold_utf8_flags)) { sayNO; @@ -4209,7 +4237,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) { sayNO; } - if (PL_regeol - locinput < ln) + if (reginfo->strend - locinput < ln) sayNO; if (ln > 1 && ! folder(s, locinput, ln)) sayNO; @@ -4222,7 +4250,7 @@ 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 */ - PL_reg_flags |= RF_tainted; + RX_MATCH_TAINTED_on(reginfo->prog); /* FALL THROUGH */ case BOUND: /* /\b/ */ case BOUNDU: /* /\b/u */ @@ -4235,26 +4263,27 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET && FLAGS(scan) != REGEX_ASCII_MORE_RESTRICTED_CHARSET) { - if (locinput == PL_bostr) + if (locinput == reginfo->strbeg) ln = '\n'; else { - const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr); + const U8 * const r = + reghop3((U8*)locinput, -1, (U8*)(reginfo->strbeg)); ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags); } if (FLAGS(scan) != REGEX_LOCALE_CHARSET) { - ln = isALNUM_uni(ln); + ln = isWORDCHAR_uni(ln); if (NEXTCHR_IS_EOS) n = 0; else { LOAD_UTF8_CHARCLASS_ALNUM(); - n = swash_fetch(PL_utf8_alnum, (U8*)locinput, + n = swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)locinput, utf8_target); } } else { - ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln)); - n = NEXTCHR_IS_EOS ? 0 : isALNUM_LC_utf8((U8*)locinput); + ln = isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(ln)); + n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC_utf8((U8*)locinput); } } else { @@ -4270,7 +4299,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * byte is never mistakable for ASCII, and so the test * will say it is not a word character, which is the * correct answer. */ - ln = (locinput != PL_bostr) ? + ln = (locinput != reginfo->strbeg) ? UCHARAT(locinput - 1) : '\n'; switch (FLAGS(scan)) { case REGEX_UNICODE_CHARSET: @@ -4278,12 +4307,12 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_L1(nextchr); break; case REGEX_LOCALE_CHARSET: - ln = isALNUM_LC(ln); - n = NEXTCHR_IS_EOS ? 0 : isALNUM_LC(nextchr); + ln = isWORDCHAR_LC(ln); + n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC(nextchr); break; case REGEX_DEPENDS_CHARSET: - ln = isALNUM(ln); - n = NEXTCHR_IS_EOS ? 0 : isALNUM(nextchr); + ln = isWORDCHAR(ln); + n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR(nextchr); break; case REGEX_ASCII_RESTRICTED_CHARSET: case REGEX_ASCII_MORE_RESTRICTED_CHARSET: @@ -4302,131 +4331,214 @@ 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)) sayNO; locinput += UTF8SKIP(locinput); - break; } else { if (!REGINCLASS(rex, scan, (U8*)locinput)) sayNO; locinput++; - break; } break; - /* Special char classes: \d, \w etc. - * The defines start on line 166 or so */ - CCC_TRY_U(ALNUM, NALNUM, isWORDCHAR, - ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8, - ALNUMU, NALNUMU, isWORDCHAR_L1, - ALNUMA, NALNUMA, isWORDCHAR_A, - alnum, "a"); + /* The argument (FLAGS) to all the POSIX node types is the class number + * */ - case SPACEL: - PL_reg_flags |= RF_tainted; - if (NEXTCHR_IS_EOS) { + case NPOSIXL: /* \W or [:^punct:] etc. under /l */ + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXL: /* \w or [:punct:] etc. under /l */ + if (NEXTCHR_IS_EOS) sayNO; - } - if (utf8_target && UTF8_IS_CONTINUED(nextchr)) { - if (! isSPACE_LC_utf8((U8 *) locinput)) { + + /* 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) */ + if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) { + if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) { sayNO; } } - else if (! isSPACE_LC((U8) nextchr)) { - sayNO; - } - goto increment_locinput; - - case NSPACEL: - PL_reg_flags |= RF_tainted; - if (NEXTCHR_IS_EOS) { - sayNO; - } - if (utf8_target && UTF8_IS_CONTINUED(nextchr)) { - if (isSPACE_LC_utf8((U8 *) locinput)) { + else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { + if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), + (U8) TWO_BYTE_UTF8_TO_UNI(nextchr, + *(locinput + 1)))))) + { sayNO; } } - else if (isSPACE_LC(nextchr)) { - sayNO; + else { /* Here, must be an above Latin-1 code point */ + goto utf8_posix_not_eos; } - goto increment_locinput; - case SPACE: - if (utf8_target) { - goto utf8_space; - } - /* FALL THROUGH */ - case SPACEA: - if (NEXTCHR_IS_EOS || ! isSPACE_A(nextchr)) { - sayNO; - } - /* Matched a utf8-invariant, so don't have to worry about utf8 */ - locinput++; + /* Here, must be utf8 */ + locinput += UTF8SKIP(locinput); break; - case NSPACE: + case NPOSIXD: /* \W or [:^punct:] etc. under /d */ + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXD: /* \w or [:punct:] etc. under /d */ if (utf8_target) { - goto utf8_nspace; + goto utf8_posix; } - /* FALL THROUGH */ - case NSPACEA: - if (NEXTCHR_IS_EOS || isSPACE_A(nextchr)) { - sayNO; - } - goto increment_locinput; + goto posixa; + + case NPOSIXA: /* \W or [:^punct:] etc. under /a */ - case SPACEU: - utf8_space: - if (NEXTCHR_IS_EOS || ! is_XPERLSPACE(locinput, utf8_target)) { + if (NEXTCHR_IS_EOS) { sayNO; } - goto increment_locinput; - case NSPACEU: - utf8_nspace: - if (NEXTCHR_IS_EOS || is_XPERLSPACE(locinput, utf8_target)) { - sayNO; + /* All UTF-8 variants match */ + if (! UTF8_IS_INVARIANT(nextchr)) { + goto increment_locinput; } - goto increment_locinput; - CCC_TRY(DIGIT, NDIGIT, isDIGIT, - DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8, - DIGITA, NDIGITA, isDIGIT_A, - digit, "0"); + to_complement = 1; + /* FALLTHROUGH */ - case POSIXA: /* /[[:ascii:]]/ etc */ - if (NEXTCHR_IS_EOS || ! _generic_isCC_A(nextchr, FLAGS(scan))) { + case POSIXA: /* \w or [:punct:] etc. under /a */ + + posixa: + /* We get here through POSIXD, NPOSIXD, and NPOSIXA when not in + * UTF-8, and also from NPOSIXA even in UTF-8 when the current + * character is a single byte */ + + if (NEXTCHR_IS_EOS + || ! (to_complement ^ cBOOL(_generic_isCC_A(nextchr, + FLAGS(scan))))) + { sayNO; } - /* Matched a utf8-invariant, so don't have to worry about utf8 */ + + /* Here we are either not in utf8, or we matched a utf8-invariant, + * so the next char is the next byte */ locinput++; break; - case NPOSIXA: /* /[^[:ascii:]]/ etc */ - if (NEXTCHR_IS_EOS || _generic_isCC_A(nextchr, FLAGS(scan))) { + case NPOSIXU: /* \W or [:^punct:] etc. under /u */ + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXU: /* \w or [:punct:] etc. under /u */ + utf8_posix: + if (NEXTCHR_IS_EOS) { sayNO; } - goto increment_locinput; + utf8_posix_not_eos: + + /* Use _generic_isCC() for characters within Latin1. (Note that + * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else + * wouldn't be invariant) */ + if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) { + if (! (to_complement ^ cBOOL(_generic_isCC(nextchr, + FLAGS(scan))))) + { + sayNO; + } + locinput++; + } + else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { + if (! (to_complement + ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(nextchr, + *(locinput + 1)), + FLAGS(scan))))) + { + sayNO; + } + locinput += 2; + } + else { /* Handle above Latin-1 code points */ + classnum = (_char_class_number) FLAGS(scan); + if (classnum < _FIRST_NON_SWASH_CC) { + + /* Here, uses a swash to find such code points. Load if if + * not 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); + } + if (! (to_complement + ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], + (U8 *) locinput, TRUE)))) + { + sayNO; + } + } + else { /* Here, uses macros to find above Latin-1 code points */ + switch (classnum) { + case _CC_ENUM_SPACE: /* XXX would require separate + code if we revert the change + of \v matching this */ + case _CC_ENUM_PSXSPC: + if (! (to_complement + ^ cBOOL(is_XPERLSPACE_high(locinput)))) + { + sayNO; + } + break; + case _CC_ENUM_BLANK: + if (! (to_complement + ^ cBOOL(is_HORIZWS_high(locinput)))) + { + sayNO; + } + break; + case _CC_ENUM_XDIGIT: + if (! (to_complement + ^ cBOOL(is_XDIGIT_high(locinput)))) + { + sayNO; + } + break; + case _CC_ENUM_VERTSPACE: + if (! (to_complement + ^ cBOOL(is_VERTWS_high(locinput)))) + { + sayNO; + } + break; + default: /* The rest, e.g. [:cntrl:], can't match + above Latin1 */ + if (! to_complement) { + sayNO; + } + break; + } + } + locinput += UTF8SKIP(locinput); + } + break; case CLUMP: /* Match \X: logical Unicode character. This is defined as a Unicode extended Grapheme Cluster */ /* From http://www.unicode.org/reports/tr29 (5.2 version). An extended Grapheme Cluster is: - CR LF - | Prepend* Begin Extend* - | . + CR LF + | Prepend* Begin Extend* + | . - Begin is: ( Special_Begin | ! Control ) - Special_Begin is: ( Regional-Indicator+ | Hangul-syllable ) - Extend is: ( Grapheme_Extend | Spacing_Mark ) - Control is: [ GCB_Control CR LF ] - Hangul-syllable is: ( T+ | ( L* ( L | ( LVT | ( V | LV ) V* ) T* ) )) + Begin is: ( Special_Begin | ! Control ) + Special_Begin is: ( Regional-Indicator+ | Hangul-syllable ) + Extend is: ( Grapheme_Extend | Spacing_Mark ) + Control is: [ GCB_Control | CR | LF ] + Hangul-syllable is: ( T+ | ( L* ( L | ( LVT | ( V | LV ) V* ) T* ) )) If we create a 'Regular_Begin' = Begin - Special_Begin, then we can rewrite @@ -4456,15 +4568,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) locinput++; /* Match the . or CR */ if (nextchr == '\r' /* And if it was CR, and the next is LF, match the LF */ - && locinput < PL_regeol - && UCHARAT(locinput) == '\n') locinput++; + && locinput < reginfo->strend + && UCHARAT(locinput) == '\n') + { + locinput++; + } } else { /* Utf8: See if is ( CR LF ); already know that locinput < - * PL_regeol, so locinput+1 is in bounds */ - if ( nextchr == '\r' && locinput+1 < PL_regeol - && UCHARAT(locinput + 1) == '\n') + * reginfo->strend, so locinput+1 is in bounds */ + if ( nextchr == '\r' && locinput+1 < reginfo->strend + && UCHARAT(locinput + 1) == '\n') { locinput += 2; } @@ -4475,12 +4590,12 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) char *starting = locinput; /* In case have to backtrack the last prepend */ - char *previous_prepend = 0; + char *previous_prepend = NULL; LOAD_UTF8_CHARCLASS_GCB(); /* Match (prepend)* */ - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_Prepend_utf8(locinput))) { previous_prepend = locinput; @@ -4491,16 +4606,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * the next thing won't match, back off the last prepend we * matched, as it is guaranteed to match the begin */ if (previous_prepend - && (locinput >= PL_regeol + && (locinput >= reginfo->strend || (! swash_fetch(PL_utf8_X_regular_begin, (U8*)locinput, utf8_target) - && ! is_GCB_SPECIAL_BEGIN_utf8(locinput))) + && ! is_GCB_SPECIAL_BEGIN_START_utf8(locinput))) ) { locinput = previous_prepend; } - /* Note that here we know PL_regeol > locinput, as we + /* Note that here we know reginfo->strend > locinput, as we * tested that upon input to this switch case, and if we * moved locinput forward, we tested the result just above * and it either passed, or we backed off so that it will @@ -4509,7 +4624,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) (U8*)locinput, utf8_target)) { locinput += UTF8SKIP(locinput); } - else if (! is_GCB_SPECIAL_BEGIN_utf8(locinput)) { + else if (! is_GCB_SPECIAL_BEGIN_START_utf8(locinput)) { /* Here did not match the required 'Begin' in the * second term. So just match the very first @@ -4523,7 +4638,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * RI+ */ if ((len = is_GCB_RI_utf8(locinput))) { locinput += len; - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_RI_utf8(locinput))) { locinput += len; @@ -4531,7 +4646,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } else if ((len = is_GCB_T_utf8(locinput))) { /* Another possibility is T+ */ locinput += len; - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_T_utf8(locinput))) { locinput += len; @@ -4544,7 +4659,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * L* (L | LVT T* | V * V* T* | LV V* T*) */ /* Match L* */ - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_L_utf8(locinput))) { locinput += len; @@ -4556,20 +4671,25 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * equation, we have a complete hangul syllable. * Are done. */ - if (locinput < PL_regeol + if (locinput < reginfo->strend && is_GCB_LV_LVT_V_utf8(locinput)) { - /* Otherwise keep going. Must be LV, LVT or V. - * See if LVT */ - if (is_utf8_X_LVT((U8*)locinput)) { + * See if LVT, by first ruling out V, then LV */ + if (! is_GCB_V_utf8(locinput) + /* All but every TCount one is LV */ + && (valid_utf8_to_uvchr((U8 *) locinput, + NULL) + - SBASE) + % TCount != 0) + { locinput += UTF8SKIP(locinput); } else { /* Must be V or LV. Take it, then match * V* */ locinput += UTF8SKIP(locinput); - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_V_utf8(locinput))) { locinput += len; @@ -4578,7 +4698,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* And any of LV, LVT, or V can be followed * by T* */ - while (locinput < PL_regeol + while (locinput < reginfo->strend && (len = is_GCB_T_utf8(locinput))) { locinput += len; @@ -4588,7 +4708,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } /* Match any extender */ - while (locinput < PL_regeol + while (locinput < reginfo->strend && swash_fetch(PL_utf8_X_extend, (U8*)locinput, utf8_target)) { @@ -4596,7 +4716,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } } exit_utf8: - if (locinput > PL_regeol) sayNO; + if (locinput > reginfo->strend) sayNO; } break; @@ -4607,13 +4727,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) op. */ /* don't initialize these in the declaration, it makes C++ unhappy */ - char *s; + const char *s; char type; re_fold_t folder; const U8 *fold_array; UV utf8_fold_flags; - PL_reg_flags |= RF_tainted; + RX_MATCH_TAINTED_on(reginfo->prog); folder = foldEQ_locale; fold_array = PL_fold_locale; type = REFFL; @@ -4658,7 +4778,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) goto do_nref_ref_common; case REFFL: /* /\1/il */ - PL_reg_flags |= RF_tainted; + RX_MATCH_TAINTED_on(reginfo->prog); folder = foldEQ_locale; fold_array = PL_fold_locale; utf8_fold_flags = FOLDEQ_UTF8_LOCALE; @@ -4693,23 +4813,23 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) do_nref_ref_common: ln = rex->offs[n].start; - PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ + reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ if (rex->lastparen < n || ln == -1) sayNO; /* Do not match unless seen CLOSEn. */ if (ln == rex->offs[n].end) break; - s = PL_bostr + ln; + s = reginfo->strbeg + ln; if (type != REF /* REF can do byte comparison */ && (utf8_target || type == REFFU)) { /* XXX handle REFFL better */ - char * limit = PL_regeol; + char * limit = reginfo->strend; /* This call case insensitively compares the entire buffer * at s, with the current input starting at locinput, but - * not going off the end given by PL_regeol, and returns in - * upon success, how much of the current input was - * matched */ + * not going off the end given by reginfo->strend, and + * returns in upon success, how much of the + * current input was matched */ if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target, locinput, &limit, 0, utf8_target, utf8_fold_flags)) { @@ -4726,7 +4846,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) UCHARAT(s) != fold_array[nextchr])) sayNO; ln = rex->offs[n].end - ln; - if (locinput + ln > PL_regeol) + if (locinput + ln > reginfo->strend) sayNO; if (ln > 1 && (type == REF ? memNE(s, locinput, ln) @@ -4790,36 +4910,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* execute the code in the {...} */ dSP; - PADOFFSET before; + IV before; OP * const oop = PL_op; COP * const ocurcop = PL_curcop; OP *nop; - char *saved_regeol = PL_regeol; - struct re_save_state saved_state; CV *newcv; /* save *all* paren positions */ - regcppush(rex, 0); + regcppush(rex, 0, maxopenparen); REGCP_SET(runops_cp); - /* To not corrupt the existing regex state while executing the - * eval we would normally put it on the save stack, like with - * save_re_context. However, re-evals have a weird scoping so we - * can't just add ENTER/LEAVE here. With that, things like - * - * (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) - * - * would break, as they expect the localisation to be unwound - * only when the re-engine backtracks through the bit that - * localised it. - * - * What we do instead is just saving the state in a local c - * variable. - */ - Copy(&PL_reg_state, &saved_state, 1, struct re_save_state); - - PL_reg_state.re_reparsing = FALSE; - if (!caller_cv) caller_cv = find_runcv(NULL); @@ -4853,12 +4953,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * points to newcv's pad. */ if (newcv != last_pushed_cv || PL_comppad != last_pad) { - I32 depth = (newcv == caller_cv) ? 0 : 1; + U8 flags = (CXp_SUB_RE | + ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0)); if (last_pushed_cv) { - CHANGE_MULTICALL_WITHDEPTH(newcv, depth); + CHANGE_MULTICALL_FLAGS(newcv, flags); } else { - PUSH_MULTICALL_WITHDEPTH(newcv, depth); + PUSH_MULTICALL_FLAGS(newcv, flags); } last_pushed_cv = newcv; } @@ -4905,7 +5006,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) ); - rex->offs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr; + 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; if (sv_yes_mark) { SV *sv_mrk = get_sv("REGMARK", 1); @@ -4915,11 +5019,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* we don't use MULTICALL here as we want to call the * first op of the block of interest, rather than the * first op of the sub */ - before = SP-PL_stack_base; + before = (IV)(SP-PL_stack_base); PL_op = nop; CALLRUNOPS(aTHX); /* Scalar context. */ SPAGAIN; - if (SP-PL_stack_base == before) + if ((IV)(SP-PL_stack_base) == before) ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */ else { ret = POPs; @@ -4964,16 +5068,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } - Copy(&saved_state, &PL_reg_state, 1, struct re_save_state); - /* *** Note that at this point we don't restore * PL_comppad, (or pop the CxSUB) on the assumption it may * be used again soon. This is safe as long as nothing * in the regexp code uses the pad ! */ PL_op = oop; PL_curcop = ocurcop; - PL_regeol = saved_regeol; - S_regcp_restore(aTHX_ rex, runops_cp); + S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen); + PL_curpm = PL_reg_curpm; if (logical != 2) break; @@ -4990,7 +5092,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } else { U32 pm_flags = 0; - const I32 osize = PL_regsize; if (SvUTF8(ret) && IN_BYTES) { /* In use 'bytes': make a copy of the octet @@ -5020,11 +5121,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) scalar. */ sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0); } - PL_regsize = osize; /* 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); + S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen); } SAVEFREESV(re_sv); re = ReANY(re_sv); @@ -5036,31 +5136,35 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) re->subcoffset = rex->subcoffset; rei = RXi_GET(re); DEBUG_EXECUTE_r( - debug_start_match(re_sv, utf8_target, locinput, PL_regeol, - "Matching embedded"); + debug_start_match(re_sv, utf8_target, locinput, + reginfo->strend, "Matching embedded"); ); 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 (??{...}) */ - ST.cp = regcppush(rex, 0); /* Save *all* the positions. */ + + /* Save *all* the positions. */ + ST.cp = regcppush(rex, 0, maxopenparen); REGCP_SET(ST.lastcp); re->lastparen = 0; re->lastcloseparen = 0; - PL_regsize = 0; + maxopenparen = 0; - /* XXXX This is too dramatic a measure... */ - PL_reg_maxiter = 0; + /* invalidate the S-L poscache. We're now executing a + * different set of WHILEM ops (and their associated + * indexes) against the same string, so the bits in the + * cache are meaningless. Setting maxiter to zero forces + * the cache to be invalidated and zeroed before reuse. + * XXX This is too dramatic a measure. Ideally we should + * save the old cache and restore when running the outer + * pattern again */ + reginfo->poscache_maxiter = 0; - ST.toggle_reg_flags = PL_reg_flags; - if (RX_UTF8(re_sv)) - PL_reg_flags |= RF_utf8; - else - PL_reg_flags &= ~RF_utf8; - ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */ + is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(re_sv)); ST.prev_rex = rex_sv; ST.prev_curlyx = cur_curlyx; @@ -5079,8 +5183,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EVAL_AB: /* cleanup after a successful (??{A})B */ /* note: this is called twice; first after popping B, then A */ - PL_reg_flags ^= ST.toggle_reg_flags; rex_sv = ST.prev_rex; + is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); SET_reg_curpm(rex_sv); rex = ReANY(rex_sv); rexi = RXi_GET(rex); @@ -5088,8 +5192,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) cur_eval = ST.prev_eval; cur_curlyx = ST.prev_curlyx; - /* XXXX This is too dramatic a measure... */ - PL_reg_maxiter = 0; + /* Invalidate cache. See "invalidate" comment above. */ + reginfo->poscache_maxiter = 0; if ( nochange_depth ) nochange_depth--; sayYES; @@ -5097,18 +5201,18 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */ /* note: this is called twice; first after popping B, then A */ - PL_reg_flags ^= ST.toggle_reg_flags; rex_sv = ST.prev_rex; + is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); SET_reg_curpm(rex_sv); rex = ReANY(rex_sv); rexi = RXi_GET(rex); REGCP_UNWIND(ST.lastcp); - regcppop(rex); + regcppop(rex, &maxopenparen); cur_eval = ST.prev_eval; cur_curlyx = ST.prev_curlyx; - /* XXXX This is too dramatic a measure... */ - PL_reg_maxiter = 0; + /* Invalidate cache. See "invalidate" comment above. */ + reginfo->poscache_maxiter = 0; if ( nochange_depth ) nochange_depth--; sayNO_SILENT; @@ -5116,16 +5220,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case OPEN: /* ( */ n = ARG(scan); /* which paren pair */ - rex->offs[n].start_tmp = locinput - PL_bostr; - if (n > PL_regsize) - PL_regsize = n; + rex->offs[n].start_tmp = locinput - reginfo->strbeg; + if (n > maxopenparen) + maxopenparen = n; DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; regsize=%"UVuf"\n", + "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n", PTR2UV(rex), PTR2UV(rex->offs), (UV)n, (IV)rex->offs[n].start_tmp, - (UV)PL_regsize + (UV)maxopenparen )); lastopen = n; break; @@ -5133,7 +5237,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) /* XXX really need to log other places start/end are set too */ #define CLOSE_CAPTURE \ rex->offs[n].start = rex->offs[n].start_tmp; \ - rex->offs[n].end = locinput - PL_bostr; \ + rex->offs[n].end = locinput - reginfo->strbeg; \ DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \ "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \ PTR2UV(rex), \ @@ -5146,8 +5250,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case CLOSE: /* ) */ n = ARG(scan); /* which paren pair */ CLOSE_CAPTURE; - /*if (n > PL_regsize) - PL_regsize = n;*/ if (n > rex->lastparen) rex->lastparen = n; rex->lastcloseparen = n; @@ -5167,8 +5269,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) n = ARG(cursor); if ( n <= lastopen ) { CLOSE_CAPTURE; - /*if (n > PL_regsize) - PL_regsize = n;*/ if (n > rex->lastparen) rex->lastparen = n; rex->lastcloseparen = n; @@ -5202,7 +5302,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) break; case IFTHEN: /* (?(cond)A|B) */ - PL_reg_leftiter = PL_reg_maxiter; /* Void cache */ + reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ if (sw) next = NEXTOPER(NEXTOPER(scan)); else { @@ -5311,7 +5411,7 @@ NULL next += ARG(next); /* XXXX Probably it is better to teach regpush to support - parenfloor > PL_regsize... */ + parenfloor > maxopenparen ... */ if (parenfloor > (I32)rex->lastparen) parenfloor = rex->lastparen; /* Pessimization... */ @@ -5371,7 +5471,8 @@ NULL /* First just match a string of min A's. */ if (n < min) { - ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor); + ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, + maxopenparen); cur_curlyx->u.curlyx.lastloc = locinput; REGCP_SET(ST.lastcp); @@ -5389,33 +5490,66 @@ NULL goto do_whilem_B_max; } - /* super-linear cache processing */ + /* super-linear cache processing. + * + * The idea here is that for certain types of CURLYX/WHILEM - + * principally those whose upper bound is infinity (and + * excluding regexes that have things like \1 and other very + * non-regular expresssiony things), then if a pattern like + * /....A*.../ fails and we backtrack to the WHILEM, then we + * make a note that this particular WHILEM op was at string + * position 47 (say) when the rest of pattern failed. Then, if + * we ever find ourselves back at that WHILEM, and at string + * position 47 again, we can just fail immediately rather than + * running the rest of the pattern again. + * + * This is very handy when patterns start to go + * 'super-linear', like in (a+)*(a+)*(a+)*, where you end up + * with a combinatorial explosion of backtracking. + * + * The cache is implemented as a bit array, with one bit per + * string byte position per WHILEM op (up to 16) - so its + * between 0.25 and 2x the string size. + * + * To avoid allocating a poscache buffer every time, we do an + * initially countdown; only after we have executed a WHILEM + * op (string-length x #WHILEMs) times do we allocate the + * cache. + * + * The top 4 bits of scan->flags byte say how many different + * relevant CURLLYX/WHILEM op pairs there are, while the + * bottom 4-bits is the identifying index number of this + * WHILEM. + */ if (scan->flags) { - if (!PL_reg_maxiter) { + if (!reginfo->poscache_maxiter) { /* start the countdown: Postpone detection until we * know the match is not *that* much linear. */ - PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4); + reginfo->poscache_maxiter + = (reginfo->strend - reginfo->strbeg + 1) + * (scan->flags>>4); /* possible overflow for long strings and many CURLYX's */ - if (PL_reg_maxiter < 0) - PL_reg_maxiter = I32_MAX; - PL_reg_leftiter = PL_reg_maxiter; + if (reginfo->poscache_maxiter < 0) + reginfo->poscache_maxiter = I32_MAX; + reginfo->poscache_iter = reginfo->poscache_maxiter; } - if (PL_reg_leftiter-- == 0) { + if (reginfo->poscache_iter-- == 0) { /* initialise cache */ - const I32 size = (PL_reg_maxiter + 7)/8; - if (PL_reg_poscache) { - if ((I32)PL_reg_poscache_size < size) { - Renew(PL_reg_poscache, size, char); - PL_reg_poscache_size = size; + const I32 size = (reginfo->poscache_maxiter + 7)/8; + regmatch_info_aux *const aux = reginfo->info_aux; + if (aux->poscache) { + if ((I32)reginfo->poscache_size < size) { + Renew(aux->poscache, size, char); + reginfo->poscache_size = size; } - Zero(PL_reg_poscache, size, char); + Zero(aux->poscache, size, char); } else { - PL_reg_poscache_size = size; - Newxz(PL_reg_poscache, size, char); + reginfo->poscache_size = size; + Newxz(aux->poscache, size, char); } DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "%swhilem: Detected a super-linear match, switching on caching%s...\n", @@ -5423,14 +5557,17 @@ NULL ); } - if (PL_reg_leftiter < 0) { + if (reginfo->poscache_iter < 0) { /* have we already failed at this position? */ I32 offset, mask; + + reginfo->poscache_iter = -1; /* stop eventual underflow */ offset = (scan->flags & 0xf) - 1 - + (locinput - PL_bostr) * (scan->flags>>4); + + (locinput - reginfo->strbeg) + * (scan->flags>>4); mask = 1 << (offset % 8); offset /= 8; - if (PL_reg_poscache[offset] & mask) { + if (reginfo->info_aux->poscache[offset] & mask) { DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "%*s whilem: (cache) already tried at this position...\n", REPORT_CODE_OFF+depth*2, "") @@ -5447,7 +5584,8 @@ NULL if (cur_curlyx->u.curlyx.minmod) { ST.save_curlyx = cur_curlyx; cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; - ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor); + ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor, + maxopenparen); REGCP_SET(ST.lastcp); PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B, locinput); @@ -5457,7 +5595,8 @@ NULL /* Prefer A over B for maximal matching. */ if (n < max) { /* More greed allowed? */ - ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor); + ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, + maxopenparen); cur_curlyx->u.curlyx.lastloc = locinput; REGCP_SET(ST.lastcp); PUSH_STATE_GOTO(WHILEM_A_max, A, locinput); @@ -5484,7 +5623,7 @@ NULL /* FALL THROUGH */ case WHILEM_A_pre_fail: /* just failed to match even minimal A */ REGCP_UNWIND(ST.lastcp); - regcppop(rex); + regcppop(rex, &maxopenparen); cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; cur_curlyx->u.curlyx.count--; CACHEsayNO; @@ -5492,7 +5631,7 @@ NULL case WHILEM_A_max_fail: /* just failed to match A in a maximal match */ REGCP_UNWIND(ST.lastcp); - regcppop(rex); /* Restore some previous $s? */ + regcppop(rex, &maxopenparen); /* Restore some previous $s? */ DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%*s whilem: failed, trying continuation...\n", REPORT_CODE_OFF+depth*2, "") @@ -5500,9 +5639,9 @@ NULL do_whilem_B_max: if (cur_curlyx->u.curlyx.count >= REG_INFTY && ckWARN(WARN_REGEXP) - && !(PL_reg_flags & RF_warned)) + && !reginfo->warned) { - PL_reg_flags |= RF_warned; + reginfo->warned = TRUE; Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Complex regular subexpression recursion limit (%d) " "exceeded", @@ -5519,15 +5658,15 @@ NULL case WHILEM_B_min_fail: /* just failed to match B in a minimal match */ cur_curlyx = ST.save_curlyx; REGCP_UNWIND(ST.lastcp); - regcppop(rex); + regcppop(rex, &maxopenparen); if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) { /* Maximum greed exceeded */ if (cur_curlyx->u.curlyx.count >= REG_INFTY && ckWARN(WARN_REGEXP) - && !(PL_reg_flags & RF_warned)) + && !reginfo->warned) { - PL_reg_flags |= RF_warned; + reginfo->warned = TRUE; Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Complex regular subexpression recursion " "limit (%d) exceeded", @@ -5542,7 +5681,8 @@ NULL ); /* Try grabbing another A and see if it helps. */ cur_curlyx->u.curlyx.lastloc = locinput; - ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor); + ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, + maxopenparen); REGCP_SET(ST.lastcp); PUSH_STATE_GOTO(WHILEM_A_min, /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS, @@ -5638,8 +5778,8 @@ NULL /* if paren positive, emulate an OPEN/CLOSE around A */ if (ST.me->flags) { U32 paren = ST.me->flags; - if (paren > PL_regsize) - PL_regsize = paren; + if (paren > maxopenparen) + maxopenparen = paren; scan += NEXT_OFF(scan); /* Skip former OPEN. */ } ST.A = scan; @@ -5662,7 +5802,7 @@ NULL ST.count++; /* after first match, determine A's length: u.curlym.alen */ if (ST.count == 1) { - if (PL_reg_match_utf8) { + if (reginfo->is_utf8_target) { char *s = st->locinput; while (s < locinput) { ST.alen++; @@ -5721,7 +5861,8 @@ NULL */ if (PL_regkind[OP(text_node)] == EXACT) { if (! S_setup_EXACTISH_ST_c1_c2(aTHX_ - text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8)) + text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8, + reginfo)) { sayNO; } @@ -5771,8 +5912,8 @@ NULL I32 paren = ST.me->flags; if (ST.count) { rex->offs[paren].start - = HOPc(locinput, -ST.alen) - PL_bostr; - rex->offs[paren].end = locinput - PL_bostr; + = HOPc(locinput, -ST.alen) - reginfo->strbeg; + rex->offs[paren].end = locinput - reginfo->strbeg; if ((U32)paren > rex->lastparen) rex->lastparen = paren; rex->lastcloseparen = paren; @@ -5814,8 +5955,8 @@ NULL #define CURLY_SETPAREN(paren, success) \ if (paren) { \ if (success) { \ - rex->offs[paren].start = HOPc(locinput, -1) - PL_bostr; \ - rex->offs[paren].end = locinput - PL_bostr; \ + rex->offs[paren].start = HOPc(locinput, -1) - reginfo->strbeg; \ + rex->offs[paren].end = locinput - reginfo->strbeg; \ if (paren > rex->lastparen) \ rex->lastparen = paren; \ rex->lastcloseparen = paren; \ @@ -5845,8 +5986,8 @@ NULL ST.paren = scan->flags; /* Which paren to set */ ST.lastparen = rex->lastparen; ST.lastcloseparen = rex->lastcloseparen; - if (ST.paren > PL_regsize) - PL_regsize = ST.paren; + if (ST.paren > maxopenparen) + maxopenparen = ST.paren; ST.min = ARG1(scan); /* min to match */ ST.max = ARG2(scan); /* max to match */ if (cur_eval && cur_eval->u.eval.close_paren && @@ -5897,7 +6038,8 @@ NULL if this changes back then the macro for IS_TEXT and friends need to change. */ if (! S_setup_EXACTISH_ST_c1_c2(aTHX_ - text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8)) + text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8, + reginfo)) { sayNO; } @@ -5910,7 +6052,9 @@ NULL if (minmod) { char *li = locinput; minmod = 0; - if (ST.min && regrepeat(rex, &li, ST.A, ST.min, depth) < ST.min) + if (ST.min && + regrepeat(rex, &li, ST.A, reginfo, ST.min, depth) + < ST.min) sayNO; SET_locinput(li); ST.count = ST.min; @@ -5923,7 +6067,7 @@ NULL /* set ST.maxpos to the furthest point along the * string that could possibly match */ if (ST.max == REG_INFTY) { - ST.maxpos = PL_regeol - 1; + ST.maxpos = reginfo->strend - 1; if (utf8_target) while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos)) ST.maxpos--; @@ -5931,13 +6075,13 @@ NULL else if (utf8_target) { int m = ST.max - ST.min; for (ST.maxpos = locinput; - m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--) + m >0 && ST.maxpos < reginfo->strend; m--) ST.maxpos += UTF8SKIP(ST.maxpos); } else { ST.maxpos = locinput + ST.max - ST.min; - if (ST.maxpos >= PL_regeol) - ST.maxpos = PL_regeol - 1; + if (ST.maxpos >= reginfo->strend) + ST.maxpos = reginfo->strend - 1; } goto curly_try_B_min_known; @@ -5946,7 +6090,7 @@ NULL /* avoid taking address of locinput, so it can remain * a register var */ char *li = locinput; - ST.count = regrepeat(rex, &li, ST.A, ST.max, depth); + ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max, depth); if (ST.count < ST.min) sayNO; SET_locinput(li); @@ -6030,7 +6174,7 @@ NULL * locinput matches */ char *li = ST.oldloc; ST.count += n; - if (regrepeat(rex, &li, ST.A, n, depth) < n) + if (regrepeat(rex, &li, ST.A, reginfo, n, depth) < n) sayNO; assert(n == REG_INFTY || locinput == li); } @@ -6054,7 +6198,7 @@ NULL /* failed -- move forward one */ { char *li = locinput; - if (!regrepeat(rex, &li, ST.A, 1, depth)) { + if (!regrepeat(rex, &li, ST.A, reginfo, 1, depth)) { sayNO; } locinput = li; @@ -6084,7 +6228,7 @@ NULL goto fake_end; } { - bool could_match = locinput < PL_regeol; + bool could_match = locinput < reginfo->strend; /* If it could work, try it. */ if (ST.c1 != CHRTEST_VOID && could_match) { @@ -6129,13 +6273,13 @@ NULL fake_end: if (cur_eval) { /* we've just finished A in /(??{A})B/; now continue with B */ - st->u.eval.toggle_reg_flags - = cur_eval->u.eval.toggle_reg_flags; - PL_reg_flags ^= st->u.eval.toggle_reg_flags; st->u.eval.prev_rex = rex_sv; /* inner */ - st->u.eval.cp = regcppush(rex, 0); /* Save *all* the positions. */ + + /* Save *all* the positions. */ + st->u.eval.cp = regcppush(rex, 0, maxopenparen); rex_sv = cur_eval->u.eval.prev_rex; + is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); SET_reg_curpm(rex_sv); rex = ReANY(rex_sv); rexi = RXi_GET(rex); @@ -6145,7 +6289,8 @@ NULL /* Restore parens of the outer rex without popping the * savestack */ - S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp); + S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp, + &maxopenparen); st->u.eval.prev_eval = cur_eval; cur_eval = cur_eval->u.eval.prev_eval; @@ -6163,8 +6308,8 @@ NULL DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", PL_colors[4], - (long)(locinput - PL_reg_starttry), - (long)(reginfo->till - PL_reg_starttry), + (long)(locinput - startpos), + (long)(reginfo->till - startpos), PL_colors[5])); sayNO_SILENT; /* Cannot match: too short. */ @@ -6256,7 +6401,7 @@ NULL break; case COMMIT: /* (*COMMIT) */ - reginfo->cutpoint = PL_regeol; + reginfo->cutpoint = reginfo->strend; /* FALLTHROUGH */ case PRUNE: /* (*PRUNE) */ @@ -6356,35 +6501,12 @@ NULL #undef ST case LNBREAK: /* \R */ - if ((n=is_LNBREAK_safe(locinput, PL_regeol, utf8_target))) { + if ((n=is_LNBREAK_safe(locinput, reginfo->strend, utf8_target))) { locinput += n; } else sayNO; break; -#define CASE_CLASS(nAmE) \ - case nAmE: \ - if (NEXTCHR_IS_EOS) \ - sayNO; \ - if ((n=is_##nAmE(locinput,utf8_target))) { \ - locinput += n; \ - } else \ - sayNO; \ - break; \ - case N##nAmE: \ - if (NEXTCHR_IS_EOS) \ - sayNO; \ - if ((n=is_##nAmE(locinput,utf8_target))) { \ - sayNO; \ - } else { \ - locinput += UTF8SKIP(locinput); \ - } \ - break - - CASE_CLASS(VERTWS); /* \v \V */ - CASE_CLASS(HORIZWS); /* \h \H */ -#undef CASE_CLASS - default: PerlIO_printf(Perl_error_log, "%"UVxf" %d\n", PTR2UV(scan), OP(scan)); @@ -6397,7 +6519,7 @@ NULL if (utf8_target) { locinput += PL_utf8skip[nextchr]; /* locinput is allowed to go 1 char off the end, but not 2+ */ - if (locinput > PL_regeol) + if (locinput > reginfo->strend) sayNO; } else @@ -6509,7 +6631,7 @@ yes: DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n", PL_colors[4], PL_colors[5])); - if (PL_reg_state.re_state_eval_setup_done) { + if (reginfo->info_aux_eval) { /* each successfully executed (?{...}) block does the equivalent of * local $^R = do {...} * When popping the save stack, all these locals would be undone; @@ -6581,11 +6703,8 @@ no_silent: PERL_UNUSED_VAR(SP); } - /* clean up; in particular, free all slabs above current one */ - LEAVE_SCOPE(oldsave); - - assert(!result || locinput - PL_bostr >= 0); - return result ? locinput - PL_bostr : -1; + assert(!result || locinput - reginfo->strbeg >= 0); + return result ? locinput - reginfo->strbeg : -1; } /* @@ -6598,19 +6717,23 @@ no_silent: * to point to the byte following the highest successful * match. * p - the regnode to be repeatedly matched against. + * reginfo - struct holding match state, such as strend * max - maximum number of things to match. * depth - (for debugging) backtracking depth. */ STATIC I32 -S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 max, int depth) +S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, + regmatch_info *const reginfo, I32 max, int depth) { dVAR; char *scan; /* Pointer to current position in target string */ I32 c; - char *loceol = PL_regeol; /* local version */ + char *loceol = reginfo->strend; /* local version */ I32 hardcount = 0; /* How many matches so far */ - bool utf8_target = PL_reg_match_utf8; + bool utf8_target = reginfo->is_utf8_target; + int to_complement = 0; /* Invert the result? */ UV utf8_flags; + _char_class_number classnum; #ifndef DEBUGGING PERL_UNUSED_ARG(depth); #endif @@ -6620,7 +6743,7 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma scan = *startposp; if (max == REG_INFTY) max = I32_MAX; - else if (! utf8_target && scan + max < loceol) + else if (! utf8_target && loceol - scan > max) loceol = scan + max; /* Here, for the case of a non-UTF-8 target we have adjusted down @@ -6669,7 +6792,7 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma scan = loceol; break; case CANY: /* Move forward bytes, unless goes off end */ - if (utf8_target && scan + max < loceol) { + if (utf8_target && loceol - scan > max) { /* hadn't been adjusted in the UTF-8 case */ scan += max; @@ -6679,7 +6802,7 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma } break; case EXACT: - assert(STR_LEN(p) == (UTF_PATTERN) ? UTF8SKIP(STRING(p)) : 1); + assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1); c = (U8)*STRING(p); @@ -6687,8 +6810,8 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma * under UTF-8, or both target and pattern aren't UTF-8. Note that we * can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's * true iff it doesn't matter if the argument is in UTF-8 or not */ - if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! UTF_PATTERN)) { - if (utf8_target && scan + max < loceol) { + if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! reginfo->is_utf8_pat)) { + if (utf8_target && loceol - scan > max) { /* We didn't adjust because is UTF-8, but ok to do so, * since here, to match at all, 1 char == 1 byte */ loceol = scan + max; @@ -6697,15 +6820,15 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma scan++; } } - else if (UTF_PATTERN) { + else if (reginfo->is_utf8_pat) { if (utf8_target) { STRLEN scan_char_len; /* When both target and pattern are UTF-8, we have to do * string EQ */ while (hardcount < max - && scan + (scan_char_len = UTF8SKIP(scan)) <= loceol - && scan_char_len <= STR_LEN(p) + && scan < loceol + && (scan_char_len = UTF8SKIP(scan)) <= STR_LEN(p) && memEQ(scan, STRING(p), scan_char_len)) { scan += scan_char_len; @@ -6748,7 +6871,7 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma goto do_exactf; case EXACTFL: - PL_reg_flags |= RF_tainted; + RXp_MATCH_TAINTED_on(prog); utf8_flags = FOLDEQ_UTF8_LOCALE; goto do_exactf; @@ -6759,26 +6882,28 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma case EXACTFU_SS: case EXACTFU_TRICKYFOLD: case EXACTFU: - utf8_flags = (UTF_PATTERN) ? FOLDEQ_S2_ALREADY_FOLDED : 0; + utf8_flags = reginfo->is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0; do_exactf: { int c1, c2; U8 c1_utf8[UTF8_MAXBYTES+1], c2_utf8[UTF8_MAXBYTES+1]; - assert(STR_LEN(p) == (UTF_PATTERN) ? UTF8SKIP(STRING(p)) : 1); + assert(STR_LEN(p) == reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1); - if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8)) { + if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8, + reginfo)) + { if (c1 == CHRTEST_VOID) { /* Use full Unicode fold matching */ - char *tmpeol = PL_regeol; - STRLEN pat_len = (UTF_PATTERN) ? UTF8SKIP(STRING(p)) : 1; + char *tmpeol = reginfo->strend; + STRLEN pat_len = reginfo->is_utf8_pat ? UTF8SKIP(STRING(p)) : 1; while (hardcount < max && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target, STRING(p), NULL, pat_len, - cBOOL(UTF_PATTERN), utf8_flags)) + reginfo->is_utf8_pat, utf8_flags)) { scan = tmpeol; - tmpeol = PL_regeol; + tmpeol = reginfo->strend; hardcount++; } } @@ -6819,13 +6944,13 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma break; } case ANYOF: + case ANYOF_WARN_SUPER: if (utf8_target) { - STRLEN inclasslen; while (hardcount < max - && scan + (inclasslen = UTF8SKIP(scan)) <= loceol + && scan < loceol && reginclass(prog, p, (U8*)scan, utf8_target)) { - scan += inclasslen; + scan += UTF8SKIP(scan); hardcount++; } } else { @@ -6833,316 +6958,214 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma scan++; } break; - case ALNUMU: - if (utf8_target) { - utf8_wordchar: - LOAD_UTF8_CHARCLASS_ALNUM(); - while (hardcount < max && scan < loceol && - swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && isWORDCHAR_L1((U8) *scan)) { - scan++; - } - } - break; - case ALNUM: - if (utf8_target) - goto utf8_wordchar; - while (scan < loceol && isALNUM((U8) *scan)) { - scan++; - } - break; - case ALNUMA: - if (utf8_target && scan + max < loceol) { - /* We didn't adjust because is UTF-8, but ok to do so, - * since here, to match, 1 char == 1 byte */ - loceol = scan + max; - } - while (scan < loceol && isWORDCHAR_A((U8) *scan)) { - scan++; - } - break; - case ALNUML: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - isALNUM_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && isALNUM_LC(*scan)) - scan++; - } - break; - case NALNUMU: - if (utf8_target) { + /* The argument (FLAGS) to all the POSIX node types is the class number */ - utf8_Nwordchar: + case NPOSIXL: + to_complement = 1; + /* FALLTHROUGH */ - LOAD_UTF8_CHARCLASS_ALNUM(); - while (hardcount < max && scan < loceol && - ! swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target)) + case POSIXL: + RXp_MATCH_TAINTED_on(prog); + if (! utf8_target) { + while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p), + *scan))) { - scan += UTF8SKIP(scan); + scan++; + } + } else { + while (hardcount < max && scan < loceol + && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p), + (U8 *) scan))) + { + scan += UTF8SKIP(scan); hardcount++; } - } else { - while (scan < loceol && ! isWORDCHAR_L1((U8) *scan)) { - scan++; - } - } - break; - case NALNUM: - if (utf8_target) - goto utf8_Nwordchar; - while (scan < loceol && ! isALNUM((U8) *scan)) { - scan++; } break; + case POSIXD: + if (utf8_target) { + goto utf8_posix; + } + /* FALLTHROUGH */ + case POSIXA: - if (utf8_target && scan + max < loceol) { + if (utf8_target && loceol - scan > max) { - /* We didn't adjust because is UTF-8, but ok to do so, - * since here, to match, 1 char == 1 byte */ + /* We didn't adjust at the beginning of this routine + * because is UTF-8, but it is actually ok to do so, since here, to + * match, 1 char == 1 byte. */ loceol = scan + max; } while (scan < loceol && _generic_isCC_A((U8) *scan, FLAGS(p))) { scan++; } break; - case NPOSIXA: - if (utf8_target) { - while (scan < loceol && hardcount < max - && ! _generic_isCC_A((U8) *scan, FLAGS(p))) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } - else { - while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) { - scan++; - } - } - break; - case NALNUMA: - if (utf8_target) { - while (scan < loceol && hardcount < max - && ! isWORDCHAR_A((U8) *scan)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } - else { - while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) { - scan++; - } - } - break; - case NALNUML: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - !isALNUM_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !isALNUM_LC(*scan)) - scan++; - } - break; - case SPACEU: - if (utf8_target) { - utf8_space: + case NPOSIXD: + if (utf8_target) { + to_complement = 1; + goto utf8_posix; + } + /* FALL THROUGH */ - while (hardcount < max && scan < loceol - && is_XPERLSPACE_utf8((U8*)scan)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - break; - } - else { - while (scan < loceol && isSPACE_L1((U8) *scan)) { + case NPOSIXA: + if (! utf8_target) { + while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) { scan++; } - break; - } - case SPACE: - if (utf8_target) - goto utf8_space; - - while (scan < loceol && isSPACE((U8) *scan)) { - scan++; - } - break; - case SPACEA: - if (utf8_target && scan + max < loceol) { - - /* We didn't adjust because is UTF-8, but ok to do so, - * since here, to match, 1 char == 1 byte */ - loceol = scan + max; } - while (scan < loceol && isSPACE_A((U8) *scan)) { - scan++; - } - break; - case SPACEL: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - isSPACE_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && isSPACE_LC(*scan)) - scan++; - } - break; - case NSPACEU: - if (utf8_target) { - - utf8_Nspace: + 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. */ while (hardcount < max && scan < loceol - && ! is_XPERLSPACE_utf8((U8*)scan)) + && (! UTF8_IS_INVARIANT(*scan) + || ! _generic_isCC_A((U8) *scan, FLAGS(p)))) { - scan += UTF8SKIP(scan); + scan += UTF8SKIP(scan); hardcount++; } - break; - } - else { - while (scan < loceol && ! isSPACE_L1((U8) *scan)) { - scan++; - } - } - break; - case NSPACE: - if (utf8_target) - goto utf8_Nspace; + } + break; - while (scan < loceol && ! isSPACE((U8) *scan)) { - scan++; - } - break; - case NSPACEA: - if (utf8_target) { - while (hardcount < max && scan < loceol - && ! isSPACE_A((U8) *scan)) + case NPOSIXU: + to_complement = 1; + /* FALLTHROUGH */ + + case POSIXU: + if (! utf8_target) { + while (scan < loceol && to_complement + ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p)))) { - scan += UTF8SKIP(scan); - hardcount++; - } + scan++; + } } else { - while (scan < loceol && ! isSPACE_A((U8) *scan)) { - scan++; - } - } - break; - case NSPACEL: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - !isSPACE_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !isSPACE_LC(*scan)) - scan++; - } - break; - case DIGIT: - if (utf8_target) { - LOAD_UTF8_CHARCLASS_DIGIT(); - while (hardcount < max && scan < loceol && - swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && isDIGIT(*scan)) - scan++; + utf8_posix: + classnum = (_char_class_number) FLAGS(p); + if (classnum < _FIRST_NON_SWASH_CC) { + + /* Here, a swash is needed for above-Latin1 code points. + * Process as many Latin1 code points using the built-in rules. + * Go to another loop to finish processing upon encountering + * the first Latin1 code point. We could do that in this loop + * as well, but the other way saves having to test if the swash + * has been loaded every time through the loop: extra space to + * save a test. */ + while (hardcount < max && scan < loceol) { + if (UTF8_IS_INVARIANT(*scan)) { + if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan, + classnum)))) + { + break; + } + scan++; + } + else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) { + if (! (to_complement + ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(*scan, + *(scan + 1)), + classnum)))) + { + break; + } + scan += 2; + } + else { + goto found_above_latin1; + } + + hardcount++; + } + } + else { + /* For these character classes, the knowledge of how to handle + * every code point is compiled in to Perl via a macro. This + * code is written for making the loops as tight as possible. + * It could be refactored to save space instead */ + switch (classnum) { + case _CC_ENUM_SPACE: /* XXX would require separate code + if we revert the change of \v + matching this */ + /* FALL THROUGH */ + case _CC_ENUM_PSXSPC: + while (hardcount < max + && scan < loceol + && (to_complement ^ cBOOL(isSPACE_utf8(scan)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + case _CC_ENUM_BLANK: + while (hardcount < max + && scan < loceol + && (to_complement ^ cBOOL(isBLANK_utf8(scan)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + case _CC_ENUM_XDIGIT: + while (hardcount < max + && scan < loceol + && (to_complement ^ cBOOL(isXDIGIT_utf8(scan)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + case _CC_ENUM_VERTSPACE: + while (hardcount < max + && scan < loceol + && (to_complement ^ cBOOL(isVERTWS_utf8(scan)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + case _CC_ENUM_CNTRL: + while (hardcount < max + && scan < loceol + && (to_complement ^ cBOOL(isCNTRL_utf8(scan)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + default: + Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum); + } + } } - break; - case DIGITA: - if (utf8_target && scan + max < loceol) { + break; - /* We didn't adjust because is UTF-8, but ok to do so, - * since here, to match, 1 char == 1 byte */ - loceol = scan + max; + found_above_latin1: /* Continuation of POSIXU and NPOSIXU */ + + /* Load the swash if not already present */ + 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); } - while (scan < loceol && isDIGIT_A((U8) *scan)) { - scan++; - } - break; - case DIGITL: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - isDIGIT_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && isDIGIT_LC(*scan)) - scan++; - } - break; - case NDIGIT: - if (utf8_target) { - LOAD_UTF8_CHARCLASS_DIGIT(); - while (hardcount < max && scan < loceol && - !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !isDIGIT(*scan)) - scan++; - } - break; - case NDIGITA: - if (utf8_target) { - while (hardcount < max && scan < loceol - && ! isDIGIT_A((U8) *scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } - else { - while (scan < loceol && ! isDIGIT_A((U8) *scan)) { - scan++; - } - } - break; - case NDIGITL: - PL_reg_flags |= RF_tainted; - if (utf8_target) { - while (hardcount < max && scan < loceol && - !isDIGIT_LC_utf8((U8*)scan)) { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !isDIGIT_LC(*scan)) - scan++; - } - break; + + while (hardcount < max && scan < loceol + && to_complement ^ cBOOL(_generic_utf8( + classnum, + scan, + swash_fetch(PL_utf8_swash_ptrs[classnum], + (U8 *) scan, + TRUE)))) + { + scan += UTF8SKIP(scan); + hardcount++; + } + break; + case LNBREAK: if (utf8_target) { while (hardcount < max && scan < loceol && @@ -7154,68 +7177,13 @@ S_regrepeat(pTHX_ const regexp *prog, char **startposp, const regnode *p, I32 ma /* LNBREAK can match one or two latin chars, which is ok, but we * have to use hardcount in this situation, and throw away the * adjustment to done before the switch statement */ - loceol = PL_regeol; + loceol = reginfo->strend; while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) { scan+=c; hardcount++; } } break; - case HORIZWS: - if (utf8_target) { - while (hardcount < max && scan < loceol && - (c=is_HORIZWS_utf8_safe(scan, loceol))) - { - scan += c; - hardcount++; - } - } else { - while (scan < loceol && is_HORIZWS_latin1_safe(scan, loceol)) - scan++; - } - break; - case NHORIZWS: - if (utf8_target) { - while (hardcount < max && scan < loceol && - !is_HORIZWS_utf8_safe(scan, loceol)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !is_HORIZWS_latin1_safe(scan, loceol)) - scan++; - - } - break; - case VERTWS: - if (utf8_target) { - while (hardcount < max && scan < loceol && - (c=is_VERTWS_utf8_safe(scan, loceol))) - { - scan += c; - hardcount++; - } - } else { - while (scan < loceol && is_VERTWS_latin1_safe(scan, loceol)) - scan++; - - } - break; - case NVERTWS: - if (utf8_target) { - while (hardcount < max && scan < loceol && - !is_VERTWS_utf8_safe(scan, loceol)) - { - scan += UTF8SKIP(scan); - hardcount++; - } - } else { - while (scan < loceol && !is_VERTWS_latin1_safe(scan, loceol)) - scan++; - - } - break; case BOUND: case BOUNDA: @@ -7385,7 +7353,7 @@ S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit */ STATIC bool -S_reginclass(pTHX_ const 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 bool utf8_target) { dVAR; const char flags = ANYOF_FLAGS(n); @@ -7418,47 +7386,57 @@ S_reginclass(pTHX_ const regexp * const prog, const regnode * const n, const U8* match = TRUE; } else if (flags & ANYOF_LOCALE) { - PL_reg_flags |= RF_tainted; + RXp_MATCH_TAINTED_on(prog); if ((flags & ANYOF_LOC_FOLD) && ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) { match = TRUE; } - else if (ANYOF_CLASS_TEST_ANY_SET(n) && - ((ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK_LC(c)) || - (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK_LC(c)) - ) /* How's that for a conditional? */ - ) { - match = TRUE; + else if (ANYOF_CLASS_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 + * bit/2; and 1, 3, 5, ... are set if the class includes the + * complemented Posix class given by int(bit/2). So we loop + * through the bits, each time changing whether we complement + * the result or not. Suppose for the sake of illustration + * that bits 0-3 mean respectively, \w, \W, \s, \S. If bit 0 + * is set, it means there is a match for this ANYOF node if the + * character is in the class given by the expression (0 / 2 = 0 + * = \w). If it is in that class, isFOO_lc() will return 1, + * and since 'to_complement' is 0, the result will stay TRUE, + * and we exit the loop. Suppose instead that bit 0 is 0, but + * bit 1 is 1. That means there is a match if the character + * matches \W. We won't bother to call isFOO_lc() on bit 0, + * but will on bit 1. On the second iteration 'to_complement' + * will be 1, so the exclusive or will reverse things, so we + * are testing for \W. On the third iteration, 'to_complement' + * will be 0, and we would be testing for \s; the fourth + * iteration would test for \S, etc. + * + * Note that this code assumes that all the classes are closed + * under folding. For example, if a character matches \w, then + * its fold does too; and vice versa. This should be true for + * any well-behaved locale for all the currently defined Posix + * classes, except for :lower: and :upper:, which are handled + * by the pseudo-class :cased: which matches if either of the + * other two does. To get rid of this assumption, an outer + * loop could be used below to iterate over both the source + * character, and its fold (if different) */ + + int count = 0; + int to_complement = 0; + while (count < ANYOF_MAX) { + if (ANYOF_CLASS_TEST(n, count) + && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c))) + { + match = TRUE; + break; + } + count++; + to_complement ^= 1; + } } } } @@ -7481,7 +7459,7 @@ S_reginclass(pTHX_ const regexp * const prog, const regnode * const n, const U8* || (utf8_target && (c >=256 || (! (flags & ANYOF_LOCALE)) - || (flags & ANYOF_IS_SYNTHETIC))))) + || OP(n) == ANYOF_SYNTHETIC)))) { SV * const sw = core_regclass_swash(prog, n, TRUE, 0); if (sw) { @@ -7503,7 +7481,7 @@ S_reginclass(pTHX_ const regexp * const prog, const regnode * const n, const U8* } if (UNICODE_IS_SUPER(c) - && (flags & ANYOF_WARN_SUPER) + && OP(n) == ANYOF_WARN_SUPER && ckWARN_d(WARN_NON_UNICODE)) { Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), @@ -7607,28 +7585,143 @@ S_reghopmaybe3(U8* s, I32 off, const U8* lim) return s; } + +/* when executing a regex that may have (?{}), extra stuff needs setting + up that will be visible to the called code, even before the current + match has finished. In particular: + + * $_ is localised to the SV currently being matched; + * pos($_) is created if necessary, ready to be updated on each call-out + to code; + * a fake PMOP is created that can be set to PL_curpm (normally PL_curpm + isn't set until the current pattern is successfully finished), so that + $1 etc of the match-so-far can be seen; + * save the old values of subbeg etc of the current regex, and set then + to the current string (again, this is normally only done at the end + of execution) +*/ + static void -restore_pos(pTHX_ void *arg) +S_setup_eval_state(pTHX_ regmatch_info *const reginfo) +{ + MAGIC *mg; + regexp *const rex = ReANY(reginfo->prog); + regmatch_info_aux_eval *eval_state = reginfo->info_aux_eval; + + eval_state->rex = rex; + + if (reginfo->sv) { + /* Make $_ available to executed code. */ + if (reginfo->sv != DEFSV) { + SAVE_DEFSV; + DEFSV_set(reginfo->sv); + } + + if (!(mg = mg_find_mglob(reginfo->sv))) { + /* prepare for quick setting of pos */ + mg = sv_magicext_mglob(reginfo->sv); + mg->mg_len = -1; + } + eval_state->pos_magic = mg; + eval_state->pos = mg->mg_len; + } + else + eval_state->pos_magic = NULL; + + if (!PL_reg_curpm) { + /* PL_reg_curpm is a fake PMOP that we can attach the current + * regex to and point PL_curpm at, so that $1 et al are visible + * within a /(?{})/. It's just allocated once per interpreter the + * first time its needed */ + Newxz(PL_reg_curpm, 1, PMOP); +#ifdef USE_ITHREADS + { + SV* const repointer = &PL_sv_undef; + /* 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_regex_pad = AvARRAY(PL_regex_padav); + } +#endif + } + SET_reg_curpm(reginfo->prog); + eval_state->curpm = PL_curpm; + PL_curpm = PL_reg_curpm; + if (RXp_MATCH_COPIED(rex)) { + /* Here is a serious problem: we cannot rewrite subbeg, + since it may be needed if this match fails. Thus + $` inside (?{}) could fail... */ + eval_state->subbeg = rex->subbeg; + eval_state->sublen = rex->sublen; + eval_state->suboffset = rex->suboffset; + eval_state->subcoffset = rex->subcoffset; +#ifdef PERL_ANY_COW + eval_state->saved_copy = rex->saved_copy; +#endif + RXp_MATCH_COPIED_off(rex); + } + else + eval_state->subbeg = NULL; + rex->subbeg = (char *)reginfo->strbeg; + rex->suboffset = 0; + rex->subcoffset = 0; + rex->sublen = reginfo->strend - reginfo->strbeg; +} + + +/* destructor to clear up regmatch_info_aux and regmatch_info_aux_eval */ + +static void +S_cleanup_regmatch_info_aux(pTHX_ void *arg) { dVAR; - regexp * const rex = (regexp *)arg; - if (PL_reg_state.re_state_eval_setup_done) { - if (PL_reg_oldsaved) { - rex->subbeg = PL_reg_oldsaved; - rex->sublen = PL_reg_oldsavedlen; - rex->suboffset = PL_reg_oldsavedoffset; - rex->subcoffset = PL_reg_oldsavedcoffset; -#ifdef PERL_OLD_COPY_ON_WRITE - rex->saved_copy = PL_nrs; + regmatch_info_aux *aux = (regmatch_info_aux *) arg; + regmatch_info_aux_eval *eval_state = aux->info_aux_eval; + regmatch_slab *s; + + Safefree(aux->poscache); + + if (eval_state) { + + /* undo the effects of S_setup_eval_state() */ + + if (eval_state->subbeg) { + regexp * const rex = eval_state->rex; + rex->subbeg = eval_state->subbeg; + rex->sublen = eval_state->sublen; + rex->suboffset = eval_state->suboffset; + rex->subcoffset = eval_state->subcoffset; +#ifdef PERL_ANY_COW + rex->saved_copy = eval_state->saved_copy; #endif - RXp_MATCH_COPIED_on(rex); - } - PL_reg_magic->mg_len = PL_reg_oldpos; - PL_reg_state.re_state_eval_setup_done = FALSE; - PL_curpm = PL_reg_oldcurpm; - } + RXp_MATCH_COPIED_on(rex); + } + if (eval_state->pos_magic) + eval_state->pos_magic->mg_len = eval_state->pos; + + PL_curpm = eval_state->curpm; + } + + PL_regmatch_state = aux->old_regmatch_state; + PL_regmatch_slab = aux->old_regmatch_slab; + + /* free all slabs above current one - this must be the last action + * of this function, as aux and eval_state are allocated within + * slabs and may be freed here */ + + s = PL_regmatch_slab->next; + if (s) { + PL_regmatch_slab->next = NULL; + while (s) { + regmatch_slab * const osl = s; + s = s->next; + Safefree(osl); + } + } } + STATIC void S_to_utf8_substr(pTHX_ regexp *prog) { @@ -7699,74 +7792,6 @@ S_to_byte_substr(pTHX_ regexp *prog) return TRUE; } -/* These constants are for finding GCB=LV and GCB=LVT. These are for the - * pre-composed Hangul syllables, which are all in a contiguous block and - * arranged there in such a way so as to facilitate alorithmic determination of - * their characteristics. As such, they don't need a swash, but can be - * determined by simple arithmetic. Almost all are GCB=LVT, but every 28th one - * is a GCB=LV */ -#define SBASE 0xAC00 /* Start of block */ -#define SCount 11172 /* Length of block */ -#define TCount 28 - -#if 0 /* This routine is not currently used */ -PERL_STATIC_INLINE bool -S_is_utf8_X_LV(pTHX_ const U8 *p) -{ - /* Unlike most other similarly named routines here, this does not create a - * swash, so swash_fetch() cannot be used on PL_utf8_X_LV. */ - - dVAR; - - UV cp = valid_utf8_to_uvchr(p, NULL); - - PERL_ARGS_ASSERT_IS_UTF8_X_LV; - - /* The earliest Unicode releases did not have these precomposed Hangul - * syllables. Set to point to undef in that case, so will return false on - * every call */ - if (! PL_utf8_X_LV) { /* Set up if this is the first time called */ - PL_utf8_X_LV = swash_init("utf8", "_X_GCB_LV", &PL_sv_undef, 1, 0); - if (_invlist_len(_get_swash_invlist(PL_utf8_X_LV)) == 0) { - SvREFCNT_dec(PL_utf8_X_LV); - PL_utf8_X_LV = &PL_sv_undef; - } - } - - return (PL_utf8_X_LV != &PL_sv_undef - && cp >= SBASE && cp < SBASE + SCount - && (cp - SBASE) % TCount == 0); /* Only every TCount one is LV */ -} -#endif - -PERL_STATIC_INLINE bool -S_is_utf8_X_LVT(pTHX_ const U8 *p) -{ - /* Unlike most other similarly named routines here, this does not create a - * swash, so swash_fetch() cannot be used on PL_utf8_X_LVT. */ - - dVAR; - - UV cp = valid_utf8_to_uvchr(p, NULL); - - PERL_ARGS_ASSERT_IS_UTF8_X_LVT; - - /* The earliest Unicode releases did not have these precomposed Hangul - * syllables. Set to point to undef in that case, so will return false on - * every call */ - if (! PL_utf8_X_LVT) { /* Set up if this is the first time called */ - PL_utf8_X_LVT = swash_init("utf8", "_X_GCB_LVT", &PL_sv_undef, 1, 0); - if (_invlist_len(_get_swash_invlist(PL_utf8_X_LVT)) == 0) { - SvREFCNT_dec(PL_utf8_X_LVT); - PL_utf8_X_LVT = &PL_sv_undef; - } - } - - return (PL_utf8_X_LVT != &PL_sv_undef - && cp >= SBASE && cp < SBASE + SCount - && (cp - SBASE) % TCount != 0); /* All but every TCount one is LV */ -} - /* * Local variables: * c-indentation-style: bsd