}
/* If e.g., both \w and \W are set, matches everything */
- if (ANYOF_FLAGS(ssc) & ANYOF_POSIXL) {
+ if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
int i;
for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
* necessary. */
if (RExC_contains_locale) {
ANYOF_POSIXL_SETALL(ssc);
- ANYOF_FLAGS(ssc) |= ANYOF_LOCALE|ANYOF_POSIXL;
}
else {
ANYOF_POSIXL_ZERO(ssc);
return FALSE;
}
- if (RExC_contains_locale
- && ! ((ANYOF_FLAGS(ssc) & ANYOF_LOCALE)
- || ! (ANYOF_FLAGS(ssc) & ANYOF_POSIXL)
- || ! ANYOF_POSIXL_TEST_ALL_SET(ssc)))
- {
+ if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
return FALSE;
}
STATIC SV*
S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
- const regnode_charclass_posixl_fold* const node)
+ const regnode_charclass* const node)
{
/* Returns a mortal inversion list defining which code points are matched
* by 'node', which is of type ANYOF. Handles complementing the result if
* possibility. */
SV* invlist = sv_2mortal(_new_invlist(0));
+ SV* only_utf8_locale_invlist = NULL;
unsigned int i;
const U32 n = ARG(node);
bool new_node_has_latin1 = FALSE;
* known until runtime -- we have to assume it could be anything */
return _add_range_to_invlist(invlist, 0, UV_MAX);
}
- else {
+ else if (ary[3] && ary[3] != &PL_sv_undef) {
/* Here no compile-time swash, and no run-time only data. Use the
* node's inversion list */
- invlist = sv_2mortal(invlist_clone(ary[2]));
+ invlist = sv_2mortal(invlist_clone(ary[3]));
+ }
+
+ /* Get the code points valid only under UTF-8 locales */
+ if ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD)
+ && ary[2] && ary[2] != &PL_sv_undef)
+ {
+ only_utf8_locale_invlist = ary[2];
}
}
_invlist_union(invlist, PL_Latin1, &invlist);
}
- /* Similarly add the UTF-8 locale possible matches */
- if (ANYOF_FLAGS(node) & ANYOF_LOC_FOLD && ANYOF_UTF8_LOCALE_INVLIST(node))
- {
+ /* Similarly add the UTF-8 locale possible matches. These have to be
+ * deferred until after the non-UTF-8 locale ones are taken care of just
+ * above, or it leads to wrong results under ANYOF_INVERT */
+ if (only_utf8_locale_invlist) {
_invlist_union_maybe_complement_2nd(invlist,
- ANYOF_UTF8_LOCALE_INVLIST(node),
+ only_utf8_locale_invlist,
ANYOF_FLAGS(node) & ANYOF_INVERT,
&invlist);
}
#define ssc_add_cp(ssc, cp) ssc_add_range((ssc), (cp), (cp))
#define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
-STATIC void
-S_ssc_flags_and(regnode_ssc *ssc, const U8 and_with)
-{
- /* Take the flags 'and_with' and accumulate them anded into the flags for
- * the SSC 'ssc'. The non-SSC related flags in 'and_with' are ignored.
- * The flags 'and_with' should not come from another SSC (otherwise the
- * EMPTY_STRING flag won't work) */
-
- const U8 ssc_only_flags = ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS;
-
- PERL_ARGS_ASSERT_SSC_FLAGS_AND;
-
- /* Use just the SSC-related flags from 'and_with' */
- ANYOF_FLAGS(ssc) &= (and_with & ANYOF_COMMON_FLAGS);
- ANYOF_FLAGS(ssc) |= ssc_only_flags;
-}
-
/* 'AND' a given class with another one. Can create false positives. 'ssc'
* should not be inverted. 'and_with->flags & ANYOF_POSIXL' should be 0 if
* 'and_with' is a regnode_charclass instead of a regnode_ssc. */
}
}
else {
- anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state,
- (regnode_charclass_posixl_fold*) and_with);
+ anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
}
if (! (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) {
ANYOF_POSIXL_ZERO(ssc);
}
- else if (ANYOF_POSIXL_TEST_ANY_SET(ssc)) {
+ else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
/* Note that the Posix class component P from 'and_with' actually
* looks like:
* standard, in particular almost everything by Microsoft.
* The loop below just changes e.g., \w into \W and vice versa */
- regnode_charclass_posixl_fold temp;
+ regnode_charclass_posixl temp;
int add = 1; /* To calculate the index of the complement */
ANYOF_POSIXL_ZERO(&temp);
}
}
}
- else if ((ANYOF_FLAGS(ssc) & ANYOF_POSIXL)
- || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL))
+ else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
+ || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL))
{
/* One or the other of P1, P2 is non-empty. */
- ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
+ if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) {
+ ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
+ }
ssc_union(ssc, anded_cp_list, FALSE);
}
else { /* P1 = P2 = empty */
ored_flags = ANYOF_FLAGS(or_with);
}
else {
- ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state,
- (regnode_charclass_posixl_fold*) or_with);
+ ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
}
&& ! is_ANYOF_SYNTHETIC(or_with))
{
/* We ignore P2, leaving P1 going forward */
- }
- else { /* Not inverted */
+ } /* else Not inverted */
+ else if (ANYOF_FLAGS(or_with) & ANYOF_POSIXL) {
ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
- if (ANYOF_POSIXL_TEST_ANY_SET(ssc)) {
+ if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
unsigned int i;
for (i = 0; i < ANYOF_MAX; i += 2) {
if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
ssc_match_all_cp(ssc);
ANYOF_POSIXL_CLEAR(ssc, i);
ANYOF_POSIXL_CLEAR(ssc, i+1);
- if (! ANYOF_POSIXL_TEST_ANY_SET(ssc)) {
- ANYOF_FLAGS(ssc) &= ~ANYOF_POSIXL;
- }
}
}
}
populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
- set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL, FALSE);
+ set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
+ NULL, NULL, NULL, FALSE);
- /* The code points that could match under /li are already incorporated into
- * the inversion list and bit map */
- ANYOF_FLAGS(ssc) &= ~ANYOF_LOC_FOLD;
+ /* Make sure is clone-safe */
+ ssc->invlist = NULL;
+
+ if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
+ ANYOF_FLAGS(ssc) |= ANYOF_POSIXL;
+ }
- assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE) || RExC_contains_locale);
+ assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
}
#define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
foldlen -= UTF8SKIP(uc);
}
else {
- foldlen = is_MULTI_CHAR_FOLD_utf8(uc);
+ foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e);
minbytes++;
}
}
foldlen--;
}
else {
- foldlen = is_MULTI_CHAR_FOLD_latin1(uc);
+ foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e);
minbytes++;
}
}
DEBUG_OPTIMISE_r({if (scan){ \
SV * const mysv=sv_newmortal(); \
regnode *Next = regnext(scan); \
- regprop(RExC_rx, mysv, scan); \
+ regprop(RExC_rx, mysv, scan, NULL); \
PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
(int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
Next ? (REG_NODE_NUM(Next)) : 0 ); \
length sequence we are looking for is 2 */
{
int count = 0; /* How many characters in a multi-char fold */
- int len = is_MULTI_CHAR_FOLD_utf8(s);
+ int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
if (! len) { /* Not a multi-char fold: get next char */
s += UTF8SKIP(s);
continue;
: s_end -1;
while (s < upper) {
- int len = is_MULTI_CHAR_FOLD_latin1(s);
+ int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
if (! len) { /* Not a multi-char fold. */
if (*s == LATIN_SMALL_LETTER_SHARP_S
&& (OP(scan) == EXACTF || OP(scan) == EXACTFL))
DEBUG_PEEP("Peep", scan, depth);
- /* Its not clear to khw or hv why this is done here, and not in the
- * clauses that deal with EXACT nodes. khw's guess is that it's
- * because of a previous design */
+ /* The reason we do this here we need to deal with things like /(?:f)(?:o)(?:o)/
+ * which cant be dealt with by the normal EXACT parsing code, as each (?:..) is handled
+ * by a different invocation of reg() -- Yves
+ */
JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
/* Follow the next-chain of the current node and optimize
}
}
- if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch )
- == BRANCH )
+ if (PERL_ENABLE_TRIE_OPTIMISATION &&
+ OP( startbranch ) == BRANCH )
{
/* demq.
DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, mysv, tail );
+ regprop(RExC_rx, mysv, tail, NULL);
PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
(int)depth * 2 + 2, "",
"Looking for TRIE'able sequences. Tail node is: ",
#endif
DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, mysv, cur);
+ regprop(RExC_rx, mysv, cur, NULL);
PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
(int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
- regprop(RExC_rx, mysv, noper);
+ regprop(RExC_rx, mysv, noper, NULL);
PerlIO_printf( Perl_debug_log, " -> %s",
SvPV_nolen_const(mysv));
if ( noper_next ) {
- regprop(RExC_rx, mysv, noper_next );
+ regprop(RExC_rx, mysv, noper_next, NULL);
PerlIO_printf( Perl_debug_log,"\t=> %s\t",
SvPV_nolen_const(mysv));
}
} /* end handle unmergable node */
} /* loop over branches */
DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, mysv, cur);
+ regprop(RExC_rx, mysv, cur, NULL);
PerlIO_printf( Perl_debug_log,
"%*s- %s (%d) <SCAN FINISHED>\n",
(int)depth * 2 + 2,
* something like this: (?:|) So we can
* turn it into a plain NOTHING op. */
DEBUG_TRIE_COMPILE_r({
- regprop(RExC_rx, mysv, cur);
+ regprop(RExC_rx, mysv, cur, NULL);
PerlIO_printf( Perl_debug_log,
"%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
"", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
}
}
if (OP(scan) == EXACTFL) {
- if (flags & SCF_DO_STCLASS_AND) {
- ssc_flags_and(data->start_class, ANYOF_LOCALE);
- }
- else if (flags & SCF_DO_STCLASS_OR) {
- ANYOF_FLAGS(data->start_class) |= ANYOF_LOCALE;
- }
/* We don't know what the folds are; it could be anything. XXX
* Actually, we only support UTF-8 encoding for code points
ssc_match_all_cp(data->start_class);
ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
ANYOF_POSIXL_CLEAR(data->start_class, complement);
- if (! ANYOF_POSIXL_TEST_ANY_SET(data->start_class))
- {
- ANYOF_FLAGS(data->start_class) &= ~ANYOF_POSIXL;
- }
}
else { /* The usual case; just add this class to the
existing set */
ANYOF_POSIXL_SET(data->start_class, namedclass);
- ANYOF_FLAGS(data->start_class)
- |= ANYOF_LOCALE|ANYOF_POSIXL;
}
}
break;
DEBUG_STUDYDATA("OPFAIL",data,depth);
/*DEBUG_PARSE_MSG("opfail");*/
- regprop(RExC_rx, mysv_val, upto);
+ regprop(RExC_rx, mysv_val, upto, NULL);
PerlIO_printf(Perl_debug_log,
"~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
SvPV_nolen_const(mysv_val),
if (rx_flags & PMf_FOLD) {
RExC_contains_i = 1;
}
- if (initial_charset == REGEX_LOCALE_CHARSET) {
- RExC_contains_locale = 1;
- }
- else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
+ if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
/* Set to use unicode semantics if the pattern is in utf8 and has the
* 'depends' charset specified, as it means unicode when utf8 */
ri->regstclass = (regnode*)RExC_rxi->data->data[n];
r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
- regprop(r, sv, (regnode*)data.start_class);
+ regprop(r, sv, (regnode*)data.start_class, NULL);
PerlIO_printf(Perl_debug_log,
"synthetic stclass \"%s\".\n",
SvPVX_const(sv));});
ri->regstclass = (regnode*)RExC_rxi->data->data[n];
r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
- regprop(r, sv, (regnode*)data.start_class);
+ regprop(r, sv, (regnode*)data.start_class, NULL);
PerlIO_printf(Perl_debug_log,
"synthetic stclass \"%s\".\n",
SvPVX_const(sv));});
if (r->intflags & PREGf_ANCH)
r->extflags |= RXf_IS_ANCHORED;
+
{
+ /* this is used to identify "special" patterns that might result
+ * in Perl NOT calling the regex engine and instead doing the match "itself",
+ * particularly special cases in split//. By having the regex compiler
+ * do this pattern matching at a regop level (instead of by inspecting the pattern)
+ * we avoid weird issues with equivalent patterns resulting in different behavior,
+ * AND we allow non Perl engines to get the same optimizations by the setting the
+ * flags appropriately - Yves */
regnode *first = ri->program + 1;
U8 fop = OP(first);
regnode *next = NEXTOPER(first);
r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
}
+
+ if (RExC_contains_locale) {
+ RXp_EXTFLAGS(r) |= RXf_TAINTED_SEEN;
+ }
+
#ifdef DEBUGGING
if (RExC_paren_names) {
ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
} else if (flags & RXapif_ONE) {
ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
av = MUTABLE_AV(SvRV(ret));
- length = av_len(av);
+ length = av_tindex(av);
SvREFCNT_dec_NN(ret);
return newSViv(length + 1);
} else {
}
cs = REGEX_LOCALE_CHARSET;
has_charset_modifier = LOCALE_PAT_MOD;
- RExC_contains_locale = 1;
break;
case UNICODE_PAT_MOD:
if (has_charset_modifier) {
SV * const mysv_val1=sv_newmortal();
SV * const mysv_val2=sv_newmortal();
DEBUG_PARSE_MSG("lsbr");
- regprop(RExC_rx, mysv_val1, lastbr);
- regprop(RExC_rx, mysv_val2, ender);
+ regprop(RExC_rx, mysv_val1, lastbr, NULL);
+ regprop(RExC_rx, mysv_val2, ender, NULL);
PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
SvPV_nolen_const(mysv_val1),
(IV)REG_NODE_NUM(lastbr),
SV * const mysv_val1=sv_newmortal();
SV * const mysv_val2=sv_newmortal();
DEBUG_PARSE_MSG("NADA");
- regprop(RExC_rx, mysv_val1, ret);
- regprop(RExC_rx, mysv_val2, ender);
+ regprop(RExC_rx, mysv_val1, ret, NULL);
+ regprop(RExC_rx, mysv_val2, ender, NULL);
PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
SvPV_nolen_const(mysv_val1),
(IV)REG_NODE_NUM(ret),
PERL_STATIC_INLINE void
S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
regnode *node, I32* flagp, STRLEN len, UV code_point,
- const bool downgradable)
+ bool downgradable)
{
/* This knows the details about sizing an EXACTish node, setting flags for
* it (by setting <*flagp>, and potentially populating it with a single
PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
+ /* Don't bother to check for downgrading in PASS1, as it doesn't make any
+ * sizing difference, and is extra work that is thrown away */
+ if (downgradable && ! PASS2) {
+ downgradable = FALSE;
+ }
+
if (! len_passed_in) {
if (UTF) {
if (UNI_IS_INVARIANT(code_point)) {
{
*flagp |= SIMPLE;
}
+
+ /* The OP may not be well defined in PASS1 */
+ if (PASS2 && OP(node) == EXACTFL) {
+ RExC_contains_locale = 1;
+ }
}
if (op > BOUNDA) { /* /aa is same as /a */
op = BOUNDA;
}
+ else if (op == BOUNDL) {
+ RExC_contains_locale = 1;
+ }
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
if (op > NBOUNDA) { /* /aa is same as /a */
op = NBOUNDA;
}
+ else if (op == NBOUNDL) {
+ RExC_contains_locale = 1;
+ }
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
if (op > POSIXA) { /* /aa is same as /a */
op = POSIXA;
}
+ else if (op == POSIXL) {
+ RExC_contains_locale = 1;
+ }
join_posix_op_known:
}
else {
num = S_backref_value(RExC_parse);
- /* bare \NNN might be backref or octal */
+ /* bare \NNN might be backref or octal - if it is larger than or equal
+ * RExC_npar then it is assumed to be and octal escape.
+ * Note RExC_npar is +1 from the actual number of parens*/
if (num == I32_MAX || (num > 9 && num >= RExC_npar
&& *RExC_parse != '8' && *RExC_parse != '9'))
+ {
/* Probably a character specified in octal, e.g. \35 */
goto defchar;
+ }
}
/* at this point RExC_parse definitely points to a backref
* 118 OR as "\11" . "8" depending on whether there
* were 118 capture buffers defined already in the
* pattern. */
- if ( !isDIGIT(p[1]) || S_backref_value(p) <= RExC_npar)
+
+ /* NOTE, RExC_npar is 1 more than the actual number of
+ * parens we have seen so far, hence the < RExC_npar below. */
+
+ if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
{ /* Not to be treated as an octal constant, go
find backref */
--p;
if (! SIZE_ONLY
&& RExC_flags & RXf_PMf_EXTENDED
&& ckWARN_d(WARN_DEPRECATED)
- && is_PATWS_non_low(p, UTF))
+ && is_PATWS_non_low_safe(p, RExC_end, UTF))
{
vWARN_dep(p + ((UTF) ? UTF8SKIP(p) : 1),
"Escape literal pattern white space under /x");
if (end == UV_MAX && start <= 256) {
ANYOF_FLAGS(node) |= ANYOF_ABOVE_LATIN1_ALL;
}
+ else if (end >= 256) {
+ ANYOF_FLAGS(node) |= ANYOF_UTF8;
+ }
/* Quit if are above what we should change */
if (start > 255) {
* that fold to/from them under /i */
SV* cp_foldable_list = NULL;
+ /* Like cp_list, but code points on this list are valid only when the
+ * runtime locale is UTF-8 */
+ SV* only_utf8_locale_list = NULL;
+
#ifdef EBCDIC
/* In a range, counts how many 0-2 of the ends of it came from literals,
* not escapes. Thus we can tell if 'A' was input vs \x{C1} */
ANYOF_FLAGS(ret) = 0;
RExC_emit += ANYOF_SKIP;
- if (LOC) {
- ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
- }
listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
initial_listsv_len = SvCUR(listsv);
SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated. */
/* Here, we have the current token in 'value' */
- /* What matches in a locale is not known until runtime. This includes
- * what the Posix classes (like \w, [:space:]) match. Room must be
- * reserved (one time per outer bracketed class) to store such classes,
- * either if Perl is compiled so that locale nodes always should have
- * this space, or if there is such posix class info to be stored. The
- * space will contain a bit for each named class that is to be matched
- * against. This isn't needed for \p{} and pseudo-classes, as they are
- * not affected by locale, and hence are dealt with separately */
- if (LOC) {
- if (FOLD && ! need_class) {
- need_class = 1;
- if (SIZE_ONLY) {
- RExC_size += ANYOF_POSIXL_FOLD_SKIP - ANYOF_SKIP;
- }
- else {
- RExC_emit += ANYOF_POSIXL_FOLD_SKIP - ANYOF_SKIP;
- }
-
- /* We need to initialize this here because this node type has
- * this field, and will skip getting initialized when we get to
- * a posix class since are doing it here */
- ANYOF_POSIXL_ZERO(ret);
- }
- if (ANYOF_LOCALE == ANYOF_POSIXL
- || (namedclass > OOB_NAMEDCLASS
- && namedclass < ANYOF_POSIXL_MAX))
- {
- if (! need_class) {
- need_class = 1;
- if (SIZE_ONLY) {
- RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
- }
- else {
- RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
- }
- ANYOF_POSIXL_ZERO(ret);
- }
- ANYOF_FLAGS(ret) |= ANYOF_POSIXL;
- }
- }
-
if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
U8 classnum;
&& classnum != _CC_ASCII
#endif
) {
+ /* What the Posix classes (like \w, [:space:]) match in locale
+ * isn't knowable under locale until actual match time. Room
+ * must be reserved (one time per outer bracketed class) to
+ * store such classes. The space will contain a bit for each
+ * named class that is to be matched against. This isn't
+ * needed for \p{} and pseudo-classes, as they are not affected
+ * by locale, and hence are dealt with separately */
+ if (! need_class) {
+ need_class = 1;
+ if (SIZE_ONLY) {
+ RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
+ }
+ else {
+ RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
+ }
+ ANYOF_FLAGS(ret) |= ANYOF_POSIXL;
+ ANYOF_POSIXL_ZERO(ret);
+ }
/* See if it already matches the complement of this POSIX
* class */
#endif
/* Look at the longest folds first */
- for (cp_count = av_len(multi_char_matches); cp_count > 0; cp_count--) {
+ for (cp_count = av_tindex(multi_char_matches); cp_count > 0; cp_count--) {
if (av_exists(multi_char_matches, cp_count)) {
AV** this_array_ptr;
else {
RExC_emit = (regnode *)orig_emit;
if (PL_regkind[op] == POSIXD) {
+ if (op == POSIXL) {
+ RExC_contains_locale = 1;
+ }
if (invert) {
op += NPOSIXD - POSIXD;
}
* runtime only when the locale indicates Unicode rules. For
* non-locale, we just use to the general list */
if (LOC) {
- use_list = &ANYOF_UTF8_LOCALE_INVLIST(ret);
- *use_list = NULL;
+ use_list = &only_utf8_locale_list;
}
else {
use_list = &cp_list;
{
AV* list = (AV*) *listp;
IV k;
- for (k = 0; k <= av_len(list); k++) {
+ for (k = 0; k <= av_tindex(list); k++) {
SV** c_p = av_fetch(list, k, FALSE);
UV c;
if (c_p == NULL) {
* fetching). We know to set the flag if we have a non-NULL list for UTF-8
* locales, or the class matches at least one 0-255 range code point */
if (LOC && FOLD) {
- if (ANYOF_UTF8_LOCALE_INVLIST(ret)) {
+ if (only_utf8_locale_list) {
ANYOF_FLAGS(ret) |= ANYOF_LOC_FOLD;
}
else if (cp_list) { /* Look to see if there a 0-255 code point is in
* invert if there are things such as \w, which aren't known until runtime
* */
if (invert
- && ! (ANYOF_FLAGS(ret) & (ANYOF_LOC_FOLD|ANYOF_POSIXL))
+ && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
&& ! depends_list
&& ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
{
if (cp_list
&& ! invert
&& ! depends_list
- && ! (ANYOF_FLAGS(ret) & (ANYOF_LOC_FOLD|ANYOF_POSIXL))
+ && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
&& ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
/* We don't optimize if we are supposed to make sure all non-Unicode
else {
cp_list = depends_list;
}
+ ANYOF_FLAGS(ret) |= ANYOF_UTF8;
}
/* If there is a swash and more than one element, we can't use the swash in
set_ANYOF_arg(pRExC_state, ret, cp_list,
(HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
? listsv : NULL,
+ only_utf8_locale_list,
swash, has_user_defined_property);
*flagp |= HASWIDTH|SIMPLE;
+
+ if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
+ RExC_contains_locale = 1;
+ }
+
return ret;
}
regnode* const node,
SV* const cp_list,
SV* const runtime_defns,
+ SV* const only_utf8_locale_list,
SV* const swash,
const bool has_user_defined_property)
{
* av[1] if &PL_sv_undef, is a placeholder to later contain the swash
* computed from av[0]. But if no further computation need be done,
* the swash is stored here now (and av[0] is &PL_sv_undef).
- * av[2] stores the cp_list inversion list for use in addition or instead
+ * av[2] stores the inversion list of code points that match only if the
+ * current locale is UTF-8
+ * av[3] stores the cp_list inversion list for use in addition or instead
* of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
* (Otherwise everything needed is already in av[0] and av[1])
- * av[3] is set if any component of the class is from a user-defined
- * property; used only if av[2] exists */
+ * av[4] is set if any component of the class is from a user-defined
+ * property; used only if av[3] exists */
UV n;
PERL_ARGS_ASSERT_SET_ANYOF_ARG;
- if (! cp_list && ! runtime_defns) {
+ if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
+ assert(! (ANYOF_FLAGS(node)
+ & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8)));
ARG_SET(node, ANYOF_NONBITMAP_EMPTY);
}
else {
AV * const av = newAV();
SV *rv;
+ assert(ANYOF_FLAGS(node)
+ & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD));
+
av_store(av, 0, (runtime_defns)
? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
if (swash) {
else {
av_store(av, 1, &PL_sv_undef);
if (cp_list) {
- av_store(av, 2, cp_list);
- av_store(av, 3, newSVuv(has_user_defined_property));
+ av_store(av, 3, cp_list);
+ av_store(av, 4, newSVuv(has_user_defined_property));
}
}
+ if (only_utf8_locale_list) {
+ av_store(av, 2, only_utf8_locale_list);
+ }
+ else {
+ av_store(av, 2, &PL_sv_undef);
+ }
+
rv = newRV_noinc(MUTABLE_SV(av));
n = add_data(pRExC_state, STR_WITH_LEN("s"));
RExC_rxi->data->data[n] = (void*)rv;
DEBUG_PARSE_r({
SV * const mysv=sv_newmortal();
DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
- regprop(RExC_rx, mysv, scan);
+ regprop(RExC_rx, mysv, scan, NULL);
PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
(temp == NULL ? "->" : ""),
DEBUG_PARSE_r({
SV * const mysv=sv_newmortal();
DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
- regprop(RExC_rx, mysv, scan);
+ regprop(RExC_rx, mysv, scan, NULL);
PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
SvPV_nolen_const(mysv),
REG_NODE_NUM(scan),
DEBUG_PARSE_r({
SV * const mysv_val=sv_newmortal();
DEBUG_PARSE_MSG("");
- regprop(RExC_rx, mysv_val, val);
+ regprop(RExC_rx, mysv_val, val, NULL);
PerlIO_printf(Perl_debug_log,
"~ attach to %s (%"IVdf") offset to %"IVdf"\n",
SvPV_nolen_const(mysv_val),
PerlIO_printf(Perl_debug_log, ") ");
if (ri->regstclass) {
- regprop(r, sv, ri->regstclass);
+ regprop(r, sv, ri->regstclass, NULL);
PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
}
if (r->intflags & PREGf_ANCH) {
}
/*
-- regprop - printable representation of opcode
+- regprop - printable representation of opcode, with run time support
*/
void
-Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
+Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo)
{
#ifdef DEBUGGING
dVAR;
(UV)trie->maxlen,
(UV)TRIE_CHARCOUNT(trie),
(UV)trie->uniquecharcount
- )
+ );
);
if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
sv_catpvs(sv, "[");
}
}
}
+ if ( k == REF && reginfo) {
+ U32 n = ARG(o); /* which paren pair */
+ I32 ln = prog->offs[n].start;
+ if (prog->lastparen < n || ln == -1)
+ Perl_sv_catpvf(aTHX_ sv, ": FAIL");
+ else if (ln == prog->offs[n].end)
+ Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
+ else {
+ const char *s = reginfo->strbeg + ln;
+ Perl_sv_catpvf(aTHX_ sv, ": ");
+ Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
+ PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
+ }
+ }
} else if (k == GOSUB)
/* Paren and offset */
Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o));
int do_sep = 0;
- if (flags & ANYOF_LOCALE)
+ if (flags & ANYOF_LOCALE_FLAGS)
sv_catpvs(sv, "{loc}");
if (flags & ANYOF_LOC_FOLD)
sv_catpvs(sv, "{i}");
}
}
- if ((flags & ANYOF_ABOVE_LATIN1_ALL)
- || ANYOF_UTF8_LOCALE_INVLIST(o) || ANYOF_NONBITMAP(o))
+ if ((flags & (ANYOF_ABOVE_LATIN1_ALL
+ |ANYOF_UTF8
+ |ANYOF_NONBITMAP_NON_UTF8
+ |ANYOF_LOC_FOLD)))
{
if (do_sep) {
Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
/* output information about the unicode matching */
if (flags & ANYOF_ABOVE_LATIN1_ALL)
sv_catpvs(sv, "{unicode_all}");
- else if (ANYOF_NONBITMAP(o)) {
+ else if (ARG(o) != ANYOF_NONBITMAP_EMPTY) {
SV *lv; /* Set if there is something outside the bit map. */
bool byte_output = FALSE; /* If something in the bitmap has
been output */
+ SV *only_utf8_locale;
/* Get the stuff that wasn't in the bitmap */
- (void) regclass_swash(prog, o, FALSE, &lv, NULL);
+ (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
+ &lv, &only_utf8_locale);
if (lv && lv != &PL_sv_undef) {
char *s = savesvpv(lv);
char * const origs = s;
Safefree(origs);
SvREFCNT_dec_NN(lv);
}
- }
- /* Output any UTF-8 locale code points */
- if (flags & ANYOF_LOC_FOLD && ANYOF_UTF8_LOCALE_INVLIST(o)) {
- UV start, end;
- int max_entries = 256;
-
- sv_catpvs(sv, "{utf8 locale}");
- invlist_iterinit(ANYOF_UTF8_LOCALE_INVLIST(o));
- while (invlist_iternext(ANYOF_UTF8_LOCALE_INVLIST(o),
- &start, &end)) {
- put_range(sv, start, end);
- max_entries --;
- if (max_entries < 0) {
- sv_catpvs(sv, "...");
- break;
+ if ((flags & ANYOF_LOC_FOLD)
+ && only_utf8_locale
+ && only_utf8_locale != &PL_sv_undef)
+ {
+ UV start, end;
+ int max_entries = 256;
+
+ sv_catpvs(sv, "{utf8 locale}");
+ invlist_iterinit(only_utf8_locale);
+ while (invlist_iternext(only_utf8_locale,
+ &start, &end)) {
+ put_range(sv, start, end);
+ max_entries --;
+ if (max_entries < 0) {
+ sv_catpvs(sv, "...");
+ break;
+ }
}
+ invlist_iterfinish(only_utf8_locale);
}
- invlist_iterfinish(ANYOF_UTF8_LOCALE_INVLIST(o));
}
}
}
else if (k == POSIXD || k == NPOSIXD) {
U8 index = FLAGS(o) * 2;
- if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
- Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
- }
- else {
+ if (index < C_ARRAY_LENGTH(anyofs)) {
if (*anyofs[index] != '[') {
sv_catpv(sv, "[");
}
sv_catpv(sv, "]");
}
}
+ else {
+ Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
+ }
}
else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(o);
PERL_UNUSED_ARG(prog);
+ PERL_UNUSED_ARG(reginfo);
#endif /* DEBUGGING */
}
+
+
SV *
Perl_re_intuit_string(pTHX_ REGEXP * const r)
{ /* Assume that RE_INTUIT is set */
} else
CLEAR_OPTSTART;
- regprop(r, sv, node);
+ regprop(r, sv, node, NULL);
PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
(int)(2*indent + 1), "", SvPVX_const(sv));
}
else if (PL_regkind[(U8)op] == ANYOF) {
/* arglen 1 + class block */
- node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LOC_FOLD)
- ? ANYOF_POSIXL_FOLD_SKIP
- : (ANYOF_FLAGS(node) & ANYOF_POSIXL)
- ? ANYOF_POSIXL_SKIP
- : ANYOF_SKIP);
+ node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL)
+ ? ANYOF_POSIXL_SKIP
+ : ANYOF_SKIP);
node = NEXTOPER(node);
}
else if (PL_regkind[(U8)op] == EXACT) {
https://perl5.git.perl.org / perl5.git / blobdiff