return TRUE;
}
+#define INVLIST_INDEX 0
+#define ONLY_LOCALE_MATCHES_INDEX 1
+#define DEFERRED_USER_DEFINED_INDEX 2
+
STATIC SV*
S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
const regnode_charclass* const node)
SV **const ary = AvARRAY(av);
assert(RExC_rxi->data->what[n] == 's');
- if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
- invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1]), NULL));
- }
- else if (ary[0] && ary[0] != &PL_sv_undef) {
+ if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
- /* Here, no compile-time swash, and there are things that won't be
- * known until runtime -- we have to assume it could be anything */
+ /* Here there are things that won't be known until runtime -- we
+ * have to assume it could be anything */
invlist = sv_2mortal(_new_invlist(1));
return _add_range_to_invlist(invlist, 0, UV_MAX);
}
- else if (ary[3] && ary[3] != &PL_sv_undef) {
+ else if (ary[INVLIST_INDEX]) {
- /* Here no compile-time swash, and no run-time only data. Use the
- * node's inversion list */
- invlist = sv_2mortal(invlist_clone(ary[3], NULL));
+ /* Use the node's inversion list */
+ invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL));
}
/* Get the code points valid only under UTF-8 locales */
- if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
- && ary[2] && ary[2] != &PL_sv_undef)
+ if ( (ANYOF_FLAGS(node) & ANYOFL_FOLD)
+ && av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX)
{
- only_utf8_locale_invlist = ary[2];
+ only_utf8_locale_invlist = ary[ONLY_LOCALE_MATCHES_INDEX];
}
}
}
/* Add in the points from the bit map */
- for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
- if (ANYOF_BITMAP_TEST(node, i)) {
- unsigned int start = i++;
+ if (OP(node) != ANYOFH) {
+ for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
+ if (ANYOF_BITMAP_TEST(node, i)) {
+ unsigned int start = i++;
- for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
- /* empty */
+ for (; i < NUM_ANYOF_CODE_POINTS
+ && ANYOF_BITMAP_TEST(node, i); ++i)
+ {
+ /* empty */
+ }
+ invlist = _add_range_to_invlist(invlist, start, i-1);
+ new_node_has_latin1 = TRUE;
}
- invlist = _add_range_to_invlist(invlist, start, i-1);
- new_node_has_latin1 = TRUE;
}
}
if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
_invlist_invert(invlist);
}
- else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
+ else if (ANYOF_FLAGS(node) & ANYOFL_FOLD) {
+ if (new_node_has_latin1) {
- /* Under /li, any 0-255 could fold to any other 0-255, depending on the
- * locale. We can skip this if there are no 0-255 at all. */
- _invlist_union(invlist, PL_Latin1, &invlist);
+ /* Under /li, any 0-255 could fold to any other 0-255, depending on
+ * the locale. We can skip this if there are no 0-255 at all. */
+ _invlist_union(invlist, PL_Latin1, &invlist);
+
+ invlist = add_cp_to_invlist(invlist, LATIN_SMALL_LETTER_DOTLESS_I);
+ invlist = add_cp_to_invlist(invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
+ }
+ else {
+ if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) {
+ invlist = add_cp_to_invlist(invlist, 'I');
+ }
+ if (_invlist_contains_cp(invlist,
+ LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE))
+ {
+ invlist = add_cp_to_invlist(invlist, 'i');
+ }
+ }
}
/* Similarly add the UTF-8 locale possible matches. These have to be
U32 count = 0; /* Running total of number of code points matched by
'ssc' */
UV start, end; /* Start and end points of current range in inversion
- list */
+ XXX outdated. UTF-8 locales are common, what about invert? list */
const U32 max_code_points = (LOC)
? 256
: (( ! UNI_SEMANTICS
}
#endif
}
+
+ if ( STR_LEN(scan) == 1
+ && isALPHA_A(* STRING(scan))
+ && ( OP(scan) == EXACTFAA
+ || ( OP(scan) == EXACTFU
+ && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(scan)))))
+ {
+ U8 mask = ~ ('A' ^ 'a'); /* These differ in just one bit */
+
+ /* Replace a length 1 ASCII fold pair node with an ANYOFM node,
+ * with the mask set to the complement of the bit that differs
+ * between upper and lower case, and the lowest code point of the
+ * pair (which the '&' forces) */
+ OP(scan) = ANYOFM;
+ ARG_SET(scan, *STRING(scan) & mask);
+ FLAGS(scan) = mask;
+ }
}
#ifdef DEBUGGING
OP(next) = EXACTFU;
}
+ if ( STR_LEN(next) == 1
+ && isALPHA_A(* STRING(next))
+ && ( OP(next) == EXACTFAA
+ || ( OP(next) == EXACTFU
+ && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next)))))
+ {
+ /* These differ in just one bit */
+ U8 mask = ~ ('A' ^ 'a');
+
+ assert(isALPHA_A(* STRING(next)));
+
+ /* Then replace it by an ANYOFM node, with
+ * the mask set to the complement of the
+ * bit that differs between upper and lower
+ * case, and the lowest code point of the
+ * pair (which the '&' forces) */
+ OP(next) = ANYOFM;
+ ARG_SET(next, *STRING(next) & mask);
+ FLAGS(next) = mask;
+ }
+
if (flags & SCF_DO_STCLASS) {
mincount = 0;
maxcount = REG_INFTY;
case ANYOFD:
case ANYOFL:
case ANYOFPOSIXL:
+ case ANYOFH:
case ANYOF:
if (flags & SCF_DO_STCLASS_AND)
ssc_and(pRExC_state, data->start_class,
}
#define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
- int num; \
if (RExC_lastparse!=RExC_parse) { \
Perl_re_printf( aTHX_ "%s", \
Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse, \
} else \
Perl_re_printf( aTHX_ "%16s",""); \
\
- num=REG_NODE_NUM(REGNODE_p(RExC_emit)); \
- if (RExC_lastnum!=num) \
- Perl_re_printf( aTHX_ "|%4d", num); \
+ if (RExC_lastnum!=RExC_emit) \
+ Perl_re_printf( aTHX_ "|%4d", RExC_emit); \
else \
Perl_re_printf( aTHX_ "|%4s",""); \
Perl_re_printf( aTHX_ "|%*s%-4s", \
(int)((depth*2)), "", \
(funcname) \
); \
- RExC_lastnum=num; \
+ RExC_lastnum=RExC_emit; \
RExC_lastparse=RExC_parse; \
})
initial_size = 10;
}
- /* Allocate the initial space */
new_list = newSV_type(SVt_INVLIST);
-
initialize_invlist_guts(new_list, initial_size);
return new_list;
SV*
Perl_invlist_clone(pTHX_ SV* const invlist, SV* new_invlist)
{
-
/* Return a new inversion list that is a copy of the input one, which is
* unchanged. The new list will not be mortal even if the old one was. */
- const STRLEN nominal_length = _invlist_len(invlist); /* Why not +1 XXX */
+ const STRLEN nominal_length = _invlist_len(invlist);
const STRLEN physical_length = SvCUR(invlist);
const bool offset = *(get_invlist_offset_addr(invlist));
PERL_ARGS_ASSERT_INVLIST_CLONE;
- /* Need to allocate extra space to accommodate Perl's addition of a
- * trailing NUL to SvPV's, since it thinks they are always strings */
if (new_invlist == NULL) {
new_invlist = _new_invlist(nominal_length);
}
/*
* As best we can, determine the characters that can match the start of
- * the given EXACTF-ish node.
+ * the given EXACTF-ish node. This is for use in creating ssc nodes, so there
+ * can be false positive matches
*
* Returns the invlist as a new SV*; it is the caller's responsibility to
* call SvREFCNT_dec() when done with it.
}
else {
/* Any Latin1 range character can potentially match any
- * other depending on the locale */
+ * other depending on the locale, and in Turkic locales, U+130 and
+ * U+131 */
if (OP(node) == EXACTFL) {
_invlist_union(invlist, PL_Latin1, &invlist);
+ invlist = add_cp_to_invlist(invlist,
+ LATIN_SMALL_LETTER_DOTLESS_I);
+ invlist = add_cp_to_invlist(invlist,
+ LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
}
else {
/* But otherwise, it matches at least itself. We can
invlist = add_cp_to_invlist(invlist, c);
}
+
+ if (OP(node) == EXACTFL) {
+
+ /* If either [iI] are present in an EXACTFL node the above code
+ * should have added its normal case pair, but under a Turkish
+ * locale they could match instead the case pairs from it. Add
+ * those as potential matches as well */
+ if (isALPHA_FOLD_EQ(fc, 'I')) {
+ invlist = add_cp_to_invlist(invlist,
+ LATIN_SMALL_LETTER_DOTLESS_I);
+ invlist = add_cp_to_invlist(invlist,
+ LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
+ }
+ else if (fc == LATIN_SMALL_LETTER_DOTLESS_I) {
+ invlist = add_cp_to_invlist(invlist, 'I');
+ }
+ else if (fc == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
+ invlist = add_cp_to_invlist(invlist, 'i');
+ }
+ }
}
}
DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
"%*s%*s Setting open paren #%" IVdf " to %d\n",
22, "| |", (int)(depth * 2 + 1), "",
- (IV)parno, REG_NODE_NUM(REGNODE_p(ret))));
+ (IV)parno, ret));
RExC_open_parens[parno]= ret;
}
DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
"%*s%*s Setting close paren #%" IVdf " to %d\n",
22, "| |", (int)(depth * 2 + 1), "",
- (IV)parno, REG_NODE_NUM(REGNODE_p(ender))));
+ (IV)parno, ender));
RExC_close_parens[parno]= ender;
if (RExC_nestroot == parno)
RExC_nestroot = 0;
DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
"%*s%*s Setting close paren #0 (END) to %d\n",
22, "| |", (int)(depth * 2 + 1), "",
- REG_NODE_NUM(REGNODE_p(ender))));
+ ender));
RExC_close_parens[0]= ender;
}
regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender), NULL, pRExC_state);
Perl_re_printf( aTHX_ "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
SvPV_nolen_const(RExC_mysv1),
- (IV)REG_NODE_NUM(REGNODE_p(lastbr)),
+ (IV)lastbr,
SvPV_nolen_const(RExC_mysv2),
- (IV)REG_NODE_NUM(REGNODE_p(ender)),
+ (IV)ender,
(IV)(ender - lastbr)
);
);
SvPV_nolen_const(RExC_mysv1),
(IV)REG_NODE_NUM(ret_as_regnode),
SvPV_nolen_const(RExC_mysv2),
- (IV)REG_NODE_NUM(REGNODE_p(ender)),
+ (IV)ender,
(IV)(ender - ret)
);
);
/* FALLTHROUGH */
case 'b':
{
+ U8 flags = 0;
regex_charset charset = get_regex_charset(RExC_flags);
RExC_seen_zerolen++;
RExC_seen |= REG_LOOKBEHIND_SEEN;
op = BOUND + charset;
- if (op == BOUND) {
- RExC_seen_d_op = TRUE;
- }
- else if (op == BOUNDL) {
- RExC_contains_locale = 1;
- }
-
- ret = reg_node(pRExC_state, op);
- *flagp |= SIMPLE;
if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
- FLAGS(REGNODE_p(ret)) = TRADITIONAL_BOUND;
+ flags = TRADITIONAL_BOUND;
if (op > BOUNDA) { /* /aa is same as /a */
- OP(REGNODE_p(ret)) = BOUNDA;
+ op = BOUNDA;
}
}
else {
{
goto bad_bound_type;
}
- FLAGS(REGNODE_p(ret)) = GCB_BOUND;
+ flags = GCB_BOUND;
break;
case 'l':
if (length != 2 || *(RExC_parse + 1) != 'b') {
goto bad_bound_type;
}
- FLAGS(REGNODE_p(ret)) = LB_BOUND;
+ flags = LB_BOUND;
break;
case 's':
if (length != 2 || *(RExC_parse + 1) != 'b') {
goto bad_bound_type;
}
- FLAGS(REGNODE_p(ret)) = SB_BOUND;
+ flags = SB_BOUND;
break;
case 'w':
if (length != 2 || *(RExC_parse + 1) != 'b') {
goto bad_bound_type;
}
- FLAGS(REGNODE_p(ret)) = WB_BOUND;
+ flags = WB_BOUND;
break;
default:
bad_bound_type:
RExC_parse = endbrace;
REQUIRE_UNI_RULES(flagp, 0);
- if (op >= BOUNDA) { /* /aa is same as /a */
- OP(REGNODE_p(ret)) = BOUNDU;
+ if (op == BOUND) {
+ op = BOUNDU;
+ }
+ else if (op >= BOUNDA) { /* /aa is same as /a */
+ op = BOUNDU;
length += 4;
/* Don't have to worry about UTF-8, in this message because
}
}
+ if (op == BOUND) {
+ RExC_seen_d_op = TRUE;
+ }
+ else if (op == BOUNDL) {
+ RExC_contains_locale = 1;
+ }
+
if (invert) {
- OP(REGNODE_p(ret)) += NBOUND - BOUND;
+ op += NBOUND - BOUND;
}
+
+ ret = reg_node(pRExC_state, op);
+ FLAGS(REGNODE_p(ret)) = flags;
+
+ *flagp |= SIMPLE;
+
goto finish_meta_pat;
}
* identifies, so when it is set to less than the full node, we can
* skip the rest of this */
if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
+ PERL_UINT_FAST8_T backup_count = 0;
const STRLEN full_len = len;
assert(len >= MAX_NODE_STRING_SIZE);
- /* Here, <s> points to the final byte of the final character.
- * Look backwards through the string until find a non-
- * problematic character */
+ /* Here, <s> points to just beyond where we have output the
+ * final character of the node. Look backwards through the
+ * string until find a non- problematic character */
if (! UTF) {
goto loopdone;
}
- while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
+ while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) {
+ backup_count++;
+ }
len = s - s0 + 1;
}
else {
* special case the very first byte in the string, so
* we don't read outside the string */
s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
+ backup_count++;
} /* End of loop backwards through the string */
/* If there were only problematic characters in the string,
} else {
/* Here, the node does contain some characters that aren't
- * problematic. If one such is the final character in the
- * node, we are done */
- if (len == full_len) {
+ * problematic. If we didn't have to backup any, then the
+ * final character in the node is non-problematic, and we
+ * can take the node as-is */
+ if (backup_count == 0) {
goto loopdone;
}
- else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
+ else if (backup_count == 1) {
/* If the final character is problematic, but the
* penultimate is not, back-off that last character to
PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
assert(PL_regkind[OP(node)] == ANYOF);
+ /* There is no bitmap for this node type */
+ if (OP(node) == ANYOFH) {
+ return;
+ }
+
ANYOF_BITMAP_ZERO(node);
if (*invlist_ptr) {
STRLEN numlen;
int namedclass = OOB_NAMEDCLASS;
char *rangebegin = NULL;
- bool need_class = 0;
- SV *listsv = NULL;
+ SV *listsv = NULL; /* List of \p{user-defined} whose definitions
+ aren't available at the time this was called */
STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
than just initialized. */
SV* properties = NULL; /* Code points that match \p{} \P{} */
bool warn_super = ALWAYS_WARN_SUPER;
const char * orig_parse = RExC_parse;
- bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
/* This variable is used to mark where the end in the input is of something
* that looks like a POSIX construct but isn't. During the parse, when
allow_multi_folds = FALSE;
#endif
- listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
+ /* We include the /i status at the beginning of this so that we can
+ * know it at runtime */
+ listsv = sv_2mortal(Perl_newSVpvf(aTHX_ "#%d\n", cBOOL(FOLD)));
initial_listsv_len = SvCUR(listsv);
SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated. */
case 'P':
{
char *e;
- char *i;
-
- /* We will handle any undefined properties ourselves */
- U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
- /* And we actually would prefer to get
- * the straight inversion list of the
- * swash, since we will be accessing it
- * anyway, to save a little time */
- |_CORE_SWASH_INIT_ACCEPT_INVLIST;
SvREFCNT_dec(swash); /* Free any left-overs */
}
{
char* name = RExC_parse;
- char* base_name; /* name after any packages are stripped */
- char* lookup_name = NULL;
- const char * const colon_colon = "::";
- bool invert;
-
- SV* invlist;
-
- /* Temporary workaround for [perl #133136]. For this
- * precise input that is in the .t that is failing, load
- * utf8.pm, which is what the test wants, so that that
- * .t passes */
- if ( memEQs(RExC_start, e + 1 - RExC_start,
- "foo\\p{Alnum}")
- && ! hv_common(GvHVn(PL_incgv),
- NULL,
- "utf8.pm", sizeof("utf8.pm") - 1,
- 0, HV_FETCH_ISEXISTS, NULL, 0))
- {
- require_pv("utf8.pm");
- }
- invlist = parse_uniprop_string(name, n, FOLD, &invert);
- if (invlist) {
- if (invert) {
- value ^= 'P' ^ 'p';
- }
- }
- else {
- /* Try to get the definition of the property into
- * <invlist>. If /i is in effect, the effective property
- * will have its name be <__NAME_i>. The design is
- * discussed in commit
- * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
- name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
- SAVEFREEPV(name);
-
- for (i = RExC_parse; i < RExC_parse + n; i++) {
- if (isCNTRL(*i) && *i != '\t') {
- RExC_parse = e + 1;
- vFAIL2("Can't find Unicode property definition \"%s\"", name);
+ /* Any message returned about expanding the definition */
+ SV* msg = newSVpvs_flags("", SVs_TEMP);
+
+ /* If set TRUE, the property is user-defined as opposed to
+ * official Unicode */
+ bool user_defined = FALSE;
+
+ SV * prop_definition = parse_uniprop_string(
+ name, n, UTF, FOLD,
+ FALSE, /* This is compile-time */
+ &user_defined,
+ msg,
+ 0 /* Base level */
+ );
+ if (SvCUR(msg)) { /* Assumes any error causes a msg */
+ assert(prop_definition == NULL);
+ RExC_parse = e + 1;
+ if (SvUTF8(msg)) { /* msg being UTF-8 makes the whole
+ thing so, or else the display is
+ mojibake */
+ RExC_utf8 = TRUE;
}
+ /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
+ vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg),
+ SvCUR(msg), SvPVX(msg)));
}
- if (FOLD) {
- lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
-
- /* The function call just below that uses this can fail
- * to return, leaking memory if we don't do this */
- SAVEFREEPV(lookup_name);
- }
-
- /* Look up the property name, and get its swash and
- * inversion list, if the property is found */
- swash = _core_swash_init("utf8",
- (lookup_name)
- ? lookup_name
- : name,
- &PL_sv_undef,
- 1, /* binary */
- 0, /* not tr/// */
- NULL, /* No inversion list */
- &swash_init_flags
- );
- if (! swash || ! (invlist = _get_swash_invlist(swash))) {
- HV* curpkg = (IN_PERL_COMPILETIME)
- ? PL_curstash
- : CopSTASH(PL_curcop);
- UV final_n = n;
- bool has_pkg;
-
- if (swash) { /* Got a swash but no inversion list.
- Something is likely wrong that will
- be sorted-out later */
- SvREFCNT_dec_NN(swash);
- swash = NULL;
- }
+ if (! is_invlist(prop_definition)) {
- /* Here didn't find it. It could be a an error (like a
- * typo) in specifying a Unicode property, or it could
- * be a user-defined property that will be available at
- * run-time. The names of these must begin with 'In'
- * or 'Is' (after any packages are stripped off). So
- * if not one of those, or if we accept only
- * compile-time properties, is an error; otherwise add
- * it to the list for run-time look up. */
- if ((base_name = rninstr(name, name + n,
- colon_colon, colon_colon + 2)))
- { /* Has ::. We know this must be a user-defined
- property */
- base_name += 2;
- final_n -= base_name - name;
- has_pkg = TRUE;
+ /* Here, the definition isn't known, so we have gotten
+ * returned a string that will be evaluated if and when
+ * encountered at runtime. We add it to the list of
+ * such properties, along with whether it should be
+ * complemented or not */
+ if (value == 'P') {
+ sv_catpvs(listsv, "!");
}
else {
- base_name = name;
- has_pkg = FALSE;
- }
-
- if ( final_n < 3
- || base_name[0] != 'I'
- || (base_name[1] != 's' && base_name[1] != 'n')
- || ret_invlist)
- {
- const char * const msg
- = (has_pkg)
- ? "Illegal user-defined property name"
- : "Can't find Unicode property definition";
- RExC_parse = e + 1;
-
- /* diag_listed_as: Can't find Unicode property definition "%s" */
- vFAIL3utf8f("%s \"%" UTF8f "\"",
- msg, UTF8fARG(UTF, n, name));
+ sv_catpvs(listsv, "+");
}
+ sv_catsv(listsv, prop_definition);
- /* If the property name doesn't already have a package
- * name, add the current one to it so that it can be
- * referred to outside it. [perl #121777] */
- if (! has_pkg && curpkg) {
- char* pkgname = HvNAME(curpkg);
- if (memNEs(pkgname, HvNAMELEN(curpkg), "main")) {
- char* full_name = Perl_form(aTHX_
- "%s::%s",
- pkgname,
- name);
- n = strlen(full_name);
- name = savepvn(full_name, n);
- SAVEFREEPV(name);
- }
- }
- Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
- (value == 'p' ? '+' : '!'),
- (FOLD) ? "__" : "",
- UTF8fARG(UTF, n, name),
- (FOLD) ? "_i" : "");
- optimizable = FALSE; /* Will have to leave this an
- ANYOF node */
has_runtime_dependency |= HAS_USER_DEFINED_PROPERTY;
/* We don't know yet what this matches, so have to flag
anyof_flags |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
}
else {
+ assert (prop_definition && is_invlist(prop_definition));
- /* Here, did get the swash and its inversion list. If
- * the swash is from a user-defined property, then this
- * whole character class should be regarded as such */
- if (swash_init_flags
- & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
+ /* Here we do have the complete property definition
+ *
+ * Temporary workaround for [perl #133136]. For this
+ * precise input that is in the .t that is failing,
+ * load utf8.pm, which is what the test wants, so that
+ * that .t passes */
+ if ( memEQs(RExC_start, e + 1 - RExC_start,
+ "foo\\p{Alnum}")
+ && ! hv_common(GvHVn(PL_incgv),
+ NULL,
+ "utf8.pm", sizeof("utf8.pm") - 1,
+ 0, HV_FETCH_ISEXISTS, NULL, 0))
{
- has_runtime_dependency |= HAS_USER_DEFINED_PROPERTY;
+ require_pv("utf8.pm");
}
- }
- }
- if (invlist) {
- if (! (has_runtime_dependency
- & HAS_USER_DEFINED_PROPERTY) &&
+
+ if (! user_defined &&
/* We warn on matching an above-Unicode code point
* if the match would return true, except don't
* warn for \p{All}, which has exactly one element
* = 0 */
- (_invlist_contains_cp(invlist, 0x110000)
- && (! (_invlist_len(invlist) == 1
- && *invlist_array(invlist) == 0))))
+ (_invlist_contains_cp(prop_definition, 0x110000)
+ && (! (_invlist_len(prop_definition) == 1
+ && *invlist_array(prop_definition) == 0))))
{
warn_super = TRUE;
}
/* Invert if asking for the complement */
if (value == 'P') {
_invlist_union_complement_2nd(properties,
- invlist,
+ prop_definition,
&properties);
/* The swash can't be used as-is, because we've
* inverted things; delay removing it to here after
* have copied its invlist above */
- if (! swash) {
- SvREFCNT_dec_NN(invlist);
- }
SvREFCNT_dec(swash);
swash = NULL;
}
else {
- _invlist_union(properties, invlist, &properties);
- if (! swash) {
- SvREFCNT_dec_NN(invlist);
- }
+ _invlist_union(properties, prop_definition, &properties);
}
}
}
* be matched against. This isn't needed for \p{} and
* pseudo-classes, as they are not affected by locale, and
* hence are dealt with separately */
- if (! need_class) {
- need_class = 1;
- anyof_flags |= ANYOF_MATCHES_POSIXL;
- has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
-
- /* We can't change this into some other type of node
- * (unless this is the only element, in which case there
- * are nodes that mean exactly this) as has runtime
- * dependencies */
- optimizable = FALSE;
- }
-
- /* Coverity thinks it is possible for this to be negative; both
- * jhi and khw think it's not, but be safer */
- assert(! (anyof_flags & ANYOF_MATCHES_POSIXL)
- || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
-
- /* See if it already matches the complement of this POSIX
- * class */
- if ( (anyof_flags & ANYOF_MATCHES_POSIXL)
- && POSIXL_TEST(posixl, namedclass + ((namedclass % 2)
- ? -1
- : 1)))
- {
- posixl_matches_all = TRUE;
- break; /* No need to continue. Since it matches both
- e.g., \w and \W, it matches everything, and the
- bracketed class can be optimized into qr/./s */
- }
-
- /* Add this class to those that should be checked at runtime */
POSIXL_SET(posixl, namedclass);
has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
+ anyof_flags |= ANYOF_MATCHES_POSIXL;
/* The above-Latin1 characters are not subject to locale rules.
* Just add them to the unconditionally-matched list */
/* Our calculated list will be for Unicode rules. For locale
* matching, we have to keep a separate list that is consulted at
- * runtime only when the locale indicates Unicode rules. For
- * non-locale, we just use the general list */
+ * runtime only when the locale indicates Unicode rules (and we
+ * don't include potential matches in the ASCII/Latin1 range, as
+ * any code point could fold to any other, based on the run-time
+ * locale). For non-locale, we just use the general list */
if (LOC) {
use_list = &only_utf8_locale_list;
}
if (j < 256) {
- if (IS_IN_SOME_FOLD_L1(j)) {
+ /* Under /l, we don't know what code points below 256
+ * fold to, except we do know the MICRO SIGN folds to
+ * an above-255 character if the locale is UTF-8, so we
+ * add it to the special list (in *use_list) Otherwise
+ * we know now what things can match, though some folds
+ * are valid under /d only if the target is UTF-8.
+ * Those go in a separate list */
+ if ( IS_IN_SOME_FOLD_L1(j)
+ && ! (LOC && j != MICRO_SIGN))
+ {
/* ASCII is always matched; non-ASCII is matched
* only under Unicode rules (which could happen
only_utf8_locale_list = NULL;
}
}
- if (only_utf8_locale_list) {
+ if ( only_utf8_locale_list
+ || (cp_list && ( _invlist_contains_cp(cp_list, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
+ || _invlist_contains_cp(cp_list, LATIN_SMALL_LETTER_DOTLESS_I))))
+ {
has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
anyof_flags
|= ANYOFL_FOLD
|| (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
{
RExC_seen_d_op = TRUE;
- optimizable = FALSE;
has_runtime_dependency |= HAS_D_RUNTIME_DEPENDENCY;
}
* routine) */
*flagp |= HASWIDTH|SIMPLE;
+ if (anyof_flags & ANYOF_LOCALE_FLAGS) {
+ RExC_contains_locale = 1;
+ }
+
/* Some character classes are equivalent to other nodes. Such nodes take
* up less room, and some nodes require fewer operations to execute, than
* ANYOF nodes. EXACTish nodes may be joinable with adjacent nodes to
* improve efficiency. */
if (optimizable) {
- int posix_class = -1; /* Illegal value */
- UV start, end;
+ PERL_UINT_FAST8_T i;
+ Size_t partial_cp_count = 0;
+ UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
+ UV end[MAX_FOLD_FROMS+1] = { 0 };
+
+ if (cp_list) { /* Count the code points in enough ranges that we would
+ see all the ones possible in any fold in this version
+ of Unicode */
+
+ invlist_iterinit(cp_list);
+ for (i = 0; i <= MAX_FOLD_FROMS; i++) {
+ if (invlist_iternext(cp_list, &start[i], &end[i])) {
+ partial_cp_count += end[i] - start[i] + 1;
+ }
+ }
+
+ invlist_iterfinish(cp_list);
+ }
- if (UNLIKELY(posixl_matches_all)) {
- ret = reg_node(pRExC_state, SANY);
+ /* If we know at compile time that this matches every possible code
+ * point, any run-time dependencies don't matter */
+ if (start[0] == 0 && end[0] == UV_MAX) {
+ if (invert) {
+ ret = reganode(pRExC_state, OPFAIL, 0);
+ }
+ else {
+ ret = reg_node(pRExC_state, SANY);
+ MARK_NAUGHTY(1);
+ }
goto not_anyof;
}
- if (cp_list && ! invert) {
- invlist_iterinit(cp_list);
- if (! invlist_iternext(cp_list, &start, &end)) {
+ /* Similarly, for /l posix classes, if both a class and its
+ * complement match, any run-time dependencies don't matter */
+ if (posixl) {
+ for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX;
+ namedclass += 2)
+ {
+ if ( POSIXL_TEST(posixl, namedclass) /* class */
+ && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
+ {
+ if (invert) {
+ ret = reganode(pRExC_state, OPFAIL, 0);
+ }
+ else {
+ ret = reg_node(pRExC_state, SANY);
+ MARK_NAUGHTY(1);
+ }
+ goto not_anyof;
+ }
+ }
+ /* For well-behaved locales, some classes are subsets of others,
+ * so complementing the subset and including the non-complemented
+ * superset should match everything, like [\D[:alnum:]], and
+ * [[:^alpha:][:alnum:]], but some implementations of locales are
+ * buggy, and khw thinks its a bad idea to have optimization change
+ * behavior, even if it avoids an OS bug in a given case */
+
+#define isSINGLE_BIT_SET(n) isPOWER_OF_2(n)
+
+ /* If is a single posix /l class, can optimize to just that op.
+ * Such a node will not match anything in the Latin1 range, as that
+ * is not determinable until runtime, but will match whatever the
+ * class does outside that range. (Note that some classes won't
+ * match anything outside the range, like [:ascii:]) */
+ if ( isSINGLE_BIT_SET(posixl)
+ && (partial_cp_count == 0 || start[0] > 255))
+ {
+ U8 classnum;
+ SV * class_above_latin1 = NULL;
+ bool already_inverted;
+ bool are_equivalent;
+
+ /* Compute which bit is set, which is the same thing as, e.g.,
+ * ANYOF_CNTRL. From
+ * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn
+ * */
+ static const int MultiplyDeBruijnBitPosition2[32] =
+ {
+ 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
+ 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
+ };
+
+ namedclass = MultiplyDeBruijnBitPosition2[(posixl
+ * 0x077CB531U) >> 27];
+ classnum = namedclass_to_classnum(namedclass);
+
+ /* The named classes are such that the inverted number is one
+ * larger than the non-inverted one */
+ already_inverted = namedclass
+ - classnum_to_namedclass(classnum);
+
+ /* Create an inversion list of the official property, inverted
+ * if the constructed node list is inverted, and restricted to
+ * only the above latin1 code points, which are the only ones
+ * known at compile time */
+ _invlist_intersection_maybe_complement_2nd(
+ PL_AboveLatin1,
+ PL_XPosix_ptrs[classnum],
+ already_inverted,
+ &class_above_latin1);
+ are_equivalent = _invlistEQ(class_above_latin1, cp_list,
+ FALSE);
+ SvREFCNT_dec_NN(class_above_latin1);
+
+ if (are_equivalent) {
+
+ /* Resolve the run-time inversion flag with this possibly
+ * inverted class */
+ invert = invert ^ already_inverted;
+
+ ret = reg_node(pRExC_state,
+ POSIXL + invert * (NPOSIXL - POSIXL));
+ FLAGS(REGNODE_p(ret)) = classnum;
+ goto not_anyof;
+ }
+ }
+ }
+
+ /* khw can't think of any other possible transformation involving
+ * these. */
+ if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
+ goto is_anyof;
+ }
+
+ if (! has_runtime_dependency) {
/* If the list is empty, nothing matches. This happens, for
* example, when a Unicode property that doesn't match anything is
* the only element in the character class (perluniprops.pod notes
* such properties). */
+ if (partial_cp_count == 0) {
+ assert (! invert);
ret = reganode(pRExC_state, OPFAIL, 0);
goto not_anyof;
}
- if (start == end) { /* The range is a single code point */
- if (! invlist_iternext(cp_list, &start, &end)
+ /* If matches everything but \n */
+ if ( start[0] == 0 && end[0] == '\n' - 1
+ && start[1] == '\n' + 1 && end[1] == UV_MAX)
+ {
+ assert (! invert);
+ ret = reg_node(pRExC_state, REG_ANY);
+ MARK_NAUGHTY(1);
+ goto not_anyof;
+ }
+ }
- /* Don't do this optimization if it would require
- * changing the pattern to UTF-8 */
- && (start < 256 || UTF))
- {
- /* Here, the list contains a single code point. Can
- * optimize into an EXACTish node */
+ /* Next see if can optimize classes that contain just a few code points
+ * into an EXACTish node. The reason to do this is to let the
+ * optimizer join this node with adjacent EXACTish ones.
+ *
+ * An EXACTFish node can be generated even if not under /i, and vice
+ * versa. But care must be taken. An EXACTFish node has to be such
+ * that it only matches precisely the code points in the class, but we
+ * want to generate the least restrictive one that does that, to
+ * increase the odds of being able to join with an adjacent node. For
+ * example, if the class contains [kK], we have to make it an EXACTFAA
+ * node to prevent the KELVIN SIGN from matching. Whether we are under
+ * /i or not is irrelevant in this case. Less obvious is the pattern
+ * qr/[\x{02BC}]n/i. U+02BC is MODIFIER LETTER APOSTROPHE. That is
+ * supposed to match the single character U+0149 LATIN SMALL LETTER N
+ * PRECEDED BY APOSTROPHE. And so even though there is no simple fold
+ * that includes \X{02BC}, there is a multi-char fold that does, and so
+ * the node generated for it must be an EXACTFish one. On the other
+ * hand qr/:/i should generate a plain EXACT node since the colon
+ * participates in no fold whatsoever, and having it EXACT tells the
+ * optimizer the target string cannot match unless it has a colon in
+ * it.
+ *
+ * We don't typically generate an EXACTish node if doing so would
+ * require changing the pattern to UTF-8, as that affects /d and
+ * otherwise is slower. However, under /i, not changing to UTF-8 can
+ * miss some potential multi-character folds. We calculate the
+ * EXACTish node, and then decide if something would be missed if we
+ * don't upgrade */
+ if ( ! posixl
+ && ! invert
+
+ /* Only try if there are no more code points in the class than
+ * in the max possible fold */
+ && partial_cp_count > 0 && partial_cp_count <= MAX_FOLD_FROMS + 1
+
+ && (start[0] < 256 || UTF || FOLD))
+ {
+ if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches)
+ {
+ /* We can always make a single code point class into an
+ * EXACTish node. */
+
+ if (LOC) {
+
+ /* Here is /l: Use EXACTL, except /li indicates EXACTFL,
+ * as that means there is a fold not known until runtime so
+ * shows as only a single code point here. */
+ op = (FOLD) ? EXACTFL : EXACTL;
+ }
+ else if (! FOLD) { /* Not /l and not /i */
+ op = (start[0] < 256) ? EXACT : EXACT_ONLY8;
+ }
+ else if (start[0] < 256) { /* /i, not /l, and the code point is
+ small */
+
+ /* Under /i, it gets a little tricky. A code point that
+ * doesn't participate in a fold should be an EXACT node.
+ * We know this one isn't the result of a simple fold, or
+ * there'd be more than one code point in the list, but it
+ * could be part of a multi- character fold. In that case
+ * we better not create an EXACT node, as we would wrongly
+ * be telling the optimizer that this code point must be in
+ * the target string, and that is wrong. This is because
+ * if the sequence around this code point forms a
+ * multi-char fold, what needs to be in the string could be
+ * the code point that folds to the sequence.
+ *
+ * This handles the case of below-255 code points, as we
+ * have an easy look up for those. The next clause handles
+ * the above-256 one */
+ op = IS_IN_SOME_FOLD_L1(start[0])
+ ? EXACTFU
+ : EXACT;
+ }
+ else { /* /i, larger code point. Since we are under /i, and
+ have just this code point, we know that it can't
+ fold to something else, so PL_InMultiCharFold
+ applies to it */
+ op = _invlist_contains_cp(PL_InMultiCharFold,
+ start[0])
+ ? EXACTFU_ONLY8
+ : EXACT_ONLY8;
+ }
+
+ value = start[0];
+ }
+ else if ( ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
+ && _invlist_contains_cp(PL_in_some_fold, start[0]))
+ {
+ /* Here, the only runtime dependency, if any, is from /d, and
+ * the class matches more than one code point, and the lowest
+ * code point participates in some fold. It might be that the
+ * other code points are /i equivalent to this one, and hence
+ * they would representable by an EXACTFish node. Above, we
+ * eliminated classes that contain too many code points to be
+ * EXACTFish, with the test for MAX_FOLD_FROMS
+ *
+ * First, special case the ASCII fold pairs, like 'B' and 'b'.
+ * We do this because we have EXACTFAA at our disposal for the
+ * ASCII range */
+ if (partial_cp_count == 2 && isASCII(start[0])) {
+
+ /* The only ASCII characters that participate in folds are
+ * alphabetics */
+ assert(isALPHA(start[0]));
+ if ( end[0] == start[0] /* First range is a single
+ character, so 2nd exists */
+ && isALPHA_FOLD_EQ(start[0], start[1]))
+ {
+
+ /* Here, is part of an ASCII fold pair */
- value = start;
+ if ( ASCII_FOLD_RESTRICTED
+ || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(start[0]))
+ {
+ /* If the second clause just above was true, it
+ * means we can't be under /i, or else the list
+ * would have included more than this fold pair.
+ * Therefore we have to exclude the possibility of
+ * whatever else it is that folds to these, by
+ * using EXACTFAA */
+ op = EXACTFAA;
+ }
+ else if (HAS_NONLATIN1_FOLD_CLOSURE(start[0])) {
- if (! FOLD) {
- op = (LOC)
- ? EXACTL
- : EXACT;
+ /* Here, there's no simple fold that start[0] is part
+ * of, but there is a multi-character one. If we
+ * are not under /i, we want to exclude that
+ * possibility; if under /i, we want to include it
+ * */
+ op = (FOLD) ? EXACTFU : EXACTFAA;
+ }
+ else {
+
+ /* Here, the only possible fold start[0] particpates in
+ * is with start[1]. /i or not isn't relevant */
+ op = EXACTFU;
+ }
+
+ value = toFOLD(start[0]);
+ }
+ }
+ else if ( ! upper_latin1_only_utf8_matches
+ || ( _invlist_len(upper_latin1_only_utf8_matches)
+ == 2
+ && PL_fold_latin1[
+ invlist_highest(upper_latin1_only_utf8_matches)]
+ == start[0]))
+ {
+ /* Here, the smallest character is non-ascii or there are
+ * more than 2 code points matched by this node. Also, we
+ * either don't have /d UTF-8 dependent matches, or if we
+ * do, they look like they could be a single character that
+ * is the fold of the lowest one in the always-match list.
+ * This test quickly excludes most of the false positives
+ * when there are /d UTF-8 depdendent matches. These are
+ * like LATIN CAPITAL LETTER A WITH GRAVE matching LATIN
+ * SMALL LETTER A WITH GRAVE iff the target string is
+ * UTF-8. (We don't have to worry above about exceeding
+ * the array bounds of PL_fold_latin1[] because any code
+ * point in 'upper_latin1_only_utf8_matches' is below 256.)
+ *
+ * EXACTFAA would apply only to pairs (hence exactly 2 code
+ * points) in the ASCII range, so we can't use it here to
+ * artificially restrict the fold domain, so we check if
+ * the class does or does not match some EXACTFish node.
+ * Further, if we aren't under /i, and and the folded-to
+ * character is part of a multi-character fold, we can't do
+ * this optimization, as the sequence around it could be
+ * that multi-character fold, and we don't here know the
+ * context, so we have to assume it is that multi-char
+ * fold, to prevent potential bugs.
+ *
+ * To do the general case, we first find the fold of the
+ * lowest code point (which may be higher than the lowest
+ * one), then find everything that folds to it. (The data
+ * structure we have only maps from the folded code points,
+ * so we have to do the earlier step.) */
+
+ Size_t foldlen;
+ U8 foldbuf[UTF8_MAXBYTES_CASE];
+ UV folded = _to_uni_fold_flags(start[0],
+ foldbuf, &foldlen, 0);
+ unsigned int first_fold;
+ const unsigned int * remaining_folds;
+ Size_t folds_to_this_cp_count = _inverse_folds(
+ folded,
+ &first_fold,
+ &remaining_folds);
+ Size_t folds_count = folds_to_this_cp_count + 1;
+ SV * fold_list = _new_invlist(folds_count);
+ unsigned int i;
+
+ /* If there are UTF-8 dependent matches, create a temporary
+ * list of what this node matches, including them. */
+ SV * all_cp_list = NULL;
+ SV ** use_this_list = &cp_list;
+
+ if (upper_latin1_only_utf8_matches) {
+ all_cp_list = _new_invlist(0);
+ use_this_list = &all_cp_list;
+ _invlist_union(cp_list,
+ upper_latin1_only_utf8_matches,
+ use_this_list);
}
- else if (LOC) {
- /* A locale node under folding with one code point can
- * be an EXACTFL, as its fold won't be calculated until
- * runtime */
- op = EXACTFL;
+ /* Having gotten everything that participates in the fold
+ * containing the lowest code point, we turn that into an
+ * inversion list, making sure everything is included. */
+ fold_list = add_cp_to_invlist(fold_list, start[0]);
+ fold_list = add_cp_to_invlist(fold_list, folded);
+ fold_list = add_cp_to_invlist(fold_list, first_fold);
+ for (i = 0; i < folds_to_this_cp_count - 1; i++) {
+ fold_list = add_cp_to_invlist(fold_list,
+ remaining_folds[i]);
}
- else {
- /* Here, we are generally folding, but there is only
- * one code point to match. If we have to, we use an
- * EXACT node, but it would be better for joining with
- * adjacent nodes in the optimization phase if we used
- * the same EXACTFish node that any such are likely to
- * be. We can do this iff the code point doesn't
- * participate in any folds. For example, an EXACTF of
- * a colon is the same as an EXACT one, since nothing
- * folds to or from a colon. */
- if (value < 256) {
- if (IS_IN_SOME_FOLD_L1(value)) {
- op = EXACT;
- }
- }
- else {
- if (_invlist_contains_cp(PL_in_some_fold, value)) {
- op = EXACT;
+ /* If the fold list is identical to what's in this ANYOF
+ * node, the node can be represented by an EXACTFish one
+ * instead */
+ if (_invlistEQ(*use_this_list, fold_list,
+ 0 /* Don't complement */ )
+ ) {
+
+ /* But, we have to be careful, as mentioned above.
+ * Just the right sequence of characters could match
+ * this if it is part of a multi-character fold. That
+ * IS what we want if we are under /i. But it ISN'T
+ * what we want if not under /i, as it could match when
+ * it shouldn't. So, when we aren't under /i and this
+ * character participates in a multi-char fold, we
+ * don't optimize into an EXACTFish node. So, for each
+ * case below we have to check if we are folding
+ * and if not, if it is not part of a multi-char fold.
+ * */
+ if (start[0] > 255) { /* Highish code point */
+ if (FOLD || ! _invlist_contains_cp(
+ PL_InMultiCharFold, folded))
+ {
+ op = (LOC)
+ ? EXACTFLU8
+ : (ASCII_FOLD_RESTRICTED)
+ ? EXACTFAA
+ : EXACTFU_ONLY8;
+ value = folded;
}
+ } /* Below, the lowest code point < 256 */
+ else if ( FOLD
+ && folded == 's'
+ && DEPENDS_SEMANTICS)
+ { /* An EXACTF node containing a single character
+ 's', can be an EXACTFU if it doesn't get
+ joined with an adjacent 's' */
+ op = EXACTFU_S_EDGE;
+ value = folded;
}
+ else if ( FOLD
+ || ! HAS_NONLATIN1_FOLD_CLOSURE(start[0]))
+ {
+ if (upper_latin1_only_utf8_matches) {
+ op = EXACTF;
- /* If we haven't found the node type, above, it means
- * we can use the prevailing one */
- if (op == END) {
- op = compute_EXACTish(pRExC_state);
+ /* We can't use the fold, as that only matches
+ * under UTF-8 */
+ value = start[0];
+ }
+ else if ( UNLIKELY(start[0] == MICRO_SIGN)
+ && ! UTF)
+ { /* EXACTFUP is a special node for this
+ character */
+ op = (ASCII_FOLD_RESTRICTED)
+ ? EXACTFAA
+ : EXACTFUP;
+ value = MICRO_SIGN;
+ }
+ else if ( ASCII_FOLD_RESTRICTED
+ && ! isASCII(start[0]))
+ { /* For ASCII under /iaa, we can use EXACTFU
+ below */
+ op = EXACTFAA;
+ value = folded;
+ }
+ else {
+ op = EXACTFU;
+ value = folded;
+ }
}
}
- }
- } /* End of first range contains just a single code point */
- else if (start == 0) {
- if (end == UV_MAX) {
- op = SANY;
- MARK_NAUGHTY(1);
- }
- else if (end == '\n' - 1
- && invlist_iternext(cp_list, &start, &end)
- && start == '\n' + 1 && end == UV_MAX)
- {
- op = REG_ANY;
- MARK_NAUGHTY(1);
+
+ SvREFCNT_dec_NN(fold_list);
+ SvREFCNT_dec(all_cp_list);
}
}
- invlist_iterfinish(cp_list);
if (op != END) {
- if (PL_regkind[op] != EXACT) {
- ret = reg_node(pRExC_state, op);
+
+ /* Here, we have calculated what EXACTish node we would use.
+ * But we don't use it if it would require converting the
+ * pattern to UTF-8, unless not using it could cause us to miss
+ * some folds (hence be buggy) */
+
+ if (! UTF && value > 255) {
+ SV * in_multis = NULL;
+
+ assert(FOLD);
+
+ /* If there is no code point that is part of a multi-char
+ * fold, then there aren't any matches, so we don't do this
+ * optimization. Otherwise, it could match depending on
+ * the context around us, so we do upgrade */
+ _invlist_intersection(PL_InMultiCharFold, cp_list, &in_multis);
+ if (UNLIKELY(_invlist_len(in_multis) != 0)) {
+ REQUIRE_UTF8(flagp);
+ }
+ else {
+ op = END;
+ }
}
- else {
+
+ if (op != END) {
U8 len = (UTF) ? UVCHR_SKIP(value) : 1;
ret = regnode_guts(pRExC_state, op, len, "exact");
else {
uvchr_to_utf8((U8 *) STRING(REGNODE_p(ret)), value);
}
+ goto not_anyof;
}
- goto not_anyof;
}
+ }
- {
+ if (! has_runtime_dependency) {
/* See if this can be turned into an ANYOFM node. Think about the
* bit patterns in two different bytes. In some positions, the
}
if (invlist_highest(cp_list) <= max_permissible) {
- UV this_start, this_end, lowest_cp;
+ UV this_start, this_end;
+ UV lowest_cp = UV_MAX; /* inited to suppress compiler warn */
U8 bits_differing = 0;
Size_t full_cp_count = 0;
bool first_time = TRUE;
if (op != END) {
goto not_anyof;
}
- }
+ }
- {
+ if (! (anyof_flags & ANYOF_LOCALE_FLAGS)) {
PERL_UINT_FAST8_T type;
+ SV * intersection = NULL;
+ SV* d_invlist = NULL;
- /* Here, didn't find an optimization. See if this matches any
- * of the POSIX classes. The POSIXA ones are about the same speed
- * as ANYOF ops, but take less room; the ones that have
- * above-Latin1 code point matches are somewhat faster than ANYOF.
- * */
+ /* See if this matches any of the POSIX classes. The POSIXA and
+ * POSIXD ones are about the same speed as ANYOF ops, but take less
+ * room; the ones that have above-Latin1 code point matches are
+ * somewhat faster than ANYOF. */
- for (type = POSIXU; type <= POSIXA; type++) {
+ for (type = POSIXA; type >= POSIXD; type--) {
+ int posix_class;
+
+ if (type == POSIXL) { /* But not /l posix classes */
+ continue;
+ }
for (posix_class = 0;
posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
official_code_points = &PL_XPosix_ptrs[posix_class];
}
+ /* Skip non-existent classes of this type. e.g. \v only
+ * has an entry in PL_XPosix_ptrs */
+ if (! *official_code_points) {
+ continue;
+ }
+
/* Try both the regular class, and its inversion */
for (try_inverted = 0; try_inverted < 2; try_inverted++) {
- /* Check if matches, normal or inverted */
- if (*official_code_points) {
- if (_invlistEQ(*our_code_points,
- *official_code_points,
- try_inverted))
+ bool this_inverted = invert ^ try_inverted;
+
+ if (type != POSIXD) {
+
+ /* This class that isn't /d can't match if we have
+ * /d dependencies */
+ if (has_runtime_dependency
+ & HAS_D_RUNTIME_DEPENDENCY)
{
- ret = reg_node(pRExC_state, (try_inverted)
- ? type + NPOSIXA
- - POSIXA
- : type);
- FLAGS(REGNODE_p(ret)) = posix_class;
- goto not_anyof;
+ continue;
}
}
+ else /* is /d */ if (! this_inverted) {
+
+ /* /d classes don't match anything non-ASCII below
+ * 256 unconditionally (which cp_list contains) */
+ _invlist_intersection(cp_list, PL_UpperLatin1,
+ &intersection);
+ if (_invlist_len(intersection) != 0) {
+ continue;
+ }
+
+ SvREFCNT_dec(d_invlist);
+ d_invlist = invlist_clone(cp_list, NULL);
+
+ /* But under UTF-8 it turns into using /u rules.
+ * Add the things it matches under these conditions
+ * so that we check below that these are identical
+ * to what the tested class should match */
+ if (upper_latin1_only_utf8_matches) {
+ _invlist_union(
+ d_invlist,
+ upper_latin1_only_utf8_matches,
+ &d_invlist);
+ }
+ our_code_points = &d_invlist;
+ }
+ else { /* POSIXD, inverted. If this doesn't have this
+ flag set, it isn't /d. */
+ if (! (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
+ {
+ continue;
+ }
+ our_code_points = &cp_list;
+ }
+
+ /* Here, have weeded out some things. We want to see
+ * if the list of characters this node contains
+ * ('*our_code_points') precisely matches those of the
+ * class we are currently checking against
+ * ('*official_code_points'). */
+ if (_invlistEQ(*our_code_points,
+ *official_code_points,
+ try_inverted))
+ {
+ /* Here, they precisely match. Optimize this ANYOF
+ * node into its equivalent POSIX one of the
+ * correct type, possibly inverted */
+ ret = reg_node(pRExC_state, (try_inverted)
+ ? type + NPOSIXA
+ - POSIXA
+ : type);
+ FLAGS(REGNODE_p(ret)) = posix_class;
+ SvREFCNT_dec(d_invlist);
+ SvREFCNT_dec(intersection);
+ goto not_anyof;
+ }
}
}
}
+ SvREFCNT_dec(d_invlist);
+ SvREFCNT_dec(intersection);
}
+
+ /* If didn't find an optimization and there is no need for a
+ * bitmap, optimize to indicate that */
+ if ( start[0] >= NUM_ANYOF_CODE_POINTS
+ && ! LOC
+ && ! upper_latin1_only_utf8_matches)
+ {
+ op = ANYOFH;
}
} /* End of seeing if can optimize it into a different node */
- /* It's going to be an ANYOF node. */
- op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
- ? ANYOFD
- : ((posixl)
- ? ANYOFPOSIXL
- : ((LOC)
- ? ANYOFL
- : ANYOF));
+ is_anyof: /* It's going to be an ANYOF node. */
+ if (op != ANYOFH) {
+ op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
+ ? ANYOFD
+ : ((posixl)
+ ? ANYOFPOSIXL
+ : ((LOC)
+ ? ANYOFL
+ : ANYOF));
+ }
+
ret = regnode_guts(pRExC_state, op, regarglen[op], "anyof");
FILL_NODE(ret, op); /* We set the argument later */
RExC_emit += 1 + regarglen[op];
only_utf8_locale_list,
swash, cBOOL(has_runtime_dependency
& HAS_USER_DEFINED_PROPERTY));
-
- if (ANYOF_FLAGS(REGNODE_p(ret)) & ANYOF_LOCALE_FLAGS) {
- RExC_contains_locale = 1;
- }
-
return ret;
not_anyof:
Set_Node_Offset_Length(REGNODE_p(ret), orig_parse - RExC_start,
RExC_parse - orig_parse);;
- SvREFCNT_dec_NN(cp_list);;
+ SvREFCNT_dec(cp_list);;
return ret;
}
* the node passed-in. If there is nothing outside the node's bitmap, the
* arg is set to ANYOF_ONLY_HAS_BITMAP. Otherwise, it sets the argument to
* the count returned by add_data(), having allocated and stored an array,
- * av, that that count references, as follows:
- * av[0] stores the character class description in its textual form.
- * This is used later (regexec.c:Perl_regclass_swash()) to
- * initialize the appropriate swash, and is also useful for dumping
- * the regnode. This is set to &PL_sv_undef if the textual
- * description is not needed at run-time (as happens if the other
- * elements completely define the class)
- * av[1] if &PL_sv_undef, is a placeholder to later contain the swash
- * computed from av[0]. But if no further computation need be done,
- * the swash is stored here now (and av[0] is &PL_sv_undef).
- * av[2] stores the inversion list of code points that match only if the
- * current locale is UTF-8
- * av[3] stores the cp_list inversion list for use in addition or instead
- * of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
- * (Otherwise everything needed is already in av[0] and av[1])
- * av[4] is set if any component of the class is from a user-defined
- * property; used only if av[3] exists */
+ * av, as follows:
+ *
+ * av[0] stores the inversion list defining this class as far as known at
+ * this time, or PL_sv_undef if nothing definite is now known.
+ * av[1] stores the inversion list of code points that match only if the
+ * current locale is UTF-8, or if none, PL_sv_undef if there is an
+ * av[2], or no entry otherwise.
+ * av[2] stores the list of user-defined properties whose subroutine
+ * definitions aren't known at this time, or no entry if none. */
UV n;
AV * const av = newAV();
SV *rv;
- av_store(av, 0, (runtime_defns)
- ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
- if (swash) {
- assert(cp_list);
- av_store(av, 1, swash);
- SvREFCNT_dec_NN(cp_list);
- }
- else {
- av_store(av, 1, &PL_sv_undef);
- if (cp_list) {
- av_store(av, 3, cp_list);
- av_store(av, 4, newSVuv(has_user_defined_property));
- }
- }
+ if (cp_list) {
+ av_store(av, INVLIST_INDEX, cp_list);
+ }
if (only_utf8_locale_list) {
- av_store(av, 2, only_utf8_locale_list);
+ av_store(av, ONLY_LOCALE_MATCHES_INDEX, only_utf8_locale_list);
}
- else {
- av_store(av, 2, &PL_sv_undef);
+
+ if (runtime_defns) {
+ av_store(av, DEFERRED_USER_DEFINED_INDEX, SvREFCNT_inc(runtime_defns));
}
rv = newRV_noinc(MUTABLE_SV(av));
* that, in spite of this function's name, the swash it returns may include
* the bitmap data as well */
- SV *sw = NULL;
SV *si = NULL; /* Input swash initialization string */
SV* invlist = NULL;
SV * const rv = MUTABLE_SV(data->data[n]);
AV * const av = MUTABLE_AV(SvRV(rv));
SV **const ary = AvARRAY(av);
- U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
- si = *ary; /* ary[0] = the string to initialize the swash with */
+ invlist = ary[INVLIST_INDEX];
- if (av_tindex_skip_len_mg(av) >= 2) {
- if (only_utf8_locale_ptr
- && ary[2]
- && ary[2] != &PL_sv_undef)
- {
- *only_utf8_locale_ptr = ary[2];
- }
- else {
- assert(only_utf8_locale_ptr);
- *only_utf8_locale_ptr = NULL;
- }
-
- /* Elements 3 and 4 are either both present or both absent. [3]
- * is any inversion list generated at compile time; [4]
- * indicates if that inversion list has any user-defined
- * properties in it. */
- if (av_tindex_skip_len_mg(av) >= 3) {
- invlist = ary[3];
- if (SvUV(ary[4])) {
- swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
+ if (av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX) {
+ *only_utf8_locale_ptr = ary[ONLY_LOCALE_MATCHES_INDEX];
+ }
+
+ if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
+ si = ary[DEFERRED_USER_DEFINED_INDEX];
+ }
+
+ if (doinit && (si || invlist)) {
+ if (si) {
+ bool user_defined;
+ SV * msg = newSVpvs_flags("", SVs_TEMP);
+
+ SV * prop_definition = handle_user_defined_property(
+ "", 0, FALSE, /* There is no \p{}, \P{} */
+ SvPVX_const(si)[1] - '0', /* /i or not has been
+ stored here for just
+ this occasion */
+ TRUE, /* run time */
+ si, /* The property definition */
+ &user_defined,
+ msg,
+ 0 /* base level call */
+ );
+
+ if (SvCUR(msg)) {
+ assert(prop_definition == NULL);
+
+ Perl_croak(aTHX_ "%" UTF8f,
+ UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg)));
}
- }
- else {
- invlist = NULL;
- }
- }
- /* Element [1] is reserved for the set-up swash. If already there,
- * return it; if not, create it and store it there */
- if (ary[1] && SvROK(ary[1])) {
- sw = ary[1];
- }
- else if (doinit && ((si && si != &PL_sv_undef)
- || (invlist && invlist != &PL_sv_undef))) {
- assert(si);
- sw = _core_swash_init("utf8", /* the utf8 package */
- "", /* nameless */
- si,
- 1, /* binary */
- 0, /* not from tr/// */
- invlist,
- &swash_init_flags);
- (void)av_store(av, 1, sw);
+ if (invlist) {
+ _invlist_union(invlist, prop_definition, &invlist);
+ SvREFCNT_dec_NN(prop_definition);
+ }
+ else {
+ invlist = prop_definition;
+ }
+
+ assert(ONLY_LOCALE_MATCHES_INDEX == 1 + INVLIST_INDEX);
+ assert(DEFERRED_USER_DEFINED_INDEX == 1
+ + ONLY_LOCALE_MATCHES_INDEX);
+
+ av_store(av, INVLIST_INDEX, invlist);
+ av_fill(av, (ary[ONLY_LOCALE_MATCHES_INDEX])
+ ? ONLY_LOCALE_MATCHES_INDEX:
+ INVLIST_INDEX);
+ si = NULL;
+ }
}
}
}
* compile-time, before everything gets resolved, in which case we
* return the currently best available information, which is the string
* that will eventually be used to do that resolving, 'si' */
- if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
- && (si && si != &PL_sv_undef))
- {
+ if (si) {
/* Here, we only have 'si' (and possibly some passed-in data in
* 'invlist', which is handled below) If the caller only wants
* 'si', use that. */
*listsvp = matches_string;
}
- return sw;
+ return invlist;
}
#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
Perl_re_printf( aTHX_ "~ %s (%d) %s %s\n",
- SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(REGNODE_p(scan)),
+ SvPV_nolen_const(RExC_mysv), scan,
(temp == NULL ? "->" : ""),
(temp == NULL ? PL_reg_name[OP(REGNODE_p(val))] : "")
);
regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
Perl_re_printf( aTHX_ "~ %s (%d) -> %s\n",
SvPV_nolen_const(RExC_mysv),
- REG_NODE_NUM(REGNODE_p(scan)),
+ scan,
PL_reg_name[exact]);
});
if (temp == NULL)
Perl_re_printf( aTHX_
"~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
SvPV_nolen_const(RExC_mysv),
- (IV)REG_NODE_NUM(REGNODE_p(val)),
+ (IV)val,
(IV)(val - scan)
);
});
/* Ready to start outputting. First, the initial left bracket */
Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
- /* Then all the things that could fit in the bitmap */
- do_sep = put_charclass_bitmap_innards(sv,
- ANYOF_BITMAP(o),
- bitmap_range_not_in_bitmap,
- only_utf8_locale_invlist,
- o,
-
- /* Can't try inverting for a
- * better display if there are
- * things that haven't been
- * resolved */
- unresolved != NULL);
- SvREFCNT_dec(bitmap_range_not_in_bitmap);
-
- /* If there are user-defined properties which haven't been defined yet,
- * output them. If the result is not to be inverted, it is clearest to
- * output them in a separate [] from the bitmap range stuff. If the
- * result is to be complemented, we have to show everything in one [],
- * as the inversion applies to the whole thing. Use {braces} to
- * separate them from anything in the bitmap and anything above the
- * bitmap. */
- if (unresolved) {
- if (inverted) {
- if (! do_sep) { /* If didn't output anything in the bitmap */
- sv_catpvs(sv, "^");
+ if (OP(o) != ANYOFH) {
+ /* Then all the things that could fit in the bitmap */
+ do_sep = put_charclass_bitmap_innards(sv,
+ ANYOF_BITMAP(o),
+ bitmap_range_not_in_bitmap,
+ only_utf8_locale_invlist,
+ o,
+
+ /* Can't try inverting for a
+ * better display if there
+ * are things that haven't
+ * been resolved */
+ unresolved != NULL);
+ SvREFCNT_dec(bitmap_range_not_in_bitmap);
+
+ /* If there are user-defined properties which haven't been defined
+ * yet, output them. If the result is not to be inverted, it is
+ * clearest to output them in a separate [] from the bitmap range
+ * stuff. If the result is to be complemented, we have to show
+ * everything in one [], as the inversion applies to the whole
+ * thing. Use {braces} to separate them from anything in the
+ * bitmap and anything above the bitmap. */
+ if (unresolved) {
+ if (inverted) {
+ if (! do_sep) { /* If didn't output anything in the bitmap
+ */
+ sv_catpvs(sv, "^");
+ }
+ sv_catpvs(sv, "{");
}
- sv_catpvs(sv, "{");
- }
- else if (do_sep) {
- Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
- }
- sv_catsv(sv, unresolved);
- if (inverted) {
- sv_catpvs(sv, "}");
+ else if (do_sep) {
+ Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
+ PL_colors[0]);
+ }
+ sv_catsv(sv, unresolved);
+ if (inverted) {
+ sv_catpvs(sv, "}");
+ }
+ do_sep = ! inverted;
}
- do_sep = ! inverted;
}
/* And, finally, add the above-the-bitmap stuff */
void
Perl_init_uniprops(pTHX)
{
+ PL_user_def_props = newHV();
+
+#ifdef USE_ITHREADS
+
+ HvSHAREKEYS_off(PL_user_def_props);
+ PL_user_def_props_aTHX = aTHX;
+
+#endif
+
/* Set up the inversion list global variables */
PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
PL_in_some_fold = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_ANY_FOLDS]);
PL_HasMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
UNI__PERL_FOLDS_TO_MULTI_CHAR]);
- PL_InMultiCharFold = _new_invlist_C_array(UNI__PERL_IS_IN_MULTI_CHAR_FOLD_invlist);
- PL_NonFinalFold = _new_invlist_C_array(UNI__PERL_NON_FINAL_FOLDS_invlist);
+ PL_InMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
+ UNI__PERL_IS_IN_MULTI_CHAR_FOLD]);
+ PL_NonFinalFold = _new_invlist_C_array(uni_prop_ptrs[
+ UNI__PERL_NON_FINAL_FOLDS]);
PL_utf8_toupper = _new_invlist_C_array(Uppercase_Mapping_invlist);
PL_utf8_tolower = _new_invlist_C_array(Lowercase_Mapping_invlist);
PL_utf8_tosimplefold = _new_invlist_C_array(Simple_Case_Folding_invlist);
PL_utf8_foldclosures = _new_invlist_C_array(_Perl_IVCF_invlist);
PL_utf8_mark = _new_invlist_C_array(uni_prop_ptrs[UNI_M]);
+ PL_CCC_non0_non230 = _new_invlist_C_array(_Perl_CCC_non0_non230_invlist);
#ifdef UNI_XIDC
/* The below are used only by deprecated functions. They could be removed */
#endif
}
-SV *
-Perl_parse_uniprop_string(pTHX_ const char * const name, const Size_t name_len,
- const bool to_fold, bool * invert)
+#if 0
+
+This code was mainly added for backcompat to give a warning for non-portable
+code points in user-defined properties. But experiments showed that the
+warning in earlier perls were only omitted on overflow, which should be an
+error, so there really isnt a backcompat issue, and actually adding the
+warning when none was present before might cause breakage, for little gain. So
+khw left this code in, but not enabled. Tests were never added.
+
+embed.fnc entry:
+Ei |const char *|get_extended_utf8_msg|const UV cp
+
+PERL_STATIC_INLINE const char *
+S_get_extended_utf8_msg(pTHX_ const UV cp)
{
- /* Parse the interior meat of \p{} passed to this in 'name' with length
- * 'name_len', and return an inversion list if a property with 'name' is
- * found, or NULL if not. 'name' point to the input with leading and
- * trailing space trimmed. 'to_fold' indicates if /i is in effect.
+ U8 dummy[UTF8_MAXBYTES + 1];
+ HV *msgs;
+ SV **msg;
+
+ uvchr_to_utf8_flags_msgs(dummy, cp, UNICODE_WARN_PERL_EXTENDED,
+ &msgs);
+
+ msg = hv_fetchs(msgs, "text", 0);
+ assert(msg);
+
+ (void) sv_2mortal((SV *) msgs);
+
+ return SvPVX(*msg);
+}
+
+#endif
+
+SV *
+Perl_handle_user_defined_property(pTHX_
+
+ /* Parses the contents of a user-defined property definition; returning the
+ * expanded definition if possible. If so, the return is an inversion
+ * list.
*
- * When the return is an inversion list, '*invert' will be set to a boolean
- * indicating if it should be inverted or not
+ * If there are subroutines that are part of the expansion and which aren't
+ * known at the time of the call to this function, this returns what
+ * parse_uniprop_string() returned for the first one encountered.
*
- * This currently doesn't handle all cases. A NULL return indicates the
- * caller should try a different approach
- */
+ * If an error was found, NULL is returned, and 'msg' gets a suitable
+ * message appended to it. (Appending allows the back trace of how we got
+ * to the faulty definition to be displayed through nested calls of
+ * user-defined subs.)
+ *
+ * The caller IS responsible for freeing any returned SV.
+ *
+ * The syntax of the contents is pretty much described in perlunicode.pod,
+ * but we also allow comments on each line */
+
+ const char * name, /* Name of property */
+ const STRLEN name_len, /* The name's length in bytes */
+ const bool is_utf8, /* ? Is 'name' encoded in UTF-8 */
+ const bool to_fold, /* ? Is this under /i */
+ const bool runtime, /* ? Are we in compile- or run-time */
+ SV* contents, /* The property's definition */
+ bool *user_defined_ptr, /* This will be set TRUE as we wouldn't be
+ getting called unless this is thought to be
+ a user-defined property */
+ SV * msg, /* Any error or warning msg(s) are appended to
+ this */
+ const STRLEN level) /* Recursion level of this call */
+{
+ STRLEN len;
+ const char * string = SvPV_const(contents, len);
+ const char * const e = string + len;
+ const bool is_contents_utf8 = cBOOL(SvUTF8(contents));
+ const STRLEN msgs_length_on_entry = SvCUR(msg);
+
+ const char * s0 = string; /* Points to first byte in the current line
+ being parsed in 'string' */
+ const char overflow_msg[] = "Code point too large in \"";
+ SV* running_definition = NULL;
+
+ PERL_ARGS_ASSERT_HANDLE_USER_DEFINED_PROPERTY;
+
+ *user_defined_ptr = TRUE;
+
+ /* Look at each line */
+ while (s0 < e) {
+ const char * s; /* Current byte */
+ char op = '+'; /* Default operation is 'union' */
+ IV min = 0; /* range begin code point */
+ IV max = -1; /* and range end */
+ SV* this_definition;
+
+ /* Skip comment lines */
+ if (*s0 == '#') {
+ s0 = strchr(s0, '\n');
+ if (s0 == NULL) {
+ break;
+ }
+ s0++;
+ continue;
+ }
- char* lookup_name;
- bool stricter = FALSE;
- bool is_nv_type = FALSE; /* nv= or numeric_value=, or possibly one
- of the cjk numeric properties (though
- it requires extra effort to compile
- them) */
- unsigned int i;
- unsigned int j = 0, lookup_len;
- int equals_pos = -1; /* Where the '=' is found, or negative if none */
- int slash_pos = -1; /* Where the '/' is found, or negative if none */
- int table_index = 0;
- bool starts_with_In_or_Is = FALSE;
- Size_t lookup_offset = 0;
+ /* For backcompat, allow an empty first line */
+ if (*s0 == '\n') {
+ s0++;
+ continue;
+ }
+
+ /* First character in the line may optionally be the operation */
+ if ( *s0 == '+'
+ || *s0 == '!'
+ || *s0 == '-'
+ || *s0 == '&')
+ {
+ op = *s0++;
+ }
+
+ /* If the line is one or two hex digits separated by blank space, its
+ * a range; otherwise it is either another user-defined property or an
+ * error */
+
+ s = s0;
+
+ if (! isXDIGIT(*s)) {
+ goto check_if_property;
+ }
+
+ do { /* Each new hex digit will add 4 bits. */
+ if (min > ( (IV) MAX_LEGAL_CP >> 4)) {
+ s = strchr(s, '\n');
+ if (s == NULL) {
+ s = e;
+ }
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpv(msg, overflow_msg);
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
+ UTF8fARG(is_contents_utf8, s - s0, s0));
+ sv_catpvs(msg, "\"");
+ goto return_msg;
+ }
+
+ /* Accumulate this digit into the value */
+ min = (min << 4) + READ_XDIGIT(s);
+ } while (isXDIGIT(*s));
+
+ while (isBLANK(*s)) { s++; }
+
+ /* We allow comments at the end of the line */
+ if (*s == '#') {
+ s = strchr(s, '\n');
+ if (s == NULL) {
+ s = e;
+ }
+ s++;
+ }
+ else if (s < e && *s != '\n') {
+ if (! isXDIGIT(*s)) {
+ goto check_if_property;
+ }
+
+ /* Look for the high point of the range */
+ max = 0;
+ do {
+ if (max > ( (IV) MAX_LEGAL_CP >> 4)) {
+ s = strchr(s, '\n');
+ if (s == NULL) {
+ s = e;
+ }
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpv(msg, overflow_msg);
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
+ UTF8fARG(is_contents_utf8, s - s0, s0));
+ sv_catpvs(msg, "\"");
+ goto return_msg;
+ }
+
+ max = (max << 4) + READ_XDIGIT(s);
+ } while (isXDIGIT(*s));
+
+ while (isBLANK(*s)) { s++; }
+
+ if (*s == '#') {
+ s = strchr(s, '\n');
+ if (s == NULL) {
+ s = e;
+ }
+ }
+ else if (s < e && *s != '\n') {
+ goto check_if_property;
+ }
+ }
+
+ if (max == -1) { /* The line only had one entry */
+ max = min;
+ }
+ else if (max < min) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Illegal range in \"");
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
+ UTF8fARG(is_contents_utf8, s - s0, s0));
+ sv_catpvs(msg, "\"");
+ goto return_msg;
+ }
+
+#if 0 /* See explanation at definition above of get_extended_utf8_msg() */
+
+ if ( UNICODE_IS_PERL_EXTENDED(min)
+ || UNICODE_IS_PERL_EXTENDED(max))
+ {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+
+ /* If both code points are non-portable, warn only on the lower
+ * one. */
+ sv_catpv(msg, get_extended_utf8_msg(
+ (UNICODE_IS_PERL_EXTENDED(min))
+ ? min : max));
+ sv_catpvs(msg, " in \"");
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
+ UTF8fARG(is_contents_utf8, s - s0, s0));
+ sv_catpvs(msg, "\"");
+ }
+
+#endif
+
+ /* Here, this line contains a legal range */
+ this_definition = sv_2mortal(_new_invlist(2));
+ this_definition = _add_range_to_invlist(this_definition, min, max);
+ goto calculate;
+
+ check_if_property:
+
+ /* Here it isn't a legal range line. See if it is a legal property
+ * line. First find the end of the meat of the line */
+ s = strpbrk(s, "#\n");
+ if (s == NULL) {
+ s = e;
+ }
+
+ /* Ignore trailing blanks in keeping with the requirements of
+ * parse_uniprop_string() */
+ s--;
+ while (s > s0 && isBLANK_A(*s)) {
+ s--;
+ }
+ s++;
+
+ this_definition = parse_uniprop_string(s0, s - s0,
+ is_utf8, to_fold, runtime,
+ user_defined_ptr, msg,
+ (name_len == 0)
+ ? level /* Don't increase level
+ if input is empty */
+ : level + 1
+ );
+ if (this_definition == NULL) {
+ goto return_msg; /* 'msg' should have had the reason appended to
+ it by the above call */
+ }
+
+ if (! is_invlist(this_definition)) { /* Unknown at this time */
+ return newSVsv(this_definition);
+ }
+
+ if (*s != '\n') {
+ s = strchr(s, '\n');
+ if (s == NULL) {
+ s = e;
+ }
+ }
+
+ calculate:
+
+ switch (op) {
+ case '+':
+ _invlist_union(running_definition, this_definition,
+ &running_definition);
+ break;
+ case '-':
+ _invlist_subtract(running_definition, this_definition,
+ &running_definition);
+ break;
+ case '&':
+ _invlist_intersection(running_definition, this_definition,
+ &running_definition);
+ break;
+ case '!':
+ _invlist_union_complement_2nd(running_definition,
+ this_definition, &running_definition);
+ break;
+ default:
+ Perl_croak(aTHX_ "panic: %s: %d: Unexpected operation %d",
+ __FILE__, __LINE__, op);
+ break;
+ }
+
+ /* Position past the '\n' */
+ s0 = s + 1;
+ } /* End of loop through the lines of 'contents' */
+
+ /* Here, we processed all the lines in 'contents' without error. If we
+ * didn't add any warnings, simply return success */
+ if (msgs_length_on_entry == SvCUR(msg)) {
+
+ /* If the expansion was empty, the answer isn't nothing: its an empty
+ * inversion list */
+ if (running_definition == NULL) {
+ running_definition = _new_invlist(1);
+ }
+
+ return running_definition;
+ }
+
+ /* Otherwise, add some explanatory text, but we will return success */
+
+ return_msg:
+
+ if (name_len > 0) {
+ sv_catpvs(msg, " in expansion of ");
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
+ }
+
+ return running_definition;
+}
+
+/* As explained below, certain operations need to take place in the first
+ * thread created. These macros switch contexts */
+#ifdef USE_ITHREADS
+# define DECLARATION_FOR_GLOBAL_CONTEXT \
+ PerlInterpreter * save_aTHX = aTHX;
+# define SWITCH_TO_GLOBAL_CONTEXT \
+ PERL_SET_CONTEXT((aTHX = PL_user_def_props_aTHX))
+# define RESTORE_CONTEXT PERL_SET_CONTEXT((aTHX = save_aTHX));
+# define CUR_CONTEXT aTHX
+# define ORIGINAL_CONTEXT save_aTHX
+#else
+# define DECLARATION_FOR_GLOBAL_CONTEXT
+# define SWITCH_TO_GLOBAL_CONTEXT NOOP
+# define RESTORE_CONTEXT NOOP
+# define CUR_CONTEXT NULL
+# define ORIGINAL_CONTEXT NULL
+#endif
+
+STATIC void
+S_delete_recursion_entry(pTHX_ void *key)
+{
+ /* Deletes the entry used to detect recursion when expanding user-defined
+ * properties. This is a function so it can be set up to be called even if
+ * the program unexpectedly quits */
+
+ SV ** current_entry;
+ const STRLEN key_len = strlen((const char *) key);
+ DECLARATION_FOR_GLOBAL_CONTEXT;
+
+ SWITCH_TO_GLOBAL_CONTEXT;
+
+ /* If the entry is one of these types, it is a permanent entry, and not the
+ * one used to detect recursions. This function should delete only the
+ * recursion entry */
+ current_entry = hv_fetch(PL_user_def_props, (const char *) key, key_len, 0);
+ if ( current_entry
+ && ! is_invlist(*current_entry)
+ && ! SvPOK(*current_entry))
+ {
+ (void) hv_delete(PL_user_def_props, (const char *) key, key_len,
+ G_DISCARD);
+ }
+
+ RESTORE_CONTEXT;
+}
+
+SV *
+Perl_parse_uniprop_string(pTHX_
+
+ /* Parse the interior of a \p{}, \P{}. Returns its definition if knowable
+ * now. If so, the return is an inversion list.
+ *
+ * If the property is user-defined, it is a subroutine, which in turn
+ * may call other subroutines. This function will call the whole nest of
+ * them to get the definition they return; if some aren't known at the time
+ * of the call to this function, the fully qualified name of the highest
+ * level sub is returned. It is an error to call this function at runtime
+ * without every sub defined.
+ *
+ * If an error was found, NULL is returned, and 'msg' gets a suitable
+ * message appended to it. (Appending allows the back trace of how we got
+ * to the faulty definition to be displayed through nested calls of
+ * user-defined subs.)
+ *
+ * The caller should NOT try to free any returned inversion list.
+ *
+ * Other parameters will be set on return as described below */
+
+ const char * const name, /* The first non-blank in the \p{}, \P{} */
+ const Size_t name_len, /* Its length in bytes, not including any
+ trailing space */
+ const bool is_utf8, /* ? Is 'name' encoded in UTF-8 */
+ const bool to_fold, /* ? Is this under /i */
+ const bool runtime, /* TRUE if this is being called at run time */
+ bool *user_defined_ptr, /* Upon return from this function it will be
+ set to TRUE if any component is a
+ user-defined property */
+ SV * msg, /* Any error or warning msg(s) are appended to
+ this */
+ const STRLEN level) /* Recursion level of this call */
+{
+ char* lookup_name; /* normalized name for lookup in our tables */
+ unsigned lookup_len; /* Its length */
+ bool stricter = FALSE; /* Some properties have stricter name
+ normalization rules, which we decide upon
+ based on parsing */
+
+ /* nv= or numeric_value=, or possibly one of the cjk numeric properties
+ * (though it requires extra effort to download them from Unicode and
+ * compile perl to know about them) */
+ bool is_nv_type = FALSE;
+
+ unsigned int i, j = 0;
+ int equals_pos = -1; /* Where the '=' is found, or negative if none */
+ int slash_pos = -1; /* Where the '/' is found, or negative if none */
+ int table_index = 0; /* The entry number for this property in the table
+ of all Unicode property names */
+ bool starts_with_In_or_Is = FALSE; /* ? Does the name start with 'In' or
+ 'Is' */
+ Size_t lookup_offset = 0; /* Used to ignore the first few characters of
+ the normalized name in certain situations */
+ Size_t non_pkg_begin = 0; /* Offset of first byte in 'name' that isn't
+ part of a package name */
+ bool could_be_user_defined = TRUE; /* ? Could this be a user-defined
+ property rather than a Unicode
+ one. */
+ SV * prop_definition = NULL; /* The returned definition of 'name' or NULL
+ if an error. If it is an inversion list,
+ it is the definition. Otherwise it is a
+ string containing the fully qualified sub
+ name of 'name' */
+ bool invert_return = FALSE; /* ? Do we need to complement the result before
+ returning it */
PERL_ARGS_ASSERT_PARSE_UNIPROP_STRING;
- /* The input will be modified into 'lookup_name' */
+ /* The input will be normalized into 'lookup_name' */
Newx(lookup_name, name_len, char);
SAVEFREEPV(lookup_name);
for (i = 0; i < name_len; i++) {
char cur = name[i];
- /* These characters can be freely ignored in most situations. Later it
- * may turn out we shouldn't have ignored them, and we have to reparse,
- * but we don't have enough information yet to make that decision */
- if (cur == '-' || cur == '_' || isSPACE_A(cur)) {
+ /* Most of the characters in the input will be of this ilk, being parts
+ * of a name */
+ if (isIDCONT_A(cur)) {
+
+ /* Case differences are ignored. Our lookup routine assumes
+ * everything is lowercase, so normalize to that */
+ if (isUPPER_A(cur)) {
+ lookup_name[j++] = toLOWER_A(cur);
+ continue;
+ }
+
+ if (cur == '_') { /* Don't include these in the normalized name */
+ continue;
+ }
+
+ lookup_name[j++] = cur;
+
+ /* The first character in a user-defined name must be of this type.
+ * */
+ if (i - non_pkg_begin == 0 && ! isIDFIRST_A(cur)) {
+ could_be_user_defined = FALSE;
+ }
+
continue;
}
- /* Case differences are also ignored. Our lookup routine assumes
- * everything is lowercase */
- if (isUPPER_A(cur)) {
- lookup_name[j++] = toLOWER(cur);
+ /* Here, the character is not something typically in a name, But these
+ * two types of characters (and the '_' above) can be freely ignored in
+ * most situations. Later it may turn out we shouldn't have ignored
+ * them, and we have to reparse, but we don't have enough information
+ * yet to make that decision */
+ if (cur == '-' || isSPACE_A(cur)) {
+ could_be_user_defined = FALSE;
continue;
}
- /* A double colon is either an error, or a package qualifier to a
- * subroutine user-defined property; neither of which do we currently
- * handle
- *
- * But a single colon is a synonym for '=' */
- if (cur == ':') {
- if (i < name_len - 1 && name[i+1] == ':') {
- return NULL;
- }
- cur = '=';
+ /* An equals sign or single colon mark the end of the first part of
+ * the property name */
+ if ( cur == '='
+ || (cur == ':' && (i >= name_len - 1 || name[i+1] != ':')))
+ {
+ lookup_name[j++] = '='; /* Treat the colon as an '=' */
+ equals_pos = j; /* Note where it occurred in the input */
+ could_be_user_defined = FALSE;
+ break;
}
/* Otherwise, this character is part of the name. */
lookup_name[j++] = cur;
- /* Only the equals sign needs further processing */
- if (cur == '=') {
- equals_pos = j; /* Note where it occurred in the input */
- break;
+ /* Here it isn't a single colon, so if it is a colon, it must be a
+ * double colon */
+ if (cur == ':') {
+
+ /* A double colon should be a package qualifier. We note its
+ * position and continue. Note that one could have
+ * pkg1::pkg2::...::foo
+ * so that the position at the end of the loop will be just after
+ * the final qualifier */
+
+ i++;
+ non_pkg_begin = i + 1;
+ lookup_name[j++] = ':';
+ }
+ else { /* Only word chars (and '::') can be in a user-defined name */
+ could_be_user_defined = FALSE;
}
+ } /* End of parsing through the lhs of the property name (or all of it if
+ no rhs) */
+
+#define STRLENs(s) (sizeof("" s "") - 1)
+
+ /* If there is a single package name 'utf8::', it is ambiguous. It could
+ * be for a user-defined property, or it could be a Unicode property, as
+ * all of them are considered to be for that package. For the purposes of
+ * parsing the rest of the property, strip it off */
+ if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
+ lookup_name += STRLENs("utf8::");
+ j -= STRLENs("utf8::");
+ equals_pos -= STRLENs("utf8::");
}
/* Here, we are either done with the whole property name, if it was simple;
}
}
- /* Certain properties need special handling. They may optionally be
- * prefixed by 'is'. Ignore that prefix for the purposes of checking
- * if this is one of those properties */
+ /* Certain properties whose values are numeric need special handling.
+ * They may optionally be prefixed by 'is'. Ignore that prefix for the
+ * purposes of checking if this is one of those properties */
if (memBEGINPs(lookup_name, name_len, "is")) {
lookup_offset = 2;
}
- /* Then check if it is one of these properties. This is hard-coded
- * because easier this way, and the list is unlikely to change. There
- * are several properties like this in the Unihan DB, which is unlikely
- * to be compiled, and they all end with 'numeric'. The interiors
+ /* Then check if it is one of these specially-handled properties. The
+ * possibilities are hard-coded because easier this way, and the list
+ * is unlikely to change.
+ *
+ * All numeric value type properties are of this ilk, and are also
+ * special in a different way later on. So find those first. There
+ * are several numeric value type properties in the Unihan DB (which is
+ * unlikely to be compiled with perl, but we handle it here in case it
+ * does get compiled). They all end with 'numeric'. The interiors
* aren't checked for the precise property. This would stop working if
* a cjk property were to be created that ended with 'numeric' and
* wasn't a numeric type */
{
unsigned int k;
- /* What makes these properties special is that the stuff after the
- * '=' is a number. Therefore, we can't throw away '-'
- * willy-nilly, as those could be a minus sign. Other stricter
+ /* Since the stuff after the '=' is a number, we can't throw away
+ * '-' willy-nilly, as those could be a minus sign. Other stricter
* rules also apply. However, these properties all can have the
* rhs not be a number, in which case they contain at least one
* alphabetic. In those cases, the stricter rules don't apply.
* But the numeric type properties can have the alphas [Ee] to
* signify an exponent, and it is still a number with stricter
- * rules. So look for an alpha that signifys not-strict */
+ * rules. So look for an alpha that signifies not-strict */
stricter = TRUE;
for (k = i; k < name_len; k++) {
if ( isALPHA_A(name[k])
* zeros, or between the final leading zero and the first other
* digit */
for (; i < name_len - 1; i++) {
- if ( name[i] != '0'
+ if ( name[i] != '0'
&& (name[i] != '_' || ! isDIGIT_A(name[i+1])))
{
break;
}
else { /* No '=' */
- /* We are now in a position to determine if this property should have
- * been parsed using stricter rules. Only a few are like that, and
- * unlikely to change. */
+ /* Only a few properties without an '=' should be parsed with stricter
+ * rules. The list is unlikely to change. */
if ( memBEGINPs(lookup_name, j, "perl")
&& memNEs(lookup_name + 4, j - 4, "space")
&& memNEs(lookup_name + 4, j - 4, "word"))
{
lookup_name[j++] = '&';
}
- else if (name_len > 2 && name[0] == 'I' && ( name[1] == 'n'
- || name[1] == 's'))
- {
-
- /* Also, if the original input began with 'In' or 'Is', it could be a
- * subroutine call instead of a property names, which currently isn't
- * handled by this function. Subroutine calls can't happen if there is
- * an '=' in the name */
- if (equals_pos < 0 && get_cvn_flags(name, name_len, GV_NOTQUAL) != NULL)
- {
- return NULL;
- }
+ /* If the original input began with 'In' or 'Is', it could be a subroutine
+ * call to a user-defined property instead of a Unicode property name. */
+ if ( non_pkg_begin + name_len > 2
+ && name[non_pkg_begin+0] == 'I'
+ && (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
+ {
starts_with_In_or_Is = TRUE;
}
+ else {
+ could_be_user_defined = FALSE;
+ }
+
+ if (could_be_user_defined) {
+ CV* user_sub;
+
+ /* Here, the name could be for a user defined property, which are
+ * implemented as subs. */
+ user_sub = get_cvn_flags(name, name_len, 0);
+ if (user_sub) {
+
+ /* Here, there is a sub by the correct name. Normally we call it
+ * to get the property definition */
+ dSP;
+ SV * user_sub_sv = MUTABLE_SV(user_sub);
+ SV * error; /* Any error returned by calling 'user_sub' */
+ SV * fq_name; /* Fully qualified property name */
+ SV * placeholder;
+ char to_fold_string[] = "0:"; /* The 0 gets overwritten with the
+ actual value */
+ SV ** saved_user_prop_ptr; /* Hash entry for this property */
+
+ /* How many times to retry when another thread is in the middle of
+ * expanding the same definition we want */
+ PERL_INT_FAST8_T retry_countdown = 10;
+
+ DECLARATION_FOR_GLOBAL_CONTEXT;
+
+ /* If we get here, we know this property is user-defined */
+ *user_defined_ptr = TRUE;
+
+ /* We refuse to call a tainted subroutine; returning an error
+ * instead */
+ if (TAINT_get) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Insecure user-defined property");
+ goto append_name_to_msg;
+ }
+
+ /* In principal, we only call each subroutine property definition
+ * once during the life of the program. This guarantees that the
+ * property definition never changes. The results of the single
+ * sub call are stored in a hash, which is used instead for future
+ * references to this property. The property definition is thus
+ * immutable. But, to allow the user to have a /i-dependent
+ * definition, we call the sub once for non-/i, and once for /i,
+ * should the need arise, passing the /i status as a parameter.
+ *
+ * We start by constructing the hash key name, consisting of the
+ * fully qualified subroutine name */
+ fq_name = sv_2mortal(newSV(10)); /* 10 is just a guess */
+ (void) cv_name(user_sub, fq_name, 0);
+
+ /* But precede the sub name in the key with the /i status, so that
+ * there is a key for /i and a different key for non-/i */
+ to_fold_string[0] = to_fold + '0';
+ sv_insert(fq_name, 0, 0, to_fold_string, 2);
+
+ /* We only call the sub once throughout the life of the program
+ * (with the /i, non-/i exception noted above). That means the
+ * hash must be global and accessible to all threads. It is
+ * created at program start-up, before any threads are created, so
+ * is accessible to all children. But this creates some
+ * complications.
+ *
+ * 1) The keys can't be shared, or else problems arise; sharing is
+ * turned off at hash creation time
+ * 2) All SVs in it are there for the remainder of the life of the
+ * program, and must be created in the same interpreter context
+ * as the hash, or else they will be freed from the wrong pool
+ * at global destruction time. This is handled by switching to
+ * the hash's context to create each SV going into it, and then
+ * immediately switching back
+ * 3) All accesses to the hash must be controlled by a mutex, to
+ * prevent two threads from getting an unstable state should
+ * they simultaneously be accessing it. The code below is
+ * crafted so that the mutex is locked whenever there is an
+ * access and unlocked only when the next stable state is
+ * achieved.
+ *
+ * The hash stores either the definition of the property if it was
+ * valid, or, if invalid, the error message that was raised. We
+ * use the type of SV to distinguish.
+ *
+ * There's also the need to guard against the definition expansion
+ * from infinitely recursing. This is handled by storing the aTHX
+ * of the expanding thread during the expansion. Again the SV type
+ * is used to distinguish this from the other two cases. If we
+ * come to here and the hash entry for this property is our aTHX,
+ * it means we have recursed, and the code assumes that we would
+ * infinitely recurse, so instead stops and raises an error.
+ * (Any recursion has always been treated as infinite recursion in
+ * this feature.)
+ *
+ * If instead, the entry is for a different aTHX, it means that
+ * that thread has gotten here first, and hasn't finished expanding
+ * the definition yet. We just have to wait until it is done. We
+ * sleep and retry a few times, returning an error if the other
+ * thread doesn't complete. */
+
+ re_fetch:
+ USER_PROP_MUTEX_LOCK;
+
+ /* If we have an entry for this key, the subroutine has already
+ * been called once with this /i status. */
+ saved_user_prop_ptr = hv_fetch(PL_user_def_props,
+ SvPVX(fq_name), SvCUR(fq_name), 0);
+ if (saved_user_prop_ptr) {
+
+ /* If the saved result is an inversion list, it is the valid
+ * definition of this property */
+ if (is_invlist(*saved_user_prop_ptr)) {
+ prop_definition = *saved_user_prop_ptr;
+
+ /* The SV in the hash won't be removed until global
+ * destruction, so it is stable and we can unlock */
+ USER_PROP_MUTEX_UNLOCK;
+
+ /* The caller shouldn't try to free this SV */
+ return prop_definition;
+ }
+
+ /* Otherwise, if it is a string, it is the error message
+ * that was returned when we first tried to evaluate this
+ * property. Fail, and append the message */
+ if (SvPOK(*saved_user_prop_ptr)) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catsv(msg, *saved_user_prop_ptr);
+
+ /* The SV in the hash won't be removed until global
+ * destruction, so it is stable and we can unlock */
+ USER_PROP_MUTEX_UNLOCK;
+
+ return NULL;
+ }
+
+ assert(SvIOK(*saved_user_prop_ptr));
+
+ /* Here, we have an unstable entry in the hash. Either another
+ * thread is in the middle of expanding the property's
+ * definition, or we are ourselves recursing. We use the aTHX
+ * in it to distinguish */
+ if (SvIV(*saved_user_prop_ptr) != PTR2IV(CUR_CONTEXT)) {
- lookup_len = j; /* Use a more mnemonic name starting here */
+ /* Here, it's another thread doing the expanding. We've
+ * looked as much as we are going to at the contents of the
+ * hash entry. It's safe to unlock. */
+ USER_PROP_MUTEX_UNLOCK;
+
+ /* Retry a few times */
+ if (retry_countdown-- > 0) {
+ PerlProc_sleep(1);
+ goto re_fetch;
+ }
+
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Timeout waiting for another thread to "
+ "define");
+ goto append_name_to_msg;
+ }
+
+ /* Here, we are recursing; don't dig any deeper */
+ USER_PROP_MUTEX_UNLOCK;
+
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg,
+ "Infinite recursion in user-defined property");
+ goto append_name_to_msg;
+ }
+
+ /* Here, this thread has exclusive control, and there is no entry
+ * for this property in the hash. So we have the go ahead to
+ * expand the definition ourselves. */
+
+ ENTER;
+
+ /* Create a temporary placeholder in the hash to detect recursion
+ * */
+ SWITCH_TO_GLOBAL_CONTEXT;
+ placeholder= newSVuv(PTR2IV(ORIGINAL_CONTEXT));
+ (void) hv_store_ent(PL_user_def_props, fq_name, placeholder, 0);
+ RESTORE_CONTEXT;
+
+ /* Now that we have a placeholder, we can let other threads
+ * continue */
+ USER_PROP_MUTEX_UNLOCK;
+
+ /* Make sure the placeholder always gets destroyed */
+ SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(fq_name));
+
+ PUSHMARK(SP);
+ SAVETMPS;
+
+ /* Call the user's function, with the /i status as a parameter.
+ * Note that we have gone to a lot of trouble to keep this call
+ * from being within the locked mutex region. */
+ XPUSHs(boolSV(to_fold));
+ PUTBACK;
+
+ (void) call_sv(user_sub_sv, G_EVAL|G_SCALAR);
+
+ SPAGAIN;
+
+ error = ERRSV;
+ if (SvTRUE(error)) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Error \"");
+ sv_catsv(msg, error);
+ sv_catpvs(msg, "\"");
+ if (name_len > 0) {
+ sv_catpvs(msg, " in expansion of ");
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8,
+ name_len,
+ name));
+ }
+
+ (void) POPs;
+ prop_definition = NULL;
+ }
+ else { /* G_SCALAR guarantees a single return value */
+
+ /* The contents is supposed to be the expansion of the property
+ * definition. Call a function to check for valid syntax and
+ * handle it */
+ prop_definition = handle_user_defined_property(name, name_len,
+ is_utf8, to_fold, runtime,
+ POPs, user_defined_ptr,
+ msg,
+ level);
+ }
+
+ /* Here, we have the results of the expansion. Replace the
+ * placeholder with them. We need exclusive access to the hash,
+ * and we can't let anyone else in, between when we delete the
+ * placeholder and add the permanent entry */
+ USER_PROP_MUTEX_LOCK;
+
+ S_delete_recursion_entry(aTHX_ SvPVX(fq_name));
+
+ if (! prop_definition || is_invlist(prop_definition)) {
+
+ /* If we got success we use the inversion list defining the
+ * property; otherwise use the error message */
+ SWITCH_TO_GLOBAL_CONTEXT;
+ (void) hv_store_ent(PL_user_def_props,
+ fq_name,
+ ((prop_definition)
+ ? newSVsv(prop_definition)
+ : newSVsv(msg)),
+ 0);
+ RESTORE_CONTEXT;
+ }
+
+ /* All done, and the hash now has a permanent entry for this
+ * property. Give up exclusive control */
+ USER_PROP_MUTEX_UNLOCK;
+
+ FREETMPS;
+ LEAVE;
+
+ if (prop_definition) {
+
+ /* If the definition is for something not known at this time,
+ * we toss it, and go return the main property name, as that's
+ * the one the user will be aware of */
+ if (! is_invlist(prop_definition)) {
+ SvREFCNT_dec_NN(prop_definition);
+ goto definition_deferred;
+ }
+
+ sv_2mortal(prop_definition);
+ }
+
+ /* And return */
+ return prop_definition;
+
+ } /* End of calling the subroutine for the user-defined property */
+ } /* End of it could be a user-defined property */
+
+ /* Here it wasn't a user-defined property that is known at this time. See
+ * if it is a Unicode property */
+
+ lookup_len = j; /* This is a more mnemonic name than 'j' */
/* Get the index into our pointer table of the inversion list corresponding
* to the property */
table_index = match_uniprop((U8 *) lookup_name, lookup_len);
- /* If it didn't find the property */
+ /* If it didn't find the property ... */
if (table_index == 0) {
- /* If didn't find the property, we try again stripping off any initial
- * 'In' or 'Is' */
+ /* Try again stripping off any initial 'In' or 'Is' */
if (starts_with_In_or_Is) {
lookup_name += 2;
lookup_len -= 2;
if (table_index == 0) {
char * canonical;
- /* If not found, and not a numeric type property, isn't a legal
- * property */
+ /* Here, we didn't find it. If not a numeric type property, and
+ * can't be a user-defined one, it isn't a legal property */
if (! is_nv_type) {
- return NULL;
- }
+ if (! could_be_user_defined) {
+ goto failed;
+ }
+
+ /* Here, the property name is legal as a user-defined one. At
+ * compile time, it might just be that the subroutine for that
+ * property hasn't been encountered yet, but at runtime, it's
+ * an error to try to use an undefined one */
+ if (runtime) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Unknown user-defined property name");
+ goto append_name_to_msg;
+ }
+
+ goto definition_deferred;
+ } /* End of isn't a numeric type property */
- /* But the numeric type properties need more work to decide. What
- * we do is make sure we have the number in canonical form and look
+ /* The numeric type properties need more work to decide. What we
+ * do is make sure we have the number in canonical form and look
* that up. */
if (slash_pos < 0) { /* No slash */
lookup_len - equals_pos)
!= lookup_name + lookup_len)
{
- return NULL;
+ goto failed;
}
- /* If the value is an integer, the canonical value is integral */
+ /* If the value is an integer, the canonical value is integral
+ * */
if (Perl_ceil(value) == value) {
canonical = Perl_form(aTHX_ "%.*s%.0" NVff,
- equals_pos, lookup_name, value);
+ equals_pos, lookup_name, value);
}
else { /* Otherwise, it is %e with a known precision */
char * exp_ptr;
/* Convert the numerator to numeric */
end_ptr = this_lookup_name + slash_pos;
if (! grok_atoUV(this_lookup_name, &numerator, &end_ptr)) {
- return NULL;
+ goto failed;
}
/* It better have included all characters before the slash */
if (*end_ptr != '/') {
- return NULL;
+ goto failed;
}
/* Set to look at just the denominator */
/* Convert the denominator to numeric */
if (! grok_atoUV(this_lookup_name, &denominator, &end_ptr)) {
- return NULL;
+ goto failed;
}
/* It better be the rest of the characters, and don't divide by
if ( end_ptr != this_lookup_name + lookup_len
|| denominator == 0)
{
- return NULL;
+ goto failed;
}
/* Get the greatest common denominator using
/* If already in lowest possible terms, we have already tried
* looking this up */
if (gcd == 1) {
- return NULL;
+ goto failed;
}
- /* Reduce the rational, which should put it in canonical form.
- * Then look it up */
+ /* Reduce the rational, which should put it in canonical form
+ * */
numerator /= gcd;
denominator /= gcd;
/* Here, we have the number in canonical form. Try that */
table_index = match_uniprop((U8 *) canonical, strlen(canonical));
if (table_index == 0) {
- return NULL;
+ goto failed;
}
- }
- }
+ } /* End of still didn't find the property in our table */
+ } /* End of didn't find the property in our table */
- /* The return is an index into a table of ptrs. A negative return
- * signifies that the real index is the absolute value, but the result
- * needs to be inverted */
+ /* Here, we have a non-zero return, which is an index into a table of ptrs.
+ * A negative return signifies that the real index is the absolute value,
+ * but the result needs to be inverted */
if (table_index < 0) {
- *invert = TRUE;
+ invert_return = TRUE;
table_index = -table_index;
}
- else {
- *invert = FALSE;
- }
/* Out-of band indices indicate a deprecated property. The proper index is
* modulo it with the table size. And dividing by the table size yields
- * an offset into a table constructed to contain the corresponding warning
- * message */
+ * an offset into a table constructed by regen/mk_invlists.pl to contain
+ * the corresponding warning message */
if (table_index > MAX_UNI_KEYWORD_INDEX) {
Size_t warning_offset = table_index / MAX_UNI_KEYWORD_INDEX;
table_index %= MAX_UNI_KEYWORD_INDEX;
}
/* Create and return the inversion list */
- return _new_invlist_C_array(uni_prop_ptrs[table_index]);
+ prop_definition =_new_invlist_C_array(uni_prop_ptrs[table_index]);
+ if (invert_return) {
+ _invlist_invert(prop_definition);
+ }
+ sv_2mortal(prop_definition);
+ return prop_definition;
+
+
+ failed:
+ if (non_pkg_begin != 0) {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Illegal user-defined property name");
+ }
+ else {
+ if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
+ sv_catpvs(msg, "Can't find Unicode property definition");
+ }
+ /* FALLTHROUGH */
+
+ append_name_to_msg:
+ {
+ const char * prefix = (runtime && level == 0) ? " \\p{" : " \"";
+ const char * suffix = (runtime && level == 0) ? "}" : "\"";
+
+ sv_catpv(msg, prefix);
+ Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
+ sv_catpv(msg, suffix);
+ }
+
+ return NULL;
+
+ definition_deferred:
+
+ /* Here it could yet to be defined, so defer evaluation of this
+ * until its needed at runtime. */
+ prop_definition = newSVpvs_flags("", SVs_TEMP);
+
+ /* To avoid any ambiguity, the package is always specified.
+ * Use the current one if it wasn't included in our input */
+ if (non_pkg_begin == 0) {
+ const HV * pkg = (IN_PERL_COMPILETIME)
+ ? PL_curstash
+ : CopSTASH(PL_curcop);
+ const char* pkgname = HvNAME(pkg);
+
+ Perl_sv_catpvf(aTHX_ prop_definition, "%" UTF8f,
+ UTF8fARG(is_utf8, strlen(pkgname), pkgname));
+ sv_catpvs(prop_definition, "::");
+ }
+
+ Perl_sv_catpvf(aTHX_ prop_definition, "%" UTF8f,
+ UTF8fARG(is_utf8, name_len, name));
+ sv_catpvs(prop_definition, "\n");
+
+ *user_defined_ptr = TRUE;
+ return prop_definition;
}
#endif
https://perl5.git.perl.org / perl5.git / blobdiff