#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), \
/* 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);
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);
* should eventually be made public */
/* The header definitions are in F<inline_invlist.c> */
-#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
*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;
}
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
/* 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 (0x02|0x04)
+ 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;
+ 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) {
+ 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
*
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;
if (*RExC_parse == '?') { /* (?...) */
bool is_logical = 0;
const char * const seqstart = RExC_parse;
- bool has_use_defaults = FALSE;
RExC_parse++;
paren = *RExC_parse++;
vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
}
}
+ case '[': /* (?[ ... ]) */
+ 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:
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;
{
char * const oregcomp_parse = ++RExC_parse;
ret = regclass(pRExC_state, flagp,depth+1,
- FALSE /* means parse the whole char class */ );
+ 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':
RExC_parse--;
ret = regclass(pRExC_state, flagp,depth+1,
- TRUE /* means just parse this element */ );
+ 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_parse--;
* 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;
&error_msg,
TRUE, /* out warnings */
FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
UTF);
if (! valid) {
RExC_parse = p; /* going to die anyway; point
}
case 'x':
{
- UV result;
+ UV result = UV_MAX; /* initialize to erroneous
+ value */
const char* error_msg;
bool valid = grok_bslash_x(&p,
&error_msg,
TRUE, /* out warnings */
FALSE, /* not strict */
+ TRUE, /* Output warnings
+ for non-
+ portables */
UTF);
if (! valid) {
RExC_parse = p; /* going to die anyway; point
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;
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_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:]
+ * 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_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
+ * 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_A_POSIX_CLASS;
+
+ 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_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 */
+
+ 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_REGEX_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 (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
+ * 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_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);
+ /* 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 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_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) {
+ 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() 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_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);
+ /* 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_tindex(stack) < 0 /* Was empty */
+ || ((final = av_pop(stack)) == NULL)
+ || ! IS_OPERAND(final)
+ || av_tindex(stack) >= 0) /* More left on stack */
+ {
+ vFAIL("Incomplete expression within '(?[ ])'");
+ }
+
+ /* Here, 'final' is the resultant inversion list from evaluating the
+ * expression. Return it if so requested */
+ if (return_invlist) {
+ *return_invlist = final;
+ return END;
+ }
+
+ /* 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) {
+ 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, const bool stop_at_1)
+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;
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 (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. */
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 (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 && POSIXCC(nextvalue)) {
+ if (!SIZE_ONLY && RExC_parse < RExC_end && POSIXCC(UCHARAT(RExC_parse))) {
const char *s = RExC_parse;
const char c = *s++;
stop_ptr = RExC_parse + 1;
}
- /* allow 1st char to be ] (allowing it to be - is dealt with later) */
+ /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
if (UCHARAT(RExC_parse) == ']')
goto charclassloop;
parseit:
- while (RExC_parse < stop_ptr && 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;
}
}
/* 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;
bool valid = grok_bslash_o(&RExC_parse,
&value,
&error_msg,
- SIZE_ONLY,
- FALSE, /* Not strict */
+ SIZE_ONLY, /* warnings in pass
+ 1 only */
+ strict,
+ silence_non_portable,
UTF);
if (! valid) {
vFAIL(error_msg);
&value,
&error_msg,
TRUE, /* Output warnings */
- FALSE, /* Not strict */
+ strict,
+ silence_non_portable,
UTF);
- if (! valid) {
+ 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 && isWORDCHAR(value) && value != '_') {
- SAVEFREESV(RExC_rx_sv);
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 switch on char following backslash */
} /* end of handling backslash escape sequences */
#ifdef EBCDIC
- else
- literal_endpoint++;
+ else
+ literal_endpoint++;
#endif
+ /* 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
* 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 */
* 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 ( ! PL_utf8_swash_ptrs[classnum]) {
if (namedclass % 2 == 0) { /* A non-complemented
class */
}
} /* 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
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().
https://perl5.git.perl.org / perl5.git / blobdiff