#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
- ((*s) == '{' && regcurly(s)))
+ ((*s) == '{' && regcurly(s, FALSE)))
#ifdef SPSTART
#undef SPSTART /* dratted cpp namespace... */
(int)offset, RExC_precomp, RExC_precomp + offset); \
} STMT_END
+#define vFAIL4(m,a1,a2,a3) STMT_START { \
+ if (!SIZE_ONLY) \
+ SAVEFREESV(RExC_rx_sv); \
+ Simple_vFAIL4(m, a1, a2, a3); \
+} STMT_END
+
+/* m is not necessarily a "literal string", in this macro */
+#define reg_warn_non_literal_string(loc, m) STMT_START { \
+ const IV offset = loc - RExC_precomp; \
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
+ m, (int)offset, RExC_precomp, RExC_precomp + offset); \
+} STMT_END
+
#define ckWARNreg(loc,m) STMT_START { \
const IV offset = loc - RExC_precomp; \
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
(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), \
PERL_ARGS_ASSERT_CL_IS_ANYTHING;
- for (value = 0; value <= ANYOF_MAX; value += 2)
+ for (value = 0; value < ANYOF_MAX; value += 2)
if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
return 1;
if (!(cl->flags & ANYOF_UNICODE_ALL))
}
/* TODO ideally should handle [..], (#..), /#.../x to reduce false
* positives here */
- if (pat[s] == '(' && pat[s+1] == '?' &&
- (pat[s+2] == '{' || (pat[s+2] == '?' && pat[s+3] == '{'))
+ if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
+ (pat[s+2] == '{'
+ || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
)
return 1;
}
data.offset_float_min,
data.minlen_float,
longest_float_length,
- data.flags & SF_FL_BEFORE_EOL,
- data.flags & SF_FL_BEFORE_MEOL))
+ cBOOL(data.flags & SF_FL_BEFORE_EOL),
+ cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
{
r->float_min_offset = data.offset_float_min - data.lookbehind_float;
r->float_max_offset = data.offset_float_max;
data.offset_fixed,
data.minlen_fixed,
longest_fixed_length,
- data.flags & SF_FIX_BEFORE_EOL,
- data.flags & SF_FIX_BEFORE_MEOL))
+ cBOOL(data.flags & SF_FIX_BEFORE_EOL),
+ cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
{
r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
SvREFCNT_inc_simple_void_NN(data.longest_fixed);
PerlIO_printf(Perl_debug_log, "\n");
});
#endif
+
+#ifdef USE_ITHREADS
+ /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
+ * by setting the regexp SV to readonly-only instead. If the
+ * pattern's been recompiled, the USEDness should remain. */
+ if (old_re && SvREADONLY(old_re))
+ SvREADONLY_on(rx);
+#endif
return rx;
}
if (UTF)
do {
RExC_parse += UTF8SKIP(RExC_parse);
- } while (isALNUM_utf8((U8*)RExC_parse));
+ } while (isWORDCHAR_utf8((U8*)RExC_parse));
else
do {
RExC_parse++;
- } while (isALNUM(*RExC_parse));
+ } while (isWORDCHAR(*RExC_parse));
} else {
RExC_parse++; /* so the <- from the vFAIL is after the offending character */
vFAIL("Group name must start with a non-digit word character");
Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
{
/* Take the union of two inversion lists and point <output> to it. *output
- * should be defined upon input, and if it points to one of the two lists,
+ * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
* the reference count to that list will be decremented. The first list,
* <a>, may be NULL, in which case a copy of the second list is returned.
* If <complement_b> is TRUE, the union is taken of the complement
}
}
+ /* If we've changed b, restore it */
+ if (complement_b) {
+ array_b[0] = 1;
+ }
+
/* We may be removing a reference to one of the inputs */
if (a == *output || b == *output) {
assert(! invlist_is_iterating(*output));
SvREFCNT_dec_NN(*output);
}
- /* If we've changed b, restore it */
- if (complement_b) {
- array_b[0] = 1;
- }
-
*output = u;
return;
}
Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
{
/* Take the intersection of two inversion lists and point <i> to it. *i
- * should be defined upon input, and if it points to one of the two lists,
+ * SHOULD BE DEFINED upon input, and if it points to one of the two lists,
* the reference count to that list will be decremented.
* If <complement_b> is TRUE, the result will be the intersection of <a>
* and the complement (or inversion) of <b> instead of <b> directly.
}
}
+ /* If we've changed b, restore it */
+ if (complement_b) {
+ array_b[0] = 1;
+ }
+
/* We may be removing a reference to one of the inputs */
if (a == *i || b == *i) {
assert(! invlist_is_iterating(*i));
SvREFCNT_dec_NN(*i);
}
- /* If we've changed b, restore it */
- if (complement_b) {
- array_b[0] = 1;
- }
-
*i = r;
return;
}
len = _invlist_len(invlist);
}
- /* If comes after the final entry, can just append it to the end */
+ /* If comes after the final entry actually in the list, can just append it
+ * to the end, */
if (len == 0
- || start >= invlist_array(invlist)
- [_invlist_len(invlist) - 1])
+ || (! ELEMENT_RANGE_MATCHES_INVLIST(len - 1)
+ && start >= invlist_array(invlist)[len - 1]))
{
_append_range_to_invlist(invlist, start, end);
return invlist;
vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
}
}
+ case '[': /* (?[ ... ]) */
+ return handle_sets(pRExC_state, flagp, depth, oregcomp_parse);
case 0:
RExC_parse--; /* for vFAIL to print correctly */
vFAIL("Sequence (? incomplete");
op = *RExC_parse;
- if (op == '{' && regcurly(RExC_parse)) {
+ if (op == '{' && regcurly(RExC_parse, FALSE)) {
maxpos = NULL;
#ifdef RE_TRACK_PATTERN_OFFSETS
parse_start = RExC_parse; /* MJD */
}
STATIC bool
-S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class)
+S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, UV *valuep, I32 *flagp, U32 depth, bool in_char_class,
+ const bool strict /* Apply stricter parsing rules? */
+ )
{
/* This is expected to be called by a parser routine that has recognized '\N'
/* Disambiguate between \N meaning a named character versus \N meaning
* [^\n]. The former is assumed when it can't be the latter. */
- if (*p != '{' || regcurly(p)) {
+ if (*p != '{' || regcurly(p, FALSE)) {
RExC_parse = p;
if (! node_p) {
/* no bare \N in a charclass */
}
else if (in_char_class) {
if (SIZE_ONLY && in_char_class) {
- ckWARNreg(RExC_parse,
- "Ignoring zero length \\N{} in character class"
- );
+ if (strict) {
+ RExC_parse++; /* Position after the "}" */
+ vFAIL("Zero length \\N{}");
+ }
+ else {
+ ckWARNreg(RExC_parse,
+ "Ignoring zero length \\N{} in character class");
+ }
}
ret = FALSE;
}
}
if (in_char_class && has_multiple_chars) {
- ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
+ if (strict) {
+ RExC_parse = endbrace;
+ vFAIL("\\N{} in character class restricted to one character");
+ }
+ else {
+ ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
+ }
}
RExC_parse = endbrace + 1;
{
dVAR;
regnode *ret = NULL;
- I32 flags;
+ I32 flags = 0;
char *parse_start = RExC_parse;
U8 op;
int invert = 0;
case '[':
{
char * const oregcomp_parse = ++RExC_parse;
- ret = regclass(pRExC_state, flagp,depth+1);
+ ret = regclass(pRExC_state, flagp,depth+1,
+ FALSE, /* means parse the whole char class */
+ TRUE, /* allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings. */
+ NULL);
if (*RExC_parse != ']') {
RExC_parse = oregcomp_parse;
vFAIL("Unmatched [");
vFAIL("Internal urp");
/* Supposed to be caught earlier. */
break;
+ case '{':
+ if (!regcurly(RExC_parse, FALSE)) {
+ RExC_parse++;
+ goto defchar;
+ }
+ /* FALL THROUGH */
case '?':
case '+':
case '*':
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
+ if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
+ ckWARNdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" or \"\\b[{]\" instead");
+ }
goto finish_meta_pat;
case 'B':
RExC_seen_zerolen++;
ret = reg_node(pRExC_state, op);
FLAGS(ret) = get_regex_charset(RExC_flags);
*flagp |= SIMPLE;
+ if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
+ ckWARNdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" or \"\\B[{]\" instead");
+ }
goto finish_meta_pat;
case 'D':
case 'p':
case 'P':
{
- char* const oldregxend = RExC_end;
#ifdef DEBUGGING
char* parse_start = RExC_parse - 2;
#endif
- if (RExC_parse[1] == '{') {
- /* a lovely hack--pretend we saw [\pX] instead */
- RExC_end = strchr(RExC_parse, '}');
- if (!RExC_end) {
- const U8 c = (U8)*RExC_parse;
- RExC_parse += 2;
- RExC_end = oldregxend;
- vFAIL2("Missing right brace on \\%c{}", c);
- }
- RExC_end++;
- }
- else {
- RExC_end = RExC_parse + 2;
- if (RExC_end > oldregxend)
- RExC_end = oldregxend;
- }
RExC_parse--;
- ret = regclass(pRExC_state, flagp,depth+1);
+ ret = regclass(pRExC_state, flagp,depth+1,
+ TRUE, /* means just parse this element */
+ FALSE, /* don't allow multi-char folds */
+ FALSE, /* don't silence non-portable warnings.
+ It would be a bug if these returned
+ non-portables */
+ NULL);
- RExC_end = oldregxend;
RExC_parse--;
Set_Node_Offset(ret, parse_start + 2);
* special treatment for quantifiers is not needed for such single
* character sequences */
++RExC_parse;
- if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE)) {
+ if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE,
+ FALSE /* not strict */ )) {
RExC_parse--;
goto defchar;
}
* */
RExC_parse = p + 1;
if (! grok_bslash_N(pRExC_state, NULL, &ender,
- flagp, depth, FALSE))
+ flagp, depth, FALSE,
+ FALSE /* not strict */ ))
{
RExC_parse = p = oldp;
goto loopdone;
break;
case 'o':
{
- STRLEN brace_len = len;
UV result;
const char* error_msg;
- bool valid = grok_bslash_o(p,
+ bool valid = grok_bslash_o(&p,
&result,
- &brace_len,
&error_msg,
- 1);
- p += brace_len;
+ TRUE, /* out warnings */
+ FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
+ UTF);
if (! valid) {
RExC_parse = p; /* going to die anyway; point
to exact spot of failure */
vFAIL(error_msg);
}
- else
- {
- ender = result;
- }
+ ender = result;
if (PL_encoding && ender < 0x100) {
goto recode_encoding;
}
}
case 'x':
{
- STRLEN brace_len = len;
- UV result;
+ UV result = UV_MAX; /* initialize to erroneous
+ value */
const char* error_msg;
- bool valid = grok_bslash_x(p,
+ bool valid = grok_bslash_x(&p,
&result,
- &brace_len,
&error_msg,
- 1);
- p += brace_len;
+ TRUE, /* out warnings */
+ FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
+ UTF);
if (! valid) {
RExC_parse = p; /* going to die anyway; point
to exact spot of failure */
vFAIL(error_msg);
}
- else {
- ender = result;
- }
+ ender = result;
+
if (PL_encoding && ender < 0x100) {
goto recode_encoding;
}
REQUIRE_UTF8;
}
p += numlen;
+ if (SIZE_ONLY /* like \08, \178 */
+ && numlen < 3
+ && p < RExC_end
+ && isDIGIT(*p) && ckWARN(WARN_REGEXP))
+ {
+ reg_warn_non_literal_string(
+ p + 1,
+ form_short_octal_warning(p, numlen));
+ }
}
- else {
+ else { /* Not to be treated as an octal constant, go
+ find backref */
--p;
goto loopdone;
}
/* FALL THROUGH */
default:
if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
- ckWARN2reg(p + 1, "Unrecognized escape \\%.1s passed through", p);
+ /* Include any { following the alpha to emphasize
+ * that it could be part of an escape at some point
+ * in the future */
+ int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
+ ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
}
goto normal_default;
- }
+ } /* End of switch on '\' */
break;
- case '{':
- /* Currently we don't warn when the lbrace is at the start
- * of a construct. This catches it in the middle of a
- * literal string, or when its the first thing after
- * something like "\b" */
- if (! SIZE_ONLY
- && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
- {
- ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
- }
- /*FALLTHROUGH*/
- default:
+ default: /* A literal character */
+
+ if (! SIZE_ONLY
+ && RExC_flags & RXf_PMf_EXTENDED
+ && ckWARN(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;
len += foldlen - 1;
}
else {
- *(s++) = ender;
+ *(s++) = (char) ender;
maybe_exact &= ! IS_IN_SOME_FOLD_L1(ender);
}
}
return p;
}
+STATIC char *
+S_regpatws( RExC_state_t *pRExC_state, char *p , const bool recognize_comment )
+{
+ /* Returns the next non-pattern-white space, non-comment character (the
+ * latter only if 'recognize_comment is true) in the string p, which is
+ * ended by RExC_end. If there is no line break ending a comment,
+ * RExC_seen has added the REG_SEEN_RUN_ON_COMMENT flag; */
+ const char *e = RExC_end;
+
+ PERL_ARGS_ASSERT_REGPATWS;
+
+ while (p < e) {
+ STRLEN len;
+ if ((len = is_PATWS_safe(p, e, UTF))) {
+ p += len;
+ }
+ else if (recognize_comment && *p == '#') {
+ bool ended = 0;
+ do {
+ p++;
+ if (is_LNBREAK_safe(p, e, UTF)) {
+ ended = 1;
+ break;
+ }
+ } while (p < e);
+ if (!ended)
+ RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
+ }
+ else
+ break;
+ }
+ return p;
+}
+
/* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
Character classes ([:foo:]) can also be negated ([:^foo:]).
Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
#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)
+S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me,
+ const bool strict)
{
dVAR;
I32 namedclass = OOB_NAMEDCLASS;
if (value == '[' && RExC_parse + 1 < RExC_end &&
/* I smell either [: or [= or [. -- POSIX has been here, right? */
- POSIXCC(UCHARAT(RExC_parse))) {
+ POSIXCC(UCHARAT(RExC_parse)))
+ {
const char c = UCHARAT(RExC_parse);
char* const s = RExC_parse++;
while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
RExC_parse++;
- if (RExC_parse == RExC_end)
+ if (RExC_parse == RExC_end) {
+ if (strict) {
+
+ /* Try to give a better location for the error (than the end of
+ * the string) by looking for the matching ']' */
+ RExC_parse = s;
+ while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
+ RExC_parse++;
+ }
+ vFAIL2("Unmatched '%c' in POSIX class", c);
+ }
/* Grandfather lone [:, [=, [. */
RExC_parse = s;
+ }
else {
const char* const t = RExC_parse++; /* skip over the c */
assert(*t == c);
/* Initially switch on the length of the name. */
switch (skip) {
case 4:
- if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
+ if (memEQ(posixcc, "word", 4)) /* this is not POSIX,
+ this is the Perl \w
+ */
namedclass = ANYOF_WORDCHAR;
break;
case 5:
} else {
/* Maternal grandfather:
* "[:" ending in ":" but not in ":]" */
+ if (strict) {
+ vFAIL("Unmatched '[' in POSIX class");
+ }
+
+ /* Grandfather lone [:, [=, [. */
RExC_parse = s;
}
}
return namedclass;
}
+STATIC bool
+S_could_it_be_POSIX(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:]
+ * class. It returns true if it really is a posix class, of course, but it
+ * also can return true if it thinks that what was intended was a posix
+ * class that didn't quite make it.
+ *
+ * It will return true for
+ * [:alphanumerics:
+ * [:alphanumerics] (as long as the ] isn't followed immediately by a
+ * ')' indicating the end of the (?[
+ * [:any garbage including %^&$ punctuation:]
+ *
+ * This is designed to be called only from S_handle_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
+ * change long-standing behavior, so I (khw) didn't do that */
+ char* p = RExC_parse + 1;
+ char first_char = *p;
+
+ PERL_ARGS_ASSERT_COULD_IT_BE_POSIX;
+
+ assert(*(p - 1) == '[');
+
+ if (! POSIXCC(first_char)) {
+ return FALSE;
+ }
+
+ p++;
+ while (p < RExC_end && isWORDCHAR(*p)) p++;
+
+ if (p >= RExC_end) {
+ return FALSE;
+ }
+
+ if (p - RExC_parse > 2 /* Got at least 1 word character */
+ && (*p == first_char
+ || (*p == ']' && p + 1 < RExC_end && *(p + 1) != ')')))
+ {
+ return TRUE;
+ }
+
+ p = (char *) memchr(RExC_parse, ']', RExC_end - RExC_parse);
+
+ return (p
+ && p - RExC_parse > 2 /* [:] evaluates to colon;
+ [::] is a bad posix class. */
+ && first_char == *(p - 1));
+}
+
+STATIC regnode *
+S_handle_sets(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
+ char * const oregcomp_parse)
+{
+ /* Handle the (?[...]) construct to do set operations */
+
+ U8 curchar;
+ UV start, end; /* End points of code point ranges */
+ SV* result_string;
+ char *save_end, *save_parse;
+ SV* final;
+ STRLEN len;
+ regnode* node;
+ AV* stack;
+ const bool save_fold = FOLD;
+
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ PERL_ARGS_ASSERT_HANDLE_SETS;
+
+ if (LOC) {
+ vFAIL("(?[...]) not valid in locale");
+ }
+ RExC_uni_semantics = 1;
+
+ /* This will return only an ANYOF regnode, or (unlikely) something smaller
+ * (such as EXACT). Thus we can skip most everything if just sizing. We
+ * call regclass to handle '[]' so as to not have to reinvent its parsing
+ * rules here (throwing away the size it computes each time). And, we exit
+ * upon an unescaped ']' that isn't one ending a regclass. To do both
+ * these things, we need to realize that something preceded by a backslash
+ * is escaped, so we have to keep track of backslashes */
+ if (SIZE_ONLY) {
+
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
+ "The regex_sets feature is experimental" REPORT_LOCATION,
+ (int) (RExC_parse - RExC_precomp) , RExC_precomp, RExC_parse);
+
+ while (RExC_parse < RExC_end) {
+ SV* current = NULL;
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ TRUE); /* means recognize comments */
+ switch (*RExC_parse) {
+ 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 */
+ 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
+ * 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);
+ 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);
+ /* function call leaves parse pointing to the ']', except
+ * if we faked it */
+ if (is_posix_class) {
+ RExC_parse--;
+ }
+
+ SvREFCNT_dec(current); /* In case it returned something */
+ break;
+ }
+
+ case ']':
+ RExC_parse++;
+ if (RExC_parse < RExC_end
+ && *RExC_parse == ')')
+ {
+ node = reganode(pRExC_state, ANYOF, 0);
+ RExC_size += ANYOF_SKIP;
+ nextchar(pRExC_state);
+ Set_Node_Length(node,
+ RExC_parse - oregcomp_parse + 1); /* MJD */
+ return node;
+ }
+ goto no_close;
+ }
+ RExC_parse++;
+ }
+
+ no_close:
+ FAIL("Syntax error in (?[...])");
+ }
+
+ /* Pass 2 only after this. Everything in this construct is a
+ * metacharacter. Operands begin with either a '\' (for an escape
+ * sequence), or a '[' for a bracketed character class. Any other
+ * character should be an operator, or parenthesis for grouping. Both
+ * types of operands are handled by calling regclass() to parse them. It
+ * is called with a parameter to indicate to return the computed inversion
+ * list. The parsing here is implemented via a stack. Each entry on the
+ * stack is a single character representing one of the operators, or the
+ * '('; or else a pointer to an operand inversion list. */
+
+#define IS_OPERAND(a) (! SvIOK(a))
+
+ /* The stack starts empty. It is a syntax error if the first thing parsed
+ * is a binary operator; everything else is pushed on the stack. When an
+ * operand is parsed, the top of the stack is examined. If it is a binary
+ * operator, the item before it should be an operand, and both are replaced
+ * by the result of doing that operation on the new operand and the one on
+ * the stack. Thus a sequence of binary operands is reduced to a single
+ * one before the next one is parsed.
+ *
+ * A unary operator may immediately follow a binary in the input, for
+ * example
+ * [a] + ! [b]
+ * When an operand is parsed and the top of the stack is a unary operator,
+ * the operation is performed, and then the stack is rechecked to see if
+ * this new operand is part of a binary operation; if so, it is handled as
+ * 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 */
+
+ stack = newAV();
+
+ while (RExC_parse < RExC_end) {
+ I32 top_index = av_top(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 */
+ break;
+ }
+
+ switch (curchar) {
+
+ 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() will return with parsing just the \ sequence,
+ * leaving the parse pointer at the next thing to parse */
+ RExC_parse--;
+ goto handle_operand;
+
+ case '[': /* Is a bracketed character class */
+ {
+ bool is_posix_class = could_it_be_POSIX(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);
+ /* function call leaves parse pointing to the ']', except if we
+ * faked it */
+ if (is_posix_class) {
+ RExC_parse--;
+ }
+
+ goto handle_operand;
+ }
+
+ case '&':
+ case '|':
+ case '+':
+ case '-':
+ case '^':
+ if (top_index < 0
+ || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
+ || ! IS_OPERAND(*top_ptr))
+ {
+ RExC_parse++;
+ vFAIL2("Unexpected binary operator '%c' with no preceding operand", curchar);
+ }
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case '!':
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case '(':
+ if (top_index >= 0) {
+ top_ptr = av_fetch(stack, top_index, FALSE);
+ assert(top_ptr);
+ if (IS_OPERAND(*top_ptr)) {
+ RExC_parse++;
+ vFAIL("Unexpected '(' with no preceding operator");
+ }
+ }
+ av_push(stack, newSVuv(curchar));
+ break;
+
+ case ')':
+ {
+ SV* lparen;
+ if (top_index < 1
+ || ! (current = av_pop(stack))
+ || ! IS_OPERAND(current)
+ || ! (lparen = av_pop(stack))
+ || IS_OPERAND(lparen)
+ || SvUV(lparen) != '(')
+ {
+ RExC_parse++;
+ vFAIL("Unexpected ')'");
+ }
+ top_index -= 2;
+ SvREFCNT_dec_NN(lparen);
+
+ /* FALL THROUGH */
+ }
+
+ handle_operand:
+
+ /* Here, we have an operand to process, in 'current' */
+
+ if (top_index < 0) { /* Just push if stack is empty */
+ av_push(stack, current);
+ }
+ else {
+ SV* top = av_pop(stack);
+ char current_operator;
+
+ if (IS_OPERAND(top)) {
+ vFAIL("Operand with no preceding operator");
+ }
+ current_operator = (char) SvUV(top);
+ switch (current_operator) {
+ case '(': /* Push the '(' back on followed by the new
+ operand */
+ av_push(stack, top);
+ av_push(stack, current);
+ SvREFCNT_inc(top); /* Counters the '_dec' done
+ just after the 'break', so
+ it doesn't get wrongly freed
+ */
+ break;
+
+ case '!':
+ _invlist_invert(current);
+
+ /* Unlike binary operators, the top of the stack,
+ * now that this unary one has been popped off, may
+ * legally be an operator, and we now have operand
+ * for it. */
+ top_index--;
+ SvREFCNT_dec_NN(top);
+ goto handle_operand;
+
+ case '&':
+ _invlist_intersection(av_pop(stack),
+ current,
+ ¤t);
+ av_push(stack, current);
+ break;
+
+ case '|':
+ case '+':
+ _invlist_union(av_pop(stack), current, ¤t);
+ av_push(stack, current);
+ break;
+
+ case '-':
+ _invlist_subtract(av_pop(stack), current, ¤t);
+ av_push(stack, current);
+ break;
+
+ case '^': /* The union minus the intersection */
+ {
+ SV* i = NULL;
+ SV* u = NULL;
+ SV* element;
+
+ element = av_pop(stack);
+ _invlist_union(element, current, &u);
+ _invlist_intersection(element, current, &i);
+ _invlist_subtract(u, i, ¤t);
+ av_push(stack, current);
+ SvREFCNT_dec_NN(i);
+ SvREFCNT_dec_NN(u);
+ SvREFCNT_dec_NN(element);
+ break;
+ }
+
+ default:
+ Perl_croak(aTHX_ "panic: Unexpected item on '(?[ ])' stack");
+ }
+ SvREFCNT_dec_NN(top);
+ }
+ }
+
+ RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
+ }
+
+ if (av_top(stack) < 0 /* Was empty */
+ || ((final = av_pop(stack)) == NULL)
+ || ! IS_OPERAND(final)
+ || av_top(stack) >= 0) /* More left on stack */
+ {
+ vFAIL("Incomplete expression within '(?[ ])'");
+ }
+
+ invlist_iterinit(final);
+
+ /* 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 */
+ result_string = newSVpvs("");
+ while (invlist_iternext(final, &start, &end)) {
+ if (start == end) {
+ Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}", start);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ result_string, "\\x{%"UVXf"}-\\x{%"UVXf"}",
+ start, end);
+ }
+ }
+
+ save_parse = RExC_parse;
+ RExC_parse = SvPV(result_string, len);
+ save_end = RExC_end;
+ RExC_end = RExC_parse + len;
+
+ /* We turn off folding around the call, as the class we have constructed
+ * already has all folding taken into consideration, and we don't want
+ * regclass() to add to that */
+ RExC_flags &= ~RXf_PMf_FOLD;
+ node = regclass(pRExC_state, flagp,depth+1,
+ FALSE, /* means parse the whole char class */
+ FALSE, /* don't allow multi-char folds */
+ TRUE, /* silence non-portable warnings. The above may very
+ well have generated non-portable code points, but
+ they're valid on this machine */
+ NULL);
+ if (save_fold) {
+ RExC_flags |= RXf_PMf_FOLD;
+ }
+ RExC_parse = save_parse + 1;
+ RExC_end = save_end;
+ SvREFCNT_dec_NN(final);
+ SvREFCNT_dec_NN(result_string);
+ SvREFCNT_dec_NN(stack);
+
+ nextchar(pRExC_state);
+ Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
+ return node;
+}
+#undef IS_OPERAND
/* The names of properties whose definitions are not known at compile time are
* stored in this SV, after a constant heading. So if the length has been
#define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION (SvCUR(listsv) != initial_listsv_len)
STATIC regnode *
-S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
+S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
+ const bool stop_at_1, /* Just parse the next thing, don't
+ look for a full character class */
+ bool allow_multi_folds,
+ const bool silence_non_portable, /* Don't output warnings
+ about too large
+ characters */
+ SV** ret_invlist) /* Return an inversion list, not a node */
{
- /* parse a bracketed class specification. Most of these will produce an ANYOF node;
- * but something like [a] will produce an EXACT node; [aA], an EXACTFish
- * node; [[:ascii:]], a POSIXA node; etc. It is more complex under /i with
- * multi-character folds: it will be rewritten following the paradigm of
- * this example, where the <multi-fold>s are characters which fold to
- * multiple character sequences:
+ /* parse a bracketed class specification. Most of these will produce an
+ * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
+ * EXACTFish node; [[:ascii:]], a POSIXA node; etc. It is more complex
+ * under /i with multi-character folds: it will be rewritten following the
+ * paradigm of this example, where the <multi-fold>s are characters which
+ * fold to multiple character sequences:
* /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
* gets effectively rewritten as:
* /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
* compile time */
dVAR;
- UV nextvalue;
UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
IV range = 0;
UV value = OOB_UNICODE, save_value = OOB_UNICODE;
AV * multi_char_matches = NULL; /* Code points that fold to more than one
character; used under /i */
UV n;
+ char * stop_ptr = RExC_end; /* where to stop parsing */
+ const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
+ space? */
+ const bool strict = cBOOL(ret_invlist); /* Apply strict parsing rules? */
/* Unicode properties are stored in a swash; this holds the current one
* being parsed. If this swash is the only above-latin1 component of the
/* Assume we are going to generate an ANYOF node. */
ret = reganode(pRExC_state, ANYOF, 0);
- if (!SIZE_ONLY) {
- ANYOF_FLAGS(ret) = 0;
- }
-
- if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
- RExC_parse++;
- invert = TRUE;
- RExC_naughty++;
- }
-
if (SIZE_ONLY) {
RExC_size += ANYOF_SKIP;
listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
}
else {
+ ANYOF_FLAGS(ret) = 0;
+
RExC_emit += ANYOF_SKIP;
if (LOC) {
ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
initial_listsv_len = SvCUR(listsv);
}
- nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
- if (!SIZE_ONLY && POSIXCC(nextvalue))
- {
+ if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
+ RExC_parse++;
+ invert = TRUE;
+ allow_multi_folds = FALSE;
+ RExC_naughty++;
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+ }
+
+ /* Check that they didn't say [:posix:] instead of [[:posix:]] */
+ if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
const char *s = RExC_parse;
const char c = *s++;
- while (isALNUM(*s))
+ while (isWORDCHAR(*s))
s++;
if (*s && c == *s && s[1] == ']') {
SAVEFREESV(RExC_rx_sv);
}
}
- /* allow 1st char to be ] (allowing it to be - is dealt with later) */
+ /* If the caller wants us to just parse a single element, accomplish this
+ * by faking the loop ending condition */
+ if (stop_at_1 && RExC_end > RExC_parse) {
+ stop_ptr = RExC_parse + 1;
+ }
+
+ /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
if (UCHARAT(RExC_parse) == ']')
goto charclassloop;
parseit:
- while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
+ while (1) {
+ if (RExC_parse >= stop_ptr) {
+ break;
+ }
+
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+
+ if (UCHARAT(RExC_parse) == ']') {
+ break;
+ }
charclassloop:
else
value = UCHARAT(RExC_parse++);
- nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
- if (value == '[' && POSIXCC(nextvalue))
- namedclass = regpposixcc(pRExC_state, value, listsv);
- else if (value == '\\') {
+ if (value == '['
+ && RExC_parse < RExC_end
+ && POSIXCC(UCHARAT(RExC_parse)))
+ {
+ namedclass = regpposixcc(pRExC_state, value, listsv, strict);
+ }
+ else if (value == '\\') {
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
RExC_end - RExC_parse,
}
else
value = UCHARAT(RExC_parse++);
+
/* Some compilers cannot handle switching on 64-bit integer
* values, therefore value cannot be an UV. Yes, this will
* be a problem later if we want switch on Unicode.
* A similar issue a little bit later when switching on
* namedclass. --jhi */
- switch ((I32)value) {
+
+ /* If the \ is escaping white space when white space is being
+ * skipped, it means that that white space is wanted literally, and
+ * is already in 'value'. Otherwise, need to translate the escape
+ * into what it signifies. */
+ if (! skip_white || ! is_PATWS_cp(value)) switch ((I32)value) {
+
case 'w': namedclass = ANYOF_WORDCHAR; break;
case 'W': namedclass = ANYOF_NWORDCHAR; break;
case 's': namedclass = ANYOF_SPACE; break;
from earlier versions, OTOH that behaviour was broken
as well. */
if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth,
- TRUE /* => charclass */))
+ TRUE, /* => charclass */
+ strict))
{
goto parseit;
}
{
char *e;
- /* This routine will handle any undefined properties */
+ /* We will handle any undefined properties ourselves */
U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF;
if (RExC_parse >= RExC_end)
}
/* Here didn't find it. It could be a user-defined
- * property that will be available at run-time. Add it
- * to the list to look up then */
+ * property that will be available at run-time. If we
+ * accept only compile-time properties, is an error;
+ * otherwise add it to the list for run-time look up */
+ if (ret_invlist) {
+ RExC_parse = e + 1;
+ vFAIL3("Property '%.*s' is unknown", (int) n, name);
+ }
Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
(value == 'p' ? '+' : '!'),
name);
Safefree(name);
}
RExC_parse = e + 1;
- namedclass = ANYOF_UNIPROP; /* no official name, but it's named */
+ namedclass = ANYOF_UNIPROP; /* no official name, but it's
+ named */
/* \p means they want Unicode semantics */
RExC_uni_semantics = 1;
RExC_parse--; /* function expects to be pointed at the 'o' */
{
const char* error_msg;
- bool valid = grok_bslash_o(RExC_parse,
+ bool valid = grok_bslash_o(&RExC_parse,
&value,
- &numlen,
&error_msg,
- SIZE_ONLY);
- RExC_parse += numlen;
+ SIZE_ONLY, /* warnings in pass
+ 1 only */
+ strict,
+ silence_non_portable,
+ UTF);
if (! valid) {
vFAIL(error_msg);
}
RExC_parse--; /* function expects to be pointed at the 'x' */
{
const char* error_msg;
- bool valid = grok_bslash_x(RExC_parse,
+ bool valid = grok_bslash_x(&RExC_parse,
&value,
- &numlen,
&error_msg,
- 1);
- RExC_parse += numlen;
- if (! valid) {
+ TRUE, /* Output warnings */
+ strict,
+ silence_non_portable,
+ UTF);
+ if (! valid) {
vFAIL(error_msg);
}
}
{
/* Take 1-3 octal digits */
I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
- numlen = 3;
- value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
+ numlen = (strict) ? 4 : 3;
+ 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");
+ }
+ else if (! SIZE_ONLY /* like \08, \178 */
+ && numlen < 3
+ && RExC_parse < RExC_end
+ && isDIGIT(*RExC_parse)
+ && ckWARN(WARN_REGEXP))
+ {
+ SAVEFREESV(RExC_rx_sv);
+ reg_warn_non_literal_string(
+ RExC_parse + 1,
+ 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;
break;
if (! RExC_override_recoding) {
SV* enc = PL_encoding;
value = reg_recode((const char)(U8)value, &enc);
- if (!enc && SIZE_ONLY)
- ckWARNreg(RExC_parse,
+ if (!enc) {
+ if (strict) {
+ vFAIL("Invalid escape in the specified encoding");
+ }
+ else if (SIZE_ONLY) {
+ ckWARNreg(RExC_parse,
"Invalid escape in the specified encoding");
+ }
+ }
break;
}
default:
/* Allow \_ to not give an error */
- if (!SIZE_ONLY && isALNUM(value) && value != '_') {
- SAVEFREESV(RExC_rx_sv);
+ if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
SAVEFREESV(listsv);
- ckWARN2reg(RExC_parse,
- "Unrecognized escape \\%c in character class passed through",
- (int)value);
- (void)ReREFCNT_inc(RExC_rx_sv);
+ if (strict) {
+ vFAIL2("Unrecognized escape \\%c in character class",
+ (int)value);
+ }
+ else {
+ SAVEFREESV(RExC_rx_sv);
+ ckWARN2reg(RExC_parse,
+ "Unrecognized escape \\%c in character class passed through",
+ (int)value);
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ }
SvREFCNT_inc_simple_void_NN(listsv);
}
break;
- }
- } /* end of \blah */
+ } /* End of switch on char following backslash */
+ } /* end of handling backslash escape sequences */
#ifdef EBCDIC
- else
- literal_endpoint++;
+ else
+ literal_endpoint++;
#endif
- /* 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 class) to store such
- * classes, either if Perl is compiled so that locale nodes always
- * should have this space, or if there is such 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
- && ! need_class
- && (ANYOF_LOCALE == ANYOF_CLASS
- || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
- {
- need_class = 1;
- if (SIZE_ONLY) {
- RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
- }
- else {
- RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
- ANYOF_CLASS_ZERO(ret);
- }
- ANYOF_FLAGS(ret) |= ANYOF_CLASS;
- }
+ /* 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 class) to store such classes, either if Perl
+ * is compiled so that locale nodes always should have this space, or
+ * if there is such 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
+ && ! need_class
+ && (ANYOF_LOCALE == ANYOF_CLASS
+ || (namedclass > OOB_NAMEDCLASS && namedclass < ANYOF_MAX)))
+ {
+ need_class = 1;
+ if (SIZE_ONLY) {
+ RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
+ }
+ else {
+ RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
+ ANYOF_CLASS_ZERO(ret);
+ }
+ ANYOF_FLAGS(ret) |= ANYOF_CLASS;
+ }
if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
* the 'a' in the examples */
if (range) {
if (!SIZE_ONLY) {
- const int w =
- RExC_parse >= rangebegin ?
- RExC_parse - rangebegin : 0;
- SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
- SAVEFREESV(listsv);
- ckWARN4reg(RExC_parse,
- "False [] range \"%*.*s\"",
- w, w, rangebegin);
- (void)ReREFCNT_inc(RExC_rx_sv);
- SvREFCNT_inc_simple_void_NN(listsv);
- cp_list = add_cp_to_invlist(cp_list, '-');
- cp_list = add_cp_to_invlist(cp_list, prevvalue);
+ 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);
+ }
+ else {
+ SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
+ ckWARN4reg(RExC_parse,
+ "False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ (void)ReREFCNT_inc(RExC_rx_sv);
+ 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 */
if (! SIZE_ONLY) {
U8 classnum = namedclass_to_classnum(namedclass);
+ if (namedclass >= ANYOF_MAX) { /* If a special class */
+ if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
+
+ /* Here, should be \h, \H, \v, or \V. Neither /d nor
+ * /l make a difference in what these match. There
+ * would be problems if these characters had folds
+ * other than themselves, as cp_list is subject to
+ * folding. */
+ if (classnum != _CC_VERTSPACE) {
+ assert( namedclass == ANYOF_HORIZWS
+ || namedclass == ANYOF_NHORIZWS);
+
+ /* It turns out that \h is just a synonym for
+ * XPosixBlank */
+ classnum = _CC_BLANK;
+ }
- /* The ascii range inversion list */
- SV* ascii_source = PL_Posix_ptrs[classnum];
-
- /* The full Latin1 range inversion list */
- SV* l1_source = PL_L1Posix_ptrs[classnum];
-
- /* The name of the property to use to match the full eXtended
- * Unicode range swash fo this character class */
- const char *Xname = swash_property_names[classnum];
-
- switch ((I32)namedclass) {
- case ANYOF_DIGIT:
- case ANYOF_ALPHANUMERIC: /* C's alnum, in contrast to \w */
- case ANYOF_ALPHA:
- case ANYOF_CASED:
- case ANYOF_GRAPH:
- case ANYOF_LOWER:
- case ANYOF_PRINT:
- case ANYOF_PUNCT:
- case ANYOF_UPPER:
- case ANYOF_WORDCHAR:
- if ( ! PL_utf8_swash_ptrs[classnum]) {
-
- /* If not /a matching, there are code points we don't
- * know at compile time. Arrange for the unknown
- * matches to be loaded at run-time, if needed */
- if (! AT_LEAST_ASCII_RESTRICTED) {
- Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n", Xname);
+ _invlist_union_maybe_complement_2nd(
+ cp_list,
+ PL_XPosix_ptrs[classnum],
+ cBOOL(namedclass % 2), /* Complement if odd
+ (NHORIZWS, NVERTWS)
+ */
+ &cp_list);
+ }
+ }
+ else if (classnum == _CC_ASCII) {
+#ifdef HAS_ISASCII
+ if (LOC) {
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else
+#endif /* Not isascii(); just use the hard-coded definition for it */
+ _invlist_union_maybe_complement_2nd(
+ posixes,
+ PL_ASCII,
+ cBOOL(namedclass % 2), /* Complement if odd
+ (NASCII) */
+ &posixes);
+ }
+ else { /* Garden variety class */
+
+ /* The ascii range inversion list */
+ SV* ascii_source = PL_Posix_ptrs[classnum];
+
+ /* The full Latin1 range inversion list */
+ SV* l1_source = PL_L1Posix_ptrs[classnum];
+
+ /* This code is structured into two major clauses. The
+ * first is for classes whose complete definitions may not
+ * already be known. It not, the Latin1 definition
+ * (guaranteed to already known) is used plus code is
+ * generated to load the rest at run-time (only if needed).
+ * If the complete definition is known, it drops down to
+ * the second clause, where the complete definition is
+ * known */
+
+ if (classnum < _FIRST_NON_SWASH_CC) {
+
+ /* Here, the class has a swash, which may or not
+ * already be loaded */
+
+ /* The name of the property to use to match the full
+ * eXtended Unicode range swash for this character
+ * class */
+ const char *Xname = swash_property_names[classnum];
+
+ /* If returning the inversion list, we can't defer
+ * getting this until runtime */
+ if (ret_invlist && ! PL_utf8_swash_ptrs[classnum]) {
+ PL_utf8_swash_ptrs[classnum] =
+ _core_swash_init("utf8", Xname, &PL_sv_undef,
+ 1, /* binary */
+ 0, /* not tr/// */
+ NULL, /* No inversion list */
+ NULL /* No flags */
+ );
+ assert(PL_utf8_swash_ptrs[classnum]);
}
- if (LOC) { /* Under locale, set run-time lookup */
- ANYOF_CLASS_SET(ret, namedclass);
+ if ( ! PL_utf8_swash_ptrs[classnum]) {
+ if (namedclass % 2 == 0) { /* A non-complemented
+ class */
+ /* If not /a matching, there are code points we
+ * don't know at compile time. Arrange for the
+ * unknown matches to be loaded at run-time, if
+ * needed */
+ if (! AT_LEAST_ASCII_RESTRICTED) {
+ Perl_sv_catpvf(aTHX_ listsv, "+utf8::%s\n",
+ Xname);
+ }
+ if (LOC) { /* Under locale, set run-time
+ lookup */
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else {
+ /* Add the current class's code points to
+ * the running total */
+ _invlist_union(posixes,
+ (AT_LEAST_ASCII_RESTRICTED)
+ ? ascii_source
+ : l1_source,
+ &posixes);
+ }
+ }
+ else { /* A complemented class */
+ if (AT_LEAST_ASCII_RESTRICTED) {
+ /* Under /a should match everything above
+ * ASCII, plus the complement of the set's
+ * ASCII matches */
+ _invlist_union_complement_2nd(posixes,
+ ascii_source,
+ &posixes);
+ }
+ else {
+ /* Arrange for the unknown matches to be
+ * loaded at run-time, if needed */
+ Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n",
+ Xname);
+ runtime_posix_matches_above_Unicode = TRUE;
+ if (LOC) {
+ ANYOF_CLASS_SET(ret, namedclass);
+ }
+ else {
+
+ /* We want to match everything in
+ * Latin1, except those things that
+ * l1_source matches */
+ SV* scratch_list = NULL;
+ _invlist_subtract(PL_Latin1, l1_source,
+ &scratch_list);
+
+ /* Add the list from this class to the
+ * running total */
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes,
+ scratch_list,
+ &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
+ if (DEPENDS_SEMANTICS) {
+ ANYOF_FLAGS(ret)
+ |= ANYOF_NON_UTF8_LATIN1_ALL;
+ }
+ }
+ }
+ }
+ goto namedclass_done;
}
- else {
- /* Add the current class's code points to the
- * running total */
- _invlist_union(posixes,
- (AT_LEAST_ASCII_RESTRICTED)
- ? ascii_source
- : l1_source,
- &posixes);
+
+ /* Here, there is a swash loaded for the class. If no
+ * inversion list for it yet, get it */
+ if (! PL_XPosix_ptrs[classnum]) {
+ PL_XPosix_ptrs[classnum]
+ = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
}
- break;
- }
- if (! PL_XPosix_ptrs[classnum]) {
- PL_XPosix_ptrs[classnum]
- = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
}
- /* FALL THROUGH */
- case ANYOF_BLANK:
- case ANYOF_CNTRL:
- case ANYOF_PSXSPC:
- case ANYOF_SPACE:
- case ANYOF_XDIGIT:
- if (! LOC) {
- /* For non-locale, just add it to any existing list */
- _invlist_union(posixes,
- (AT_LEAST_ASCII_RESTRICTED)
- ? ascii_source
- : PL_XPosix_ptrs[classnum],
- &posixes);
- }
- else { /* Locale */
- SV* scratch_list = NULL;
+ /* Here there is an inversion list already loaded for the
+ * entire class */
- /* For above Latin1 code points, we use the full
- * Unicode range */
- _invlist_intersection(PL_AboveLatin1,
- PL_XPosix_ptrs[classnum],
- &scratch_list);
- /* And set the output to it, adding instead if there
- * already is an output. Checking if 'posixes' is NULL
- * first saves an extra clone. Its reference count
- * will be decremented at the next union, etc, or if
- * this is the only instance, at the end of the routine
- * */
- if (! posixes) {
- posixes = scratch_list;
- }
- else {
- _invlist_union(posixes, scratch_list, &posixes);
- SvREFCNT_dec_NN(scratch_list);
+ if (namedclass % 2 == 0) { /* A non-complemented class,
+ like ANYOF_PUNCT */
+ if (! LOC) {
+ /* For non-locale, just add it to any existing list
+ * */
+ _invlist_union(posixes,
+ (AT_LEAST_ASCII_RESTRICTED)
+ ? ascii_source
+ : PL_XPosix_ptrs[classnum],
+ &posixes);
}
+ else { /* Locale */
+ SV* scratch_list = NULL;
-#ifndef HAS_ISBLANK
- if (namedclass != ANYOF_BLANK) {
-#endif
- /* Set this class in the node for runtime
- * matching */
- ANYOF_CLASS_SET(ret, namedclass);
-#ifndef HAS_ISBLANK
- }
- else {
- /* No isblank(), use the hard-coded ASCII-range
- * blanks, adding them to the running total. */
+ /* For above Latin1 code points, we use the full
+ * Unicode range */
+ _invlist_intersection(PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ &scratch_list);
+ /* And set the output to it, adding instead if
+ * there already is an output. Checking if
+ * 'posixes' is NULL first saves an extra clone.
+ * Its reference count will be decremented at the
+ * next union, etc, or if this is the only
+ * instance, at the end of the routine */
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
- _invlist_union(posixes, ascii_source, &posixes);
- }
+#ifndef HAS_ISBLANK
+ if (namedclass != ANYOF_BLANK) {
#endif
- }
- break;
-
- case ANYOF_NDIGIT:
-
- case ANYOF_NALPHANUMERIC:
- case ANYOF_NALPHA:
- case ANYOF_NGRAPH:
- case ANYOF_NLOWER:
- case ANYOF_NPRINT:
- case ANYOF_NPUNCT:
- case ANYOF_NUPPER:
- case ANYOF_NWORDCHAR:
- if ( ! PL_utf8_swash_ptrs[classnum]) {
- if (AT_LEAST_ASCII_RESTRICTED) {
- /* Under /a should match everything above ASCII,
- * and the complement of the set's ASCII matches */
- _invlist_union_complement_2nd(posixes, ascii_source,
- &posixes);
- }
- else {
- /* Arrange for the unknown matches to be loaded at
- * run-time, if needed */
- Perl_sv_catpvf(aTHX_ listsv, "!utf8::%s\n", Xname);
- runtime_posix_matches_above_Unicode = TRUE;
- if (LOC) {
+ /* Set this class in the node for runtime
+ * matching */
ANYOF_CLASS_SET(ret, namedclass);
+#ifndef HAS_ISBLANK
}
else {
+ /* No isblank(), use the hard-coded ASCII-range
+ * blanks, adding them to the running total. */
- /* We want to match everything in Latin1,
- * except those things that l1_source matches
- * */
- SV* scratch_list = NULL;
- _invlist_subtract(PL_Latin1, l1_source,
- &scratch_list);
-
- /* Add the list from this class to the running
- * total */
- if (! posixes) {
- posixes = scratch_list;
- }
- else {
- _invlist_union(posixes, scratch_list,
- &posixes);
- SvREFCNT_dec_NN(scratch_list);
- }
- if (DEPENDS_SEMANTICS) {
- ANYOF_FLAGS(ret)
- |= ANYOF_NON_UTF8_LATIN1_ALL;
- }
+ _invlist_union(posixes, ascii_source, &posixes);
}
+#endif
}
- break;
- }
- if (! PL_XPosix_ptrs[classnum]) {
- PL_XPosix_ptrs[classnum]
- = _swash_to_invlist(PL_utf8_swash_ptrs[classnum]);
}
- /* FALL THROUGH */
-
- case ANYOF_NBLANK:
- case ANYOF_NCNTRL:
- case ANYOF_NPSXSPC:
- case ANYOF_NSPACE:
- case ANYOF_NXDIGIT:
- if (! LOC) {
- _invlist_union_complement_2nd(
+ else { /* A complemented class, like ANYOF_NPUNCT */
+ if (! LOC) {
+ _invlist_union_complement_2nd(
posixes,
(AT_LEAST_ASCII_RESTRICTED)
? ascii_source
: PL_XPosix_ptrs[classnum],
&posixes);
- /* Under /d, everything in the upper half of the Latin1
- * range matches this complement */
- if (DEPENDS_SEMANTICS) {
- ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
- }
- }
- else { /* Locale */
- SV* scratch_list = NULL;
- _invlist_subtract(PL_AboveLatin1,
- PL_XPosix_ptrs[classnum],
- &scratch_list);
- if (! posixes) {
- posixes = scratch_list;
- }
- else {
- _invlist_union(posixes, scratch_list, &posixes);
- SvREFCNT_dec_NN(scratch_list);
+ /* Under /d, everything in the upper half of the
+ * Latin1 range matches this complement */
+ if (DEPENDS_SEMANTICS) {
+ ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
+ }
}
+ else { /* Locale */
+ SV* scratch_list = NULL;
+ _invlist_subtract(PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ &scratch_list);
+ if (! posixes) {
+ posixes = scratch_list;
+ }
+ else {
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
#ifndef HAS_ISBLANK
- if (namedclass != ANYOF_NBLANK) {
+ if (namedclass != ANYOF_NBLANK) {
#endif
- ANYOF_CLASS_SET(ret, namedclass);
+ ANYOF_CLASS_SET(ret, namedclass);
#ifndef HAS_ISBLANK
- }
- else {
- /* Get the list of all code points in Latin1 that
- * are not ASCII blanks, and add them to the
- * running total */
- _invlist_subtract(PL_Latin1, ascii_source,
- &scratch_list);
- _invlist_union(posixes, scratch_list, &posixes);
- SvREFCNT_dec_NN(scratch_list);
- }
-#endif
- }
- break;
-
- case ANYOF_ASCII:
-#ifdef HAS_ISASCII
- if (LOC) {
- ANYOF_CLASS_SET(ret, namedclass);
- }
- else
-#endif /* Not isascii(); just use the hard-coded definition for it */
- _invlist_union(posixes, PL_ASCII, &posixes);
- break;
- case ANYOF_NASCII:
-#ifdef HAS_ISASCII
- if (LOC) {
- ANYOF_CLASS_SET(ret, namedclass);
- }
- else {
+ }
+ else {
+ /* Get the list of all code points in Latin1
+ * that are not ASCII blanks, and add them to
+ * the running total */
+ _invlist_subtract(PL_Latin1, ascii_source,
+ &scratch_list);
+ _invlist_union(posixes, scratch_list, &posixes);
+ SvREFCNT_dec_NN(scratch_list);
+ }
#endif
- _invlist_union_complement_2nd(posixes,
- PL_ASCII, &posixes);
- if (DEPENDS_SEMANTICS) {
- ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
}
-#ifdef HAS_ISASCII
}
-#endif
- break;
-
- case ANYOF_HORIZWS:
- /* For these, we use the cp_list, as neither /d nor /l make
- * a difference in what these match. There would be
- * problems if these characters had folds other than
- * themselves, as cp_list is subject to folding.
- *
- * It turns out that \h is just a synonym for XPosixBlank */
- classnum = _CC_BLANK;
- /* FALL THROUGH */
-
- case ANYOF_VERTWS:
- _invlist_union(cp_list, PL_XPosix_ptrs[classnum], &cp_list);
- break;
-
- case ANYOF_NHORIZWS:
- classnum = _CC_BLANK;
- /* FALL THROUGH */
-
- case ANYOF_NVERTWS:
- _invlist_union_complement_2nd(cp_list,
- PL_XPosix_ptrs[classnum],
- &cp_list);
- break;
-
- case ANYOF_UNIPROP: /* this is to handle \p and \P */
- break;
-
- default:
- vFAIL("Invalid [::] class");
- break;
- }
-
+ }
+ namedclass_done:
continue; /* Go get next character */
}
} /* end of namedclass \blah */
+ /* Here, we have a single value. If 'range' is set, it is the ending
+ * of a range--check its validity. Later, we will handle each
+ * individual code point in the range. If 'range' isn't set, this
+ * could be the beginning of a range, so check for that by looking
+ * ahead to see if the next real character to be processed is the range
+ * indicator--the minus sign */
+
+ if (skip_white) {
+ RExC_parse = regpatws(pRExC_state, RExC_parse,
+ FALSE /* means don't recognize comments */);
+ }
+
if (range) {
if (prevvalue > value) /* b-a */ {
const int w = RExC_parse - rangebegin;
}
else {
prevvalue = value; /* save the beginning of the potential range */
- if (RExC_parse+1 < RExC_end
- && *RExC_parse == '-'
- && RExC_parse[1] != ']')
- {
- RExC_parse++;
+ if (! stop_at_1 /* Can't be a range if parsing just one thing */
+ && *RExC_parse == '-')
+ {
+ char* next_char_ptr = RExC_parse + 1;
+ if (skip_white) { /* Get the next real char after the '-' */
+ next_char_ptr = regpatws(pRExC_state,
+ RExC_parse + 1,
+ FALSE); /* means don't recognize
+ comments */
+ }
- /* a bad range like \w-, [:word:]- ? */
- if (namedclass > OOB_NAMEDCLASS) {
- if (ckWARN(WARN_REGEXP)) {
- const int w =
- RExC_parse >= rangebegin ?
- RExC_parse - rangebegin : 0;
- vWARN4(RExC_parse,
- "False [] range \"%*.*s\"",
- w, w, rangebegin);
- }
- if (!SIZE_ONLY) {
- cp_list = add_cp_to_invlist(cp_list, '-');
- }
- element_count++;
- } else
- range = 1; /* yeah, it's a range! */
- continue; /* but do it the next time */
+ /* If the '-' is at the end of the class (just before the ']',
+ * it is a literal minus; otherwise it is a range */
+ if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
+ RExC_parse = next_char_ptr;
+
+ /* a bad range like \w-, [:word:]- ? */
+ if (namedclass > OOB_NAMEDCLASS) {
+ if (strict || ckWARN(WARN_REGEXP)) {
+ const int w =
+ RExC_parse >= rangebegin ?
+ RExC_parse - rangebegin : 0;
+ if (strict) {
+ vFAIL4("False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ }
+ else {
+ vWARN4(RExC_parse,
+ "False [] range \"%*.*s\"",
+ w, w, rangebegin);
+ }
+ }
+ if (!SIZE_ONLY) {
+ cp_list = add_cp_to_invlist(cp_list, '-');
+ }
+ element_count++;
+ } else
+ range = 1; /* yeah, it's a range! */
+ continue; /* but do it the next time */
+ }
}
}
* "ss" =~ /^[^\xDF]+$/i => N
*
* See [perl #89750] */
- if (FOLD && ! invert && value == prevvalue) {
+ if (FOLD && allow_multi_folds && value == prevvalue) {
if (value == LATIN_SMALL_LETTER_SHARP_S
|| (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
value)))
/* If the character class contains only a single element, it may be
* optimizable into another node type which is smaller and runs faster.
* Check if this is the case for this class */
- if (element_count == 1) {
+ if (element_count == 1 && ! ret_invlist) {
U8 op = END;
U8 arg = 0;
}
/* FALLTHROUGH */
- /* The rest have more possibilities depending on the charset. We
- * take advantage of the enum ordering of the charset modifiers to
- * get the exact node type, */
+ /* The rest have more possibilities depending on the charset.
+ * We take advantage of the enum ordering of the charset
+ * modifiers to get the exact node type, */
default:
op = POSIXD + get_regex_charset(RExC_flags);
if (op > POSIXA) { /* /aa is same as /a */
* indicators, which are weeded out below using the
* IS_IN_SOME_FOLD_L1() macro */
if (invlist_highest(cp_list) < 256) {
- _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list, &fold_intersection);
+ _invlist_intersection(PL_L1Posix_ptrs[_CC_ALPHA], cp_list,
+ &fold_intersection);
}
else {
invert = FALSE;
}
+ if (ret_invlist) {
+ *ret_invlist = cp_list;
+
+ /* Discard the generated node */
+ if (SIZE_ONLY) {
+ RExC_size = orig_size;
+ }
+ else {
+ RExC_emit = orig_emit;
+ }
+ return END;
+ }
+
/* If we didn't do folding, it's because some information isn't available
* until runtime; set the run-time fold flag for these. (We don't have to
* worry about properties folding, as that is taken care of by the swash
https://perl5.git.perl.org / perl5.git / blobdiff