X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/36baafc9b54ecc5cdea82552276a70b5218958bb..b8372399b387c0e276aee3d41b3c7833dd08087b:/regcomp.c diff --git a/regcomp.c b/regcomp.c index a16b8b3..6bd7efd 100644 --- a/regcomp.c +++ b/regcomp.c @@ -126,7 +126,9 @@ typedef struct RExC_state_t { I32 whilem_seen; /* number of WHILEM in this expr */ regnode *emit_start; /* Start of emitted-code area */ regnode *emit_bound; /* First regnode outside of the allocated space */ - regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */ + regnode *emit; /* Code-emit pointer; if = &emit_dummy, + implies compiling, so don't emit */ + regnode emit_dummy; /* placeholder for emit to point to */ I32 naughty; /* How bad is this pattern? */ I32 sawback; /* Did we see \1, ...? */ U32 seen; @@ -187,6 +189,7 @@ typedef struct RExC_state_t { #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */ #endif #define RExC_emit (pRExC_state->emit) +#define RExC_emit_dummy (pRExC_state->emit_dummy) #define RExC_emit_start (pRExC_state->emit_start) #define RExC_emit_bound (pRExC_state->emit_bound) #define RExC_naughty (pRExC_state->naughty) @@ -231,8 +234,9 @@ typedef struct RExC_state_t { * REGNODE_SIMPLE */ #define SIMPLE 0x02 #define SPSTART 0x04 /* Starts with * or + */ -#define TRYAGAIN 0x08 /* Weeded out a declaration. */ -#define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */ +#define POSTPONED 0x08 /* (?1),(?&name), (??{...}) or similar */ +#define TRYAGAIN 0x10 /* Weeded out a declaration. */ +#define RESTART_UTF8 0x20 /* Restart, need to calcuate sizes as UTF-8 */ #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1) @@ -251,10 +255,11 @@ typedef struct RExC_state_t { #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren) #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren)) -/* If not already in utf8, do a longjmp back to the beginning */ -#define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */ #define REQUIRE_UTF8 STMT_START { \ - if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \ + if (!UTF) { \ + *flagp = RESTART_UTF8; \ + return NULL; \ + } \ } STMT_END /* This converts the named class defined in regcomp.h to its equivalent class @@ -548,6 +553,19 @@ static const scan_data_t zero_scan_data = (int)offset, RExC_precomp, RExC_precomp + offset); \ } STMT_END +#define vWARN_dep(loc, m) STMT_START { \ + const IV offset = loc - RExC_precomp; \ + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ +} STMT_END + +#define ckWARNdep(loc,m) STMT_START { \ + const IV offset = loc - RExC_precomp; \ + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ + m REPORT_LOCATION, \ + (int)offset, RExC_precomp, RExC_precomp + offset); \ +} STMT_END + #define ckWARNregdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ @@ -736,7 +754,7 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *min data->offset_float_min = l ? data->last_start_min : data->pos_min; data->offset_float_max = (l ? data->last_start_max - : data->pos_min + data->pos_delta); + : (data->pos_delta == I32_MAX ? I32_MAX : data->pos_min + data->pos_delta)); if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX) data->offset_float_max = I32_MAX; if (data->flags & SF_BEFORE_EOL) @@ -1015,7 +1033,9 @@ S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, con /* OR char bitmap and class bitmap separately */ for (i = 0; i < ANYOF_BITMAP_SIZE; i++) cl->bitmap[i] |= or_with->bitmap[i]; - ANYOF_CLASS_OR(or_with, cl); + if (or_with->flags & ANYOF_CLASS) { + ANYOF_CLASS_OR(or_with, cl); + } } else { /* XXXX: logic is complicated, leave it along for a moment. */ cl_anything(pRExC_state, cl); @@ -1439,7 +1459,7 @@ is the recommended Unicode-aware way of saying len = 0; \ } else { \ len = 1; \ - uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \ + uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, FOLD_FLAGS_FULL); \ skiplen = UNISKIP(uvc); \ foldlen -= skiplen; \ scan = foldbuf + skiplen; \ @@ -2669,29 +2689,37 @@ S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode * this file makes sure that in EXACTFU nodes, the sharp s gets folded to * 'ss', even if the pattern isn't UTF-8. This avoids the issues * described in the next item. - * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches - * 'ss' or not is not knowable at compile time. It will match iff the - * target string is in UTF-8, unlike the EXACTFU nodes, where it always - * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus - * it can't be folded to "ss" at compile time, unlike EXACTFU does (as - * described in item 3). An assumption that the optimizer part of - * regexec.c (probably unwittingly) makes is that a character in the - * pattern corresponds to at most a single character in the target string. - * (And I do mean character, and not byte here, unlike other parts of the - * documentation that have never been updated to account for multibyte - * Unicode.) This assumption is wrong only in this case, as all other - * cases are either 1-1 folds when no UTF-8 is involved; or is true by - * virtue of having this file pre-fold UTF-8 patterns. I'm - * reluctant to try to change this assumption, so instead the code punts. - * This routine examines EXACTF nodes for the sharp s, and returns a - * boolean indicating whether or not the node is an EXACTF node that - * contains a sharp s. When it is true, the caller sets a flag that later - * causes the optimizer in this file to not set values for the floating - * and fixed string lengths, and thus avoids the optimizer code in - * regexec.c that makes the invalid assumption. Thus, there is no - * optimization based on string lengths for EXACTF nodes that contain the - * sharp s. This only happens for /id rules (which means the pattern - * isn't in UTF-8). + * 4) A problem remains for the sharp s in EXACTF and EXACTFA nodes when the + * pattern isn't in UTF-8. (BTW, there cannot be an EXACTF node with a + * UTF-8 pattern.) An assumption that the optimizer part of regexec.c + * (probably unwittingly, in Perl_regexec_flags()) makes is that a + * character in the pattern corresponds to at most a single character in + * the target string. (And I do mean character, and not byte here, unlike + * other parts of the documentation that have never been updated to + * account for multibyte Unicode.) sharp s in EXACTF nodes can match the + * two character string 'ss'; in EXACTFA nodes it can match + * "\x{17F}\x{17F}". These violate the assumption, and they are the only + * instances where it is violated. I'm reluctant to try to change the + * assumption, as the code involved is impenetrable to me (khw), so + * instead the code here punts. This routine examines (when the pattern + * isn't UTF-8) EXACTF and EXACTFA nodes for the sharp s, and returns a + * boolean indicating whether or not the node contains a sharp s. When it + * is true, the caller sets a flag that later causes the optimizer in this + * file to not set values for the floating and fixed string lengths, and + * thus avoids the optimizer code in regexec.c that makes the invalid + * assumption. Thus, there is no optimization based on string lengths for + * non-UTF8-pattern EXACTF and EXACTFA nodes that contain the sharp s. + * (The reason the assumption is wrong only in these two cases is that all + * other non-UTF-8 folds are 1-1; and, for UTF-8 patterns, we pre-fold all + * other folds to their expanded versions. We can't prefold sharp s to + * 'ss' in EXACTF nodes because we don't know at compile time if it + * actually matches 'ss' or not. It will match iff the target string is + * in UTF-8, unlike the EXACTFU nodes, where it always matches; and + * EXACTFA and EXACTFL where it never does. In an EXACTFA node in a UTF-8 + * pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the problem; + * but in a non-UTF8 pattern, folding it to that above-Latin1 string would + * require the pattern to be forced into UTF-8, the overhead of which we + * want to avoid.) */ #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \ @@ -2821,7 +2849,8 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b OP(scan) = EXACTFU_SS; s += 2; } - else if (len == 6 /* len is the same in both ASCII and EBCDIC for these */ + else if (len == 6 /* len is the same in both ASCII and EBCDIC + for these */ && (memEQ(s, GREEK_SMALL_LETTER_IOTA_UTF8 COMBINING_DIAERESIS_UTF8 COMBINING_ACUTE_ACCENT_UTF8, @@ -2881,13 +2910,30 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, b next_iteration: ; } } - else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) { + else if (OP(scan) == EXACTFA) { - /* Here, the pattern is not UTF-8. Look for the multi-char folds - * that are all ASCII. As in the above case, EXACTFL and EXACTFA - * nodes can't have multi-char folds to this range (and there are - * no existing ones in the upper latin1 range). In the EXACTF - * case we look also for the sharp s, which can be in the final + /* Non-UTF-8 pattern, EXACTFA node. There can't be a multi-char + * fold to the ASCII range (and there are no existing ones in the + * upper latin1 range). But, as outlined in the comments preceding + * this function, we need to flag any occurrences of the sharp s */ + while (s < s_end) { + if (*s == LATIN_SMALL_LETTER_SHARP_S) { + *has_exactf_sharp_s = TRUE; + break; + } + s++; + continue; + } + } + else if (OP(scan) != EXACTFL) { + + /* Non-UTF-8 pattern, not EXACTFA nor EXACTFL node. Look for the + * multi-char folds that are all Latin1. (This code knows that + * there are no current multi-char folds possible with EXACTFL, + * relying on fold_grind.t to catch any errors if the very unlikely + * event happens that some get added in future Unicode versions.) + * As explained in the comments preceding this function, we look + * also for the sharp s in EXACTF nodes; it can be in the final * position. Otherwise we can stop looking 1 byte earlier because * have to find at least two characters for a multi-fold */ const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1; @@ -3111,10 +3157,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, stopparen, recursed, NULL, f,depth+1); if (min1 > minnext) min1 = minnext; - if (max1 < minnext + deltanext) - max1 = minnext + deltanext; - if (deltanext == I32_MAX) + if (deltanext == I32_MAX) { is_inf = is_inf_internal = 1; + max1 = I32_MAX; + } else if (max1 < minnext + deltanext) + max1 = minnext + deltanext; scan = next; if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; @@ -3137,12 +3184,18 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, min1 = 0; if (flags & SCF_DO_SUBSTR) { data->pos_min += min1; - data->pos_delta += max1 - min1; + if (data->pos_delta >= I32_MAX - (max1 - min1)) + data->pos_delta = I32_MAX; + else + data->pos_delta += max1 - min1; if (max1 != min1 || is_inf) data->longest = &(data->longest_float); } min += min1; - delta += max1 - min1; + if (delta == I32_MAX || I32_MAX - delta - (max1 - min1) < 0) + delta = I32_MAX; + else + delta += max1 - min1; if (flags & SCF_DO_STCLASS_OR) { cl_or(pRExC_state, data->start_class, &accum); if (min1) { @@ -3871,11 +3924,13 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } min += minnext * mincount; - is_inf_internal |= ((maxcount == REG_INFTY - && (minnext + deltanext) > 0) - || deltanext == I32_MAX); + is_inf_internal |= deltanext == I32_MAX + || (maxcount == REG_INFTY && minnext + deltanext > 0); is_inf |= is_inf_internal; - delta += (minnext + deltanext) * maxcount - minnext * mincount; + if (is_inf) + delta = I32_MAX; + else + delta += (minnext + deltanext) * maxcount - minnext * mincount; /* Try powerful optimization CURLYX => CURLYN. */ if ( OP(oscan) == CURLYX && data @@ -4060,7 +4115,16 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } /* It is counted once already... */ data->pos_min += minnext * (mincount - counted); - data->pos_delta += - counted * deltanext + +#if 0 +PerlIO_printf(Perl_debug_log, "counted=%d deltanext=%d I32_MAX=%d minnext=%d maxcount=%d mincount=%d\n", + counted, deltanext, I32_MAX, minnext, maxcount, mincount); +if (deltanext != I32_MAX) +PerlIO_printf(Perl_debug_log, "LHS=%d RHS=%d\n", -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount, I32_MAX - data->pos_delta); +#endif + if (deltanext == I32_MAX || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= I32_MAX - data->pos_delta) + data->pos_delta = I32_MAX; + else + data->pos_delta += - counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount; if (mincount != maxcount) { /* Cannot extend fixed substrings found inside @@ -4095,7 +4159,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, NEXT_OFF(oscan) += NEXT_OFF(next); } continue; - default: /* REF, ANYOFV, and CLUMP only? */ + default: /* REF, and CLUMP only? */ if (flags & SCF_DO_SUBSTR) { SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */ data->longest = &(data->longest_float); @@ -4578,10 +4642,11 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, if (min1 > (I32)(minnext + trie->minlen)) min1 = minnext + trie->minlen; - if (max1 < (I32)(minnext + deltanext + trie->maxlen)) - max1 = minnext + deltanext + trie->maxlen; - if (deltanext == I32_MAX) + if (deltanext == I32_MAX) { is_inf = is_inf_internal = 1; + max1 = I32_MAX; + } else if (max1 < (I32)(minnext + deltanext + trie->maxlen)) + max1 = minnext + deltanext + trie->maxlen; if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) pars++; @@ -4837,23 +4902,295 @@ Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags) NULL, NULL, rx_flags, 0); } + +/* upgrade pattern pat_p of length plen_p to UTF8, and if there are code + * blocks, recalculate the indices. Update pat_p and plen_p in-place to + * point to the realloced string and length. + * + * This is essentially a copy of Perl_bytes_to_utf8() with the code index + * stuff added */ + +static void +S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, + char **pat_p, STRLEN *plen_p, int num_code_blocks) +{ + U8 *const src = (U8*)*pat_p; + U8 *dst; + int n=0; + STRLEN s = 0, d = 0; + bool do_end = 0; + GET_RE_DEBUG_FLAGS_DECL; + + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, + "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); + + Newx(dst, *plen_p * 2 + 1, U8); + + while (s < *plen_p) { + const UV uv = NATIVE_TO_ASCII(src[s]); + if (UNI_IS_INVARIANT(uv)) + dst[d] = (U8)UTF_TO_NATIVE(uv); + else { + dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv); + dst[d] = (U8)UTF8_EIGHT_BIT_LO(uv); + } + if (n < num_code_blocks) { + if (!do_end && pRExC_state->code_blocks[n].start == s) { + pRExC_state->code_blocks[n].start = d; + assert(dst[d] == '('); + do_end = 1; + } + else if (do_end && pRExC_state->code_blocks[n].end == s) { + pRExC_state->code_blocks[n].end = d; + assert(dst[d] == ')'); + do_end = 0; + n++; + } + } + s++; + d++; + } + dst[d] = '\0'; + *plen_p = d; + *pat_p = (char*) dst; + SAVEFREEPV(*pat_p); + RExC_orig_utf8 = RExC_utf8 = 1; +} + + + +/* S_concat_pat(): concatenate a list of args to the pattern string pat, + * while recording any code block indices, and handling overloading, + * nested qr// objects etc. If pat is null, it will allocate a new + * string, or just return the first arg, if there's only one. + * + * Returns the malloced/updated pat. + * patternp and pat_count is the array of SVs to be concatted; + * oplist is the optional list of ops that generated the SVs; + * recompile_p is a pointer to a boolean that will be set if + * the regex will need to be recompiled. + * delim, if non-null is an SV that will be inserted between each element + */ + +static SV* +S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, + SV *pat, SV ** const patternp, int pat_count, + OP *oplist, bool *recompile_p, SV *delim) +{ + SV **svp; + int n = 0; + bool use_delim = FALSE; + bool alloced = FALSE; + + /* if we know we have at least two args, create an empty string, + * then concatenate args to that. For no args, return an empty string */ + if (!pat && pat_count != 1) { + pat = newSVpvn("", 0); + SAVEFREESV(pat); + alloced = TRUE; + } + + for (svp = patternp; svp < patternp + pat_count; svp++) { + SV *sv; + SV *rx = NULL; + STRLEN orig_patlen = 0; + bool code = 0; + SV *msv = use_delim ? delim : *svp; + + /* if we've got a delimiter, we go round the loop twice for each + * svp slot (except the last), using the delimiter the second + * time round */ + if (use_delim) { + svp--; + use_delim = FALSE; + } + else if (delim) + use_delim = TRUE; + + if (SvTYPE(msv) == SVt_PVAV) { + /* we've encountered an interpolated array within + * the pattern, e.g. /...@a..../. Expand the list of elements, + * then recursively append elements. + * The code in this block is based on S_pushav() */ + + AV *const av = (AV*)msv; + const I32 maxarg = AvFILL(av) + 1; + SV **array; + + if (oplist) { + assert(oplist->op_type == OP_PADAV + || oplist->op_type == OP_RV2AV); + oplist = oplist->op_sibling;; + } + + if (SvRMAGICAL(av)) { + U32 i; + + Newx(array, maxarg, SV*); + SAVEFREEPV(array); + for (i=0; i < (U32)maxarg; i++) { + SV ** const svp = av_fetch(av, i, FALSE); + array[i] = svp ? *svp : &PL_sv_undef; + } + } + else + array = AvARRAY(av); + + pat = S_concat_pat(aTHX_ pRExC_state, pat, + array, maxarg, NULL, recompile_p, + /* $" */ + GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV)))); + + continue; + } + + + /* we make the assumption here that each op in the list of + * op_siblings maps to one SV pushed onto the stack, + * except for code blocks, with have both an OP_NULL and + * and OP_CONST. + * This allows us to match up the list of SVs against the + * list of OPs to find the next code block. + * + * Note that PUSHMARK PADSV PADSV .. + * is optimised to + * PADRANGE PADSV PADSV .. + * so the alignment still works. */ + + if (oplist) { + if (oplist->op_type == OP_NULL + && (oplist->op_flags & OPf_SPECIAL)) + { + assert(n < pRExC_state->num_code_blocks); + pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0; + pRExC_state->code_blocks[n].block = oplist; + pRExC_state->code_blocks[n].src_regex = NULL; + n++; + code = 1; + oplist = oplist->op_sibling; /* skip CONST */ + assert(oplist); + } + oplist = oplist->op_sibling;; + } + + /* apply magic and QR overloading to arg */ + + SvGETMAGIC(msv); + if (SvROK(msv) && SvAMAGIC(msv)) { + SV *sv = AMG_CALLunary(msv, regexp_amg); + if (sv) { + if (SvROK(sv)) + sv = SvRV(sv); + if (SvTYPE(sv) != SVt_REGEXP) + Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); + msv = sv; + } + } + + /* try concatenation overload ... */ + if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) && + (sv = amagic_call(pat, msv, concat_amg, AMGf_assign))) + { + sv_setsv(pat, sv); + /* overloading involved: all bets are off over literal + * code. Pretend we haven't seen it */ + pRExC_state->num_code_blocks -= n; + n = 0; + } + else { + /* ... or failing that, try "" overload */ + while (SvAMAGIC(msv) + && (sv = AMG_CALLunary(msv, string_amg)) + && sv != msv + && !( SvROK(msv) + && SvROK(sv) + && SvRV(msv) == SvRV(sv)) + ) { + msv = sv; + SvGETMAGIC(msv); + } + if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) + msv = SvRV(msv); + + if (pat) { + /* this is a partially unrolled + * sv_catsv_nomg(pat, msv); + * that allows us to adjust code block indices if + * needed */ + STRLEN dlen; + char *dst = SvPV_force_nomg(pat, dlen); + orig_patlen = dlen; + if (SvUTF8(msv) && !SvUTF8(pat)) { + S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n); + sv_setpvn(pat, dst, dlen); + SvUTF8_on(pat); + } + sv_catsv_nomg(pat, msv); + rx = msv; + } + else + pat = msv; + + if (code) + pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1; + } + + /* extract any code blocks within any embedded qr//'s */ + if (rx && SvTYPE(rx) == SVt_REGEXP + && RX_ENGINE((REGEXP*)rx)->op_comp) + { + + RXi_GET_DECL(ReANY((REGEXP *)rx), ri); + if (ri->num_code_blocks) { + int i; + /* the presence of an embedded qr// with code means + * we should always recompile: the text of the + * qr// may not have changed, but it may be a + * different closure than last time */ + *recompile_p = 1; + Renew(pRExC_state->code_blocks, + pRExC_state->num_code_blocks + ri->num_code_blocks, + struct reg_code_block); + pRExC_state->num_code_blocks += ri->num_code_blocks; + + for (i=0; i < ri->num_code_blocks; i++) { + struct reg_code_block *src, *dst; + STRLEN offset = orig_patlen + + ReANY((REGEXP *)rx)->pre_prefix; + assert(n < pRExC_state->num_code_blocks); + src = &ri->code_blocks[i]; + dst = &pRExC_state->code_blocks[n]; + dst->start = src->start + offset; + dst->end = src->end + offset; + dst->block = src->block; + dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*) + src->src_regex + ? src->src_regex + : (REGEXP*)rx); + n++; + } + } + } + } + /* avoid calling magic multiple times on a single element e.g. =~ $qr */ + if (alloced) + SvSETMAGIC(pat); + + return pat; +} + + + /* see if there are any run-time code blocks in the pattern. * False positives are allowed */ static bool -S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, OP *expr, - U32 pm_flags, char *pat, STRLEN plen) +S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, + char *pat, STRLEN plen) { int n = 0; STRLEN s; - /* avoid infinitely recursing when we recompile the pattern parcelled up - * as qr'...'. A single constant qr// string can't have have any - * run-time component in it, and thus, no runtime code. (A non-qr - * string, however, can, e.g. $x =~ '(?{})') */ - if ((pm_flags & PMf_IS_QR) && expr && expr->op_type == OP_CONST) - return 0; - for (s = 0; s < plen; s++) { if (n < pRExC_state->num_code_blocks && s == pRExC_state->code_blocks[n].start) @@ -4967,11 +5304,10 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, SAVETMPS; save_re_context(); PUSHSTACKi(PERLSI_REQUIRE); - /* this causes the toker to collapse \\ into \ when parsing - * qr''; normally only q'' does this. It also alters hints - * handling */ - PL_reg_state.re_reparsing = TRUE; - eval_sv(sv, G_SCALAR); + /* G_RE_REPARSING causes the toker to collapse \\ into \ when + * parsing qr''; normally only q'' does this. It also alters + * hints handling */ + eval_sv(sv, G_SCALAR|G_RE_REPARSING); SvREFCNT_dec_NN(sv); SPAGAIN; qr_ref = POPs; @@ -5076,7 +5412,7 @@ STATIC bool S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, SV** rx_substr, I32* rx_end_shift, I32 lookbehind, I32 offset, I32 *minlen, STRLEN longest_length, bool eol, bool meol) { /* This is the common code for setting up the floating and fixed length - * string data extracted from Perlre_op_compile() below. Returns a boolean + * string data extracted from Perl_re_op_compile() below. Returns a boolean * as to whether succeeded or not */ I32 t,ml; @@ -5162,7 +5498,7 @@ S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest, SV** rx_utf8, S REGEXP * Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, - OP *expr, const regexp_engine* eng, REGEXP *VOL old_re, + OP *expr, const regexp_engine* eng, REGEXP *old_re, bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags) { dVAR; @@ -5170,32 +5506,28 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, struct regexp *r; regexp_internal *ri; STRLEN plen; - char * VOL exp; - char* xend; + char *exp; regnode *scan; I32 flags; I32 minlen = 0; U32 rx_flags; - SV * VOL pat; - SV * VOL code_blocksv = NULL; + SV *pat; + SV *code_blocksv = NULL; + SV** new_patternp = patternp; /* these are all flags - maybe they should be turned * into a single int with different bit masks */ I32 sawlookahead = 0; I32 sawplus = 0; I32 sawopen = 0; - bool used_setjump = FALSE; regex_charset initial_charset = get_regex_charset(orig_rx_flags); - bool code_is_utf8 = 0; - bool VOL recompile = 0; + bool recompile = 0; bool runtime_code = 0; - U8 jump_ret = 0; - dJMPENV; scan_data_t data; RExC_state_t RExC_state; RExC_state_t * const pRExC_state = &RExC_state; #ifdef TRIE_STUDY_OPT - int restudied; + int restudied = 0; RExC_state_t copyRExC_state; #endif GET_RE_DEBUG_FLAGS_DECL; @@ -5275,241 +5607,89 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (expr && (expr->op_type == OP_LIST || (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) { - - /* is the source UTF8, and how many code blocks are there? */ + /* allocate code_blocks if needed */ OP *o; int ncode = 0; - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { - if (o->op_type == OP_CONST && SvUTF8(cSVOPo_sv)) - code_is_utf8 = 1; - else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) - /* count of DO blocks */ - ncode++; - } + for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) + if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) + ncode++; /* count of DO blocks */ if (ncode) { pRExC_state->num_code_blocks = ncode; Newx(pRExC_state->code_blocks, ncode, struct reg_code_block); } } - if (pat_count) { - /* handle a list of SVs */ + if (!pat_count) { + /* compile-time pattern with just OP_CONSTs and DO blocks */ - SV **svp; + int n; + OP *o; - /* apply magic and RE overloading to each arg */ - for (svp = patternp; svp < patternp + pat_count; svp++) { - SV *rx = *svp; - SvGETMAGIC(rx); - if (SvROK(rx) && SvAMAGIC(rx)) { - SV *sv = AMG_CALLunary(rx, regexp_amg); - if (sv) { - if (SvROK(sv)) - sv = SvRV(sv); - if (SvTYPE(sv) != SVt_REGEXP) - Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); - *svp = sv; - } - } - } + /* find how many CONSTs there are */ + assert(expr); + n = 0; + if (expr->op_type == OP_CONST) + n = 1; + else + for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + if (o->op_type == OP_CONST) + n++; + } - if (pat_count > 1) { - /* concat multiple args and find any code block indexes */ + /* fake up an SV array */ - OP *o = NULL; - int n = 0; - bool utf8 = 0; - STRLEN orig_patlen = 0; + assert(!new_patternp); + Newx(new_patternp, n, SV*); + SAVEFREEPV(new_patternp); + pat_count = n; - if (pRExC_state->num_code_blocks) { - o = cLISTOPx(expr)->op_first; - assert( o->op_type == OP_PUSHMARK - || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) - || o->op_type == OP_PADRANGE); - o = o->op_sibling; - } + n = 0; + if (expr->op_type == OP_CONST) + new_patternp[n] = cSVOPx_sv(expr); + else + for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + if (o->op_type == OP_CONST) + new_patternp[n++] = cSVOPo_sv; + } - pat = newSVpvn("", 0); - SAVEFREESV(pat); - - /* determine if the pattern is going to be utf8 (needed - * in advance to align code block indices correctly). - * XXX This could fail to be detected for an arg with - * overloading but not concat overloading; but the main effect - * in this obscure case is to need a 'use re eval' for a - * literal code block */ - for (svp = patternp; svp < patternp + pat_count; svp++) { - if (SvUTF8(*svp)) - utf8 = 1; - } - if (utf8) - SvUTF8_on(pat); - - for (svp = patternp; svp < patternp + pat_count; svp++) { - SV *sv, *msv = *svp; - SV *rx; - bool code = 0; - /* we make the assumption here that each op in the list of - * op_siblings maps to one SV pushed onto the stack, - * except for code blocks, with have both an OP_NULL and - * and OP_CONST. - * This allows us to match up the list of SVs against the - * list of OPs to find the next code block. - * - * Note that PUSHMARK PADSV PADSV .. - * is optimised to - * PADRANGE NULL NULL .. - * so the alignment still works. */ - if (o) { - if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { - assert(n < pRExC_state->num_code_blocks); - pRExC_state->code_blocks[n].start = SvCUR(pat); - pRExC_state->code_blocks[n].block = o; - pRExC_state->code_blocks[n].src_regex = NULL; - n++; - code = 1; - o = o->op_sibling; /* skip CONST */ - assert(o); - } - o = o->op_sibling;; - } + } - if ((SvAMAGIC(pat) || SvAMAGIC(msv)) && - (sv = amagic_call(pat, msv, concat_amg, AMGf_assign))) - { - sv_setsv(pat, sv); - /* overloading involved: all bets are off over literal - * code. Pretend we haven't seen it */ - pRExC_state->num_code_blocks -= n; - n = 0; - rx = NULL; + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, + "Assembling pattern from %d elements%s\n", pat_count, + orig_rx_flags & RXf_SPLIT ? " for split" : "")); - } - else { - while (SvAMAGIC(msv) - && (sv = AMG_CALLunary(msv, string_amg)) - && sv != msv - && !( SvROK(msv) - && SvROK(sv) - && SvRV(msv) == SvRV(sv)) - ) { - msv = sv; - SvGETMAGIC(msv); - } - if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP) - msv = SvRV(msv); - orig_patlen = SvCUR(pat); - sv_catsv_nomg(pat, msv); - rx = msv; - if (code) - pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1; - } + /* set expr to the first arg op */ - /* extract any code blocks within any embedded qr//'s */ - if (rx && SvTYPE(rx) == SVt_REGEXP - && RX_ENGINE((REGEXP*)rx)->op_comp) - { + if (pRExC_state->num_code_blocks + && expr->op_type != OP_CONST) + { + expr = cLISTOPx(expr)->op_first; + assert( expr->op_type == OP_PUSHMARK + || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK) + || expr->op_type == OP_PADRANGE); + expr = expr->op_sibling; + } - RXi_GET_DECL(ReANY((REGEXP *)rx), ri); - if (ri->num_code_blocks) { - int i; - /* the presence of an embedded qr// with code means - * we should always recompile: the text of the - * qr// may not have changed, but it may be a - * different closure than last time */ - recompile = 1; - Renew(pRExC_state->code_blocks, - pRExC_state->num_code_blocks + ri->num_code_blocks, - struct reg_code_block); - pRExC_state->num_code_blocks += ri->num_code_blocks; - for (i=0; i < ri->num_code_blocks; i++) { - struct reg_code_block *src, *dst; - STRLEN offset = orig_patlen - + ReANY((REGEXP *)rx)->pre_prefix; - assert(n < pRExC_state->num_code_blocks); - src = &ri->code_blocks[i]; - dst = &pRExC_state->code_blocks[n]; - dst->start = src->start + offset; - dst->end = src->end + offset; - dst->block = src->block; - dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*) - src->src_regex - ? src->src_regex - : (REGEXP*)rx); - n++; - } - } - } - } - SvSETMAGIC(pat); - } - else { - SV *sv; - pat = *patternp; - while (SvAMAGIC(pat) - && (sv = AMG_CALLunary(pat, string_amg)) - && sv != pat) - { - pat = sv; - SvGETMAGIC(pat); - } - } + pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count, + expr, &recompile, NULL); - /* handle bare regex: foo =~ $re */ - { - SV *re = pat; - if (SvROK(re)) - re = SvRV(re); - if (SvTYPE(re) == SVt_REGEXP) { - if (is_bare_re) - *is_bare_re = TRUE; - SvREFCNT_inc(re); - Safefree(pRExC_state->code_blocks); - return (REGEXP*)re; - } - } - } - else { - /* not a list of SVs, so must be a list of OPs */ - assert(expr); - if (expr->op_type == OP_LIST) { - int i = -1; - bool is_code = 0; - OP *o; - - pat = newSVpvn("", 0); - SAVEFREESV(pat); - if (code_is_utf8) - SvUTF8_on(pat); - - /* given a list of CONSTs and DO blocks in expr, append all - * the CONSTs to pat, and record the start and end of each - * code block in code_blocks[] (each DO{} op is followed by an - * OP_CONST containing the corresponding literal '(?{...}) - * text) - */ - for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { - if (o->op_type == OP_CONST) { - sv_catsv(pat, cSVOPo_sv); - if (is_code) { - pRExC_state->code_blocks[i].end = SvCUR(pat)-1; - is_code = 0; - } - } - else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) { - assert(i+1 < pRExC_state->num_code_blocks); - pRExC_state->code_blocks[++i].start = SvCUR(pat); - pRExC_state->code_blocks[i].block = o; - pRExC_state->code_blocks[i].src_regex = NULL; - is_code = 1; - } - } - } - else { - assert(expr->op_type == OP_CONST); - pat = cSVOPx_sv(expr); - } + /* handle bare (possibly after overloading) regex: foo =~ $re */ + { + SV *re = pat; + if (SvROK(re)) + re = SvRV(re); + if (SvTYPE(re) == SVt_REGEXP) { + if (is_bare_re) + *is_bare_re = TRUE; + SvREFCNT_inc(re); + Safefree(pRExC_state->code_blocks); + DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, + "Precompiled pattern%s\n", + orig_rx_flags & RXf_SPLIT ? " for split" : "")); + + return (REGEXP*)re; + } } exp = SvPV_nomg(pat, plen); @@ -5533,121 +5713,43 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_contains_locale = 0; pRExC_state->runtime_code_qr = NULL; - /****************** LONG JUMP TARGET HERE***********************/ - /* Longjmp back to here if have to switch in midstream to utf8 */ - if (! RExC_orig_utf8) { - JMPENV_PUSH(jump_ret); - used_setjump = TRUE; - } - - if (jump_ret == 0) { /* First time through */ - xend = exp + plen; - - DEBUG_COMPILE_r({ + DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); - RE_PV_QUOTED_DECL(s, RExC_utf8, - dsv, exp, plen, 60); + RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60); PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n", - PL_colors[4],PL_colors[5],s); + PL_colors[4],PL_colors[5],s); }); - } - else { /* longjumped back */ - U8 *src, *dst; - int n=0; - STRLEN s = 0, d = 0; - bool do_end = 0; - - /* If the cause for the longjmp was other than changing to utf8, pop - * our own setjmp, and longjmp to the correct handler */ - if (jump_ret != UTF8_LONGJMP) { - JMPENV_POP; - JMPENV_JUMP(jump_ret); - } - GET_RE_DEBUG_FLAGS; + redo_first_pass: + /* we jump here if we upgrade the pattern to utf8 and have to + * recompile */ - /* It's possible to write a regexp in ascii that represents Unicode - codepoints outside of the byte range, such as via \x{100}. If we - detect such a sequence we have to convert the entire pattern to utf8 - and then recompile, as our sizing calculation will have been based - on 1 byte == 1 character, but we will need to use utf8 to encode - at least some part of the pattern, and therefore must convert the whole - thing. - -- dmq */ - DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, - "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); - - /* upgrade pattern to UTF8, and if there are code blocks, - * recalculate the indices. - * This is essentially an unrolled Perl_bytes_to_utf8() */ - - src = (U8*)SvPV_nomg(pat, plen); - Newx(dst, plen * 2 + 1, U8); - - while (s < plen) { - const UV uv = NATIVE_TO_ASCII(src[s]); - if (UNI_IS_INVARIANT(uv)) - dst[d] = (U8)UTF_TO_NATIVE(uv); - else { - dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv); - dst[d] = (U8)UTF8_EIGHT_BIT_LO(uv); - } - if (n < pRExC_state->num_code_blocks) { - if (!do_end && pRExC_state->code_blocks[n].start == s) { - pRExC_state->code_blocks[n].start = d; - assert(dst[d] == '('); - do_end = 1; - } - else if (do_end && pRExC_state->code_blocks[n].end == s) { - pRExC_state->code_blocks[n].end = d; - assert(dst[d] == ')'); - do_end = 0; - n++; - } - } - s++; - d++; - } - dst[d] = '\0'; - plen = d; - exp = (char*) dst; - xend = exp + plen; - SAVEFREEPV(exp); - RExC_orig_utf8 = RExC_utf8 = 1; - } + if ((pm_flags & PMf_USE_RE_EVAL) + /* this second condition covers the non-regex literal case, + * i.e. $foo =~ '(?{})'. */ + || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL)) + ) + runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); /* return old regex if pattern hasn't changed */ + /* XXX: note in the below we have to check the flags as well as the pattern. + * + * Things get a touch tricky as we have to compare the utf8 flag independently + * from the compile flags. + */ if ( old_re && !recompile - && !!RX_UTF8(old_re) == !!RExC_utf8 + && !!RX_UTF8(old_re) == !!RExC_utf8 + && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) ) && RX_PRECOMP(old_re) && RX_PRELEN(old_re) == plen - && memEQ(RX_PRECOMP(old_re), exp, plen)) + && memEQ(RX_PRECOMP(old_re), exp, plen) + && !runtime_code /* with runtime code, always recompile */ ) { - /* with runtime code, always recompile */ - runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags, - exp, plen); - if (!runtime_code) { - if (used_setjump) { - JMPENV_POP; - } - Safefree(pRExC_state->code_blocks); - return old_re; - } + Safefree(pRExC_state->code_blocks); + return old_re; } - else if ((pm_flags & PMf_USE_RE_EVAL) - /* this second condition covers the non-regex literal case, - * i.e. $foo =~ '(?{})'. */ - || ( !PL_reg_state.re_reparsing && IN_PERL_COMPILETIME - && (PL_hints & HINT_RE_EVAL)) - ) - runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags, - exp, plen); - -#ifdef TRIE_STUDY_OPT - restudied = 0; -#endif rx_flags = orig_rx_flags; @@ -5672,7 +5774,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { /* whoops, we have a non-utf8 pattern, whilst run-time code * got compiled as utf8. Try again with a utf8 pattern */ - JMPENV_JUMP(UTF8_LONGJMP); + S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen, + pRExC_state->num_code_blocks); + goto redo_first_pass; } } assert(!pRExC_state->runtime_code_qr); @@ -5689,12 +5793,12 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, /* First pass: determine size, legality. */ RExC_parse = exp; RExC_start = exp; - RExC_end = xend; + RExC_end = exp + plen; RExC_naughty = 0; RExC_npar = 1; RExC_nestroot = 0; RExC_size = 0L; - RExC_emit = &PL_regdummy; + RExC_emit = &RExC_emit_dummy; RExC_whilem_seen = 0; RExC_open_parens = NULL; RExC_close_parens = NULL; @@ -5720,7 +5824,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, pRExC_state->code_blocks. We cannot SAVEFREEPV it now, as we may need it to survive as long as the regexp (qr/(?{})/). We must check that code_blocksv is not already set, because we may - have longjmped back. */ + have jumped back to restart the sizing pass. */ if (pRExC_state->code_blocks && !code_blocksv) { code_blocksv = newSV_type(SVt_PV); SAVEFREESV(code_blocksv); @@ -5728,17 +5832,24 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/ } if (reg(pRExC_state, 0, &flags,1) == NULL) { - RExC_precomp = NULL; - return(NULL); + /* It's possible to write a regexp in ascii that represents Unicode + codepoints outside of the byte range, such as via \x{100}. If we + detect such a sequence we have to convert the entire pattern to utf8 + and then recompile, as our sizing calculation will have been based + on 1 byte == 1 character, but we will need to use utf8 to encode + at least some part of the pattern, and therefore must convert the whole + thing. + -- dmq */ + if (flags & RESTART_UTF8) { + S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen, + pRExC_state->num_code_blocks); + goto redo_first_pass; + } + Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#"UVxf"", (UV) flags); } if (code_blocksv) SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */ - /* Here, finished first pass. Get rid of any added setjmp */ - if (used_setjump) { - JMPENV_POP; - } - DEBUG_PARSE_r({ PerlIO_printf(Perl_debug_log, "Required size %"IVdf" nodes\n" @@ -5785,6 +5896,8 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RXi_SET( r, ri ); r->engine= eng; r->extflags = rx_flags; + RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK; + if (pm_flags & PMf_IS_QR) { ri->code_blocks = pRExC_state->code_blocks; ri->num_code_blocks = pRExC_state->num_code_blocks; @@ -5893,7 +6006,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_flags = rx_flags; /* don't let top level (?i) bleed */ RExC_pm_flags = pm_flags; RExC_parse = exp; - RExC_end = xend; + RExC_end = exp + plen; RExC_naughty = 0; RExC_npar = 1; RExC_emit_start = ri->program; @@ -5904,7 +6017,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, REGC((U8)REG_MAGIC, (char*) RExC_emit++); if (reg(pRExC_state, 0, &flags,1) == NULL) { ReREFCNT_dec(rx); - return(NULL); + Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#"UVxf"", (UV) flags); } /* XXXX To minimize changes to RE engine we always allocate 3-units-long substrs field. */ @@ -6288,7 +6401,7 @@ reStudy: if (RExC_seen & REG_SEEN_GPOS) r->extflags |= RXf_GPOS_SEEN; if (RExC_seen & REG_SEEN_LOOKBEHIND) - r->extflags |= RXf_LOOKBEHIND_SEEN; + r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */ if (pRExC_state->num_code_blocks) r->extflags |= RXf_EVAL_SEEN; if (RExC_seen & REG_SEEN_CANY) @@ -6296,7 +6409,7 @@ reStudy: if (RExC_seen & REG_SEEN_VERBARG) { r->intflags |= PREGf_VERBARG_SEEN; - r->extflags |= RXf_MODIFIES_VARS; + r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */ } if (RExC_seen & REG_SEEN_CUTGROUP) r->intflags |= PREGf_CUTGROUP_SEEN; @@ -6307,27 +6420,22 @@ reStudy: else RXp_PAREN_NAMES(r) = NULL; -#ifdef STUPID_PATTERN_CHECKS - if (RX_PRELEN(rx) == 0) - r->extflags |= RXf_NULL; - if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3)) - r->extflags |= RXf_WHITE; - else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^') - r->extflags |= RXf_START_ONLY; -#else { regnode *first = ri->program + 1; U8 fop = OP(first); + regnode *next = NEXTOPER(first); + U8 nop = OP(next); - if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END) + if (PL_regkind[fop] == NOTHING && nop == END) r->extflags |= RXf_NULL; - else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END) + else if (PL_regkind[fop] == BOL && nop == END) r->extflags |= RXf_START_ONLY; - else if (fop == PLUS && PL_regkind[OP(NEXTOPER(first))] == POSIXD && FLAGS(NEXTOPER(first)) == _CC_SPACE - && OP(regnext(first)) == END) - r->extflags |= RXf_WHITE; + else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE && OP(regnext(first)) == END) + r->extflags |= RXf_WHITE; + else if ( r->extflags & RXf_SPLIT && fop == EXACT && STR_LEN(first) == 1 && *(STRING(first)) == ' ' && OP(regnext(first)) == END ) + r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); + } -#endif #ifdef DEBUGGING if (RExC_paren_names) { ri->name_list_idx = add_data( pRExC_state, 1, "a" ); @@ -6946,8 +7054,8 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) * should eventually be made public */ /* The header definitions are in F */ -#define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV)) -#define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH) +#define TO_INTERNAL_SIZE(x) (((x) + HEADER_LENGTH) * sizeof(UV)) +#define FROM_INTERNAL_SIZE(x) (((x)/ sizeof(UV)) - HEADER_LENGTH) #define INVLIST_INITIAL_LEN 10 @@ -7111,7 +7219,7 @@ Perl__new_invlist(pTHX_ IV initial_size) *get_invlist_previous_index_addr(new_list) = 0; *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID; #if HEADER_LENGTH != 5 -# error Need to regenerate VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length +# error Need to regenerate INVLIST_VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length #endif return new_list; @@ -7580,7 +7688,7 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool co } else { cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); - cp= array_b[i_b++]; + cp = array_b[i_b++]; } /* Here, have chosen which of the two inputs to look at. Only output @@ -8305,6 +8413,201 @@ S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b) /* End of inversion list object */ +STATIC void +S_parse_lparen_question_flags(pTHX_ struct RExC_state_t *pRExC_state) +{ + /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)' + * constructs, and updates RExC_flags with them. On input, RExC_parse + * should point to the first flag; it is updated on output to point to the + * final ')' or ':'. There needs to be at least one flag, or this will + * abort */ + + /* for (?g), (?gc), and (?o) warnings; warning + about (?c) will warn about (?g) -- japhy */ + +#define WASTED_O 0x01 +#define WASTED_G 0x02 +#define WASTED_C 0x04 +#define WASTED_GC (WASTED_G|WASTED_C) + I32 wastedflags = 0x00; + U32 posflags = 0, negflags = 0; + U32 *flagsp = &posflags; + char has_charset_modifier = '\0'; + regex_charset cs; + bool has_use_defaults = FALSE; + const char* const seqstart = RExC_parse - 1; /* Point to the '?' */ + + PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS; + + /* '^' as an initial flag sets certain defaults */ + if (UCHARAT(RExC_parse) == '^') { + RExC_parse++; + has_use_defaults = TRUE; + STD_PMMOD_FLAGS_CLEAR(&RExC_flags); + set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics) + ? REGEX_UNICODE_CHARSET + : REGEX_DEPENDS_CHARSET); + } + + cs = get_regex_charset(RExC_flags); + if (cs == REGEX_DEPENDS_CHARSET + && (RExC_utf8 || RExC_uni_semantics)) + { + cs = REGEX_UNICODE_CHARSET; + } + + while (*RExC_parse) { + /* && strchr("iogcmsx", *RExC_parse) */ + /* (?g), (?gc) and (?o) are useless here + and must be globally applied -- japhy */ + switch (*RExC_parse) { + + /* Code for the imsx flags */ + CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp); + + case LOCALE_PAT_MOD: + if (has_charset_modifier) { + goto excess_modifier; + } + else if (flagsp == &negflags) { + goto neg_modifier; + } + cs = REGEX_LOCALE_CHARSET; + has_charset_modifier = LOCALE_PAT_MOD; + RExC_contains_locale = 1; + break; + case UNICODE_PAT_MOD: + if (has_charset_modifier) { + goto excess_modifier; + } + else if (flagsp == &negflags) { + goto neg_modifier; + } + cs = REGEX_UNICODE_CHARSET; + has_charset_modifier = UNICODE_PAT_MOD; + break; + case ASCII_RESTRICT_PAT_MOD: + if (flagsp == &negflags) { + goto neg_modifier; + } + if (has_charset_modifier) { + if (cs != REGEX_ASCII_RESTRICTED_CHARSET) { + goto excess_modifier; + } + /* Doubled modifier implies more restricted */ + cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET; + } + else { + cs = REGEX_ASCII_RESTRICTED_CHARSET; + } + has_charset_modifier = ASCII_RESTRICT_PAT_MOD; + break; + case DEPENDS_PAT_MOD: + if (has_use_defaults) { + goto fail_modifiers; + } + else if (flagsp == &negflags) { + goto neg_modifier; + } + else if (has_charset_modifier) { + goto excess_modifier; + } + + /* The dual charset means unicode semantics if the + * pattern (or target, not known until runtime) are + * utf8, or something in the pattern indicates unicode + * semantics */ + cs = (RExC_utf8 || RExC_uni_semantics) + ? REGEX_UNICODE_CHARSET + : REGEX_DEPENDS_CHARSET; + has_charset_modifier = DEPENDS_PAT_MOD; + break; + excess_modifier: + RExC_parse++; + if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) { + vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD); + } + else if (has_charset_modifier == *(RExC_parse - 1)) { + vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1)); + } + else { + vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1)); + } + /*NOTREACHED*/ + neg_modifier: + RExC_parse++; + vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1)); + /*NOTREACHED*/ + case ONCE_PAT_MOD: /* 'o' */ + case GLOBAL_PAT_MOD: /* 'g' */ + if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; + if (! (wastedflags & wflagbit) ) { + wastedflags |= wflagbit; + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + vWARN5( + RExC_parse + 1, + "Useless (%s%c) - %suse /%c modifier", + flagsp == &negflags ? "?-" : "?", + *RExC_parse, + flagsp == &negflags ? "don't " : "", + *RExC_parse + ); + } + } + break; + + case CONTINUE_PAT_MOD: /* 'c' */ + if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + if (! (wastedflags & WASTED_C) ) { + wastedflags |= WASTED_GC; + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + vWARN3( + RExC_parse + 1, + "Useless (%sc) - %suse /gc modifier", + flagsp == &negflags ? "?-" : "?", + flagsp == &negflags ? "don't " : "" + ); + } + } + break; + case KEEPCOPY_PAT_MOD: /* 'p' */ + if (flagsp == &negflags) { + if (SIZE_ONLY) + ckWARNreg(RExC_parse + 1,"Useless use of (?-p)"); + } else { + *flagsp |= RXf_PMf_KEEPCOPY; + } + break; + case '-': + /* A flag is a default iff it is following a minus, so + * if there is a minus, it means will be trying to + * re-specify a default which is an error */ + if (has_use_defaults || flagsp == &negflags) { + goto fail_modifiers; + } + flagsp = &negflags; + wastedflags = 0; /* reset so (?g-c) warns twice */ + break; + case ':': + case ')': + RExC_flags |= posflags; + RExC_flags &= ~negflags; + set_regex_charset(&RExC_flags, cs); + return; + /*NOTREACHED*/ + default: + fail_modifiers: + RExC_parse++; + vFAIL3("Sequence (%.*s...) not recognized", + RExC_parse-seqstart, seqstart); + /*NOTREACHED*/ + } + + ++RExC_parse; + } +} + /* - reg - regular expression, i.e. main body or parenthesized thing * @@ -8321,9 +8624,17 @@ S__invlistEQ(pTHX_ SV* const a, SV* const b, bool complement_b) #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1) #endif +/* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets + flags. Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan + needs to be restarted. + Otherwise would only return NULL if regbranch() returns NULL, which + cannot happen. */ STATIC regnode * S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) - /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */ + /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter. + * 2 is like 1, but indicates that nextchar() has been called to advance + * RExC_parse beyond the '('. Things like '(?' are indivisible tokens, and + * this flag alerts us to the need to check for that */ { dVAR; regnode *ret; /* Will be the head of the group. */ @@ -8338,15 +8649,6 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) I32 freeze_paren = 0; I32 after_freeze = 0; - /* for (?g), (?gc), and (?o) warnings; warning - about (?c) will warn about (?g) -- japhy */ - -#define WASTED_O 0x01 -#define WASTED_G 0x02 -#define WASTED_C 0x04 -#define WASTED_GC (0x02|0x04) - I32 wastedflags = 0x00; - char * parse_start = RExC_parse; /* MJD */ char * const oregcomp_parse = RExC_parse; @@ -8360,6 +8662,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* Make an OPEN node, if parenthesized. */ if (paren) { + + /* Under /x, space and comments can be gobbled up between the '(' and + * here (if paren ==2). The forms '(*VERB' and '(?...' disallow such + * intervening space, as the sequence is a token, and a token should be + * indivisible */ + bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '('; + if ( *RExC_parse == '*') { /* (*VERB:ARG) */ char *start_verb = RExC_parse; STRLEN verb_len = 0; @@ -8367,6 +8676,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) unsigned char op = 0; int argok = 1; int internal_argval = 0; /* internal_argval is only useful if !argok */ + + if (has_intervening_patws && SIZE_ONLY) { + ckWARNregdep(RExC_parse + 1, "In '(*VERB...)', splitting the initial '(*' is deprecated"); + } while ( *RExC_parse && *RExC_parse != ')' ) { if ( *RExC_parse == ':' ) { start_arg = RExC_parse + 1; @@ -8464,11 +8777,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } nextchar(pRExC_state); return ret; - } else - if (*RExC_parse == '?') { /* (?...) */ + } + else if (*RExC_parse == '?') { /* (?...) */ bool is_logical = 0; const char * const seqstart = RExC_parse; - bool has_use_defaults = FALSE; + if (has_intervening_patws && SIZE_ONLY) { + ckWARNregdep(RExC_parse + 1, "In '(?...)', splitting the initial '(?' is deprecated"); + } RExC_parse++; paren = *RExC_parse++; @@ -8630,8 +8945,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case '@': /* (?@...) */ vFAIL2("Sequence (?%c...) not implemented", (int)paren); break; - case '#': /* (?#...) */ - while (*RExC_parse && *RExC_parse != ')') + case '#': /* (?#...) */ + /* XXX As soon as we disallow separating the '?' and '*' (by + * spaces or (?#...) comment), it is believed that this case + * will be unreachable and can be removed. See + * [perl #117327] */ + while (*RExC_parse && *RExC_parse != ')') RExC_parse++; if (*RExC_parse != ')') FAIL("Sequence (?#... not terminated"); @@ -8803,11 +9122,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) || RExC_parse[1] == '<' || RExC_parse[1] == '{') { /* Lookahead or eval. */ I32 flag; + regnode *tail; ret = reg_node(pRExC_state, LOGICAL); if (!SIZE_ONLY) ret->flags = 1; - REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1)); + + tail = reg(pRExC_state, 1, &flag, depth+1); + if (flag & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + REGTAIL(pRExC_state, ret, tail); goto insert_if; } } @@ -8875,9 +9201,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) insert_if: REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0)); br = regbranch(pRExC_state, &flags, 1,depth+1); - if (br == NULL) - br = reganode(pRExC_state, LONGJMP, 0); - else + if (br == NULL) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", + (UV) flags); + } else REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0)); c = *nextchar(pRExC_state); if (flags&HASWIDTH) @@ -8886,7 +9217,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) if (is_define) vFAIL("(?(DEFINE)....) does not allow branches"); lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */ - regbranch(pRExC_state, &flags, 1,depth+1); + if (!regbranch(pRExC_state, &flags, 1,depth+1)) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", + (UV) flags); + } REGTAIL(pRExC_state, ret, lastbr); if (flags&HASWIDTH) *flagp |= HASWIDTH; @@ -8914,193 +9252,26 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } } case '[': /* (?[ ... ]) */ - return handle_sets(pRExC_state, flagp, depth, oregcomp_parse); + return handle_regex_sets(pRExC_state, NULL, flagp, depth, + oregcomp_parse); case 0: RExC_parse--; /* for vFAIL to print correctly */ vFAIL("Sequence (? incomplete"); break; - case DEFAULT_PAT_MOD: /* Use default flags with the exceptions - that follow */ - has_use_defaults = TRUE; - STD_PMMOD_FLAGS_CLEAR(&RExC_flags); - set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics) - ? REGEX_UNICODE_CHARSET - : REGEX_DEPENDS_CHARSET); - goto parse_flags; - default: + default: /* e.g., (?i) */ --RExC_parse; - parse_flags: /* (?i) */ - { - U32 posflags = 0, negflags = 0; - U32 *flagsp = &posflags; - char has_charset_modifier = '\0'; - regex_charset cs = get_regex_charset(RExC_flags); - if (cs == REGEX_DEPENDS_CHARSET - && (RExC_utf8 || RExC_uni_semantics)) - { - cs = REGEX_UNICODE_CHARSET; - } - - while (*RExC_parse) { - /* && strchr("iogcmsx", *RExC_parse) */ - /* (?g), (?gc) and (?o) are useless here - and must be globally applied -- japhy */ - switch (*RExC_parse) { - CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp); - case LOCALE_PAT_MOD: - if (has_charset_modifier) { - goto excess_modifier; - } - else if (flagsp == &negflags) { - goto neg_modifier; - } - cs = REGEX_LOCALE_CHARSET; - has_charset_modifier = LOCALE_PAT_MOD; - RExC_contains_locale = 1; - break; - case UNICODE_PAT_MOD: - if (has_charset_modifier) { - goto excess_modifier; - } - else if (flagsp == &negflags) { - goto neg_modifier; - } - cs = REGEX_UNICODE_CHARSET; - has_charset_modifier = UNICODE_PAT_MOD; - break; - case ASCII_RESTRICT_PAT_MOD: - if (flagsp == &negflags) { - goto neg_modifier; - } - if (has_charset_modifier) { - if (cs != REGEX_ASCII_RESTRICTED_CHARSET) { - goto excess_modifier; - } - /* Doubled modifier implies more restricted */ - cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET; - } - else { - cs = REGEX_ASCII_RESTRICTED_CHARSET; - } - has_charset_modifier = ASCII_RESTRICT_PAT_MOD; - break; - case DEPENDS_PAT_MOD: - if (has_use_defaults) { - goto fail_modifiers; - } - else if (flagsp == &negflags) { - goto neg_modifier; - } - else if (has_charset_modifier) { - goto excess_modifier; - } - - /* The dual charset means unicode semantics if the - * pattern (or target, not known until runtime) are - * utf8, or something in the pattern indicates unicode - * semantics */ - cs = (RExC_utf8 || RExC_uni_semantics) - ? REGEX_UNICODE_CHARSET - : REGEX_DEPENDS_CHARSET; - has_charset_modifier = DEPENDS_PAT_MOD; - break; - excess_modifier: - RExC_parse++; - if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) { - vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD); - } - else if (has_charset_modifier == *(RExC_parse - 1)) { - vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1)); - } - else { - vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1)); - } - /*NOTREACHED*/ - neg_modifier: - RExC_parse++; - vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1)); - /*NOTREACHED*/ - case ONCE_PAT_MOD: /* 'o' */ - case GLOBAL_PAT_MOD: /* 'g' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { - const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; - if (! (wastedflags & wflagbit) ) { - wastedflags |= wflagbit; - vWARN5( - RExC_parse + 1, - "Useless (%s%c) - %suse /%c modifier", - flagsp == &negflags ? "?-" : "?", - *RExC_parse, - flagsp == &negflags ? "don't " : "", - *RExC_parse - ); - } - } - break; - - case CONTINUE_PAT_MOD: /* 'c' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { - if (! (wastedflags & WASTED_C) ) { - wastedflags |= WASTED_GC; - vWARN3( - RExC_parse + 1, - "Useless (%sc) - %suse /gc modifier", - flagsp == &negflags ? "?-" : "?", - flagsp == &negflags ? "don't " : "" - ); - } - } - break; - case KEEPCOPY_PAT_MOD: /* 'p' */ - if (flagsp == &negflags) { - if (SIZE_ONLY) - ckWARNreg(RExC_parse + 1,"Useless use of (?-p)"); - } else { - *flagsp |= RXf_PMf_KEEPCOPY; - } - break; - case '-': - /* A flag is a default iff it is following a minus, so - * if there is a minus, it means will be trying to - * re-specify a default which is an error */ - if (has_use_defaults || flagsp == &negflags) { - fail_modifiers: - RExC_parse++; - vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); - /*NOTREACHED*/ - } - flagsp = &negflags; - wastedflags = 0; /* reset so (?g-c) warns twice */ - break; - case ':': - paren = ':'; - /*FALLTHROUGH*/ - case ')': - RExC_flags |= posflags; - RExC_flags &= ~negflags; - set_regex_charset(&RExC_flags, cs); - if (paren != ':') { - oregflags |= posflags; - oregflags &= ~negflags; - set_regex_charset(&oregflags, cs); - } - nextchar(pRExC_state); - if (paren != ':') { - *flagp = TRYAGAIN; - return NULL; - } else { - ret = NULL; - goto parse_rest; - } - /*NOTREACHED*/ - default: - RExC_parse++; - vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart); - /*NOTREACHED*/ - } - ++RExC_parse; - } - }} /* one for the default block, one for the switch */ + parse_flags: + parse_lparen_question_flags(pRExC_state); + if (UCHARAT(RExC_parse) != ':') { + nextchar(pRExC_state); + *flagp = TRYAGAIN; + return NULL; + } + paren = ':'; + nextchar(pRExC_state); + ret = NULL; + goto parse_rest; + } /* end switch */ } else { /* (...) */ capturing_parens: @@ -9135,8 +9306,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* branch_len = (paren != 0); */ - if (br == NULL) - return(NULL); + if (br == NULL) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags); + } if (*RExC_parse == '|') { if (!SIZE_ONLY && RExC_extralen) { reginsert(pRExC_state, BRANCHJ, br, depth+1); @@ -9175,8 +9351,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) } br = regbranch(pRExC_state, &flags, 0, depth+1); - if (br == NULL) - return(NULL); + if (br == NULL) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: regbranch returned NULL, flags=%#"UVxf"", (UV) flags); + } REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */ lastbr = br; *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED); @@ -9188,7 +9369,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) case ':': ender = reg_node(pRExC_state, TAIL); break; - case 1: + case 1: case 2: ender = reganode(pRExC_state, CLOSE, parno); if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) { DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log, @@ -9305,7 +9486,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) /* Check for proper termination. */ if (paren) { - RExC_flags = oregflags; + /* restore original flags, but keep (?p) */ + RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY); if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') { RExC_parse = oregcomp_parse; vFAIL("Unmatched ("); @@ -9333,6 +9515,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth) - regbranch - one alternative of an | operator * * Implements the concatenation operator. + * + * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be + * restarted. */ STATIC regnode * S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) @@ -9372,7 +9557,11 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) if (latest == NULL) { if (flags & TRYAGAIN) continue; - return(NULL); + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: regpiece returned NULL, flags=%#"UVxf"", (UV) flags); } else if (ret == NULL) ret = latest; @@ -9406,6 +9595,11 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) * both the endmarker for their branch list and the body of the last branch. * It might seem that this node could be dispensed with entirely, but the * endmarker role is not redundant. + * + * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with + * TRYAGAIN. + * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be + * restarted. */ STATIC regnode * S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) @@ -9434,8 +9628,10 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ret = regatom(pRExC_state, &flags,depth+1); if (ret == NULL) { - if (flags & TRYAGAIN) - *flagp |= TRYAGAIN; + if (flags & (TRYAGAIN|RESTART_UTF8)) + *flagp |= flags & (TRYAGAIN|RESTART_UTF8); + else + FAIL2("panic: regatom returned NULL, flags=%#"UVxf"", (UV) flags); return(NULL); } @@ -9665,7 +9861,10 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I The function raises an error (via vFAIL), and doesn't return for various syntax errors. Otherwise it returns TRUE and sets or on - success; it returns FALSE otherwise. + success; it returns FALSE otherwise. Returns FALSE, setting *flagp to + RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is + only possible if node_p is non-NULL. + If is non-null, it means the caller can accept an input sequence consisting of a just a single code point; <*valuep> is set to that value @@ -9869,7 +10068,14 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I /* The values are Unicode, and therefore not subject to recoding */ RExC_override_recoding = 1; - *node_p = reg(pRExC_state, 1, &flags, depth+1); + if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return FALSE; + } + FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", + (UV) flags); + } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); RExC_parse = endbrace; @@ -9955,8 +10161,9 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 * additionally will populate the node's STRING with , if * is 0. In both cases <*flagp> is appropriately set * - * It knows that under FOLD, UTF characters and the Latin Sharp S must be - * folded (the latter only when the rules indicate it can match 'ss') */ + * It knows that under FOLD, the Latin Sharp S and UTF characters above + * 255, must be folded (the former only when the rules indicate it can + * match 'ss') */ bool len_passed_in = cBOOL(len != 0); U8 character[UTF8_MAXBYTES_CASE+1]; @@ -9965,8 +10172,15 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 if (! len_passed_in) { if (UTF) { - if (FOLD) { - to_uni_fold(NATIVE_TO_UNI(code_point), character, &len); + if (FOLD && (! LOC || code_point > 255)) { + _to_uni_fold_flags(NATIVE_TO_UNI(code_point), + character, + &len, + FOLD_FLAGS_FULL | ((LOC) + ? FOLD_FLAGS_LOCALE + : (ASCII_FOLD_RESTRICTED) + ? FOLD_FLAGS_NOMIX_ASCII + : 0)); } else { uvchr_to_utf8( character, code_point); @@ -10069,6 +10283,12 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 escape sequences, with the one for handling literal escapes requiring a dummy entry for all of the special escapes that are actually handled by the other. + + Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with + TRYAGAIN. + Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs to be + restarted. + Otherwise does not return NULL. */ STATIC regnode * @@ -10136,13 +10356,19 @@ tryagain: RExC_parse = oregcomp_parse; vFAIL("Unmatched ["); } + if (ret == NULL) { + if (*flagp & RESTART_UTF8) + return NULL; + FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"", + (UV) *flagp); + } nextchar(pRExC_state); Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */ break; } case '(': nextchar(pRExC_state); - ret = reg(pRExC_state, 1, &flags,depth+1); + ret = reg(pRExC_state, 2, &flags,depth+1); if (ret == NULL) { if (flags & TRYAGAIN) { if (RExC_parse == RExC_end) { @@ -10152,7 +10378,11 @@ tryagain: } goto tryagain; } - return(NULL); + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return NULL; + } + FAIL2("panic: reg returned NULL to regatom, flags=%#"UVxf"", (UV) flags); } *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); break; @@ -10251,7 +10481,7 @@ tryagain: FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { - ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead"); + ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead"); } goto finish_meta_pat; case 'B': @@ -10265,7 +10495,7 @@ tryagain: FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { - ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead"); + ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead"); } goto finish_meta_pat; @@ -10344,6 +10574,11 @@ tryagain: It would be a bug if these returned non-portables */ NULL); + /* regclass() can only return RESTART_UTF8 if multi-char folds + are allowed. */ + if (!ret) + FAIL2("panic: regclass returned NULL to regatom, flags=%#"UVxf"", + (UV) *flagp); RExC_parse--; @@ -10366,6 +10601,8 @@ tryagain: ++RExC_parse; if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE, FALSE /* not strict */ )) { + if (*flagp & RESTART_UTF8) + return NULL; RExC_parse--; goto defchar; } @@ -10440,8 +10677,14 @@ tryagain: goto parse_named_seq; } } num = atoi(RExC_parse); - if (isg && num == 0) - vFAIL("Reference to invalid group 0"); + if (isg && num == 0) { + if (*RExC_parse == '0') { + vFAIL("Reference to invalid group 0"); + } + else { + vFAIL("Unterminated \\g... pattern"); + } + } if (isrel) { num = RExC_npar - num; if (num < 1) @@ -10454,8 +10697,6 @@ tryagain: char * const parse_start = RExC_parse - 1; /* MJD */ while (isDIGIT(*RExC_parse)) RExC_parse++; - if (parse_start == RExC_parse - 1) - vFAIL("Unterminated \\g... pattern"); if (hasbrace) { if (*RExC_parse != '}') vFAIL("Unterminated \\g{...} pattern"); @@ -10632,6 +10873,8 @@ tryagain: flagp, depth, FALSE, FALSE /* not strict */ )) { + if (*flagp & RESTART_UTF8) + FAIL("panic: grok_bslash_N set RESTART_UTF8"); RExC_parse = p = oldp; goto loopdone; } @@ -10774,9 +11017,19 @@ tryagain: ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p); } goto normal_default; - } + } /* End of switch on '\' */ break; - default: + default: /* A literal character */ + + if (! SIZE_ONLY + && RExC_flags & RXf_PMf_EXTENDED + && ckWARN_d(WARN_DEPRECATED) + && is_PATWS_non_low(p, UTF)) + { + vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1), + "Escape literal pattern white space under /x"); + } + normal_default: if (UTF8_IS_START(*p) && UTF) { STRLEN numlen; @@ -10809,98 +11062,100 @@ tryagain: goto loopdone; } - if (FOLD) { - if (UTF - /* See comments for join_exact() as to why we fold - * this non-UTF at compile time */ - || (node_type == EXACTFU - && ender == LATIN_SMALL_LETTER_SHARP_S)) - { - - - /* Prime the casefolded buffer. Locale rules, which - * apply only to code points < 256, aren't known until - * execution, so for them, just output the original - * character using utf8. If we start to fold non-UTF - * patterns, be sure to update join_exact() */ - if (LOC && ender < 256) { - if (UNI_IS_INVARIANT(ender)) { - *s = (U8) ender; - foldlen = 1; - } else { - *s = UTF8_TWO_BYTE_HI(ender); - *(s + 1) = UTF8_TWO_BYTE_LO(ender); - foldlen = 2; - } + if (! FOLD) { + if (UTF) { + const STRLEN unilen = reguni(pRExC_state, ender, s); + if (unilen > 0) { + s += unilen; + len += unilen; } - else { - UV folded = _to_uni_fold_flags( - ender, - (U8 *) s, - &foldlen, - FOLD_FLAGS_FULL - | ((LOC) ? FOLD_FLAGS_LOCALE - : (ASCII_FOLD_RESTRICTED) - ? FOLD_FLAGS_NOMIX_ASCII - : 0) - ); - /* If this node only contains non-folding code - * points so far, see if this new one is also - * non-folding */ - if (maybe_exact) { - if (folded != ender) { - maybe_exact = FALSE; + /* The loop increments each time, as all but this + * path (and one other) through it add a single byte to + * the EXACTish node. But this one has changed len to + * be the correct final value, so subtract one to + * cancel out the increment that follows */ + len--; + } + else { + REGC((char)ender, s++); + } + } + else /* FOLD */ + if (! ( UTF + /* See comments for join_exact() as to why we fold this + * non-UTF at compile time */ + || (node_type == EXACTFU + && ender == LATIN_SMALL_LETTER_SHARP_S))) + { + *(s++) = (char) ender; + maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender); + } + else { /* UTF */ + + /* Prime the casefolded buffer. Locale rules, which apply + * only to code points < 256, aren't known until execution, + * so for them, just output the original character using + * utf8. If we start to fold non-UTF patterns, be sure to + * update join_exact() */ + if (LOC && ender < 256) { + if (UNI_IS_INVARIANT(ender)) { + *s = (U8) ender; + foldlen = 1; + } else { + *s = UTF8_TWO_BYTE_HI(ender); + *(s + 1) = UTF8_TWO_BYTE_LO(ender); + foldlen = 2; + } + } + else { + UV folded = _to_uni_fold_flags( + ender, + (U8 *) s, + &foldlen, + FOLD_FLAGS_FULL + | ((LOC) ? FOLD_FLAGS_LOCALE + : (ASCII_FOLD_RESTRICTED) + ? FOLD_FLAGS_NOMIX_ASCII + : 0) + ); + + /* If this node only contains non-folding code points + * so far, see if this new one is also non-folding */ + if (maybe_exact) { + if (folded != ender) { + maybe_exact = FALSE; + } + else { + /* Here the fold is the original; we have + * to check further to see if anything + * folds to it */ + if (! PL_utf8_foldable) { + SV* swash = swash_init("utf8", + "_Perl_Any_Folds", + &PL_sv_undef, 1, 0); + PL_utf8_foldable = + _get_swash_invlist(swash); + SvREFCNT_dec_NN(swash); } - else { - /* Here the fold is the original; we have - * to check further to see if anything - * folds to it */ - if (! PL_utf8_foldable) { - SV* swash = swash_init("utf8", - "_Perl_Any_Folds", - &PL_sv_undef, 1, 0); - PL_utf8_foldable = - _get_swash_invlist(swash); - SvREFCNT_dec_NN(swash); - } - if (_invlist_contains_cp(PL_utf8_foldable, - ender)) - { - maybe_exact = FALSE; - } + if (_invlist_contains_cp(PL_utf8_foldable, + ender)) + { + maybe_exact = FALSE; } } - ender = folded; } - s += foldlen; - - /* The loop increments each time, as all but this - * path (and the one just below for UTF) through it add - * a single byte to the EXACTish node. But this one - * has changed len to be the correct final value, so - * subtract one to cancel out the increment that - * follows */ - len += foldlen - 1; - } - else { - *(s++) = (char) ender; - maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender); + ender = folded; } + s += foldlen; + + /* The loop increments each time, as all but this + * path (and one other) through it add a single byte to the + * EXACTish node. But this one has changed len to be the + * correct final value, so subtract one to cancel out the + * increment that follows */ + len += foldlen - 1; } - else if (UTF) { - const STRLEN unilen = reguni(pRExC_state, ender, s); - if (unilen > 0) { - s += unilen; - len += unilen; - } - - /* See comment just above for - 1 */ - len--; - } - else { - REGC((char)ender, s++); - } if (next_is_quantifier) { @@ -11180,8 +11435,7 @@ S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment ) #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c)) PERL_STATIC_INLINE I32 -S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me, - const bool strict) +S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, const bool strict) { dVAR; I32 namedclass = OOB_NAMEDCLASS; @@ -11305,7 +11559,6 @@ S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me, the class closes */ while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']') RExC_parse++; - SvREFCNT_dec(free_me); vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c); } } else { @@ -11325,7 +11578,7 @@ S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me, } STATIC bool -S_could_it_be_POSIX(pTHX_ RExC_state_t *pRExC_state) +S_could_it_be_a_POSIX_class(pTHX_ RExC_state_t *pRExC_state) { /* This applies some heuristics at the current parse position (which should * be at a '[') to see if what follows might be intended to be a [:posix:] @@ -11339,7 +11592,7 @@ S_could_it_be_POSIX(pTHX_ RExC_state_t *pRExC_state) * ')' indicating the end of the (?[ * [:any garbage including %^&$ punctuation:] * - * This is designed to be called only from S_handle_sets; it could be + * This is designed to be called only from S_handle_regex_sets; it could be * easily adapted to be called from the spot at the beginning of regclass() * that checks to see in a normal bracketed class if the surrounding [] * have been omitted ([:word:] instead of [[:word:]]). But doing so would @@ -11347,7 +11600,7 @@ S_could_it_be_POSIX(pTHX_ RExC_state_t *pRExC_state) char* p = RExC_parse + 1; char first_char = *p; - PERL_ARGS_ASSERT_COULD_IT_BE_POSIX; + PERL_ARGS_ASSERT_COULD_IT_BE_A_POSIX_CLASS; assert(*(p - 1) == '['); @@ -11378,7 +11631,7 @@ S_could_it_be_POSIX(pTHX_ RExC_state_t *pRExC_state) } STATIC regnode * -S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, +S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, I32 *flagp, U32 depth, char * const oregcomp_parse) { /* Handle the (?[...]) construct to do set operations */ @@ -11395,7 +11648,7 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, GET_RE_DEBUG_FLAGS_DECL; - PERL_ARGS_ASSERT_HANDLE_SETS; + PERL_ARGS_ASSERT_HANDLE_REGEX_SETS; if (LOC) { vFAIL("(?[...]) not valid in locale"); @@ -11424,30 +11677,39 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, default: break; case '\\': - /* Skip the next byte. This would have to change to skip - * the next character if we were to recognize and handle - * specific non-ASCIIs */ + /* Skip the next byte (which could cause us to end up in + * the middle of a UTF-8 character, but since none of those + * are confusable with anything we currently handle in this + * switch (invariants all), it's safe. We'll just hit the + * default: case next time and keep on incrementing until + * we find one of the invariants we do handle. */ RExC_parse++; break; case '[': { /* If this looks like it is a [:posix:] class, leave the * parse pointer at the '[' to fool regclass() into - * thinking it is part of a '[[:posix]]'. That function + * thinking it is part of a '[[:posix:]]'. That function * will use strict checking to force a syntax error if it * doesn't work out to a legitimate class */ - bool is_posix_class = could_it_be_POSIX(pRExC_state); + bool is_posix_class + = could_it_be_a_POSIX_class(pRExC_state); if (! is_posix_class) { RExC_parse++; } - (void) regclass(pRExC_state, flagp,depth+1, - is_posix_class, /* parse the whole char - class only if not a - posix class */ - FALSE, /* don't allow multi-char folds */ - TRUE, /* silence non-portable warnings. */ - ¤t); + /* regclass() can only return RESTART_UTF8 if multi-char + folds are allowed. */ + if (!regclass(pRExC_state, flagp,depth+1, + is_posix_class, /* parse the whole char + class only if not a + posix class */ + FALSE, /* don't allow multi-char folds */ + TRUE, /* silence non-portable warnings. */ + ¤t)) + FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"", + (UV) *flagp); + /* function call leaves parse pointing to the ']', except * if we faked it */ if (is_posix_class) { @@ -11508,41 +11770,111 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * above. * * A '(' is simply pushed on the stack; it is valid only if the stack is - * empty, or the top element of the stack is an operator (for which the - * parenthesized expression will become an operand). By the time the - * corresponding ')' is parsed everything in between should have been - * parsed and evaluated to a single operand (or else is a syntax error), - * and is handled as a regular operand */ + * empty, or the top element of the stack is an operator or another '(' + * (for which the parenthesized expression will become an operand). By the + * time the corresponding ')' is parsed everything in between should have + * been parsed and evaluated to a single operand (or else is a syntax + * error), and is handled as a regular operand */ stack = newAV(); while (RExC_parse < RExC_end) { - I32 top_index = av_top(stack); + I32 top_index = av_tindex(stack); SV** top_ptr; SV* current = NULL; /* Skip white space */ RExC_parse = regpatws(pRExC_state, RExC_parse, TRUE); /* means recognize comments */ - if (RExC_parse >= RExC_end - || (curchar = UCHARAT(RExC_parse)) == ']') - { /* Exit loop at the end */ + if (RExC_parse >= RExC_end) { + Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'"); + } + if ((curchar = UCHARAT(RExC_parse)) == ']') { break; } switch (curchar) { + case '?': + if (av_tindex(stack) >= 0 /* This makes sure that we can + safely subtract 1 from + RExC_parse in the next clause. + If we have something on the + stack, we have parsed something + */ + && UCHARAT(RExC_parse - 1) == '(' + && RExC_parse < RExC_end) + { + /* If is a '(?', could be an embedded '(?flags:(?[...])'. + * This happens when we have some thing like + * + * my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/; + * ... + * qr/(?[ \p{Digit} & $thai_or_lao ])/; + * + * Here we would be handling the interpolated + * '$thai_or_lao'. We handle this by a recursive call to + * ourselves which returns the inversion list the + * interpolated expression evaluates to. We use the flags + * from the interpolated pattern. */ + U32 save_flags = RExC_flags; + const char * const save_parse = ++RExC_parse; + + parse_lparen_question_flags(pRExC_state); + + if (RExC_parse == save_parse /* Makes sure there was at + least one flag (or this + embedding wasn't compiled) + */ + || RExC_parse >= RExC_end - 4 + || UCHARAT(RExC_parse) != ':' + || UCHARAT(++RExC_parse) != '(' + || UCHARAT(++RExC_parse) != '?' + || UCHARAT(++RExC_parse) != '[') + { + + /* In combination with the above, this moves the + * pointer to the point just after the first erroneous + * character (or if there are no flags, to where they + * should have been) */ + if (RExC_parse >= RExC_end - 4) { + RExC_parse = RExC_end; + } + else if (RExC_parse != save_parse) { + RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; + } + vFAIL("Expecting '(?flags:(?[...'"); + } + RExC_parse++; + (void) handle_regex_sets(pRExC_state, ¤t, flagp, + depth+1, oregcomp_parse); + + /* Here, 'current' contains the embedded expression's + * inversion list, and RExC_parse points to the trailing + * ']'; the next character should be the ')' which will be + * paired with the '(' that has been put on the stack, so + * the whole embedded expression reduces to '(operand)' */ + RExC_parse++; + + RExC_flags = save_flags; + goto handle_operand; + } + /* FALL THROUGH */ + default: RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; vFAIL("Unexpected character"); case '\\': - (void) regclass(pRExC_state, flagp,depth+1, - TRUE, /* means parse just the next thing */ - FALSE, /* don't allow multi-char folds */ - FALSE, /* don't silence non-portable warnings. - */ - ¤t); + /* regclass() can only return RESTART_UTF8 if multi-char + folds are allowed. */ + if (!regclass(pRExC_state, flagp,depth+1, + TRUE, /* means parse just the next thing */ + FALSE, /* don't allow multi-char folds */ + FALSE, /* don't silence non-portable warnings. */ + ¤t)) + FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"", + (UV) *flagp); /* regclass() will return with parsing just the \ sequence, * leaving the parse pointer at the next thing to parse */ RExC_parse--; @@ -11550,19 +11882,22 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, case '[': /* Is a bracketed character class */ { - bool is_posix_class = could_it_be_POSIX(pRExC_state); + bool is_posix_class = could_it_be_a_POSIX_class(pRExC_state); if (! is_posix_class) { RExC_parse++; } - (void) regclass(pRExC_state, flagp,depth+1, - is_posix_class, /* parse the whole char class - only if not a posix class */ - FALSE, /* don't allow multi-char folds */ - FALSE, /* don't silence non-portable warnings. - */ - ¤t); + /* regclass() can only return RESTART_UTF8 if multi-char + folds are allowed. */ + if(!regclass(pRExC_state, flagp,depth+1, + is_posix_class, /* parse the whole char class + only if not a posix class */ + FALSE, /* don't allow multi-char folds */ + FALSE, /* don't silence non-portable warnings. */ + ¤t)) + FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf"", + (UV) *flagp); /* function call leaves parse pointing to the ']', except if we * faked it */ if (is_posix_class) { @@ -11704,19 +12039,24 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; } - if (av_top(stack) < 0 /* Was empty */ + if (av_tindex(stack) < 0 /* Was empty */ || ((final = av_pop(stack)) == NULL) || ! IS_OPERAND(final) - || av_top(stack) >= 0) /* More left on stack */ + || av_tindex(stack) >= 0) /* More left on stack */ { vFAIL("Incomplete expression within '(?[ ])'"); } - invlist_iterinit(final); + /* Here, 'final' is the resultant inversion list from evaluating the + * expression. Return it if so requested */ + if (return_invlist) { + *return_invlist = final; + return END; + } - /* Here, 'final' is the resultant inversion list of evaluating the - * expression. Feed it to regclass() to generate the real resultant node. - * regclass() is expecting a string of ranges and individual code points */ + /* Otherwise generate a resultant node, based on 'final'. regclass() is + * expecting a string of ranges and individual code points */ + invlist_iterinit(final); result_string = newSVpvs(""); while (invlist_iternext(final, &start, &end)) { if (start == end) { @@ -11737,6 +12077,8 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * already has all folding taken into consideration, and we don't want * regclass() to add to that */ RExC_flags &= ~RXf_PMf_FOLD; + /* regclass() can only return RESTART_UTF8 if multi-char folds are allowed. + */ node = regclass(pRExC_state, flagp,depth+1, FALSE, /* means parse the whole char class */ FALSE, /* don't allow multi-char folds */ @@ -11744,6 +12086,9 @@ S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, well have generated non-portable code points, but they're valid on this machine */ NULL); + if (!node) + FAIL2("panic: regclass returned NULL to handle_sets, flags=%#"UVxf, + PTR2UV(flagp)); if (save_fold) { RExC_flags |= RXf_PMf_FOLD; } @@ -11793,7 +12138,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * corresponding bit set if that character is in the list. For characters * above 255, a range list or swash is used. There are extra bits for \w, * etc. in locale ANYOFs, as what these match is not determinable at - * compile time */ + * compile time + * + * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs + * to be restarted. This can only happen if ret_invlist is non-NULL. + */ dVAR; UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE; @@ -11879,8 +12228,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (LOC) { ANYOF_FLAGS(ret) |= ANYOF_LOCALE; } - listsv = newSVpvs("# comment\n"); + listsv = newSVpvs_flags("# comment\n", SVs_TEMP); initial_listsv_len = SvCUR(listsv); + SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated. */ } if (skip_white) { @@ -11908,12 +12258,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, s++; if (*s && c == *s && s[1] == ']') { SAVEFREESV(RExC_rx_sv); - SAVEFREESV(listsv); ckWARN3reg(s+2, "POSIX syntax [%c %c] belongs inside character classes", c, c); (void)ReREFCNT_inc(RExC_rx_sv); - SvREFCNT_inc_simple_void_NN(listsv); } } @@ -11965,7 +12313,7 @@ parseit: && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) { - namedclass = regpposixcc(pRExC_state, value, listsv, strict); + namedclass = regpposixcc(pRExC_state, value, strict); } else if (value == '\\') { if (UTF) { @@ -12010,6 +12358,8 @@ parseit: TRUE, /* => charclass */ strict)) { + if (*flagp & RESTART_UTF8) + FAIL("panic: grok_bslash_N set RESTART_UTF8"); goto parseit; } } @@ -12203,7 +12553,6 @@ parseit: value = grok_oct(--RExC_parse, &numlen, &flags, NULL); RExC_parse += numlen; if (numlen != 3) { - SAVEFREESV(listsv); /* In case warnings are fatalized */ if (strict) { RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1; vFAIL("Need exactly 3 octal digits"); @@ -12220,7 +12569,6 @@ parseit: form_short_octal_warning(RExC_parse, numlen)); (void)ReREFCNT_inc(RExC_rx_sv); } - SvREFCNT_inc_simple_void_NN(listsv); } if (PL_encoding && value < 0x100) goto recode_encoding; @@ -12244,7 +12592,6 @@ parseit: default: /* Allow \_ to not give an error */ if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') { - SAVEFREESV(listsv); if (strict) { vFAIL2("Unrecognized escape \\%c in character class", (int)value); @@ -12256,7 +12603,6 @@ parseit: (int)value); (void)ReREFCNT_inc(RExC_rx_sv); } - SvREFCNT_inc_simple_void_NN(listsv); } break; } /* End of switch on char following backslash */ @@ -12302,7 +12648,6 @@ parseit: const int w = (RExC_parse >= rangebegin) ? RExC_parse - rangebegin : 0; - SAVEFREESV(listsv); /* in case of fatal warnings */ if (strict) { vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin); } @@ -12315,7 +12660,6 @@ parseit: cp_list = add_cp_to_invlist(cp_list, '-'); cp_list = add_cp_to_invlist(cp_list, prevvalue); } - SvREFCNT_inc_simple_void_NN(listsv); } range = 0; /* this was not a true range */ @@ -12718,17 +13062,17 @@ parseit: /* is actually an array of arrays. * There will be one or two top-level elements: [2], * and/or [3]. The [2] element is an array, each - * element thereof is a character which folds to two - * characters; likewise for [3]. (Unicode guarantees a - * maximum of 3 characters in any fold.) When we - * rewrite the character class below, we will do so - * such that the longest folds are written first, so - * that it prefers the longest matching strings first. - * This is done even if it turns out that any - * quantifier is non-greedy, out of programmer - * laziness. Tom Christiansen has agreed that this is - * ok. This makes the test for the ligature 'ffi' come - * before the test for 'ff' */ + * element thereof is a character which folds to TWO + * characters; [3] is for folds to THREE characters. + * (Unicode guarantees a maximum of 3 characters in any + * fold.) When we rewrite the character class below, + * we will do so such that the longest folds are + * written first, so that it prefers the longest + * matching strings first. This is done even if it + * turns out that any quantifier is non-greedy, out of + * programmer laziness. Tom Christiansen has agreed + * that this is ok. This makes the test for the + * ligature 'ffi' come before the test for 'ff' */ if (av_exists(multi_char_matches, cp_count)) { this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE); @@ -12757,7 +13101,7 @@ parseit: #ifndef EBCDIC cp_list = _add_range_to_invlist(cp_list, prevvalue, value); #else - UV* this_range = _new_invlist(1); + SV* this_range = _new_invlist(1); _append_range_to_invlist(this_range, prevvalue, value); /* In EBCDIC, the ranges 'A-Z' and 'a-z' are each not contiguous. @@ -12772,8 +13116,8 @@ parseit: && (prevvalue >= 'a' && value <= 'z') || (prevvalue >= 'A' && value <= 'Z')) { - _invlist_intersection(this_range, PL_ASCII, &this_range, ); - _invlist_intersection(this_range, PL_Alpha, &this_range, ); + _invlist_intersection(this_range, PL_Posix_ptrs[_CC_ALPHA], + &this_range); } _invlist_union(cp_list, this_range, &cp_list); literal_endpoint = 0; @@ -12851,13 +13195,12 @@ parseit: ret = reg(pRExC_state, 1, ®_flags, depth+1); - *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED); + *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_UTF8); RExC_parse = save_parse; RExC_end = save_end; RExC_in_multi_char_class = 0; SvREFCNT_dec_NN(multi_char_matches); - SvREFCNT_dec_NN(listsv); return ret; } @@ -13015,7 +13358,6 @@ parseit: RExC_parse = (char *) cur_parse; SvREFCNT_dec(posixes); - SvREFCNT_dec_NN(listsv); SvREFCNT_dec(cp_list); return ret; } @@ -13234,8 +13576,7 @@ parseit: * doesn't allow them between above and below 256 */ if ((ASCII_FOLD_RESTRICTED && (isASCII(c) != isASCII(j))) - || (LOC && ((c < 256) != (j < 256)))) - { + || (LOC && c < 256)) { continue; } @@ -13383,7 +13724,7 @@ parseit: else { RExC_emit = orig_emit; } - return END; + return orig_emit; } /* If we didn't do folding, it's because some information isn't available @@ -13517,7 +13858,6 @@ parseit: } SvREFCNT_dec_NN(cp_list); - SvREFCNT_dec_NN(listsv); return ret; } } @@ -13605,7 +13945,6 @@ parseit: && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) { ARG_SET(ret, ANYOF_NONBITMAP_EMPTY); - SvREFCNT_dec_NN(listsv); } else { /* av[0] stores the character class description in its textual form: @@ -13622,8 +13961,7 @@ parseit: SV *rv; av_store(av, 0, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) - ? listsv - : (SvREFCNT_dec_NN(listsv), &PL_sv_undef)); + ? SvREFCNT_inc(listsv) : &PL_sv_undef); if (swash) { av_store(av, 1, swash); SvREFCNT_dec_NN(cp_list); @@ -14871,10 +15209,6 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) npar = r->nparens+1; Newx(ret->offs, npar, regexp_paren_pair); Copy(r->offs, ret->offs, npar, regexp_paren_pair); - if(ret->swap) { - /* no need to copy these */ - Newx(ret->swap, npar, regexp_paren_pair); - } if (ret->substrs) { /* Do it this way to avoid reading from *r after the StructCopy(). @@ -15126,29 +15460,6 @@ Perl_save_re_context(pTHX) { dVAR; - struct re_save_state *state; - - SAVEVPTR(PL_curcop); - SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1); - - state = (struct re_save_state *)(PL_savestack + PL_savestack_ix); - PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE; - SSPUSHUV(SAVEt_RE_STATE); - - Copy(&PL_reg_state, state, 1, struct re_save_state); - - PL_reg_oldsaved = NULL; - PL_reg_oldsavedlen = 0; - PL_reg_oldsavedoffset = 0; - PL_reg_oldsavedcoffset = 0; - PL_reg_maxiter = 0; - PL_reg_leftiter = 0; - PL_reg_poscache = NULL; - PL_reg_poscache_size = 0; -#ifdef PERL_ANY_COW - PL_nrs = NULL; -#endif - /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ if (PL_curpm) { const REGEXP * const rx = PM_GETRE(PL_curpm); @@ -15186,8 +15497,11 @@ S_put_byte(pTHX_ SV *sv, int c) EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all ones (binary 1111 1111, hexadecimal FF). It is similar, but not - identical, to the ASCII delete (DEL) or rubout control character. - ) So the old condition can be simplified to !isPRINT(c) */ + identical, to the ASCII delete (DEL) or rubout control character. ... + it is typically mapped to hexadecimal code 9F, in order to provide a + unique character mapping in both directions) + + So the old condition can be simplified to !isPRINT(c) */ if (!isPRINT(c)) { if (c < 256) { Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);