X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1c23e2bdad29ff1daf6392412fffae9341795834..57c40738fafded0c328e07a024c13df64e97b619:/regexec.c diff --git a/regexec.c b/regexec.c index 057e993..7be4f03 100644 --- a/regexec.c +++ b/regexec.c @@ -96,9 +96,15 @@ static const char* const non_utf8_target_but_utf8_required = "Can't match, because target string needs to be in UTF-8\n"; #endif -#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\ - goto target; \ +/* Returns a boolean as to whether the input unsigned number is a power of 2 + * (2**0, 2**1, etc). In other words if it has just a single bit set. + * If not, subtracting 1 would leave the uppermost bit set, so the & would + * yield non-zero */ +#define isPOWER_OF_2(n) ((n & (n-1)) == 0) + +#define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \ + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%s", non_utf8_target_but_utf8_required));\ + goto target; \ } STMT_END #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i) @@ -107,18 +113,18 @@ static const char* const non_utf8_target_but_utf8_required #define STATIC static #endif -/* Valid only for non-utf8 strings: avoids the reginclass - * call if there are no complications: i.e., if everything matchable is - * straight forward in the bitmap */ -#define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,c+1,0) \ - : ANYOF_BITMAP_TEST(p,*(c))) +/* Valid only if 'c', the character being looke-up, is an invariant under + * UTF-8: it avoids the reginclass call if there are no complications: i.e., if + * everything matchable is straight forward in the bitmap */ +#define REGINCLASS(prog,p,c,u) (ANYOF_FLAGS(p) \ + ? reginclass(prog,p,c,c+1,u) \ + : ANYOF_BITMAP_TEST(p,*(c))) /* * Forwards. */ #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv)) -#define CHR_DIST(a,b) (reginfo->is_utf8_target ? utf8_distance(a,b) : a - b) #define HOPc(pos,off) \ (char *)(reginfo->is_utf8_target \ @@ -126,13 +132,16 @@ static const char* const non_utf8_target_but_utf8_required (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \ : (U8*)(pos + off)) -#define HOPBACKc(pos, off) \ - (char*)(reginfo->is_utf8_target \ - ? reghopmaybe3((U8*)pos, -off, (U8*)(reginfo->strbeg)) \ - : (pos - off >= reginfo->strbeg) \ - ? (U8*)pos - off \ +/* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */ +#define HOPBACK3(pos, off, lim) \ + (reginfo->is_utf8_target \ + ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \ + : (pos - off >= lim) \ + ? (U8*)pos - off \ : NULL) +#define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg)) + #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)) @@ -149,6 +158,7 @@ static const char* const non_utf8_target_but_utf8_required #define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \ ? reghop3((U8*)(pos), off, (U8*)(lim)) \ : (U8*)((pos + off) > lim ? lim : (pos + off))) +#define HOP3clim(pos,off,lim) ((char*)HOP3lim(pos,off,lim)) #define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \ ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \ @@ -212,7 +222,8 @@ static const char* const non_utf8_target_but_utf8_required */ #define JUMPABLE(rn) ( \ OP(rn) == OPEN || \ - (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \ + (OP(rn) == CLOSE && \ + !EVAL_CLOSE_PAREN_IS(cur_eval,ARG(rn)) ) || \ OP(rn) == EVAL || \ OP(rn) == SUSPEND || OP(rn) == IFMATCH || \ OP(rn) == PLUS || OP(rn) == MINMOD || \ @@ -270,7 +281,7 @@ static regmatch_state * S_push_slab(pTHX); * are needed for the regexp context stack bookkeeping. */ STATIC CHECKPOINT -S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) +S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen _pDEPTH) { const int retval = PL_savestack_ix; const int paren_elems_to_push = @@ -288,7 +299,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) (int)parenfloor, (unsigned)REGCP_PAREN_ELEMS); if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems) - Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf + Perl_croak(aTHX_ "panic: paren_elems_to_push offset %" UVuf " out of range (%lu-%ld)", total_elems, (unsigned long)maxopenparen, @@ -298,9 +309,10 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) DEBUG_BUFFERS_r( if ((int)maxopenparen > (int)parenfloor) - PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n", - PTR2UV(rex), + Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " offs=0x%" UVxf ": saving capture indices:\n", + depth, + PTR2UV(rex), PTR2UV(rex->offs) ); ); @@ -309,9 +321,10 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) SSPUSHIV(rex->offs[p].end); SSPUSHIV(rex->offs[p].start); SSPUSHINT(rex->offs[p].start_tmp); - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, - " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n", - (UV)p, + DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ + " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "\n", + depth, + (UV)p, (IV)rex->offs[p].start, (IV)rex->offs[p].start_tmp, (IV)rex->offs[p].end @@ -329,17 +342,22 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) /* These are needed since we do not localize EVAL nodes: */ #define REGCP_SET(cp) \ DEBUG_STATE_r( \ - PerlIO_printf(Perl_debug_log, \ - " Setting an EVAL scope, savestack=%"IVdf"\n", \ - (IV)PL_savestack_ix)); \ + Perl_re_exec_indentf( aTHX_ \ + "Setting an EVAL scope, savestack=%" IVdf ",\n", \ + depth, (IV)PL_savestack_ix \ + ) \ + ); \ cp = PL_savestack_ix #define REGCP_UNWIND(cp) \ DEBUG_STATE_r( \ - if (cp != PL_savestack_ix) \ - PerlIO_printf(Perl_debug_log, \ - " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \ - (IV)(cp), (IV)PL_savestack_ix)); \ + if (cp != PL_savestack_ix) \ + Perl_re_exec_indentf( aTHX_ \ + "Clearing an EVAL scope, savestack=%" \ + IVdf "..%" IVdf "\n", \ + depth, (IV)(cp), (IV)PL_savestack_ix \ + ) \ + ); \ regcpblow(cp) #define UNWIND_PAREN(lp, lcp) \ @@ -350,7 +368,7 @@ S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen) STATIC void -S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) +S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p _pDEPTH) { UV i; U32 paren; @@ -370,9 +388,10 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) /* Now restore the parentheses context. */ DEBUG_BUFFERS_r( if (i || rex->lastparen + 1 <= rex->nparens) - PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n", - PTR2UV(rex), + Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " offs=0x%" UVxf ": restoring capture indices to:\n", + depth, + PTR2UV(rex), PTR2UV(rex->offs) ); ); @@ -384,9 +403,10 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) tmps = SSPOPIV; if (paren <= rex->lastparen) rex->offs[paren].end = tmps; - DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log, - " \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n", - (UV)paren, + DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_ + " \\%" UVuf ": %" IVdf "(%" IVdf ")..%" IVdf "%s\n", + depth, + (UV)paren, (IV)rex->offs[paren].start, (IV)rex->offs[paren].start_tmp, (IV)rex->offs[paren].end, @@ -408,9 +428,10 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) 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, + DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_ + " \\%" UVuf ": %s ..-1 undeffing\n", + depth, + (UV)i, (i > *maxopenparen_p) ? "-1" : " " )); } @@ -421,9 +442,11 @@ S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p) * but without popping the stack */ STATIC void -S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p) +S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p _pDEPTH) { I32 tmpix = PL_savestack_ix; + PERL_ARGS_ASSERT_REGCP_RESTORE; + PL_savestack_ix = ix; regcppop(rex, maxopenparen_p); PL_savestack_ix = tmpix; @@ -431,8 +454,10 @@ S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p) #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */ -STATIC bool -S_isFOO_lc(pTHX_ const U8 classnum, const U8 character) +#ifndef PERL_IN_XSUB_RE + +bool +Perl_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 @@ -452,7 +477,7 @@ S_isFOO_lc(pTHX_ const U8 classnum, const U8 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) + 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); @@ -472,6 +497,8 @@ S_isFOO_lc(pTHX_ const U8 classnum, const U8 character) return FALSE; } +#endif + STATIC bool S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) { @@ -525,6 +552,116 @@ S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character) return FALSE; /* Things like CNTRL are always below 256 */ } +STATIC char * +S_find_next_ascii(char * s, const char * send, const bool utf8_target) +{ + /* Returns the position of the first ASCII byte in the sequence between 's' + * and 'send-1' inclusive; returns 'send' if none found */ + + PERL_ARGS_ASSERT_FIND_NEXT_ASCII; + +#ifndef EBCDIC + + if ((STRLEN) (send - s) >= PERL_WORDSIZE + + /* This term is wordsize if subword; 0 if not */ + + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s) + + /* 'offset' */ + - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK)) + { + + /* Process per-byte until reach word boundary. XXX This loop could be + * eliminated if we knew that this platform had fast unaligned reads */ + while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) { + if (isASCII(*s)) { + return s; + } + s++; /* khw didn't bother creating a separate loop for + utf8_target */ + } + + /* Here, we know we have at least one full word to process. Process + * per-word as long as we have at least a full word left */ + do { + if ((* (PERL_UINTMAX_T *) s) & ~ PERL_VARIANTS_WORD_MASK) { + break; + } + s += PERL_WORDSIZE; + } while (s + PERL_WORDSIZE <= send); + } + +#endif + + /* Process per-character */ + if (utf8_target) { + while (s < send) { + if (isASCII(*s)) { + return s; + } + s += UTF8SKIP(s); + } + } + else { + while (s < send) { + if (isASCII(*s)) { + return s; + } + s++; + } + } + + return s; +} + +STATIC char * +S_find_next_non_ascii(char * s, const char * send, const bool utf8_target) +{ + /* Returns the position of the first non-ASCII byte in the sequence between + * 's' and 'send-1' inclusive; returns 'send' if none found */ + +#ifdef EBCDIC + + PERL_ARGS_ASSERT_FIND_NEXT_NON_ASCII; + + if (utf8_target) { + while (s < send) { + if ( ! isASCII(*s)) { + return s; + } + s += UTF8SKIP(s); + } + } + else { + while (s < send) { + if ( ! isASCII(*s)) { + return s; + } + s++; + } + } + + return s; + +#else + + const U8 * next_non_ascii = NULL; + + PERL_ARGS_ASSERT_FIND_NEXT_NON_ASCII; + PERL_UNUSED_ARG(utf8_target); + + /* On ASCII platforms invariants and ASCII are identical, so if the string + * is entirely invariants, there is no non-ASCII character */ + return (is_utf8_invariant_string_loc((U8 *) s, + (STRLEN) (send - s), + &next_non_ascii)) + ? (char *) send + : (char *) next_non_ascii; + +#endif + +} + /* * pregexec and friends */ @@ -650,7 +787,7 @@ Perl_re_intuit_start(pTHX_ PERL_UNUSED_ARG(flags); PERL_UNUSED_ARG(data); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Intuit: trying to determine minimum start position...\n")); /* for now, assume that all substr offsets are positive. If at some point @@ -681,12 +818,12 @@ Perl_re_intuit_start(pTHX_ * to quickly reject some cases that can't match, but will reject * them later after doing full char arithmetic */ if (prog->minlen > strend - strpos) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " String too short...\n")); goto fail; } - RX_MATCH_UTF8_set(rx,utf8_target); + RXp_MATCH_UTF8_set(prog, utf8_target); reginfo->is_utf8_target = cBOOL(utf8_target); reginfo->info_aux = NULL; reginfo->strbeg = strbeg; @@ -697,7 +834,8 @@ Perl_re_intuit_start(pTHX_ reginfo->poscache_maxiter = 0; if (utf8_target) { - if (!prog->check_utf8 && prog->check_substr) + if ((!prog->anchored_utf8 && prog->anchored_substr) + || (!prog->float_utf8 && prog->float_substr)) to_utf8_substr(prog); check = prog->check_utf8; } else { @@ -718,9 +856,9 @@ Perl_re_intuit_start(pTHX_ if (!sv) continue; - PerlIO_printf(Perl_debug_log, - " substrs[%d]: min=%"IVdf" max=%"IVdf" end shift=%"IVdf - " useful=%"IVdf" utf8=%d [%s]\n", + Perl_re_printf( aTHX_ + " substrs[%d]: min=%" IVdf " max=%" IVdf " end shift=%" IVdf + " useful=%" IVdf " utf8=%d [%s]\n", i, (IV)prog->substrs->data[i].min_offset, (IV)prog->substrs->data[i].max_offset, @@ -758,7 +896,7 @@ Perl_re_intuit_start(pTHX_ if ( strpos != strbeg && (prog->intflags & PREGf_ANCH_SBOL)) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Not at start...\n")); goto fail; } @@ -778,8 +916,8 @@ Perl_re_intuit_start(pTHX_ SSize_t slen = SvCUR(check); char *s = HOP3c(strpos, prog->check_offset_min, strend); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " Looking for check substr at fixed offset %"IVdf"...\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " Looking for check substr at fixed offset %" IVdf "...\n", (IV)prog->check_offset_min)); if (SvTAIL(check)) { @@ -792,17 +930,18 @@ Perl_re_intuit_start(pTHX_ || strend - s < slen - 1 || (strend - s == slen && strend[-1] != '\n'))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " String too long...\n")); goto fail_finish; } /* Now should match s[0..slen-2] */ slen--; } - if (slen && (*SvPVX_const(check) != *s - || (slen > 1 && memNE(SvPVX_const(check), s, slen)))) + if (slen && (strend - s < slen + || *SvPVX_const(check) != *s + || (slen > 1 && (memNE(SvPVX_const(check), s, slen))))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " String not equal...\n")); goto fail_finish; } @@ -817,8 +956,8 @@ Perl_re_intuit_start(pTHX_ #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */ if (end_shift < 0) - Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ", - (IV)end_shift, RX_PRECOMP(prog)); + Perl_croak(aTHX_ "panic: end_shift: %" IVdf " pattern:\n%s\n ", + (IV)end_shift, RX_PRECOMP(rx)); #endif restart: @@ -853,10 +992,10 @@ Perl_re_intuit_start(pTHX_ U8* end_point; DEBUG_OPTIMISE_MORE_r({ - PerlIO_printf(Perl_debug_log, - " At restart: rx_origin=%"IVdf" Check offset min: %"IVdf - " Start shift: %"IVdf" End shift %"IVdf - " Real end Shift: %"IVdf"\n", + Perl_re_printf( aTHX_ + " At restart: rx_origin=%" IVdf " Check offset min: %" IVdf + " Start shift: %" IVdf " End shift %" IVdf + " Real end Shift: %" IVdf "\n", (IV)(rx_origin - strbeg), (IV)prog->check_offset_min, (IV)start_shift, @@ -864,7 +1003,9 @@ Perl_re_intuit_start(pTHX_ (IV)prog->check_end_shift); }); - end_point = HOP3(strend, -end_shift, strbeg); + end_point = HOPBACK3(strend, end_shift, rx_origin); + if (!end_point) + goto fail_finish; start_point = HOPMAYBE3(rx_origin, start_shift, end_point); if (!start_point) goto fail_finish; @@ -882,27 +1023,36 @@ Perl_re_intuit_start(pTHX_ && prog->intflags & PREGf_ANCH && prog->check_offset_max != SSize_t_MAX) { - SSize_t len = SvCUR(check) - !!SvTAIL(check); + SSize_t check_len = SvCUR(check) - !!SvTAIL(check); const char * const anchor = (prog->intflags & PREGf_ANCH_GPOS ? strpos : strbeg); + SSize_t targ_len = (char*)end_point - anchor; + + if (check_len > targ_len) { + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + "Anchored string too short...\n")); + goto fail_finish; + } /* do a bytes rather than chars comparison. It's conservative; * so it skips doing the HOP if the result can't possibly end * up earlier than the old value of end_point. */ - if ((char*)end_point - anchor > prog->check_offset_max) { + assert(anchor + check_len <= (char *)end_point); + if (prog->check_offset_max + check_len < targ_len) { end_point = HOP3lim((U8*)anchor, prog->check_offset_max, - end_point -len) - + len; + end_point - check_len + ) + + check_len; } } check_at = fbm_instr( start_point, end_point, check, multiline ? FBMrf_MULTILINE : 0); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " doing 'check' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " doing 'check' fbm scan, [%" IVdf "..%" IVdf "] gave %" IVdf "\n", (IV)((char*)start_point - strbeg), (IV)((char*)end_point - strbeg), (IV)(check_at ? check_at - strbeg : -1) @@ -914,7 +1064,7 @@ Perl_re_intuit_start(pTHX_ DEBUG_EXECUTE_r({ RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(check), RE_SV_DUMPLEN(check), 30); - PerlIO_printf(Perl_debug_log, " %s %s substr %s%s%s", + Perl_re_printf( aTHX_ " %s %s substr %s%s%s", (check_at ? "Found" : "Did not find"), (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"), @@ -933,8 +1083,8 @@ Perl_re_intuit_start(pTHX_ if (check_at - rx_origin > prog->check_offset_max) rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin); /* Finish the diagnostic message */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%ld (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + "%ld (rx_origin now %" IVdf ")...\n", (long)(check_at - strbeg), (IV)(rx_origin - strbeg) )); @@ -1045,10 +1195,12 @@ Perl_re_intuit_start(pTHX_ char *from = s; char *to = last + SvCUR(must) - (SvTAIL(must)!=0); + if (to > strend) + to = strend; if (from > to) { s = NULL; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " skipping 'other' fbm scan: %"IVdf" > %"IVdf"\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " skipping 'other' fbm scan: %" IVdf " > %" IVdf "\n", (IV)(from - strbeg), (IV)(to - strbeg) )); @@ -1060,8 +1212,8 @@ Perl_re_intuit_start(pTHX_ must, multiline ? FBMrf_MULTILINE : 0 ); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " doing 'other' fbm scan, [%"IVdf"..%"IVdf"] gave %"IVdf"\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " doing 'other' fbm scan, [%" IVdf "..%" IVdf "] gave %" IVdf "\n", (IV)(from - strbeg), (IV)(to - strbeg), (IV)(s ? s - strbeg : -1) @@ -1072,7 +1224,7 @@ Perl_re_intuit_start(pTHX_ DEBUG_EXECUTE_r({ RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, " %s %s substr %s%s", + Perl_re_printf( aTHX_ " %s %s substr %s%s", s ? "Found" : "Contradicts", other_ix ? "floating" : "anchored", quoted, RE_SV_TAIL(must)); @@ -1083,7 +1235,7 @@ Perl_re_intuit_start(pTHX_ /* last1 is latest possible substr location. If we didn't * find it before there, we never will */ if (last >= last1) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "; giving up...\n")); goto fail_finish; } @@ -1096,8 +1248,8 @@ Perl_re_intuit_start(pTHX_ other_ix /* i.e. if other-is-float */ ? HOP3c(rx_origin, 1, strend) : HOP4c(last, 1 - other->min_offset, strbeg, strend); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "; about to retry %s at offset %ld (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + "; about to retry %s at offset %ld (rx_origin now %" IVdf ")...\n", (other_ix ? "floating" : "anchored"), (long)(HOP3c(check_at, 1, strend) - strbeg), (IV)(rx_origin - strbeg) @@ -1120,8 +1272,8 @@ Perl_re_intuit_start(pTHX_ rx_origin = HOP3c(s, -other->min_offset, strbeg); other_last = HOP3c(s, 1, strend); } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " at offset %ld (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " at offset %ld (rx_origin now %" IVdf ")...\n", (long)(s - strbeg), (IV)(rx_origin - strbeg) )); @@ -1130,10 +1282,10 @@ Perl_re_intuit_start(pTHX_ } else { DEBUG_OPTIMISE_MORE_r( - PerlIO_printf(Perl_debug_log, - " Check-only match: offset min:%"IVdf" max:%"IVdf - " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf - " strend:%"IVdf"\n", + Perl_re_printf( aTHX_ + " Check-only match: offset min:%" IVdf " max:%" IVdf + " check_at:%" IVdf " rx_origin:%" IVdf " rx_origin-check_at:%" IVdf + " strend:%" IVdf "\n", (IV)prog->check_offset_min, (IV)prog->check_offset_max, (IV)(check_at-strbeg), @@ -1151,7 +1303,7 @@ Perl_re_intuit_start(pTHX_ if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') { char *s; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " looking for /^/m anchor")); /* we have failed the constraint of a \n before rx_origin. @@ -1171,7 +1323,7 @@ Perl_re_intuit_start(pTHX_ if (s <= rx_origin || ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Did not find /%s^%s/m...\n", PL_colors[0], PL_colors[1])); goto fail_finish; @@ -1188,7 +1340,7 @@ Perl_re_intuit_start(pTHX_ /* Position contradicts check-string; either because * check was anchored (and thus has no wiggle room), * or check was float and rx_origin is above the float range */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg))); goto restart; @@ -1204,8 +1356,8 @@ Perl_re_intuit_start(pTHX_ * contradict. On the other hand, the float "check" substr * didn't contradict, so just retry the anchored "other" * substr */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " Found /%s^%s/m, rescanning for anchored from offset %"IVdf" (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " Found /%s^%s/m, rescanning for anchored from offset %" IVdf " (rx_origin now %" IVdf ")...\n", PL_colors[0], PL_colors[1], (IV)(rx_origin - strbeg + prog->anchored_offset), (IV)(rx_origin - strbeg) @@ -1215,12 +1367,12 @@ Perl_re_intuit_start(pTHX_ /* success: we don't contradict the found floating substring * (and there's no anchored substr). */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Found /%s^%s/m with rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg))); } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " (multiline anchor test skipped)\n")); } @@ -1270,17 +1422,17 @@ Perl_re_intuit_start(pTHX_ */ if (prog->anchored_substr || prog->anchored_utf8 || ml_anch) - endpos= HOP3c(rx_origin, (prog->minlen ? cl_l : 0), strend); + endpos = HOP3clim(rx_origin, (prog->minlen ? cl_l : 0), strend); else if (prog->float_substr || prog->float_utf8) { rx_max_float = HOP3c(check_at, -start_shift, strbeg); - endpos= HOP3c(rx_max_float, cl_l, strend); + endpos = HOP3clim(rx_max_float, cl_l, strend); } else endpos= strend; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - " looking for class: start_shift: %"IVdf" check_at: %"IVdf - " rx_origin: %"IVdf" endpos: %"IVdf"\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + " looking for class: start_shift: %" IVdf " check_at: %" IVdf + " rx_origin: %" IVdf " endpos: %" IVdf "\n", (IV)start_shift, (IV)(check_at - strbeg), (IV)(rx_origin - strbeg), (IV)(endpos - strbeg))); @@ -1288,11 +1440,11 @@ Perl_re_intuit_start(pTHX_ reginfo); if (!s) { if (endpos == strend) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ " Could not match STCLASS...\n") ); goto fail; } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ " This position contradicts STCLASS...\n") ); if ((prog->intflags & PREGf_ANCH) && !ml_anch && !(prog->intflags & PREGf_IMPLICIT)) @@ -1313,8 +1465,8 @@ Perl_re_intuit_start(pTHX_ * an extra anchored search may get done, but in * practice the extra fbm_instr() is likely to * get skipped anyway. */ - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " about to retry anchored at offset %ld (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ + " about to retry anchored at offset %ld (rx_origin now %" IVdf ")...\n", (long)(other_last - strbeg), (IV)(rx_origin - strbeg) )); @@ -1334,7 +1486,7 @@ Perl_re_intuit_start(pTHX_ * but since we goto a block of code that's going to * search for the next \n if any, its safe here */ rx_origin++; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ " about to look for /%s^%s/m starting at rx_origin %ld...\n", PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)) ); @@ -1358,12 +1510,12 @@ Perl_re_intuit_start(pTHX_ * It's conservative: it errs on the side of doing 'goto restart', * where there is code that does a proper char-based test */ if (rx_origin + start_shift + end_shift > strend) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ " Could not match STCLASS...\n") ); goto fail; } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - " about to look for %s substr starting at offset %ld (rx_origin now %"IVdf")...\n", + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ + " about to look for %s substr starting at offset %ld (rx_origin now %" IVdf ")...\n", (prog->substrs->check_ix ? "floating" : "anchored"), (long)(rx_origin + start_shift - strbeg), (IV)(rx_origin - strbeg) @@ -1374,13 +1526,13 @@ Perl_re_intuit_start(pTHX_ /* Success !!! */ if (rx_origin != s) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " By STCLASS: moving %ld --> %ld\n", (long)(rx_origin - strbeg), (long)(s - strbeg)) ); } else { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " Does not contradict STCLASS...\n"); ); } @@ -1392,7 +1544,7 @@ Perl_re_intuit_start(pTHX_ /* Fixed substring is found far enough so that the match cannot start at strpos. */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " try at offset...\n")); + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " try at offset...\n")); ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */ } else { @@ -1412,7 +1564,7 @@ Perl_re_intuit_start(pTHX_ ))) { /* If flags & SOMETHING - do not do it many times on the same match */ - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " ... Disabling check substring...\n")); + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ " ... Disabling check substring...\n")); /* XXX Does the destruction order has to change with utf8_target? */ SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr); SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8); @@ -1426,7 +1578,7 @@ Perl_re_intuit_start(pTHX_ } } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Intuit: %sSuccessfully guessed:%s match at offset %ld\n", PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) ); @@ -1436,7 +1588,7 @@ Perl_re_intuit_start(pTHX_ if (prog->check_substr || prog->check_utf8) /* could be removed already */ BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */ fail: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch rejected by optimizer%s\n", PL_colors[4], PL_colors[5])); return NULL; } @@ -1482,8 +1634,9 @@ STMT_START { uscan += len; \ len=0; \ } else { \ - uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags); \ len = UTF8SKIP(uc); \ + uvc = _toFOLD_utf8_flags( (const U8*) uc, uc + len, foldbuf, &foldlen, \ + flags); \ skiplen = UVCHR_SKIP( uvc ); \ foldlen -= skiplen; \ uscan = foldbuf + skiplen; \ @@ -1533,9 +1686,9 @@ STMT_START { } \ } STMT_END -#define DUMP_EXEC_POS(li,s,doutf8) \ +#define DUMP_EXEC_POS(li,s,doutf8,depth) \ dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \ - startpos, doutf8) + startpos, doutf8, depth) #define REXEC_FBC_EXACTISH_SCAN(COND) \ STMT_START { \ @@ -1660,7 +1813,7 @@ REXEC_FBC_SCAN( /* Loops while (s < strend) */ \ tmp = TEST_UV(tmp); \ LOAD_UTF8_CHARCLASS_ALNUM(); \ REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */ \ - if (tmp == ! (TEST_UTF8((U8 *) s))) { \ + if (tmp == ! (TEST_UTF8((U8 *) s, (U8 *) reginfo->strend))) { \ tmp = !tmp; \ IF_SUCCESS; \ } \ @@ -1736,12 +1889,26 @@ REXEC_FBC_SCAN( /* Loops while (s < strend) */ \ FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), \ TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT) +#ifdef DEBUGGING +static IV +S_get_break_val_cp_checked(SV* const invlist, const UV cp_in) { + IV cp_out = Perl__invlist_search(invlist, cp_in); + assert(cp_out >= 0); + return cp_out; +} +# define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \ + invmap[S_get_break_val_cp_checked(invlist, cp)] +#else +# define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \ + invmap[_invlist_search(invlist, cp)] +#endif + /* Takes a pointer to an inversion list, a pointer to its corresponding * inversion map, and a code point, and returns the code point's value * according to the two arrays. It assumes that all code points have a value. * This is used as the base macro for macros for particular properties */ #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp) \ - invmap[_invlist_search(invlist, cp)] + _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead * of a code point, returning the value for the first code point in the string. @@ -1849,8 +2016,11 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, REXEC_FBC_UTF8_CLASS_SCAN( reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target)); } + else if (ANYOF_FLAGS(c)) { + REXEC_FBC_CLASS_SCAN(reginclass(prog,c, (U8*)s, (U8*)s+1, 0)); + } else { - REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s)); + REXEC_FBC_CLASS_SCAN(ANYOF_BITMAP_TEST(c, *((U8*)s))); } break; @@ -1934,10 +2104,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, * trying that it will fail; so don't start a match past the * required minimum number from the far end */ e = HOP3c(strend, -((SSize_t)ln), s); - - if (reginfo->intuit && e < s) { - e = s; /* Due to minlen logic of intuit() */ - } + if (e < s) + break; c1 = *pat_string; c2 = fold_array[c1]; @@ -1981,10 +2149,6 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, */ e = HOP3c(strend, -((SSize_t)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. @@ -2015,7 +2179,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, goto do_boundu; } - FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); + FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8_safe); break; case NBOUNDL: @@ -2028,14 +2192,14 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, goto do_nboundu; } - FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8); + FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8_safe); break; case BOUND: /* regcomp.c makes sure that this only has the traditional \b meaning */ assert(FLAGS(c) == TRADITIONAL_BOUND); - FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); + FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8_safe); break; case BOUNDA: /* regcomp.c makes sure that this only has the traditional \b @@ -2049,7 +2213,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, meaning */ assert(FLAGS(c) == TRADITIONAL_BOUND); - FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8); + FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8_safe); break; case NBOUNDA: /* regcomp.c makes sure that this only has the traditional \b @@ -2061,7 +2225,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, case NBOUNDU: if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) { - FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); + FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8_safe); break; } @@ -2074,7 +2238,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, do_boundu: switch((bound_type) FLAGS(c)) { case TRADITIONAL_BOUND: - FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8); + FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8_safe); break; case GCB_BOUND: if (s == reginfo->strbeg) { @@ -2098,7 +2262,11 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, while (s < strend) { GCB_enum after = getGCB_VAL_UTF8((U8*) s, (U8*) reginfo->strend); - if ( (to_complement ^ isGCB(before, after)) + if ( (to_complement ^ isGCB(before, + after, + (U8*) reginfo->strbeg, + (U8*) s, + utf8_target)) && (reginfo->intuit || regtry(reginfo, &s))) { goto got_it; @@ -2321,6 +2489,22 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, ); break; + case ASCII: + s = find_next_ascii(s, strend, utf8_target); + if (s < strend && (reginfo->intuit || regtry(reginfo, &s))) { + goto got_it; + } + + break; + + case NASCII: + s = find_next_non_ascii(s, strend, utf8_target); + if (s < strend && (reginfo->intuit || regtry(reginfo, &s))) { + goto got_it; + } + + break; + /* 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[] */ @@ -2348,18 +2532,25 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, if (utf8_target) { /* The complement of something that matches only ASCII matches all * non-ASCII, plus everything in ASCII that isn't in the class. */ - REXEC_FBC_UTF8_CLASS_SCAN(! isASCII_utf8(s) + REXEC_FBC_UTF8_CLASS_SCAN( ! isASCII_utf8_safe(s, strend) || ! _generic_isCC_A(*s, FLAGS(c))); break; } to_complement = 1; - /* FALLTHROUGH */ + goto posixa; case POSIXA: - posixa: /* Don't need to worry about utf8, as it can match only a single - * byte invariant character. */ + * byte invariant character. But we do anyway for performance reasons, + * as otherwise we would have to examine all the continuation + * characters */ + if (utf8_target) { + REXEC_FBC_UTF8_CLASS_SCAN(_generic_isCC_A(*s, FLAGS(c))); + break; + } + + posixa: REXEC_FBC_CLASS_SCAN( to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c)))); break; @@ -2390,7 +2581,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, if ((UTF8_IS_INVARIANT(*s) && to_complement ^ cBOOL(_generic_isCC((U8) *s, classnum))) - || (UTF8_IS_DOWNGRADEABLE_START(*s) + || ( UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(s, strend) && to_complement ^ cBOOL( _generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s + 1)), @@ -2412,27 +2603,27 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, macros */ case _CC_ENUM_SPACE: REXEC_FBC_UTF8_CLASS_SCAN( - to_complement ^ cBOOL(isSPACE_utf8(s))); + to_complement ^ cBOOL(isSPACE_utf8_safe(s, strend))); break; case _CC_ENUM_BLANK: REXEC_FBC_UTF8_CLASS_SCAN( - to_complement ^ cBOOL(isBLANK_utf8(s))); + to_complement ^ cBOOL(isBLANK_utf8_safe(s, strend))); break; case _CC_ENUM_XDIGIT: REXEC_FBC_UTF8_CLASS_SCAN( - to_complement ^ cBOOL(isXDIGIT_utf8(s))); + to_complement ^ cBOOL(isXDIGIT_utf8_safe(s, strend))); break; case _CC_ENUM_VERTSPACE: REXEC_FBC_UTF8_CLASS_SCAN( - to_complement ^ cBOOL(isVERTWS_utf8(s))); + to_complement ^ cBOOL(isVERTWS_utf8_safe(s, strend))); break; case _CC_ENUM_CNTRL: REXEC_FBC_UTF8_CLASS_SCAN( - to_complement ^ cBOOL(isCNTRL_utf8(s))); + to_complement ^ cBOOL(isCNTRL_utf8_safe(s, strend))); break; default: @@ -2457,9 +2648,10 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, * 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( + to_complement ^ cBOOL(_generic_utf8_safe( classnum, s, + strend, swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *) s, TRUE)))); break; @@ -2549,8 +2741,8 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 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, + (char *)uc, utf8_target, 0 ); + Perl_re_printf( aTHX_ " Scanning for legal start char...\n"); } ); @@ -2585,9 +2777,9 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 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" ", + real_start, s, utf8_target, 0); + Perl_re_printf( aTHX_ + " Charid:%3u CP:%4" UVxf " ", charid, uvc); }); } @@ -2606,9 +2798,9 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 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, + s, utf8_target, 0 ); + Perl_re_printf( aTHX_ + "%sState: %4" UVxf ", word=%" UVxf, failed ? " Fail transition to " : "", (UV)state, (UV)word); }); @@ -2623,13 +2815,13 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, && (tmp=trie->trans[offset].next)) { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - legal\n")); + Perl_re_printf( aTHX_ " - legal\n")); state = tmp; break; } else { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - fail\n")); + Perl_re_printf( aTHX_ " - fail\n")); failed = 1; state = aho->fail[state]; } @@ -2637,7 +2829,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, else { /* we must be accepting here */ DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log," - accepting\n")); + Perl_re_printf( aTHX_ " - accepting\n")); failed = 1; break; } @@ -2659,8 +2851,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, if (leftmost) { s = (char*)leftmost; DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( - Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n", + Perl_re_printf( aTHX_ "Matches word #%" UVxf " at position %" IVdf ". Trying full pattern...\n", (UV)accepted_word, (IV)(s - real_start) ); }); @@ -2671,11 +2862,11 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, } s = HOPc(s,1); DEBUG_TRIE_EXECUTE_r({ - PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n"); + Perl_re_printf( aTHX_ "Pattern failed. Looking for new start point...\n"); }); } else { DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log,"No match.\n")); + Perl_re_printf( aTHX_ "No match.\n")); break; } } @@ -2707,11 +2898,9 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, if (flags & REXEC_COPY_STR) { #ifdef PERL_ANY_COW if (SvCANCOW(sv)) { - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, + DEBUG_C(Perl_re_printf( aTHX_ "Copy on write: regexp capture, type %d\n", - (int) SvTYPE(sv)); - } + (int) SvTYPE(sv))); /* Create a new COW SV to share the match string and store * in saved_copy, unless the current COW SV in saved_copy * is valid and suitable for our purpose */ @@ -2730,7 +2919,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, } else { /* create new COW SV to share string */ - RX_MATCH_COPY_FREE(rx); + RXp_MATCH_COPY_FREE(prog); prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv); } prog->subbeg = (char *)SvPVX_const(prog->saved_copy); @@ -2793,7 +2982,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, assert(min >= 0 && min <= max && min <= strend - strbeg); sublen = max - min; - if (RX_MATCH_COPIED(rx)) { + if (RXp_MATCH_COPIED(prog)) { if (sublen > prog->sublen) prog->subbeg = (char*)saferealloc(prog->subbeg, sublen+1); @@ -2804,7 +2993,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, prog->subbeg[sublen] = '\0'; prog->suboffset = min; prog->sublen = sublen; - RX_MATCH_COPIED_on(rx); + RXp_MATCH_COPIED_on(prog); } prog->subcoffset = prog->suboffset; if (prog->suboffset && utf8_target) { @@ -2831,7 +3020,7 @@ S_reg_set_capture_string(pTHX_ REGEXP * const rx, } } else { - RX_MATCH_COPY_FREE(rx); + RXp_MATCH_COPY_FREE(prog); prog->subbeg = strbeg; prog->suboffset = 0; prog->subcoffset = 0; @@ -2907,8 +3096,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg) : strbeg; /* pos() not defined; use start of string */ - DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log, - "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg))); + DEBUG_GPOS_r(Perl_re_printf( aTHX_ + "GPOS ganch set to strbeg[%" IVdf "]\n", (IV)(reginfo->ganch - strbeg))); /* in the presence of \G, we may need to start looking earlier in * the string than the suggested start point of stringarg: @@ -2926,7 +3115,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (!startpos || ((flags & REXEC_FAIL_ON_UNDERFLOW) && startpos < stringarg)) { - DEBUG_r(PerlIO_printf(Perl_debug_log, + DEBUG_r(Perl_re_printf( aTHX_ "fail: ganch-gofs before earliest possible start\n")); return 0; } @@ -2945,7 +3134,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, minlen = prog->minlen; if ((startpos + minlen) > strend || startpos < strbeg) { - DEBUG_r(PerlIO_printf(Perl_debug_log, + DEBUG_r(Perl_re_printf( aTHX_ "Regex match can't succeed, so not even tried\n")); return 0; } @@ -2980,7 +3169,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, { /* this should only be possible under \G */ assert(prog->intflags & PREGf_GPOS_SEEN); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); goto phooey; } @@ -2988,7 +3177,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* match via INTUIT shouldn't have any captures. * Let @-, @+, $^N know */ prog->lastparen = prog->lastcloseparen = 0; - RX_MATCH_UTF8_set(rx, utf8_target); + RXp_MATCH_UTF8_set(prog, utf8_target); prog->offs[0].start = s - strbeg; prog->offs[0].end = utf8_target ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg @@ -3005,7 +3194,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, multiline = prog->extflags & RXf_PMf_MULTILINE; if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "String too short [regexec_flags]...\n")); goto phooey; } @@ -3015,8 +3204,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, Perl_croak(aTHX_ "corrupted regexp program"); } - RX_MATCH_TAINTED_off(rx); - RX_MATCH_UTF8_set(rx, utf8_target); + RXp_MATCH_TAINTED_off(prog); + RXp_MATCH_UTF8_set(prog, utf8_target); reginfo->prog = rx; /* Yes, sorry that this is confusing. */ reginfo->intuit = 0; @@ -3102,14 +3291,18 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, swap = prog->offs; /* do we need a save destructor here for eval dies? */ Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair); - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" saving offs: orig=0x%"UVxf" new=0x%"UVxf"\n", - PTR2UV(prog), + DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " saving offs: orig=0x%" UVxf " new=0x%" UVxf "\n", + 0, + PTR2UV(prog), PTR2UV(swap), PTR2UV(prog->offs) )); } + if (prog->recurse_locinput) + Zero(prog->recurse_locinput,prog->nparens + 1, char *); + /* Simplest case: anchored match need be tried only once, or with * MBOL, only at the beginning of each line. * @@ -3210,7 +3403,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, ); } DEBUG_EXECUTE_r(if (!did_match) - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "Did not find anchored character...\n") ); } @@ -3315,7 +3508,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, DEBUG_EXECUTE_r(if (!did_match) { RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0), SvPVX_const(must), RE_SV_DUMPLEN(must), 30); - PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n", + Perl_re_printf( aTHX_ "Did not find %s substr %s%s...\n", ((must == prog->anchored_substr || must == prog->anchored_utf8) ? "anchored" : "floating"), quoted, RE_SV_TAIL(must)); @@ -3334,8 +3527,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, regprop(prog, prop, c, reginfo, NULL); { RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1), - s,strend-s,60); - PerlIO_printf(Perl_debug_log, + s,strend-s,PL_dump_re_max_len); + Perl_re_printf( aTHX_ "Matching stclass %.*s against %s (%d bytes)\n", (int)SvCUR(prop), SvPVX_const(prop), quoted, (int)(strend - s)); @@ -3343,7 +3536,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, }); if (find_byclass(prog, c, s, strend, reginfo)) goto got_it; - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n")); + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "Contradicts stclass... [regexec_flags]\n")); } else { dontbother = 0; @@ -3382,14 +3575,14 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * the \n. */ char *checkpos= strend - len; DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%sChecking for float_real.%s\n", PL_colors[4], PL_colors[5])); if (checkpos + 1 < strbeg) { /* can't match, even if we remove the trailing \n * string is too short to match */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%sString shorter than required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3401,7 +3594,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, /* cant match, string is too short when the "\n" is * included */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%sString does not contain required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3412,7 +3605,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, last= checkpos; } else { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%sString does not contain required trailing substring, cannot match.%s\n", PL_colors[4], PL_colors[5])); goto phooey; @@ -3436,7 +3629,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, * pretty sure it is not anymore, so I have removed the comment * and replaced it with this one. Yves */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%sString does not contain required substring, cannot match.%s\n", PL_colors[4], PL_colors[5] )); @@ -3476,16 +3669,17 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, { /* this should only be possible under \G */ assert(prog->intflags & PREGf_GPOS_SEEN); - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n")); goto phooey; } DEBUG_BUFFERS_r( if (swap) - PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n", - PTR2UV(prog), + Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " freeing offs: 0x%" UVxf "\n", + 0, + PTR2UV(prog), PTR2UV(swap) ); ); @@ -3509,7 +3703,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, return 1; phooey: - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch failed%s\n", PL_colors[4], PL_colors[5])); /* clean up; this will trigger destructors that will free all slabs @@ -3520,9 +3714,10 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, if (swap) { /* we failed :-( roll it back */ - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, - "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n", - PTR2UV(prog), + DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " rolling back offs: freeing=0x%" UVxf " restoring=0x%" UVxf "\n", + 0, + PTR2UV(prog), PTR2UV(prog->offs), PTR2UV(swap) )); @@ -3553,6 +3748,9 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) REGEXP *const rx = reginfo->prog; regexp *const prog = ReANY(rx); SSize_t result; +#ifdef DEBUGGING + U32 depth = 0; /* used by REGCP_SET */ +#endif RXi_GET_DECL(prog,progi); GET_RE_DEBUG_FLAGS_DECL; @@ -3577,6 +3775,14 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) * above-mentioned test suite tests to succeed. The common theme * on those tests seems to be returning null fields from matches. * --jhi updated by dapm */ + + /* After encountering a variant of the issue mentioned above I think + * the point Ilya was making is that if we properly unwind whenever + * we set lastparen to a smaller value then we should not need to do + * this every time, only when needed. So if we have tests that fail if + * we remove this, then it suggests somewhere else we are improperly + * unwinding the lastparen/paren buffers. See UNWIND_PARENS() and + * places it is called, and related regcp() routines. - Yves */ #if 1 if (prog->nparens) { regexp_paren_pair *pp = prog->offs; @@ -3613,10 +3819,26 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) sayNO /* this is used to determine how far from the left messages like - 'failed...' are printed. It should be set such that messages - are inline with the regop output that created them. + 'failed...' are printed in regexec.c. It should be set such that + messages are inline with the regop output that created them. */ -#define REPORT_CODE_OFF 32 +#define REPORT_CODE_OFF 29 +#define INDENT_CHARS(depth) ((int)(depth) % 20) +#ifdef DEBUGGING +int +Perl_re_exec_indentf(pTHX_ const char *fmt, U32 depth, ...) +{ + va_list ap; + int result; + PerlIO *f= Perl_debug_log; + PERL_ARGS_ASSERT_RE_EXEC_INDENTF; + va_start(ap, depth); + PerlIO_printf(f, "%*s|%4" UVuf "| %*s", REPORT_CODE_OFF, "", (UV)depth, INDENT_CHARS(depth), "" ); + result = PerlIO_vprintf(f, fmt, ap); + va_end(ap); + return result; +} +#endif /* DEBUGGING */ #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */ @@ -3629,9 +3851,6 @@ S_regtry(pTHX_ regmatch_info *reginfo, char **startposp) STATIC regmatch_state * S_push_slab(pTHX) { -#if PERL_VERSION < 9 && !defined(PERL_CORE) - dMY_CXT; -#endif regmatch_slab *s = PL_regmatch_slab->next; if (!s) { Newx(s, 1, regmatch_slab); @@ -3797,18 +4016,18 @@ regmatch(), slabs allocated since entry are freed. */ -#define DEBUG_STATE_pp(pp) \ - DEBUG_STATE_r({ \ - DUMP_EXEC_POS(locinput, scan, utf8_target); \ - PerlIO_printf(Perl_debug_log, \ - " %*s"pp" %s%s%s%s%s\n", \ - depth*2, "", \ - PL_reg_name[st->resume_state], \ - ((st==yes_state||st==mark_state) ? "[" : ""), \ - ((st==yes_state) ? "Y" : ""), \ - ((st==mark_state) ? "M" : ""), \ - ((st==yes_state||st==mark_state) ? "]" : "") \ - ); \ +#define DEBUG_STATE_pp(pp) \ + DEBUG_STATE_r({ \ + DUMP_EXEC_POS(locinput, scan, utf8_target,depth); \ + Perl_re_printf( aTHX_ \ + "%*s" pp " %s%s%s%s%s\n", \ + INDENT_CHARS(depth), "", \ + PL_reg_name[st->resume_state], \ + ((st==yes_state||st==mark_state) ? "[" : ""), \ + ((st==yes_state) ? "Y" : ""), \ + ((st==mark_state) ? "M" : ""), \ + ((st==yes_state||st==mark_state) ? "]" : "") \ + ); \ }); @@ -3828,17 +4047,17 @@ S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target, reginitcolors(); { RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), - RX_PRECOMP_const(prog), RX_PRELEN(prog), 60); + RX_PRECOMP_const(prog), RX_PRELEN(prog), PL_dump_re_max_len); RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1), - start, end - start, 60); + start, end - start, PL_dump_re_max_len); - PerlIO_printf(Perl_debug_log, + Perl_re_printf( aTHX_ "%s%s REx%s %s against %s\n", PL_colors[4], blurb, PL_colors[5], s0, s1); if (utf8_target||utf8_pat) - PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n", + Perl_re_printf( aTHX_ "UTF-8 %s%s%s...\n", utf8_pat ? "pattern" : "", utf8_pat && utf8_target ? " and " : "", utf8_target ? "string" : "" @@ -3852,7 +4071,9 @@ S_dump_exec_pos(pTHX_ const char *locinput, const char *loc_regeol, const char *loc_bostr, const char *loc_reg_starttry, - const bool utf8_target) + const bool utf8_target, + const U32 depth + ) { const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4]; const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */ @@ -3885,25 +4106,26 @@ S_dump_exec_pos(pTHX_ const char *locinput, const int is_uni = utf8_target ? 1 : 0; RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0), - (locinput - pref_len),pref0_len, 60, 4, 5); + (locinput - pref_len),pref0_len, PL_dump_re_max_len, 4, 5); RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1), (locinput - pref_len + pref0_len), - pref_len - pref0_len, 60, 2, 3); + pref_len - pref0_len, PL_dump_re_max_len, 2, 3); RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2), locinput, loc_regeol - locinput, 10, 0, 1); const STRLEN tlen=len0+len1+len2; - PerlIO_printf(Perl_debug_log, - "%4"IVdf" <%.*s%.*s%s%.*s>%*s|", + Perl_re_printf( aTHX_ + "%4" IVdf " <%.*s%.*s%s%.*s>%*s|%4u| ", (IV)(locinput - loc_bostr), len0, s0, len1, s1, (docolor ? "" : "> <"), len2, s2, (int)(tlen > 19 ? 0 : 19 - tlen), - ""); + "", + depth); } } @@ -4063,10 +4285,11 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } else { STRLEN len; - _to_utf8_fold_flags(s, - d, - &len, - FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE); + _toFOLD_utf8_flags(s, + pat_end, + d, + &len, + FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE); d += len; s += UTF8SKIP(s); } @@ -4111,7 +4334,7 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, } else { /* Does participate in folds */ AV* list = (AV*) *listp; - if (av_tindex(list) != 1) { + if (av_tindex_skip_len_mg(list) != 1) { /* If there aren't exactly two folds to this, it is * outside the scope of this function */ @@ -4247,13 +4470,108 @@ S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, return TRUE; } -PERL_STATIC_INLINE bool -S_isGCB(const GCB_enum before, const GCB_enum after) +STATIC bool +S_isGCB(pTHX_ const GCB_enum before, const GCB_enum after, const U8 * const strbeg, const U8 * const curpos, const bool utf8_target) { /* returns a boolean indicating if there is a Grapheme Cluster Boundary - * between the inputs. See http://www.unicode.org/reports/tr29/ */ + * between the inputs. See http://www.unicode.org/reports/tr29/. */ + + PERL_ARGS_ASSERT_ISGCB; + + switch (GCB_table[before][after]) { + case GCB_BREAKABLE: + return TRUE; + + case GCB_NOBREAK: + return FALSE; + + case GCB_RI_then_RI: + { + int RI_count = 1; + U8 * temp_pos = (U8 *) curpos; + + /* Do not break within emoji flag sequences. That is, do not + * break between regional indicator (RI) symbols if there is an + * odd number of RI characters before the break point. + * GB12 sot (RI RI)* RI × RI + * GB13 [^RI] (RI RI)* RI × RI */ + + while (backup_one_GCB(strbeg, + &temp_pos, + utf8_target) == GCB_Regional_Indicator) + { + RI_count++; + } + + return RI_count % 2 != 1; + } + + case GCB_EX_then_EM: + + /* GB10 ( E_Base | E_Base_GAZ ) Extend* × E_Modifier */ + { + U8 * temp_pos = (U8 *) curpos; + GCB_enum prev; + + do { + prev = backup_one_GCB(strbeg, &temp_pos, utf8_target); + } + while (prev == GCB_Extend); + + return prev != GCB_E_Base && prev != GCB_E_Base_GAZ; + } + + default: + break; + } + +#ifdef DEBUGGING + Perl_re_printf( aTHX_ "Unhandled GCB pair: GCB_table[%d, %d] = %d\n", + before, after, GCB_table[before][after]); + assert(0); +#endif + return TRUE; +} + +STATIC GCB_enum +S_backup_one_GCB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_target) +{ + GCB_enum gcb; + + PERL_ARGS_ASSERT_BACKUP_ONE_GCB; + + if (*curpos < strbeg) { + return GCB_EDGE; + } + + if (utf8_target) { + U8 * prev_char_pos = reghopmaybe3(*curpos, -1, strbeg); + U8 * prev_prev_char_pos; + + if (! prev_char_pos) { + return GCB_EDGE; + } + + if ((prev_prev_char_pos = reghopmaybe3((U8 *) prev_char_pos, -1, strbeg))) { + gcb = getGCB_VAL_UTF8(prev_prev_char_pos, prev_char_pos); + *curpos = prev_char_pos; + prev_char_pos = prev_prev_char_pos; + } + else { + *curpos = (U8 *) strbeg; + return GCB_EDGE; + } + } + else { + if (*curpos - 2 < strbeg) { + *curpos = (U8 *) strbeg; + return GCB_EDGE; + } + (*curpos)--; + gcb = getGCB_VAL_CP(*(*curpos - 1)); + } - return GCB_table[before][after]; + return gcb; } /* Combining marks attach to most classes that precede them, but this defines @@ -4284,7 +4602,7 @@ S_isLB(pTHX_ LB_enum before, PERL_ARGS_ASSERT_ISLB; - /* Rule numbers in the comments below are as of Unicode 8.0 */ + /* Rule numbers in the comments below are as of Unicode 9.0 */ redo: before = prev; @@ -4378,14 +4696,14 @@ S_isLB(pTHX_ LB_enum before, * that is overriden */ return LB_table[prev][after] != LB_NOBREAK_EVEN_WITH_SP_BETWEEN; - case LB_CM_foo: + case LB_CM_ZWJ_foo: /* We don't know how to treat the CM except by looking at the first - * non-CM character preceding it */ + * non-CM character preceding it. ZWJ is treated as CM */ do { prev = backup_one_LB(strbeg, &temp_pos, utf8_target); } - while (prev == LB_Combining_Mark); + while (prev == LB_Combining_Mark || prev == LB_ZWJ); /* Here, 'prev' is that first earlier non-CM character. If the CM * attatches to it, then it inherits the behavior of 'prev'. If it @@ -4458,12 +4776,34 @@ S_isLB(pTHX_ LB_enum before, return LB_various_then_PO_or_PR; } + case LB_RI_then_RI + LB_NOBREAK: + case LB_RI_then_RI + LB_BREAKABLE: + { + int RI_count = 1; + + /* LB30a Break between two regional indicator symbols if and + * only if there are an even number of regional indicators + * preceding the position of the break. + * + * sot (RI RI)* RI × RI + * [^RI] (RI RI)* RI × RI */ + + while (backup_one_LB(strbeg, + &temp_pos, + utf8_target) == LB_Regional_Indicator) + { + RI_count++; + } + + return RI_count % 2 == 0; + } + default: break; } #ifdef DEBUGGING - PerlIO_printf(Perl_error_log, "Unhandled LB pair: LB_table[%d, %d] = %d\n", + Perl_re_printf( aTHX_ "Unhandled LB pair: LB_table[%d, %d] = %d\n", before, after, LB_table[before][after]); assert(0); #endif @@ -4540,11 +4880,6 @@ S_backup_one_LB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_tar return lb; } -/* This creates a single number by combining two, with 'before' being like the - * 10's digit, but this isn't necessarily base 10; it is base however many - * elements of the enum there are */ -#define SBcase(before, after) ((SB_ENUM_COUNT * before) + after) - STATIC bool S_isSB(pTHX_ SB_enum before, SB_enum after, @@ -4557,16 +4892,17 @@ S_isSB(pTHX_ SB_enum before, * between the inputs. See http://www.unicode.org/reports/tr29/ */ U8 * lpos = (U8 *) curpos; - U8 * temp_pos; - SB_enum backup; + bool has_para_sep = FALSE; + bool has_sp = FALSE; PERL_ARGS_ASSERT_ISSB; /* Break at the start and end of text. SB1. sot ÷ - SB2. ÷ eot */ + SB2. ÷ eot + But unstated in Unicode is don't break if the text is empty */ if (before == SB_EDGE || after == SB_EDGE) { - return TRUE; + return before != after; } /* SB 3: Do not break within CRLF. */ @@ -4574,8 +4910,10 @@ S_isSB(pTHX_ SB_enum before, return FALSE; } - /* Break after paragraph separators. (though why CR and LF are considered - * so is beyond me (khw) + /* Break after paragraph separators. CR and LF are considered + * so because Unicode views text as like word processing text where there + * are no newlines except between paragraphs, and the word processor takes + * care of wrapping without there being hard line-breaks in the text *./ SB4. Sep | CR | LF ÷ */ if (before == SB_Sep || before == SB_CR || before == SB_LF) { return TRUE; @@ -4585,11 +4923,31 @@ S_isSB(pTHX_ SB_enum before, * (See Section 6.2, Replacing Ignore Rules.) SB5. X (Extend | Format)* → X */ if (after == SB_Extend || after == SB_Format) { + + /* Implied is that the these characters attach to everything + * immediately prior to them except for those separator-type + * characters. And the rules earlier have already handled the case + * when one of those immediately precedes the extend char */ return FALSE; } if (before == SB_Extend || before == SB_Format) { - before = backup_one_SB(strbeg, &lpos, utf8_target); + U8 * temp_pos = lpos; + const SB_enum backup = backup_one_SB(strbeg, &temp_pos, utf8_target); + if ( backup != SB_EDGE + && backup != SB_Sep + && backup != SB_CR + && backup != SB_LF) + { + before = backup; + lpos = temp_pos; + } + + /* Here, both 'before' and 'backup' are these types; implied is that we + * don't break between them */ + if (backup == SB_Extend || backup == SB_Format) { + return FALSE; + } } /* Do not break after ambiguous terminators like period, if they are @@ -4607,97 +4965,107 @@ S_isSB(pTHX_ SB_enum before, /* SB7. (Upper | Lower) ATerm × Upper */ if (before == SB_ATerm && after == SB_Upper) { - temp_pos = lpos; - backup = backup_one_SB(strbeg, &temp_pos, utf8_target); + U8 * temp_pos = lpos; + SB_enum backup = backup_one_SB(strbeg, &temp_pos, utf8_target); if (backup == SB_Upper || backup == SB_Lower) { return FALSE; } } - /* SB8a. (STerm | ATerm) Close* Sp* × (SContinue | STerm | ATerm) - * SB10. (STerm | ATerm) Close* Sp* × ( Sp | Sep | CR | LF ) */ - backup = before; - temp_pos = lpos; - while (backup == SB_Sp) { - backup = backup_one_SB(strbeg, &temp_pos, utf8_target); - } - while (backup == SB_Close) { - backup = backup_one_SB(strbeg, &temp_pos, utf8_target); - } - if ((backup == SB_STerm || backup == SB_ATerm) - && ( after == SB_SContinue - || after == SB_STerm - || after == SB_ATerm - || after == SB_Sp - || after == SB_Sep - || after == SB_CR - || after == SB_LF)) - { - return FALSE; + /* The remaining rules that aren't the final one, all require an STerm or + * an ATerm after having backed up over some Close* Sp*, and in one case an + * optional Paragraph separator, although one rule doesn't have any Sp's in it. + * So do that backup now, setting flags if either Sp or a paragraph + * separator are found */ + + if (before == SB_Sep || before == SB_CR || before == SB_LF) { + has_para_sep = TRUE; + before = backup_one_SB(strbeg, &lpos, utf8_target); } - /* SB8. ATerm Close* Sp* × ( ¬(OLetter | Upper | Lower | Sep | CR | LF | - * STerm | ATerm) )* Lower */ - if (backup == SB_ATerm) { - U8 * rpos = (U8 *) curpos; - SB_enum later = after; - - while ( later != SB_OLetter - && later != SB_Upper - && later != SB_Lower - && later != SB_Sep - && later != SB_CR - && later != SB_LF - && later != SB_STerm - && later != SB_ATerm - && later != SB_EDGE) - { - later = advance_one_SB(&rpos, strend, utf8_target); - } - if (later == SB_Lower) { - return FALSE; + if (before == SB_Sp) { + has_sp = TRUE; + do { + before = backup_one_SB(strbeg, &lpos, utf8_target); } + while (before == SB_Sp); } - /* Break after sentence terminators, but include closing punctuation, - * trailing spaces, and a paragraph separator (if present). [See note - * below.] - * SB9. ( STerm | ATerm ) Close* × ( Close | Sp | Sep | CR | LF ) */ - backup = before; - temp_pos = lpos; - while (backup == SB_Close) { - backup = backup_one_SB(strbeg, &temp_pos, utf8_target); - } - if ((backup == SB_STerm || backup == SB_ATerm) - && ( after == SB_Close - || after == SB_Sp - || after == SB_Sep - || after == SB_CR - || after == SB_LF)) - { - return FALSE; + while (before == SB_Close) { + before = backup_one_SB(strbeg, &lpos, utf8_target); } + /* The next few rules apply only when the backed-up-to is an ATerm, and in + * most cases an STerm */ + if (before == SB_STerm || before == SB_ATerm) { - /* SB11. ( STerm | ATerm ) Close* Sp* ( Sep | CR | LF )? ÷ */ - temp_pos = lpos; - backup = backup_one_SB(strbeg, &temp_pos, utf8_target); - if ( backup == SB_Sep - || backup == SB_CR - || backup == SB_LF) - { - lpos = temp_pos; - } - else { - backup = before; - } - while (backup == SB_Sp) { - backup = backup_one_SB(strbeg, &lpos, utf8_target); - } - while (backup == SB_Close) { - backup = backup_one_SB(strbeg, &lpos, utf8_target); - } - if (backup == SB_STerm || backup == SB_ATerm) { + /* So, here the lhs matches + * (STerm | ATerm) Close* Sp* (Sep | CR | LF)? + * and we have set flags if we found an Sp, or the optional Sep,CR,LF. + * The rules that apply here are: + * + * SB8 ATerm Close* Sp* × ( ¬(OLetter | Upper | Lower | Sep | CR + | LF | STerm | ATerm) )* Lower + SB8a (STerm | ATerm) Close* Sp* × (SContinue | STerm | ATerm) + SB9 (STerm | ATerm) Close* × (Close | Sp | Sep | CR | LF) + SB10 (STerm | ATerm) Close* Sp* × (Sp | Sep | CR | LF) + SB11 (STerm | ATerm) Close* Sp* (Sep | CR | LF)? ÷ + */ + + /* And all but SB11 forbid having seen a paragraph separator */ + if (! has_para_sep) { + if (before == SB_ATerm) { /* SB8 */ + U8 * rpos = (U8 *) curpos; + SB_enum later = after; + + while ( later != SB_OLetter + && later != SB_Upper + && later != SB_Lower + && later != SB_Sep + && later != SB_CR + && later != SB_LF + && later != SB_STerm + && later != SB_ATerm + && later != SB_EDGE) + { + later = advance_one_SB(&rpos, strend, utf8_target); + } + if (later == SB_Lower) { + return FALSE; + } + } + + if ( after == SB_SContinue /* SB8a */ + || after == SB_STerm + || after == SB_ATerm) + { + return FALSE; + } + + if (! has_sp) { /* SB9 applies only if there was no Sp* */ + if ( after == SB_Close + || after == SB_Sp + || after == SB_Sep + || after == SB_CR + || after == SB_LF) + { + return FALSE; + } + } + + /* SB10. This and SB9 could probably be combined some way, but khw + * has decided to follow the Unicode rule book precisely for + * simplified maintenance */ + if ( after == SB_Sp + || after == SB_Sep + || after == SB_CR + || after == SB_LF) + { + return FALSE; + } + } + + /* SB11. */ return TRUE; } @@ -4788,8 +5156,6 @@ S_backup_one_SB(pTHX_ const U8 * const strbeg, U8 ** curpos, const bool utf8_tar return sb; } -#define WBcase(before, after) ((WB_ENUM_COUNT * before) + after) - STATIC bool S_isWB(pTHX_ WB_enum previous, WB_enum before, @@ -4811,190 +5177,168 @@ S_isWB(pTHX_ WB_enum previous, U8 * before_pos = (U8 *) curpos; U8 * after_pos = (U8 *) curpos; + WB_enum prev = before; + WB_enum next; PERL_ARGS_ASSERT_ISWB; - /* WB1 and WB2: Break at the start and end of text. */ - if (before == WB_EDGE || after == WB_EDGE) { - return TRUE; - } + /* Rule numbers in the comments below are as of Unicode 9.0 */ - /* WB 3 is: "Do not break within CRLF." Perl extends this so that all - * white space sequences ending in a vertical space are treated as one - * unit. */ + redo: + before = prev; + switch (WB_table[before][after]) { + case WB_BREAKABLE: + return TRUE; - if (after == WB_CR || after == WB_LF || after == WB_Newline) { - if (before == WB_CR || before == WB_LF || before == WB_Newline - || before == WB_Perl_Tailored_HSpace) - { + case WB_NOBREAK: return FALSE; - } - - /* WB 3a: Otherwise break before Newlines (including CR and LF) */ - return TRUE; - } - /* Here, we know that 'after' is not a vertical space character, but - * 'before' could be. WB 3b is: "Otherwise break after Newlines (including - * CR and LF)." Perl changes that to not break-up spans of white space, - * except when horizontal space is followed by an Extend or Format - * character. These apply just to the final white space character in the - * span, so it is broken away from the rest. (If the Extend or Format - * character follows a vertical space character, it is treated as beginning - * a line, and doesn't modify the preceeding character.) */ - if ( before == WB_CR || before == WB_LF || before == WB_Newline - || before == WB_Perl_Tailored_HSpace) - { - if (after == WB_Perl_Tailored_HSpace) { - U8 * temp_pos = (U8 *) curpos; - const WB_enum next - = advance_one_WB(&temp_pos, strend, utf8_target, + case WB_hs_then_hs: /* 2 horizontal spaces in a row */ + next = advance_one_WB(&after_pos, strend, utf8_target, FALSE /* Don't skip Extend nor Format */ ); + /* A space immediately preceeding an Extend or Format is attached + * to by them, and hence gets separated from previous spaces. + * Otherwise don't break between horizontal white space */ return next == WB_Extend || next == WB_Format; - } - else if (before != WB_Perl_Tailored_HSpace) { - /* Here, 'before' must be one of the vertical space characters, and - * after is not any type of white-space. Follow WB 3b. */ - return TRUE; - } + /* WB4 Ignore Format and Extend characters, except when they appear at + * the beginning of a region of text. This code currently isn't + * general purpose, but it works as the rules are currently and likely + * to be laid out. The reason it works is that when 'they appear at + * the beginning of a region of text', the rule is to break before + * them, just like any other character. Therefore, the default rule + * applies and we don't have to look in more depth. Should this ever + * change, we would have to have 2 'case' statements, like in the rules + * below, and backup a single character (not spacing over the extend + * ones) and then see if that is one of the region-end characters and + * go from there */ + case WB_Ex_or_FO_or_ZWJ_then_foo: + prev = backup_one_WB(&previous, strbeg, &before_pos, utf8_target); + goto redo; - /* Here, 'before' is horizontal space, and 'after' is not any kind of - * space. Normal rules apply */ - } + case WB_DQ_then_HL + WB_BREAKABLE: + case WB_DQ_then_HL + WB_NOBREAK: - /* Ignore Format and Extend characters, except when they appear at the - * beginning of a region of text. - * WB4. X (Extend | Format)* → X. */ + /* WB7c Hebrew_Letter Double_Quote × Hebrew_Letter */ - if (after == WB_Extend || after == WB_Format) { - return FALSE; - } + if (backup_one_WB(&previous, strbeg, &before_pos, utf8_target) + == WB_Hebrew_Letter) + { + return FALSE; + } - if (before == WB_Extend || before == WB_Format) { - before = backup_one_WB(&previous, strbeg, &before_pos, utf8_target); - } + return WB_table[before][after] - WB_DQ_then_HL == WB_BREAKABLE; - switch (WBcase(before, after)) { - /* Otherwise, break everywhere (including around ideographs). - WB14. Any ÷ Any */ - default: - return TRUE; + case WB_HL_then_DQ + WB_BREAKABLE: + case WB_HL_then_DQ + WB_NOBREAK: - /* Do not break between most letters. - WB5. (ALetter | Hebrew_Letter) × (ALetter | Hebrew_Letter) */ - case WBcase(WB_ALetter, WB_ALetter): - case WBcase(WB_ALetter, WB_Hebrew_Letter): - case WBcase(WB_Hebrew_Letter, WB_ALetter): - case WBcase(WB_Hebrew_Letter, WB_Hebrew_Letter): - return FALSE; + /* WB7b Hebrew_Letter × Double_Quote Hebrew_Letter */ - /* Do not break letters across certain punctuation. - WB6. (ALetter | Hebrew_Letter) - × (MidLetter | MidNumLet | Single_Quote) (ALetter - | Hebrew_Letter) */ - case WBcase(WB_ALetter, WB_MidLetter): - case WBcase(WB_ALetter, WB_MidNumLet): - case WBcase(WB_ALetter, WB_Single_Quote): - case WBcase(WB_Hebrew_Letter, WB_MidLetter): - case WBcase(WB_Hebrew_Letter, WB_MidNumLet): - /*case WBcase(WB_Hebrew_Letter, WB_Single_Quote):*/ - after = advance_one_WB(&after_pos, strend, utf8_target, - TRUE /* Do skip Extend and Format */ ); - return after != WB_ALetter && after != WB_Hebrew_Letter; - - /* WB7. (ALetter | Hebrew_Letter) (MidLetter | MidNumLet | - * Single_Quote) × (ALetter | Hebrew_Letter) */ - case WBcase(WB_MidLetter, WB_ALetter): - case WBcase(WB_MidLetter, WB_Hebrew_Letter): - case WBcase(WB_MidNumLet, WB_ALetter): - case WBcase(WB_MidNumLet, WB_Hebrew_Letter): - case WBcase(WB_Single_Quote, WB_ALetter): - case WBcase(WB_Single_Quote, WB_Hebrew_Letter): - before - = backup_one_WB(&previous, strbeg, &before_pos, utf8_target); - return before != WB_ALetter && before != WB_Hebrew_Letter; - - /* WB7a. Hebrew_Letter × Single_Quote */ - case WBcase(WB_Hebrew_Letter, WB_Single_Quote): + if (advance_one_WB(&after_pos, strend, utf8_target, + TRUE /* Do skip Extend and Format */ ) + == WB_Hebrew_Letter) + { return FALSE; + } - /* WB7b. Hebrew_Letter × Double_Quote Hebrew_Letter */ - case WBcase(WB_Hebrew_Letter, WB_Double_Quote): - return advance_one_WB(&after_pos, strend, utf8_target, - TRUE /* Do skip Extend and Format */ ) - != WB_Hebrew_Letter; + return WB_table[before][after] - WB_HL_then_DQ == WB_BREAKABLE; - /* WB7c. Hebrew_Letter Double_Quote × Hebrew_Letter */ - case WBcase(WB_Double_Quote, WB_Hebrew_Letter): - return backup_one_WB(&previous, strbeg, &before_pos, utf8_target) - != WB_Hebrew_Letter; + case WB_LE_or_HL_then_MB_or_ML_or_SQ + WB_NOBREAK: + case WB_LE_or_HL_then_MB_or_ML_or_SQ + WB_BREAKABLE: - /* Do not break within sequences of digits, or digits adjacent to - * letters (“3a”, or “A3”). - WB8. Numeric × Numeric */ - case WBcase(WB_Numeric, WB_Numeric): - return FALSE; + /* WB6 (ALetter | Hebrew_Letter) × (MidLetter | MidNumLet + * | Single_Quote) (ALetter | Hebrew_Letter) */ - /* WB9. (ALetter | Hebrew_Letter) × Numeric */ - case WBcase(WB_ALetter, WB_Numeric): - case WBcase(WB_Hebrew_Letter, WB_Numeric): - return FALSE; + next = advance_one_WB(&after_pos, strend, utf8_target, + TRUE /* Do skip Extend and Format */ ); - /* WB10. Numeric × (ALetter | Hebrew_Letter) */ - case WBcase(WB_Numeric, WB_ALetter): - case WBcase(WB_Numeric, WB_Hebrew_Letter): + if (next == WB_ALetter || next == WB_Hebrew_Letter) + { return FALSE; + } - /* Do not break within sequences, such as “3.2” or “3,456.789”. - WB11. Numeric (MidNum | MidNumLet | Single_Quote) × Numeric - */ - case WBcase(WB_MidNum, WB_Numeric): - case WBcase(WB_MidNumLet, WB_Numeric): - case WBcase(WB_Single_Quote, WB_Numeric): - return backup_one_WB(&previous, strbeg, &before_pos, utf8_target) - != WB_Numeric; - - /* WB12. Numeric × (MidNum | MidNumLet | Single_Quote) Numeric - * */ - case WBcase(WB_Numeric, WB_MidNum): - case WBcase(WB_Numeric, WB_MidNumLet): - case WBcase(WB_Numeric, WB_Single_Quote): - return advance_one_WB(&after_pos, strend, utf8_target, - TRUE /* Do skip Extend and Format */ ) - != WB_Numeric; - - /* Do not break between Katakana. - WB13. Katakana × Katakana */ - case WBcase(WB_Katakana, WB_Katakana): - return FALSE; + return WB_table[before][after] + - WB_LE_or_HL_then_MB_or_ML_or_SQ == WB_BREAKABLE; + + case WB_MB_or_ML_or_SQ_then_LE_or_HL + WB_NOBREAK: + case WB_MB_or_ML_or_SQ_then_LE_or_HL + WB_BREAKABLE: - /* Do not break from extenders. - WB13a. (ALetter | Hebrew_Letter | Numeric | Katakana | - ExtendNumLet) × ExtendNumLet */ - case WBcase(WB_ALetter, WB_ExtendNumLet): - case WBcase(WB_Hebrew_Letter, WB_ExtendNumLet): - case WBcase(WB_Numeric, WB_ExtendNumLet): - case WBcase(WB_Katakana, WB_ExtendNumLet): - case WBcase(WB_ExtendNumLet, WB_ExtendNumLet): + /* WB7 (ALetter | Hebrew_Letter) (MidLetter | MidNumLet + * | Single_Quote) × (ALetter | Hebrew_Letter) */ + + prev = backup_one_WB(&previous, strbeg, &before_pos, utf8_target); + if (prev == WB_ALetter || prev == WB_Hebrew_Letter) + { return FALSE; + } - /* WB13b. ExtendNumLet × (ALetter | Hebrew_Letter | Numeric - * | Katakana) */ - case WBcase(WB_ExtendNumLet, WB_ALetter): - case WBcase(WB_ExtendNumLet, WB_Hebrew_Letter): - case WBcase(WB_ExtendNumLet, WB_Numeric): - case WBcase(WB_ExtendNumLet, WB_Katakana): + return WB_table[before][after] + - WB_MB_or_ML_or_SQ_then_LE_or_HL == WB_BREAKABLE; + + case WB_MB_or_MN_or_SQ_then_NU + WB_NOBREAK: + case WB_MB_or_MN_or_SQ_then_NU + WB_BREAKABLE: + + /* WB11 Numeric (MidNum | (MidNumLet | Single_Quote)) × Numeric + * */ + + if (backup_one_WB(&previous, strbeg, &before_pos, utf8_target) + == WB_Numeric) + { return FALSE; + } + + return WB_table[before][after] + - WB_MB_or_MN_or_SQ_then_NU == WB_BREAKABLE; - /* Do not break between regional indicator symbols. - WB13c. Regional_Indicator × Regional_Indicator */ - case WBcase(WB_Regional_Indicator, WB_Regional_Indicator): + case WB_NU_then_MB_or_MN_or_SQ + WB_NOBREAK: + case WB_NU_then_MB_or_MN_or_SQ + WB_BREAKABLE: + + /* WB12 Numeric × (MidNum | MidNumLet | Single_Quote) Numeric */ + + if (advance_one_WB(&after_pos, strend, utf8_target, + TRUE /* Do skip Extend and Format */ ) + == WB_Numeric) + { return FALSE; + } + + return WB_table[before][after] + - WB_NU_then_MB_or_MN_or_SQ == WB_BREAKABLE; + case WB_RI_then_RI + WB_NOBREAK: + case WB_RI_then_RI + WB_BREAKABLE: + { + int RI_count = 1; + + /* Do not break within emoji flag sequences. That is, do not + * break between regional indicator (RI) symbols if there is an + * odd number of RI characters before the potential break + * point. + * + * WB15 sot (RI RI)* RI × RI + * WB16 [^RI] (RI RI)* RI × RI */ + + while (backup_one_WB(&previous, + strbeg, + &before_pos, + utf8_target) == WB_Regional_Indicator) + { + RI_count++; + } + + return RI_count % 2 != 1; + } + + default: + break; } - NOT_REACHED; /* NOTREACHED */ +#ifdef DEBUGGING + Perl_re_printf( aTHX_ "Unhandled WB pair: WB_table[%d, %d] = %d\n", + before, after, WB_table[before][after]); + assert(0); +#endif + return TRUE; } STATIC WB_enum @@ -5065,8 +5409,8 @@ S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, *previous = (*curpos <= strbeg) ? WB_EDGE : WB_UNKNOWN; } - /* And we always back up over these two types */ - if (wb != WB_Extend && wb != WB_Format) { + /* And we always back up over these three types */ + if (wb != WB_Extend && wb != WB_Format && wb != WB_ZWJ) { return wb; } } @@ -5097,7 +5441,7 @@ S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, *curpos = (U8 *) strbeg; return WB_EDGE; } - } while (wb == WB_Extend || wb == WB_Format); + } while (wb == WB_Extend || wb == WB_Format || wb == WB_ZWJ); } else { do { @@ -5113,13 +5457,32 @@ S_backup_one_WB(pTHX_ WB_enum * previous, const U8 * const strbeg, U8 ** curpos, return wb; } +#define EVAL_CLOSE_PAREN_IS(st,expr) \ +( \ + ( ( st ) ) && \ + ( ( st )->u.eval.close_paren ) && \ + ( ( ( st )->u.eval.close_paren ) == ( (expr) + 1 ) ) \ +) + +#define EVAL_CLOSE_PAREN_IS_TRUE(st,expr) \ +( \ + ( ( st ) ) && \ + ( ( st )->u.eval.close_paren ) && \ + ( ( expr ) ) && \ + ( ( ( st )->u.eval.close_paren ) == ( (expr) + 1 ) ) \ +) + + +#define EVAL_CLOSE_PAREN_SET(st,expr) \ + (st)->u.eval.close_paren = ( (expr) + 1 ) + +#define EVAL_CLOSE_PAREN_CLEAR(st) \ + (st)->u.eval.close_paren = 0 + /* returns -1 on failure, $+[0] on success */ STATIC SSize_t S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) { -#if PERL_VERSION < 9 && !defined(PERL_CORE) - dMY_CXT; -#endif dVAR; const bool utf8_target = reginfo->is_utf8_target; const U32 uniflags = UTF8_ALLOW_DEFAULT; @@ -5133,12 +5496,13 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) regnode *next; U32 n = 0; /* general value; init to avoid compiler warning */ SSize_t ln = 0; /* len or last; init to avoid compiler warning */ + SSize_t endref = 0; /* offset of end of backref when ln is start */ char *locinput = startpos; char *pushinput; /* where to continue after a PUSH */ - I32 nextchr; /* is always set to UCHARAT(locinput) */ + I32 nextchr; /* is always set to UCHARAT(locinput), or -1 at EOS */ bool result = 0; /* return value of S_regmatch */ - int depth = 0; /* depth of backtrack stack */ + U32 depth = 0; /* depth of backtrack stack */ U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */ const U32 max_nochange_depth = (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ? @@ -5159,7 +5523,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) SV *sv_yes_mark = NULL; /* last mark name we have seen during a successful match */ U32 lastopen = 0; /* last open we saw */ - bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0; + bool has_cutgroup = RXp_HAS_CUTGROUP(rex) ? 1 : 0; SV* const oreplsv = GvSVn(PL_replgv); /* these three flags are set by various ops to signal information to * the very next op. They have a useful lifetime of exactly one loop @@ -5180,13 +5544,20 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) U8 gimme = G_SCALAR; 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; bool match = FALSE; - + I32 orig_savestack_ix = PL_savestack_ix; + U8 * script_run_begin = NULL; + +/* Solaris Studio 12.3 messes up fetching PL_charclass['\n'] */ +#if (defined(__SUNPRO_C) && (__SUNPRO_C == 0x5120) && defined(__x86_64) && defined(USE_64_BIT_ALL)) +# define SOLARIS_BAD_OPTIMIZER + const U32 *pl_charclass_dup = PL_charclass; +# define PL_charclass pl_charclass_dup +#endif #ifdef DEBUGGING GET_RE_DEBUG_FLAGS_DECL; @@ -5201,37 +5572,41 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) PERL_ARGS_ASSERT_REGMATCH; - DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({ - PerlIO_printf(Perl_debug_log,"regmatch start\n"); - })); - st = PL_regmatch_state; /* Note that nextchr is a byte even in UTF */ SET_nextchr; scan = prog; - while (scan != NULL) { - DEBUG_EXECUTE_r( { - SV * const prop = sv_newmortal(); - regnode *rnext=regnext(scan); - DUMP_EXEC_POS( locinput, scan, utf8_target ); - regprop(rex, prop, scan, reginfo, NULL); - - PerlIO_printf(Perl_debug_log, - "%3"IVdf":%*s%s(%"IVdf")\n", - (IV)(scan - rexi->program), depth*2, "", - SvPVX_const(prop), - (PL_regkind[OP(scan)] == END || !rnext) ? - 0 : (IV)(rnext - rexi->program)); - }); + DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({ + DUMP_EXEC_POS( locinput, scan, utf8_target, depth ); + Perl_re_printf( aTHX_ "regmatch start\n" ); + })); + while (scan != NULL) { next = scan + NEXT_OFF(scan); if (next == scan) next = NULL; state_num = OP(scan); reenter_switch: + DEBUG_EXECUTE_r( + if (state_num <= REGNODE_MAX) { + SV * const prop = sv_newmortal(); + regnode *rnext = regnext(scan); + + DUMP_EXEC_POS( locinput, scan, utf8_target, depth ); + regprop(rex, prop, scan, reginfo, NULL); + Perl_re_printf( aTHX_ + "%*s%" IVdf ":%s(%" IVdf ")\n", + INDENT_CHARS(depth), "", + (IV)(scan - rexi->program), + SvPVX_const(prop), + (PL_regkind[OP(scan)] == END || !rnext) ? + 0 : (IV)(rnext - rexi->program)); + } + ); + to_complement = 0; SET_nextchr; @@ -5261,14 +5636,12 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) st->u.keeper.val = rex->offs[0].start; rex->offs[0].start = locinput - reginfo->strbeg; PUSH_STATE_GOTO(KEEPS_next, next, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case KEEPS_next_fail: /* rollback the start point change */ rex->offs[0].start = st->u.keeper.val; sayNO_SILENT; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case MEOL: /* /..$/m */ @@ -5307,12 +5680,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) */ if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed to match trie start class...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n", + depth, PL_colors[4], PL_colors[5]) ); sayNO_SILENT; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } /* FALLTHROUGH */ @@ -5374,6 +5745,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (scan->flags == EXACTL || scan->flags == EXACTFLU8) { _CHECK_AND_WARN_PROBLEMATIC_LOCALE; if (utf8_target + && nextchr >= 0 /* guard against negative EOS value in nextchr */ && UTF8_IS_ABOVE_LATIN1(nextchr) && scan->flags == EXACTL) { @@ -5389,17 +5761,15 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) { if (trie->states[ state ].wordnum) { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %smatched empty string...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_exec_indentf( aTHX_ "%smatched empty string...%s\n", + depth, PL_colors[4], PL_colors[5]) ); if (!trie->jump) break; } else { DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed to match trie start class...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]) + Perl_re_exec_indentf( aTHX_ "%sfailed to match trie start class...%s\n", + depth, PL_colors[4], PL_colors[5]) ); sayNO_SILENT; } @@ -5451,10 +5821,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } DEBUG_TRIE_EXECUTE_r({ - DUMP_EXEC_POS( (char *)uc, scan, utf8_target ); - PerlIO_printf( Perl_debug_log, - "%*s %sState: %4"UVxf" Accepted: %c ", - 2+depth * 2, "", PL_colors[4], + DUMP_EXEC_POS( (char *)uc, scan, utf8_target, depth ); + /* HERE */ + PerlIO_printf( Perl_debug_log, + "%*s%sState: %4" UVxf " Accepted: %c ", + INDENT_CHARS(depth), "", PL_colors[4], (UV)state, (accepted ? 'Y' : 'N')); }); @@ -5486,8 +5857,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) state = 0; } DEBUG_TRIE_EXECUTE_r( - PerlIO_printf( Perl_debug_log, - "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n", + Perl_re_printf( aTHX_ + "Charid:%3x CP:%4" UVxf " After State: %4" UVxf "%s\n", charid, uvc, (UV)state, PL_colors[5] ); ); } @@ -5506,28 +5877,30 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } DEBUG_EXECUTE_r( - PerlIO_printf( Perl_debug_log, - "%*s %sgot %"IVdf" possible matches%s\n", - REPORT_CODE_OFF + depth * 2, "", + Perl_re_exec_indentf( aTHX_ "%sgot %" IVdf " possible matches%s\n", + depth, PL_colors[4], (IV)ST.accepted, PL_colors[5] ); ); goto trie_first_try; /* jump into the fail handler */ }} - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case TRIE_next_fail: /* we failed - try next alternative */ { U8 *uc; - if ( ST.jump) { + if ( ST.jump ) { + /* undo any captures done in the tail part of a branch, + * e.g. + * /(?:X(.)(.)|Y(.)).../ + * where the trie just matches X then calls out to do the + * rest of the branch */ REGCP_UNWIND(ST.cp); UNWIND_PAREN(ST.lastparen, ST.lastcloseparen); } if (!--ST.accepted) { DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sTRIE failed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_exec_indentf( aTHX_ "%sTRIE failed...%s\n", + depth, PL_colors[4], PL_colors[5] ); }); @@ -5554,7 +5927,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) no_final = 0; } - if ( ST.jump) { + if ( ST.jump ) { ST.lastparen = rex->lastparen; ST.lastcloseparen = rex->lastcloseparen; REGCP_SET(ST.cp); @@ -5617,18 +5990,16 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) : NEXT_OFF(ST.me)); DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sTRIE matched word #%d, continuing%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_exec_indentf( aTHX_ "%sTRIE matched word #%d, continuing%s\n", + depth, PL_colors[4], ST.nextword, PL_colors[5] ); }); - if (ST.accepted > 1 || has_cutgroup) { + if ( ST.accepted > 1 || has_cutgroup || ST.jump ) { PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } /* only one choice left - just continue */ @@ -5639,9 +6010,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) ? av_fetch(trie_words, ST.nextword - 1, 0) : NULL; SV *sv= tmp ? sv_newmortal() : NULL; - PerlIO_printf( Perl_debug_log, - "%*s %sonly one match left, short-circuiting: #%d <%s>%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], + Perl_re_exec_indentf( aTHX_ "%sonly one match left, short-circuiting: #%d <%s>%s\n", + depth, PL_colors[4], ST.nextword, tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0, PL_colors[0], PL_colors[1], @@ -5857,12 +6227,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (locinput == reginfo->strbeg) b1 = isWORDCHAR_LC('\n'); else { - b1 = isWORDCHAR_LC_utf8(reghop3((U8*)locinput, -1, - (U8*)(reginfo->strbeg))); + b1 = isWORDCHAR_LC_utf8_safe(reghop3((U8*)locinput, -1, + (U8*)(reginfo->strbeg)), + (U8*)(reginfo->strend)); } b2 = (NEXTCHR_IS_EOS) ? isWORDCHAR_LC('\n') - : isWORDCHAR_LC_utf8((U8*)locinput); + : isWORDCHAR_LC_utf8_safe((U8*) locinput, + (U8*) reginfo->strend); } else { /* Here the string isn't utf8 */ b1 = (locinput == reginfo->strbeg) @@ -5936,11 +6308,15 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) bool b1, b2; b1 = (locinput == reginfo->strbeg) ? 0 /* isWORDCHAR_L1('\n') */ - : isWORDCHAR_utf8(reghop3((U8*)locinput, -1, - (U8*)(reginfo->strbeg))); + : isWORDCHAR_utf8_safe( + reghop3((U8*)locinput, + -1, + (U8*)(reginfo->strbeg)), + (U8*) reginfo->strend); b2 = (NEXTCHR_IS_EOS) ? 0 /* isWORDCHAR_L1('\n') */ - : isWORDCHAR_utf8((U8*)locinput); + : isWORDCHAR_utf8_safe((U8*)locinput, + (U8*) reginfo->strend); match = cBOOL(b1 != b2); break; } @@ -5958,7 +6334,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) (U8*)(reginfo->strbeg)), (U8*) reginfo->strend), getGCB_VAL_UTF8((U8*) locinput, - (U8*) reginfo->strend)); + (U8*) reginfo->strend), + (U8*) reginfo->strbeg, + (U8*) locinput, + utf8_target); } break; @@ -6123,12 +6502,28 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) locinput += UTF8SKIP(locinput); } else { - if (!REGINCLASS(rex, scan, (U8*)locinput)) + if (!REGINCLASS(rex, scan, (U8*)locinput, utf8_target)) sayNO; locinput++; } break; + case ASCII: + if (NEXTCHR_IS_EOS || ! isASCII(UCHARAT(locinput))) { + sayNO; + } + + locinput++; /* ASCII is always single byte */ + break; + + case NASCII: + if (NEXTCHR_IS_EOS || isASCII(UCHARAT(locinput))) { + sayNO; + } + + goto increment_locinput; + break; + /* The argument (FLAGS) to all the POSIX node types is the class number * */ @@ -6148,23 +6543,28 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) { sayNO; } + + locinput++; + break; } - else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { - if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), - EIGHT_BIT_UTF8_TO_NATIVE(nextchr, - *(locinput + 1)))))) - { - sayNO; - } - } - else { /* Here, must be an above Latin-1 code point */ - _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, reginfo->strend); + + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(locinput, reginfo->strend)) { + /* An above Latin-1 code point, or malformed */ + _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(locinput, + reginfo->strend); goto utf8_posix_above_latin1; } - /* Here, must be utf8 */ - locinput += UTF8SKIP(locinput); - break; + /* Here is a UTF-8 variant code point below 256 and the target is + * UTF-8 */ + if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), + EIGHT_BIT_UTF8_TO_NATIVE(nextchr, + *(locinput + 1)))))) + { + sayNO; + } + + goto increment_locinput; case NPOSIXD: /* \W or [:^punct:] etc. under /d */ to_complement = 1; @@ -6188,7 +6588,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } to_complement = 1; - /* FALLTHROUGH */ + goto join_nposixa; case POSIXA: /* \w or [:punct:] etc. under /a */ @@ -6197,9 +6597,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * 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))))) + if (NEXTCHR_IS_EOS) { + sayNO; + } + + join_nposixa: + + if (! (to_complement ^ cBOOL(_generic_isCC_A(nextchr, + FLAGS(scan))))) { sayNO; } @@ -6230,7 +6635,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } locinput++; } - else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) { + else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(locinput, reginfo->strend)) { if (! (to_complement ^ cBOOL(_generic_isCC(EIGHT_BIT_UTF8_TO_NATIVE(nextchr, *(locinput + 1)), @@ -6335,7 +6740,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) while (locinput < reginfo->strend) { GCB_enum cur_gcb = getGCB_VAL_UTF8((U8*) locinput, (U8*) reginfo->strend); - if (isGCB(prev_gcb, cur_gcb)) { + if (isGCB(prev_gcb, cur_gcb, + (U8*) reginfo->strbeg, (U8*) locinput, + utf8_target)) + { break; } @@ -6440,10 +6848,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) do_nref_ref_common: ln = rex->offs[n].start; + endref = rex->offs[n].end; reginfo->poscache_iter = reginfo->poscache_maxiter; /* Void cache */ - if (rex->lastparen < n || ln == -1) + if (rex->lastparen < n || ln == -1 || endref == -1) sayNO; /* Do not match unless seen CLOSEn. */ - if (ln == rex->offs[n].end) + if (ln == endref) break; s = reginfo->strbeg + ln; @@ -6457,7 +6866,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * 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, + if (! foldEQ_utf8_flags(s, NULL, endref - ln, utf8_target, locinput, &limit, 0, utf8_target, utf8_fold_flags)) { sayNO; @@ -6472,7 +6881,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) (type == REF || UCHARAT(s) != fold_array[nextchr])) sayNO; - ln = rex->offs[n].end - ln; + ln = endref - ln; if (locinput + ln > reginfo->strend) sayNO; if (ln > 1 && (type == REF @@ -6491,18 +6900,19 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) #undef ST #define ST st->u.eval +#define CUR_EVAL cur_eval->u.eval + { SV *ret; REGEXP *re_sv; regexp *re; regexp_internal *rei; regnode *startpoint; + U32 arg; - case GOSTART: /* (?R) */ case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */ - if (cur_eval && cur_eval->locinput==locinput) { - if (cur_eval->u.eval.close_paren == (U32)ARG(scan)) - Perl_croak(aTHX_ "Infinite recursion in regex"); + arg= (U32)ARG(scan); + if (cur_eval && cur_eval->locinput == locinput) { if ( ++nochange_depth > max_nochange_depth ) Perl_croak(aTHX_ "Pattern subroutine nesting without pos change" @@ -6513,12 +6923,33 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) re_sv = rex_sv; re = rex; rei = rexi; - if (OP(scan)==GOSUB) { - startpoint = scan + ARG2L(scan); - ST.close_paren = ARG(scan); + startpoint = scan + ARG2L(scan); + EVAL_CLOSE_PAREN_SET( st, arg ); + /* Detect infinite recursion + * + * A pattern like /(?R)foo/ or /(?(?&y)foo)(?(?&x)bar)/ + * or "a"=~/(.(?2))((?<=(?=(?1)).))/ could recurse forever. + * So we track the position in the string we are at each time + * we recurse and if we try to enter the same routine twice from + * the same position we throw an error. + */ + if ( rex->recurse_locinput[arg] == locinput ) { + /* FIXME: we should show the regop that is failing as part + * of the error message. */ + Perl_croak(aTHX_ "Infinite recursion in regex"); } else { - startpoint = rei->program+1; - ST.close_paren = 0; + ST.prev_recurse_locinput= rex->recurse_locinput[arg]; + rex->recurse_locinput[arg]= locinput; + + DEBUG_r({ + GET_RE_DEBUG_FLAGS_DECL; + DEBUG_STACK_r({ + Perl_re_exec_indentf( aTHX_ + "entering GOSUB, prev_recurse_locinput=%p recurse_locinput[%d]=%p\n", + depth, ST.prev_recurse_locinput, arg, rex->recurse_locinput[arg] + ); + }); + }); } /* Save all the positions seen so far. */ @@ -6529,7 +6960,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) goto eval_recurse_doit; /* NOTREACHED */ - case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */ + case EVAL: /* /(?{...})B/ /(??{A})B/ and /(?(?{...})X|Y)B/ */ if (cur_eval && cur_eval->locinput==locinput) { if ( ++nochange_depth > max_nochange_depth ) Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex"); @@ -6547,8 +6978,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) CV *newcv; /* save *all* paren positions */ - regcppush(rex, 0, maxopenparen); - REGCP_SET(runops_cp); + regcppush(rex, 0, maxopenparen); + REGCP_SET(ST.lastcp); if (!caller_cv) caller_cv = find_runcv(NULL); @@ -6556,10 +6987,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) n = ARG(scan); if (rexi->data->what[n] == 'r') { /* code from an external qr */ - newcv = (ReANY( - (REGEXP*)(rexi->data->data[n]) - ))->qr_anoncv - ; + newcv = (ReANY( + (REGEXP*)(rexi->data->data[n]) + ))->qr_anoncv; nop = (OP*)rexi->data->data[n+1]; } else if (rexi->data->what[n] == 'l') { /* literal code */ @@ -6574,30 +7004,67 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) nop = (OP*)rexi->data->data[n]; } - /* normally if we're about to execute code from the same - * CV that we used previously, we just use the existing - * CX stack entry. However, its possible that in the - * meantime we may have backtracked, popped from the save - * stack, and undone the SAVECOMPPAD(s) associated with - * PUSH_MULTICALL; in which case PL_comppad no longer - * points to newcv's pad. */ + /* Some notes about MULTICALL and the context and save stacks. + * + * In something like + * /...(?{ my $x)}...(?{ my $y)}...(?{ my $z)}.../ + * since codeblocks don't introduce a new scope (so that + * local() etc accumulate), at the end of a successful + * match there will be a SAVEt_CLEARSV on the savestack + * for each of $x, $y, $z. If the three code blocks above + * happen to have come from different CVs (e.g. via + * embedded qr//s), then we must ensure that during any + * savestack unwinding, PL_comppad always points to the + * right pad at each moment. We achieve this by + * interleaving SAVEt_COMPPAD's on the savestack whenever + * there is a change of pad. + * In theory whenever we call a code block, we should + * push a CXt_SUB context, then pop it on return from + * that code block. This causes a bit of an issue in that + * normally popping a context also clears the savestack + * back to cx->blk_oldsaveix, but here we specifically + * don't want to clear the save stack on exit from the + * code block. + * Also for efficiency we don't want to keep pushing and + * popping the single SUB context as we backtrack etc. + * So instead, we push a single context the first time + * we need, it, then hang onto it until the end of this + * function. Whenever we encounter a new code block, we + * update the CV etc if that's changed. During the times + * in this function where we're not executing a code + * block, having the SUB context still there is a bit + * naughty - but we hope that no-one notices. + * When the SUB context is initially pushed, we fake up + * cx->blk_oldsaveix to be as if we'd pushed this context + * on first entry to S_regmatch rather than at some random + * point during the regexe execution. That way if we + * croak, popping the context stack will ensure that + * *everything* SAVEd by this function is undone and then + * the context popped, rather than e.g., popping the + * context (and restoring the original PL_comppad) then + * popping more of the savestack and restoring a bad + * PL_comppad. + */ + + /* If this is the first EVAL, push a MULTICALL. On + * subsequent calls, if we're executing a different CV, or + * if PL_comppad has got messed up from backtracking + * through SAVECOMPPADs, then refresh the context. + */ if (newcv != last_pushed_cv || PL_comppad != last_pad) { U8 flags = (CXp_SUB_RE | ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0)); + SAVECOMPPAD(); if (last_pushed_cv) { - /* PUSH/POP_MULTICALL save and restore the - * caller's PL_comppad; if we call multiple subs - * using the same CX block, we have to save and - * unwind the varying PL_comppad's ourselves, - * especially restoring the right PL_comppad on - * backtrack - so save it on the save stack */ - SAVECOMPPAD(); CHANGE_MULTICALL_FLAGS(newcv, flags); } else { PUSH_MULTICALL_FLAGS(newcv, flags); } + /* see notes above */ + CX_CUR()->blk_oldsaveix = orig_savestack_ix; + last_pushed_cv = newcv; } else { @@ -6639,8 +7106,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) } nop = nop->op_next; - DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, - " re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) ); + DEBUG_STATE_r( Perl_re_printf( aTHX_ + " re EVAL PL_op=0x%" UVxf "\n", PTR2UV(nop)) ); rex->offs[0].end = locinput - reginfo->strbeg; if (reginfo->info_aux_eval->pos_magic) @@ -6679,7 +7146,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (logical == 0) /* (?{})/ */ sv_setsv(save_scalar(PL_replgv), ret); /* $^R */ else if (logical == 1) { /* /(?(?{...})X|Y)/ */ - sw = cBOOL(SvTRUE(ret)); + sw = cBOOL(SvTRUE_NN(ret)); logical = 0; } else { /* /(??{}) */ @@ -6714,11 +7181,14 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) * in the regexp code uses the pad ! */ PL_op = oop; PL_curcop = ocurcop; - S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen); - PL_curpm = PL_reg_curpm; + regcp_restore(rex, ST.lastcp, &maxopenparen); + PL_curpm_under = PL_curpm; + PL_curpm = PL_reg_curpm; - if (logical != 2) - break; + if (logical != 2) { + PUSH_STATE_GOTO(EVAL_B, next, locinput); + /* NOTREACHED */ + } } /* only /(??{})/ from now on */ @@ -6778,7 +7248,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) reginfo->strend, "Matching embedded"); ); startpoint = rei->program + 1; - ST.close_paren = 0; /* only used for GOSUB */ + EVAL_CLOSE_PAREN_CLEAR(st); /* ST.close_paren = 0; + * close_paren only for GOSUB */ + ST.prev_recurse_locinput= NULL; /* only used for GOSUB */ /* Save all the seen positions so far. */ ST.cp = regcppush(rex, 0, maxopenparen); REGCP_SET(ST.lastcp); @@ -6814,13 +7286,31 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) ST.prev_eval = cur_eval; cur_eval = st; /* now continue from first node in postoned RE */ - PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput); - /* NOTREACHED */ + PUSH_YES_STATE_GOTO(EVAL_postponed_AB, startpoint, locinput); NOT_REACHED; /* NOTREACHED */ } - case EVAL_AB: /* cleanup after a successful (??{A})B */ - /* note: this is called twice; first after popping B, then A */ + case EVAL_postponed_AB: /* cleanup after a successful (??{A})B */ + /* note: this is called twice; first after popping B, then A */ + DEBUG_STACK_r({ + Perl_re_exec_indentf( aTHX_ "EVAL_AB cur_eval=%p prev_eval=%p\n", + depth, cur_eval, ST.prev_eval); + }); + +#define SET_RECURSE_LOCINPUT(STR,VAL)\ + if ( cur_eval && CUR_EVAL.close_paren ) {\ + DEBUG_STACK_r({ \ + Perl_re_exec_indentf( aTHX_ STR " GOSUB%d ce=%p recurse_locinput=%p\n",\ + depth, \ + CUR_EVAL.close_paren - 1,\ + cur_eval, \ + VAL); \ + }); \ + rex->recurse_locinput[CUR_EVAL.close_paren - 1] = VAL;\ + } + + SET_RECURSE_LOCINPUT("EVAL_AB[before]", CUR_EVAL.prev_recurse_locinput); + rex_sv = ST.prev_rex; is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); SET_reg_curpm(rex_sv); @@ -6841,11 +7331,24 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) reginfo->poscache_maxiter = 0; if ( nochange_depth ) nochange_depth--; + + SET_RECURSE_LOCINPUT("EVAL_AB[after]", cur_eval->locinput); sayYES; - case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */ + case EVAL_B_fail: /* unsuccessful B in (?{...})B */ + REGCP_UNWIND(ST.lastcp); + sayNO; + + case EVAL_postponed_AB_fail: /* unsuccessfully ran A or B in (??{A})B */ /* note: this is called twice; first after popping B, then A */ + DEBUG_STACK_r({ + Perl_re_exec_indentf( aTHX_ "EVAL_AB_fail cur_eval=%p prev_eval=%p\n", + depth, cur_eval, ST.prev_eval); + }); + + SET_RECURSE_LOCINPUT("EVAL_AB_fail[before]", CUR_EVAL.prev_recurse_locinput); + rex_sv = ST.prev_rex; is_utf8_pat = reginfo->is_utf8_pat = cBOOL(RX_UTF8(rex_sv)); SET_reg_curpm(rex_sv); @@ -6853,14 +7356,17 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) rexi = RXi_GET(rex); REGCP_UNWIND(ST.lastcp); - regcppop(rex, &maxopenparen); + regcppop(rex, &maxopenparen); cur_eval = ST.prev_eval; cur_curlyx = ST.prev_curlyx; + /* Invalidate cache. See "invalidate" comment above. */ reginfo->poscache_maxiter = 0; if ( nochange_depth ) nochange_depth--; - sayNO_SILENT; + + SET_RECURSE_LOCINPUT("EVAL_AB_fail[after]", cur_eval->locinput); + sayNO_SILENT; #undef ST case OPEN: /* ( */ @@ -6868,8 +7374,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) 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; maxopenparen=%"UVuf"\n", + DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ + "rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " tmp; maxopenparen=%" UVuf "\n", + depth, PTR2UV(rex), PTR2UV(rex->offs), (UV)n, @@ -6879,17 +7386,22 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) lastopen = n; break; + case SROPEN: /* (*SCRIPT_RUN: */ + script_run_begin = (U8 *) locinput; + break; + /* 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 - reginfo->strbeg; \ - DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \ - "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \ - PTR2UV(rex), \ - PTR2UV(rex->offs), \ - (UV)n, \ - (IV)rex->offs[n].start, \ - (IV)rex->offs[n].end \ +#define CLOSE_CAPTURE \ + rex->offs[n].start = rex->offs[n].start_tmp; \ + rex->offs[n].end = locinput - reginfo->strbeg; \ + DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_ \ + "rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf "..%" IVdf "\n", \ + depth, \ + PTR2UV(rex), \ + PTR2UV(rex->offs), \ + (UV)n, \ + (IV)rex->offs[n].start, \ + (IV)rex->offs[n].end \ )) case CLOSE: /* ) */ @@ -6898,11 +7410,21 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (n > rex->lastparen) rex->lastparen = n; rex->lastcloseparen = n; - if (cur_eval && cur_eval->u.eval.close_paren == n) { + if ( EVAL_CLOSE_PAREN_IS( cur_eval, n ) ) goto fake_end; - } + break; + case SRCLOSE: /* (*SCRIPT_RUN: ... ) */ + + if (! isSCRIPT_RUN(script_run_begin, (U8 *) locinput, utf8_target)) + { + sayNO; + } + + break; + + case ACCEPT: /* (*ACCEPT) */ if (scan->flags) sv_yes_mark = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); @@ -6919,8 +7441,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) if (n > rex->lastparen) rex->lastparen = n; rex->lastcloseparen = n; - if ( n == ARG(scan) || (cur_eval && - cur_eval->u.eval.close_paren == n)) + if ( n == ARG(scan) || EVAL_CLOSE_PAREN_IS(cur_eval, n) ) break; } } @@ -6941,7 +7462,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) case INSUBP: /* (?(R)) */ n = ARG(scan); - sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n)); + /* this does not need to use EVAL_CLOSE_PAREN macros, as the arg + * of SCAN is already set up as matches a eval.close_paren */ + sw = cur_eval && (n == 0 || CUR_EVAL.close_paren == n); break; case DEFINEP: /* (?(DEFINE)) */ @@ -7077,21 +7600,18 @@ NULL ST.lastloc = NULL; /* this will be updated by WHILEM */ PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } case CURLYX_end: /* just finished matching all of A*B */ cur_curlyx = ST.prev_curlyx; sayYES; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CURLYX_end_fail: /* just failed to match all of A*B */ regcpblow(ST.cp); cur_curlyx = ST.prev_curlyx; sayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ @@ -7116,30 +7636,26 @@ NULL ST.cache_mask = 0; - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "%*s whilem: matched %ld out of %d..%d\n", - REPORT_CODE_OFF+depth*2, "", (long)n, min, max) + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: matched %ld out of %d..%d\n", + depth, (long)n, min, max) ); /* First just match a string of min A's. */ if (n < min) { - ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor, - maxopenparen); + 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_pre, A, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } /* If degenerate A matches "", assume A done. */ if (locinput == cur_curlyx->u.curlyx.lastloc) { - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, - "%*s whilem: empty match detected, trying continuation...\n", - REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: empty match detected, trying continuation...\n", + depth) ); goto do_whilem_B_max; } @@ -7205,7 +7721,7 @@ NULL reginfo->poscache_size = size; Newxz(aux->poscache, size, char); } - DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, + DEBUG_EXECUTE_r( Perl_re_printf( aTHX_ "%swhilem: Detected a super-linear match, switching on caching%s...\n", PL_colors[4], PL_colors[5]) ); @@ -7222,10 +7738,10 @@ NULL mask = 1 << (offset % 8); offset /= 8; 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, "") + DEBUG_EXECUTE_r( Perl_re_exec_indentf( aTHX_ "whilem: (cache) already tried at this position...\n", + depth) ); + cur_curlyx->u.curlyx.count--; sayNO; /* cache records failure */ } ST.cache_offset = offset; @@ -7238,36 +7754,29 @@ 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, - maxopenparen); - REGCP_SET(ST.lastcp); PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } /* 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); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } goto do_whilem_B_max; } - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case WHILEM_B_min: /* just matched B in a minimal match */ case WHILEM_B_max: /* just matched B in a maximal match */ cur_curlyx = ST.save_curlyx; sayYES; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case WHILEM_B_max_fail: /* just failed to match B in a maximal match */ @@ -7275,26 +7784,23 @@ NULL cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; cur_curlyx->u.curlyx.count--; CACHEsayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ - case WHILEM_A_min_fail: /* just failed to match A in a minimal match */ - /* FALLTHROUGH */ case WHILEM_A_pre_fail: /* just failed to match even minimal A */ REGCP_UNWIND(ST.lastcp); - regcppop(rex, &maxopenparen); + regcppop(rex, &maxopenparen); + /* FALLTHROUGH */ + case WHILEM_A_min_fail: /* just failed to match A in a minimal match */ cur_curlyx->u.curlyx.lastloc = ST.save_lastloc; cur_curlyx->u.curlyx.count--; CACHEsayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case WHILEM_A_max_fail: /* just failed to match A in a maximal match */ REGCP_UNWIND(ST.lastcp); - 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, "") + regcppop(rex, &maxopenparen); /* Restore some previous $s? */ + DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "whilem: failed, trying continuation...\n", + depth) ); do_whilem_B_max: if (cur_curlyx->u.curlyx.count >= REG_INFTY @@ -7313,13 +7819,10 @@ NULL cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx; PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ 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, &maxopenparen); if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) { /* Maximum greed exceeded */ @@ -7337,18 +7840,13 @@ NULL CACHEsayNO; } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "") + DEBUG_EXECUTE_r(Perl_re_exec_indentf( aTHX_ "trying longer...\n", depth) ); /* Try grabbing another A and see if it helps. */ cur_curlyx->u.curlyx.lastloc = locinput; - 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, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ #undef ST @@ -7374,7 +7872,6 @@ NULL } else { PUSH_STATE_GOTO(BRANCH_next, scan, locinput); } - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CUTGROUP: /* /(*THEN)/ */ @@ -7382,7 +7879,6 @@ NULL ? MUTABLE_SV(rexi->data->data[ ARG( scan ) ]) : NULL; PUSH_STATE_GOTO(CUTGROUP_next, next, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CUTGROUP_next_fail: @@ -7391,12 +7887,10 @@ NULL if (st->u.mark.mark_name) sv_commit = st->u.mark.mark_name; sayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case BRANCH_next: sayYES; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case BRANCH_next_fail: /* that branch failed; try the next, if any */ @@ -7410,9 +7904,8 @@ NULL /* no more branches? */ if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) { DEBUG_EXECUTE_r({ - PerlIO_printf( Perl_debug_log, - "%*s %sBRANCH failed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_exec_indentf( aTHX_ "%sBRANCH failed...%s\n", + depth, PL_colors[4], PL_colors[5] ); }); @@ -7463,7 +7956,6 @@ NULL curlym_do_A: /* execute the A in /A{m,n}B/ */ PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput); /* match A */ - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CURLYM_A: /* we've just matched an A */ @@ -7484,14 +7976,11 @@ NULL ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me); } DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n", - (int)(REPORT_CODE_OFF+(depth*2)), "", - (IV) ST.count, (IV)ST.alen) + Perl_re_exec_indentf( aTHX_ "CURLYM now matched %" IVdf " times, len=%" IVdf "...\n", + depth, (IV) ST.count, (IV)ST.alen) ); - if (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.me->flags) + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) goto fake_end; { @@ -7504,9 +7993,9 @@ NULL case CURLYM_A_fail: /* just failed to match an A */ REGCP_UNWIND(ST.cp); + if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ - || (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.me->flags)) + || EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) sayNO; curlym_do_B: /* execute the B in /A{m,n}B/ */ @@ -7540,10 +8029,8 @@ NULL } DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM trying tail with matches=%"IVdf"...\n", - (int)(REPORT_CODE_OFF+(depth*2)), - "", (IV)ST.count) + Perl_re_exec_indentf( aTHX_ "CURLYM trying tail with matches=%" IVdf "...\n", + depth, (IV)ST.count) ); if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) { if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) { @@ -7552,9 +8039,8 @@ NULL { /* simulate B failing */ DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=0x%"UVXf" c1=0x%"UVXf" c2=0x%"UVXf"\n", - (int)(REPORT_CODE_OFF+(depth*2)),"", + Perl_re_exec_indentf( aTHX_ "CURLYM Fast bail next target=0x%" UVXf " c1=0x%" UVXf " c2=0x%" UVXf "\n", + depth, valid_utf8_to_uvchr((U8 *) locinput, NULL), valid_utf8_to_uvchr(ST.c1_utf8, NULL), valid_utf8_to_uvchr(ST.c2_utf8, NULL)) @@ -7566,9 +8052,8 @@ NULL else if (nextchr != ST.c1 && nextchr != ST.c2) { /* simulate B failing */ DEBUG_OPTIMISE_r( - PerlIO_printf(Perl_debug_log, - "%*s CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n", - (int)(REPORT_CODE_OFF+(depth*2)),"", + Perl_re_exec_indentf( aTHX_ "CURLYM Fast bail next target=0x%X c1=0x%X c2=0x%X\n", + depth, (int) nextchr, ST.c1, ST.c2) ); state_num = CURLYM_B_fail; @@ -7589,8 +8074,8 @@ NULL } else rex->offs[paren].end = -1; - if (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.me->flags) + + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.me->flags)) { if (ST.count) goto fake_end; @@ -7600,7 +8085,6 @@ NULL } PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput); /* match B */ - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CURLYM_B_fail: /* just failed to match a B */ @@ -7660,8 +8144,8 @@ NULL 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 && - cur_eval->u.eval.close_paren == (U32)ST.paren) { + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren)) + { ST.min=1; ST.max=1; } @@ -7723,7 +8207,7 @@ NULL char *li = locinput; minmod = 0; if (ST.min && - regrepeat(rex, &li, ST.A, reginfo, ST.min, depth) + regrepeat(rex, &li, ST.A, reginfo, ST.min) < ST.min) sayNO; SET_locinput(li); @@ -7760,7 +8244,7 @@ NULL /* avoid taking address of locinput, so it can remain * a register var */ char *li = locinput; - ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max, depth); + ST.count = regrepeat(rex, &li, ST.A, reginfo, ST.max); if (ST.count < ST.min) sayNO; SET_locinput(li); @@ -7779,7 +8263,6 @@ NULL REGCP_SET(ST.cp); goto curly_try_B_max; } - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CURLY_B_min_known_fail: @@ -7824,16 +8307,46 @@ NULL } else { /* Not utf8_target */ if (ST.c1 == ST.c2) { - while (locinput <= ST.maxpos && - UCHARAT(locinput) != ST.c1) - locinput++; - } - else { - while (locinput <= ST.maxpos - && UCHARAT(locinput) != ST.c1 - && UCHARAT(locinput) != ST.c2) - locinput++; + locinput = (char *) memchr(locinput, + ST.c1, + ST.maxpos + 1 - locinput); + if (! locinput) { + locinput = ST.maxpos + 1; + } } + else { + U8 c1_c2_bits_differing = ST.c1 ^ ST.c2; + + if (! isPOWER_OF_2(c1_c2_bits_differing)) { + while ( locinput <= ST.maxpos + && UCHARAT(locinput) != ST.c1 + && UCHARAT(locinput) != ST.c2) + { + locinput++; + } + } + else { + /* If c1 and c2 only differ by a single bit, we can + * avoid a conditional each time through the loop, + * at the expense of a little preliminary setup and + * an extra mask each iteration. By masking out + * that bit, we match exactly two characters, c1 + * and c2, and so we don't have to test for both. + * On both ASCII and EBCDIC platforms, most of the + * ASCII-range and Latin1-range folded equivalents + * differ only in a single bit, so this is actually + * the most common case. (e.g. 'A' 0x41 vs 'a' + * 0x61). */ + U8 c1_masked = ST.c1 &~ c1_c2_bits_differing; + U8 c1_c2_mask = ~ c1_c2_bits_differing; + while ( locinput <= ST.maxpos + && (UCHARAT(locinput) & c1_c2_mask) + != c1_masked) + { + locinput++; + } + } + } n = locinput - ST.oldloc; } if (locinput > ST.maxpos) @@ -7844,18 +8357,15 @@ NULL * locinput matches */ char *li = ST.oldloc; ST.count += n; - if (regrepeat(rex, &li, ST.A, reginfo, n, depth) < n) + if (regrepeat(rex, &li, ST.A, reginfo, n) < n) sayNO; assert(n == REG_INFTY || locinput == li); } CURLY_SETPAREN(ST.paren, ST.count); - if (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.paren) { + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren)) goto fake_end; - } PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput); } - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case CURLY_B_min_fail: @@ -7868,7 +8378,7 @@ NULL /* failed -- move forward one */ { char *li = locinput; - if (!regrepeat(rex, &li, ST.A, reginfo, 1, depth)) { + if (!regrepeat(rex, &li, ST.A, reginfo, 1)) { sayNO; } locinput = li; @@ -7880,23 +8390,18 @@ NULL { curly_try_B_min: CURLY_SETPAREN(ST.paren, ST.count); - if (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.paren) { + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren)) goto fake_end; - } PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput); } } sayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ curly_try_B_max: /* a successful greedy match: now try to match B */ - if (cur_eval && cur_eval->u.eval.close_paren && - cur_eval->u.eval.close_paren == (U32)ST.paren) { + if (EVAL_CLOSE_PAREN_IS_TRUE(cur_eval,(U32)ST.paren)) goto fake_end; - } { bool could_match = locinput < reginfo->strend; @@ -7919,7 +8424,6 @@ NULL if (ST.c1 == CHRTEST_VOID || could_match) { CURLY_SETPAREN(ST.paren, ST.count); PUSH_STATE_GOTO(CURLY_B_max, ST.B, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } } @@ -7944,40 +8448,43 @@ NULL fake_end: if (cur_eval) { /* we've just finished A in /(??{A})B/; now continue with B */ - + SET_RECURSE_LOCINPUT("FAKE-END[before]", CUR_EVAL.prev_recurse_locinput); st->u.eval.prev_rex = rex_sv; /* inner */ /* Save *all* the positions. */ - st->u.eval.cp = regcppush(rex, 0, maxopenparen); - rex_sv = cur_eval->u.eval.prev_rex; + st->u.eval.cp = regcppush(rex, 0, maxopenparen); + rex_sv = CUR_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); - cur_curlyx = cur_eval->u.eval.prev_curlyx; + + st->u.eval.prev_curlyx = cur_curlyx; + cur_curlyx = CUR_EVAL.prev_curlyx; REGCP_SET(st->u.eval.lastcp); /* Restore parens of the outer rex without popping the * savestack */ - S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp, - &maxopenparen); + regcp_restore(rex, CUR_EVAL.lastcp, &maxopenparen); st->u.eval.prev_eval = cur_eval; - cur_eval = cur_eval->u.eval.prev_eval; + cur_eval = CUR_EVAL.prev_eval; DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n", - REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval));); + Perl_re_exec_indentf( aTHX_ "EVAL trying tail ... (cur_eval=%p)\n", + depth, cur_eval);); if ( nochange_depth ) nochange_depth--; - PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B, + SET_RECURSE_LOCINPUT("FAKE-END[after]", cur_eval->locinput); + + PUSH_YES_STATE_GOTO(EVAL_postponed_AB, st->u.eval.prev_eval->u.eval.B, locinput); /* match B */ } if (locinput < reginfo->till) { - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, - "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ + "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n", PL_colors[4], (long)(locinput - startpos), (long)(reginfo->till - startpos), @@ -7989,9 +8496,8 @@ NULL case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */ DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %ssubpattern success...%s\n", - REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])); + Perl_re_exec_indentf( aTHX_ "%ssubpattern success...%s\n", + depth, PL_colors[4], PL_colors[5])); sayYES; /* Success! */ #undef ST @@ -8039,7 +8545,6 @@ NULL /* execute body of (?...A) */ PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), newstart); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } @@ -8080,7 +8585,6 @@ NULL if (scan->flags) sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]); PUSH_STATE_GOTO(COMMIT_next, next, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case COMMIT_next_fail: @@ -8101,7 +8605,6 @@ NULL } else { sayNO; } - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ #define ST st->u.mark @@ -8112,13 +8615,11 @@ NULL mark_state = st; ST.mark_loc = locinput; PUSH_YES_STATE_GOTO(MARKPOINT_next, next, locinput); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case MARKPOINT_next: mark_state = ST.prev_mark; sayYES; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case MARKPOINT_next_fail: @@ -8130,9 +8631,8 @@ NULL sv_commit = ST.mark_name; DEBUG_EXECUTE_r({ - PerlIO_printf(Perl_debug_log, - "%*s %ssetting cutpoint to mark:%"SVf"...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_exec_indentf( aTHX_ "%ssetting cutpoint to mark:%" SVf "...%s\n", + depth, PL_colors[4], SVfARG(sv_commit), PL_colors[5]); }); } @@ -8140,7 +8640,6 @@ NULL sv_yes_mark = mark_state ? mark_state->u.mark.mark_name : NULL; sayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ case SKIP: /* (*SKIP) */ @@ -8186,7 +8685,6 @@ NULL } no_final = 1; sayNO; - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ #undef ST @@ -8198,7 +8696,7 @@ NULL break; default: - PerlIO_printf(Perl_error_log, "%"UVxf" %d\n", + PerlIO_printf(Perl_error_log, "%" UVxf " %d\n", PTR2UV(scan), OP(scan)); Perl_croak(aTHX_ "regexp memory corruption"); @@ -8208,7 +8706,8 @@ NULL assert(!NEXTCHR_IS_EOS); if (utf8_target) { locinput += PL_utf8skip[nextchr]; - /* locinput is allowed to go 1 char off the end, but not 2+ */ + /* locinput is allowed to go 1 char off the end (signifying + * EOS), but not 2+ */ if (locinput > reginfo->strend) sayNO; } @@ -8236,16 +8735,17 @@ NULL DEBUG_STACK_r({ regmatch_state *cur = st; regmatch_state *curyes = yes_state; - int curd = depth; + U32 i; regmatch_slab *slab = PL_regmatch_slab; - for (;curd > -1;cur--,curd--) { + for (i = 0; i < 3 && i <= depth; cur--,i++) { if (cur < SLAB_FIRST(slab)) { slab = slab->prev; cur = SLAB_LAST(slab); } - PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n", - REPORT_CODE_OFF + 2 + depth * 2,"", - curd, PL_reg_name[cur->resume_state], + Perl_re_exec_indentf( aTHX_ "%4s #%-3d %-10s %s\n", + depth, + i ? " " : "push", + depth - i, PL_reg_name[cur->resume_state], (curyes == cur) ? "yes" : "" ); if (curyes == cur) @@ -8267,14 +8767,15 @@ NULL /* NOTREACHED */ } } +#ifdef SOLARIS_BAD_OPTIMIZER +# undef PL_charclass +#endif /* * We get here only if there's trouble -- normally "case END" is * the terminating point. */ Perl_croak(aTHX_ "corrupted regexp pointers"); - /* NOTREACHED */ - sayNO; NOT_REACHED; /* NOTREACHED */ yes: @@ -8319,7 +8820,7 @@ NULL goto reenter_switch; } - DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n", + DEBUG_EXECUTE_r(Perl_re_printf( aTHX_ "%sMatch successful!%s\n", PL_colors[4], PL_colors[5])); if (reginfo->info_aux_eval) { @@ -8340,9 +8841,8 @@ NULL no: DEBUG_EXECUTE_r( - PerlIO_printf(Perl_debug_log, - "%*s %sfailed...%s\n", - REPORT_CODE_OFF+depth*2, "", + Perl_re_exec_indentf( aTHX_ "%sfailed...%s\n", + depth, PL_colors[4], PL_colors[5]) ); @@ -8370,6 +8870,7 @@ NULL yes_state = st->u.yes.prev_yes_state; state_num = st->resume_state + 1; /* failure = success + 1 */ + PERL_ASYNC_CHECK(); goto reenter_switch; } result = 0; @@ -8396,9 +8897,12 @@ NULL if (last_pushed_cv) { dSP; + /* see "Some notes about MULTICALL" above */ POP_MULTICALL; PERL_UNUSED_VAR(SP); } + else + LEAVE_SCOPE(orig_savestack_ix); assert(!result || locinput - reginfo->strbeg >= 0); return result ? locinput - reginfo->strbeg : -1; @@ -8420,7 +8924,7 @@ NULL */ STATIC I32 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, - regmatch_info *const reginfo, I32 max, int depth) + regmatch_info *const reginfo, I32 max _pDEPTH) { char *scan; /* Pointer to current position in target string */ I32 c; @@ -8430,9 +8934,6 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, unsigned int to_complement = 0; /* Invert the result? */ UV utf8_flags; _char_class_number classnum; -#ifndef DEBUGGING - PERL_UNUSED_ARG(depth); -#endif PERL_ARGS_ASSERT_REGREPEAT; @@ -8637,10 +9138,27 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } } else { - while (scan < loceol && - (UCHARAT(scan) == c1 || UCHARAT(scan) == c2)) - { - scan++; + /* See comments in regmatch() CURLY_B_min_known_fail. We avoid + * a conditional each time through the loop if the characters + * differ only in a single bit, as is the usual situation */ + U8 c1_c2_bits_differing = c1 ^ c2; + + if (isPOWER_OF_2(c1_c2_bits_differing)) { + U8 c1_masked = c1 & ~ c1_c2_bits_differing; + U8 c1_c2_mask = ~ c1_c2_bits_differing; + + while ( scan < loceol + && (UCHARAT(scan) & c1_c2_mask) == c1_masked) + { + scan++; + } + } + else { + while ( scan < loceol + && (UCHARAT(scan) == c1 || UCHARAT(scan) == c2)) + { + scan++; + } } } } @@ -8663,12 +9181,45 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, scan += UTF8SKIP(scan); hardcount++; } - } else { - while (scan < loceol && REGINCLASS(prog, p, (U8*)scan)) + } + else if (ANYOF_FLAGS(p)) { + while (scan < loceol + && reginclass(prog, p, (U8*)scan, (U8*)scan+1, 0)) + scan++; + } + else { + while (scan < loceol && ANYOF_BITMAP_TEST(p, *((U8*)scan))) scan++; } break; + case ASCII: + if (utf8_target && loceol - scan > max) { + + /* 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; + } + + scan = find_next_non_ascii(scan, loceol, utf8_target); + break; + + case NASCII: + if (utf8_target) { + while ( hardcount < max + && scan < loceol + && ! isASCII_utf8_safe(scan, loceol)) + { + scan += UTF8SKIP(scan); + hardcount++; + } + } + else { + scan = find_next_ascii(scan, loceol, utf8_target); + } + break; + /* The argument (FLAGS) to all the POSIX node types is the class number */ case NPOSIXL: @@ -8731,7 +9282,7 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, /* The complement of something that matches only ASCII matches all * non-ASCII, plus everything in ASCII that isn't in the class. */ while (hardcount < max && scan < loceol - && (! isASCII_utf8(scan) + && ( ! isASCII_utf8_safe(scan, reginfo->strend) || ! _generic_isCC_A((U8) *scan, FLAGS(p)))) { scan += UTF8SKIP(scan); @@ -8799,7 +9350,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_SPACE: while (hardcount < max && scan < loceol - && (to_complement ^ cBOOL(isSPACE_utf8(scan)))) + && (to_complement + ^ cBOOL(isSPACE_utf8_safe(scan, loceol)))) { scan += UTF8SKIP(scan); hardcount++; @@ -8808,7 +9360,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_BLANK: while (hardcount < max && scan < loceol - && (to_complement ^ cBOOL(isBLANK_utf8(scan)))) + && (to_complement + ^ cBOOL(isBLANK_utf8_safe(scan, loceol)))) { scan += UTF8SKIP(scan); hardcount++; @@ -8817,7 +9370,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_XDIGIT: while (hardcount < max && scan < loceol - && (to_complement ^ cBOOL(isXDIGIT_utf8(scan)))) + && (to_complement + ^ cBOOL(isXDIGIT_utf8_safe(scan, loceol)))) { scan += UTF8SKIP(scan); hardcount++; @@ -8826,7 +9380,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_VERTSPACE: while (hardcount < max && scan < loceol - && (to_complement ^ cBOOL(isVERTWS_utf8(scan)))) + && (to_complement + ^ cBOOL(isVERTWS_utf8_safe(scan, loceol)))) { scan += UTF8SKIP(scan); hardcount++; @@ -8835,7 +9390,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, case _CC_ENUM_CNTRL: while (hardcount < max && scan < loceol - && (to_complement ^ cBOOL(isCNTRL_utf8(scan)))) + && (to_complement + ^ cBOOL(isCNTRL_utf8_safe(scan, loceol)))) { scan += UTF8SKIP(scan); hardcount++; @@ -8861,9 +9417,10 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, } while (hardcount < max && scan < loceol - && to_complement ^ cBOOL(_generic_utf8( + && to_complement ^ cBOOL(_generic_utf8_safe( classnum, scan, + loceol, swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *) scan, TRUE)))) @@ -8913,7 +9470,6 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, default: Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]); - /* NOTREACHED */ NOT_REACHED; /* NOTREACHED */ } @@ -8929,9 +9485,8 @@ S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p, DEBUG_EXECUTE_r({ SV * const prop = sv_newmortal(); regprop(prog, prop, p, reginfo, NULL); - PerlIO_printf(Perl_debug_log, - "%*s %s can match %"IVdf" times out of %"IVdf"...\n", - REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max); + Perl_re_exec_indentf( aTHX_ "%s can match %" IVdf " times out of %" IVdf "...\n", + depth, SvPVX_const(prop),(IV)c,(IV)max); }); }); @@ -8989,13 +9544,14 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const * UTF8_IS_INVARIANT() works even if not in UTF-8 */ if (! UTF8_IS_INVARIANT(c) && utf8_target) { STRLEN c_len = 0; - c = utf8n_to_uvchr(p, p_end - p, &c_len, - (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) - | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY); - /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for - * UTF8_ALLOW_FFFF */ - if (c_len == (STRLEN)-1) - Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)"); + const U32 utf8n_flags = UTF8_ALLOW_DEFAULT; + c = utf8n_to_uvchr(p, p_end - p, &c_len, utf8n_flags | UTF8_CHECK_ONLY); + if (c_len == (STRLEN)-1) { + _force_out_malformed_utf8_message(p, p_end, + utf8n_flags, + 1 /* 1 means die */ ); + NOT_REACHED; /* NOTREACHED */ + } if (c > 255 && OP(n) == ANYOFL && ! ANYOFL_UTF8_LOCALE_REQD(flags)) { _CHECK_AND_OUTPUT_WIDE_LOCALE_CP_MSG(c); } @@ -9132,7 +9688,7 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const && ckWARN_d(WARN_NON_UNICODE)) { Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE), - "Matched non-Unicode code point 0x%04"UVXf" against Unicode property; may not be portable", c); + "Matched non-Unicode code point 0x%04" UVXf " against Unicode property; may not be portable", c); } } @@ -9158,7 +9714,10 @@ S_reghop3(U8 *s, SSize_t off, const U8* lim) if (off >= 0) { while (off-- && s < lim) { /* XXX could check well-formedness here */ - s += UTF8SKIP(s); + U8 *new_s = s + UTF8SKIP(s); + if (new_s > lim) /* lim may be in the middle of a long character */ + return s; + s = new_s; } } else { @@ -9208,7 +9767,7 @@ S_reghop4(U8 *s, SSize_t off, const U8* llim, const U8* rlim) * char pos */ STATIC U8 * -S_reghopmaybe3(U8* s, SSize_t off, const U8* lim) +S_reghopmaybe3(U8* s, SSize_t off, const U8* const lim) { PERL_ARGS_ASSERT_REGHOPMAYBE3; @@ -9301,6 +9860,7 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo) } SET_reg_curpm(reginfo->prog); eval_state->curpm = PL_curpm; + PL_curpm_under = PL_curpm; PL_curpm = PL_reg_curpm; if (RXp_MATCH_COPIED(rex)) { /* Here is a serious problem: we cannot rewrite subbeg, @@ -9449,6 +10009,410 @@ S_to_byte_substr(pTHX_ regexp *prog) return TRUE; } +#ifndef PERL_IN_XSUB_RE + +bool +Perl__is_grapheme(pTHX_ const U8 * strbeg, const U8 * s, const U8 * strend, const UV cp) +{ + /* Temporary helper function for toke.c. Verify that the code point 'cp' + * is a stand-alone grapheme. The UTF-8 for 'cp' begins at position 's' in + * the larger string bounded by 'strbeg' and 'strend'. + * + * 'cp' needs to be assigned (if not a future version of the Unicode + * Standard could make it something that combines with adjacent characters, + * so code using it would then break), and there has to be a GCB break + * before and after the character. */ + + GCB_enum cp_gcb_val, prev_cp_gcb_val, next_cp_gcb_val; + const U8 * prev_cp_start; + + PERL_ARGS_ASSERT__IS_GRAPHEME; + + /* Unassigned code points are forbidden */ + if (UNLIKELY(! ELEMENT_RANGE_MATCHES_INVLIST( + _invlist_search(PL_Assigned_invlist, cp)))) + { + return FALSE; + } + + cp_gcb_val = getGCB_VAL_CP(cp); + + /* Find the GCB value of the previous code point in the input */ + prev_cp_start = utf8_hop_back(s, -1, strbeg); + if (UNLIKELY(prev_cp_start == s)) { + prev_cp_gcb_val = GCB_EDGE; + } + else { + prev_cp_gcb_val = getGCB_VAL_UTF8(prev_cp_start, strend); + } + + /* And check that is a grapheme boundary */ + if (! isGCB(prev_cp_gcb_val, cp_gcb_val, strbeg, s, + TRUE /* is UTF-8 encoded */ )) + { + return FALSE; + } + + /* Similarly verify there is a break between the current character and the + * following one */ + s += UTF8SKIP(s); + if (s >= strend) { + next_cp_gcb_val = GCB_EDGE; + } + else { + next_cp_gcb_val = getGCB_VAL_UTF8(s, strend); + } + + return isGCB(cp_gcb_val, next_cp_gcb_val, strbeg, s, TRUE); +} + +#endif + +bool +Perl_isSCRIPT_RUN(pTHX_ const U8 * s, const U8 * send, const bool utf8_target) +{ + /* Checks that every character in the sequence from 's' to 'send' is one of + * three scripts: Common, Inherited, and possibly one other. Additionally + * all decimal digits must come from the same consecutive sequence of 10. + * 'utf8_target' is TRUE iff the sequence is encoded in UTF-8. + * + * Basically, it looks at each character in the sequence to see if the + * above conditions are met; if not it fails. It uses an inversion map to + * find the enum corresponding to the script of each character. But this + * is complicated by the fact that a few code points can be in any of + * several scripts. The data has been constructed so that there are + * additional enum values (all negative) for these situations. The + * absolute value of those is an index into another table which contains + * pointers to auxiliary tables for each such situation. Each aux array + * lists all the scripts for the given situation. There is another, + * parallel, table that gives the number of entries in each aux table. + * These are all defined in charclass_invlists.h */ + + /* XXX Here are the additional things UTS 39 says could be done: + * Mark Chinese strings as “mixed script” if they contain both simplified + * (S) and traditional (T) Chinese characters, using the Unihan data in the + * Unicode Character Database [UCD]. The criterion can only be applied if + * the language of the string is known to be Chinese. So, for example, the + * string “写真だけの結婚式 ” is Japanese, and should not be marked as + * mixed script because of a mixture of S and T characters. Testing for + * whether a character is S or T needs to be based not on whether the + * character has a S or T variant , but whether the character is an S or T + * variant. khw notes that the sample contains a Hiragana character, and it + * is unclear if absence of any foreign script marks the script as + * "Chinese" + * + * Forbid sequences of the same nonspacing mark + * + * Check to see that all the characters are in the sets of exemplar + * characters for at least one language in the Unicode Common Locale Data + * Repository [CLDR]. */ + + + /* Things that match /\d/u */ + SV * decimals_invlist = PL_XPosix_ptrs[_CC_DIGIT]; + UV * decimals_array = invlist_array(decimals_invlist); + + /* What code point is the digit '0' of the script run? */ + UV zero_of_run = 0; + SCX_enum script_of_run = SCX_INVALID; /* Illegal value */ + SCX_enum script_of_char = SCX_INVALID; + + /* If the script remains not fully determined from iteration to iteration, + * this is the current intersection of the possiblities. */ + SCX_enum * intersection = NULL; + PERL_UINT_FAST8_T intersection_len = 0; + + bool retval = TRUE; + + assert(send > s); + + PERL_ARGS_ASSERT_ISSCRIPT_RUN; + + /* Look at each character in the sequence */ + while (s < send) { + UV cp; + + /* The code allows all scripts to use the ASCII digits. This is + * because they are used in commerce even in scripts that have their + * own set. Hence any ASCII ones found are ok, unless a digit from + * another set has already been encountered. (The other digit ranges + * in Common are not similarly blessed */ + if (UNLIKELY(isDIGIT(*s))) { + if (zero_of_run > 0) { + if (zero_of_run != '0') { + retval = FALSE; + break; + } + } + else { + zero_of_run = '0'; + } + s++; + continue; + } + + /* Here, isn't an ASCII digit. Find the code point of the character */ + if (utf8_target && ! UTF8_IS_INVARIANT(*s)) { + Size_t len; + cp = valid_utf8_to_uvchr((U8 *) s, &len); + s += len; + } + else { + cp = *(s++); + } + + /* If is within the range [+0 .. +9] of the script's zero, it also is a + * digit in that script. We can skip the rest of this code for this + * character. */ + if (UNLIKELY( zero_of_run > 0 + && cp >= zero_of_run + && cp - zero_of_run <= 9)) + { + continue; + } + + /* Find the character's script. The correct values are hard-coded here + * for small-enough code points. */ + if (cp < 0x2B9) { /* From inspection of Unicode db; extremely + unlikely to change */ + if ( cp > 255 + || ( isALPHA_L1(cp) + && LIKELY(cp != MICRO_SIGN_NATIVE))) + { + script_of_char = SCX_Latin; + } + else { + script_of_char = SCX_Common; + } + } + else { + script_of_char = _Perl_SCX_invmap[ + _invlist_search(PL_SCX_invlist, cp)]; + } + + /* We arbitrarily accept a single unassigned character, but not in + * combination with anything else, and not a run of them. */ + if ( UNLIKELY(script_of_run == SCX_Unknown) + || UNLIKELY( script_of_run != SCX_INVALID + && script_of_char == SCX_Unknown)) + { + retval = FALSE; + break; + } + + if (UNLIKELY(script_of_char == SCX_Unknown)) { + script_of_run = SCX_Unknown; + continue; + } + + /* We accept 'inherited' script characters currently even at the + * beginning. (We know that no characters in Inherited are digits, or + * we'd have to check for that) */ + if (UNLIKELY(script_of_char == SCX_Inherited)) { + continue; + } + + /* If unknown, the run's script is set to the char's */ + if (UNLIKELY(script_of_run == SCX_INVALID)) { + script_of_run = script_of_char; + } + + /* All decimal digits must be from the same sequence of 10. Above, we + * handled any ASCII digits without descending to here. We also + * handled the case where we already knew what digit sequence is the + * one to use, and the character is in that sequence. Now that we know + * the script, we can use script_zeros[] to directly find which + * sequence the script uses, except in a few cases it returns 0 */ + if (UNLIKELY(zero_of_run == 0) && script_of_char >= 0) { + zero_of_run = script_zeros[script_of_char]; + } + + /* Now we can see if the script of the character is the same as that of + * the run, or 'Common' which is considered to be in every script */ + if (LIKELY( script_of_char == script_of_run + || script_of_char == SCX_Common)) + { /* By far the most common case */ + goto scripts_match; + } + +#ifndef HAS_SCX_AUX_TABLES + + /* Too early a Unicode version to have a code point belonging to more + * than one script, so, if the scripts don't exactly match, fail */ + retval = FALSE; + break; + +#else + + /* Here there is no exact match between the character's script and the + * run's. Negative script numbers signify that the value may be any of + * several scripts, and we need to look at auxiliary information to + * make our deterimination. But if both are non-negative, we can fail + * now */ + if (LIKELY(script_of_char >= 0)) { + const SCX_enum * search_in; + PERL_UINT_FAST8_T search_in_len; + PERL_UINT_FAST8_T i; + + if (LIKELY(script_of_run >= 0)) { + retval = FALSE; + break; + } + + /* Use any previously constructed set of possible scripts. + * */ + if (intersection) { + search_in = intersection; + search_in_len = intersection_len; + } + else { + search_in = SCX_AUX_TABLE_ptrs[-script_of_run]; + search_in_len = SCX_AUX_TABLE_lengths[-script_of_run]; + } + + for (i = 0; i < search_in_len; i++) { + if (search_in[i] == script_of_char) { + script_of_run = script_of_char; + goto scripts_match; + } + } + + retval = FALSE; + break; + } + else if (LIKELY(script_of_run >= 0)) { + /* script of character could be one of several, but run is a single + * script */ + const SCX_enum * search_in = SCX_AUX_TABLE_ptrs[-script_of_char]; + const PERL_UINT_FAST8_T search_in_len + = SCX_AUX_TABLE_lengths[-script_of_char]; + PERL_UINT_FAST8_T i; + + for (i = 0; i < search_in_len; i++) { + if (search_in[i] == script_of_run) { + script_of_char = script_of_run; + goto scripts_match; + } + } + + retval = FALSE; + break; + } + else { + /* Both run and char could be in one of several scripts. If the + * intersection is empty, then this character isn't in this script + * run. Otherwise, we need to calculate the intersection to use + * for future iterations of the loop, unless we are already at the + * final character */ + const SCX_enum * search_char = SCX_AUX_TABLE_ptrs[-script_of_char]; + const PERL_UINT_FAST8_T char_len + = SCX_AUX_TABLE_lengths[-script_of_char]; + const SCX_enum * search_run; + PERL_UINT_FAST8_T run_len; + + SCX_enum * new_overlap = NULL; + PERL_UINT_FAST8_T i, j; + + if (intersection) { + search_run = intersection; + run_len = intersection_len; + } + else { + search_run = SCX_AUX_TABLE_ptrs[-script_of_run]; + run_len = SCX_AUX_TABLE_lengths[-script_of_run]; + } + + intersection_len = 0; + + for (i = 0; i < run_len; i++) { + for (j = 0; j < char_len; j++) { + if (search_run[i] == search_char[j]) { + + /* Here, the script at i,j matches. That means this + * character is in the run. But continue on to find + * the complete intersection, for the next loop + * iteration, and for the digit check after it. + * + * On the first found common script, we malloc space + * for the intersection list for the worst case of the + * intersection, which is the minimum of the number of + * scripts remaining in each set. */ + if (intersection_len == 0) { + Newx(new_overlap, + MIN(run_len - i, char_len - j), + SCX_enum); + } + new_overlap[intersection_len++] = search_run[i]; + } + } + } + + /* Here we've looked through everything. If they have no scripts + * in common, not a run */ + if (intersection_len == 0) { + retval = FALSE; + break; + } + + /* If there is only a single script in common, set to that. + * Otherwise, use the intersection going forward */ + Safefree(intersection); + if (intersection_len == 1) { + script_of_run = script_of_char = new_overlap[0]; + Safefree(new_overlap); + } + else { + intersection = new_overlap; + } + } + +#endif + + scripts_match: ; + + /* Here, the script of the character is compatible with that of the + * run. Either they match exactly, or one or both can be any of + * several scripts, and the intersection is not empty. If the + * character is not a decimal digit, we are done with it. Otherwise, + * it could still fail if it is from a different set of 10 than seen + * already (or we may not have seen any, and we need to set the + * sequence). If we have determined a single script and that script + * only has one set of digits (almost all scripts are like that), then + * this isn't a problem, as any digit must come from the same sequence. + * The only scripts that have multiple sequences have been constructed + * to be 0 in 'script_zeros[]'. + * + * Here we check if it is a digit. */ + if ( cp >= FIRST_NON_ASCII_DECIMAL_DIGIT + && ( ( zero_of_run == 0 + || ( ( script_of_char >= 0 + && script_zeros[script_of_char] == 0) + || intersection)))) + { + SSize_t range_zero_index; + range_zero_index = _invlist_search(decimals_invlist, cp); + if ( LIKELY(range_zero_index >= 0) + && ELEMENT_RANGE_MATCHES_INVLIST(range_zero_index)) + { + UV range_zero = decimals_array[range_zero_index]; + if (zero_of_run) { + if (zero_of_run != range_zero) { + retval = FALSE; + break; + } + } + else { + zero_of_run = range_zero; + } + } + } + } /* end of looping through CLOSESR text */ + + Safefree(intersection); + return retval; +} + + /* * ex: set ts=8 sts=4 sw=4 et: */