I32 recurse_count; /* Number of recurse regops */
I32 in_lookbehind;
I32 contains_locale;
+ I32 override_recoding;
#if ADD_TO_REGEXEC
char *starttry; /* -Dr: where regtry was called. */
#define RExC_starttry (pRExC_state->starttry)
#define RExC_recurse_count (pRExC_state->recurse_count)
#define RExC_in_lookbehind (pRExC_state->in_lookbehind)
#define RExC_contains_locale (pRExC_state->contains_locale)
+#define RExC_override_recoding (pRExC_state->override_recoding)
#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
/* Can match anything (initialization) */
STATIC void
-S_cl_anything(struct regnode_charclass_class *cl)
+S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
{
PERL_ARGS_ASSERT_CL_ANYTHING;
ANYOF_BITMAP_SETALL(cl);
- ANYOF_CLASS_ZERO(cl); /* all bits set, so class is irrelevant */
- cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL|ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL|ANYOF_LOCALE;
- /* The above line set locale which given the current logic may not get
- * cleared even if no locale is in the regex, which may lead to false
- * positives; see the commit message */
+ cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
+ |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
+
+ /* If any portion of the regex is to operate under locale rules,
+ * initialization includes it. The reason this isn't done for all regexes
+ * is that the optimizer was written under the assumption that locale was
+ * all-or-nothing. Given the complexity and lack of documentation in the
+ * optimizer, and that there are inadequate test cases for locale, so many
+ * parts of it may not work properly, it is safest to avoid locale unless
+ * necessary. */
+ if (RExC_contains_locale) {
+ ANYOF_CLASS_SETALL(cl); /* /l uses class */
+ cl->flags |= ANYOF_LOCALE;
+ }
+ else {
+ ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */
+ }
}
/* Can match anything (initialization) */
Zero(cl, 1, struct regnode_charclass_class);
cl->type = ANYOF;
- cl_anything(cl);
+ cl_anything(pRExC_state, cl);
ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
}
/* These two functions currently do the exact same thing */
#define cl_init_zero S_cl_init
-/* 'And' a given class with another one. Can create false positives */
-/* cl should not be inverted */
+/* 'AND' a given class with another one. Can create false positives. 'cl'
+ * should not be inverted. 'and_with->flags & ANYOF_CLASS' should be 0 if
+ * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
STATIC void
S_cl_and(struct regnode_charclass_class *cl,
const struct regnode_charclass_class *and_with)
}
}
else { /* and'd node is not inverted */
+ U8 outside_bitmap_but_not_utf8; /* Temp variable */
+
if (! ANYOF_NONBITMAP(and_with)) {
/* Here 'and_with' doesn't match anything outside the bitmap
/* Here, 'and_with' does match something outside the bitmap, and cl
* doesn't have a list of things to match outside the bitmap. If
* cl can match all code points above 255, the intersection will
- * be those above-255 code points that 'and_with' matches. There
- * may be false positives from code points in 'and_with' that are
- * outside the bitmap but below 256, but those get sorted out
- * after the synthetic start class succeeds). If cl can't match
- * all Unicode code points, it means here that it can't match *
- * anything outside the bitmap, so we leave the bitmap empty */
+ * be those above-255 code points that 'and_with' matches. If cl
+ * can't match all Unicode code points, it means that it can't
+ * match anything outside the bitmap (since the 'if' that got us
+ * into this block tested for that), so we leave the bitmap empty.
+ */
if (cl->flags & ANYOF_UNICODE_ALL) {
ARG_SET(cl, ARG(and_with));
+
+ /* and_with's ARG may match things that don't require UTF8.
+ * And now cl's will too, in spite of this being an 'and'. See
+ * the comments below about the kludge */
+ cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
}
}
else {
}
- /* Take the intersection of the two sets of flags */
+ /* Take the intersection of the two sets of flags. However, the
+ * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'. This is a
+ * kludge around the fact that this flag is not treated like the others
+ * which are initialized in cl_anything(). The way the optimizer works
+ * is that the synthetic start class (SSC) is initialized to match
+ * anything, and then the first time a real node is encountered, its
+ * values are AND'd with the SSC's with the result being the values of
+ * the real node. However, there are paths through the optimizer where
+ * the AND never gets called, so those initialized bits are set
+ * inappropriately, which is not usually a big deal, as they just cause
+ * false positives in the SSC, which will just mean a probably
+ * imperceptible slow down in execution. However this bit has a
+ * higher false positive consequence in that it can cause utf8.pm,
+ * utf8_heavy.pl ... to be loaded when not necessary, which is a much
+ * bigger slowdown and also causes significant extra memory to be used.
+ * In order to prevent this, the code now takes a different tack. The
+ * bit isn't set unless some part of the regular expression needs it,
+ * but once set it won't get cleared. This means that these extra
+ * modules won't get loaded unless there was some path through the
+ * pattern that would have required them anyway, and so any false
+ * positives that occur by not ANDing them out when they could be
+ * aren't as severe as they would be if we treated this bit like all
+ * the others */
+ outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
+ & ANYOF_NONBITMAP_NON_UTF8;
cl->flags &= and_with->flags;
+ cl->flags |= outside_bitmap_but_not_utf8;
}
}
-/* 'OR' a given class with another one. Can create false positives */
-/* cl should not be inverted */
+/* 'OR' a given class with another one. Can create false positives. 'cl'
+ * should not be inverted. 'or_with->flags & ANYOF_CLASS' should be 0 if
+ * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
STATIC void
-S_cl_or(struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
+S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
{
PERL_ARGS_ASSERT_CL_OR;
* complement of everything not in the bitmap, but currently we don't
* know what that is, so give up and match anything */
if (ANYOF_NONBITMAP(or_with)) {
- cl_anything(cl);
+ cl_anything(pRExC_state, cl);
}
/* We do not use
* (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
cl->bitmap[i] |= ~or_with->bitmap[i];
} /* XXXX: logic is complicated otherwise */
else {
- cl_anything(cl);
+ cl_anything(pRExC_state, cl);
}
/* And, we can just take the union of the flags that aren't affected
}
}
else { /* XXXX: logic is complicated, leave it along for a moment. */
- cl_anything(cl);
+ cl_anything(pRExC_state, cl);
}
- /* Take the union */
- cl->flags |= or_with->flags;
-
if (ANYOF_NONBITMAP(or_with)) {
/* Use the added node's outside-the-bit-map match if there isn't a
* outside the bitmap, but what they match outside is not the same
* pointer, and hence not easily compared until XXX we extend
* inversion lists this far), give up and allow the start class to
- * match everything outside the bitmap */
+ * match everything outside the bitmap. If that stuff is all above
+ * 255, can just set UNICODE_ALL, otherwise caould be anything. */
if (! ANYOF_NONBITMAP(cl)) {
ARG_SET(cl, ARG(or_with));
}
else if (ARG(cl) != ARG(or_with)) {
- cl->flags |= ANYOF_UNICODE_ALL;
+
+ if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
+ cl_anything(pRExC_state, cl);
+ }
+ else {
+ cl->flags |= ANYOF_UNICODE_ALL;
+ }
}
}
+
+ /* Take the union */
+ cl->flags |= or_with->flags;
}
}
}
#ifdef DEBUGGING
- /* Allow dumping */
+ /* Allow dumping but overwriting the collection of skipped
+ * ops and/or strings with fake optimized ops */
n = scan + NODE_SZ_STR(scan);
while (n <= stop) {
- if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
- OP(n) = OPTIMIZED;
- NEXT_OFF(n) = 0;
- }
+ OP(n) = OPTIMIZED;
+ FLAGS(n) = 0;
+ NEXT_OFF(n) = 0;
n++;
}
#endif
data->whilem_c = data_fake.whilem_c;
}
if (flags & SCF_DO_STCLASS)
- cl_or(&accum, &this_class);
+ cl_or(pRExC_state, &accum, &this_class);
}
if (code == IFTHEN && num < 2) /* Empty ELSE branch */
min1 = 0;
min += min1;
delta += max1 - min1;
if (flags & SCF_DO_STCLASS_OR) {
- cl_or(data->start_class, &accum);
+ cl_or(pRExC_state, data->start_class, &accum);
if (min1) {
cl_and(data->start_class, and_withp);
flags &= ~SCF_DO_STCLASS;
}
} else {
/*
- Currently we do not believe that the trie logic can
- handle case insensitive matching properly when the
- pattern is not unicode (thus forcing unicode semantics).
+ Currently the trie logic handles case insensitive matching properly only
+ when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
+ semantics).
If/when this is fixed the following define can be swapped
in below to fully enable trie logic.
- XXX It may work if not UTF and/or /a (AT_LEAST_UNI_SEMANTICS) but perhaps
- not /aa
-
#define TRIE_TYPE_IS_SAFE 1
*/
-#define TRIE_TYPE_IS_SAFE ((UTF && UNI_SEMANTICS) || optype==EXACT)
+#define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
if ( last && TRIE_TYPE_IS_SAFE ) {
make_trie( pRExC_state,
}
is_inf = is_inf_internal = 1;
if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- cl_anything(data->start_class);
+ cl_anything(pRExC_state, data->start_class);
flags &= ~SCF_DO_STCLASS;
}
} else {
data->start_class = oclass;
if (mincount == 0 || minnext == 0) {
if (flags & SCF_DO_STCLASS_OR) {
- cl_or(data->start_class, &this_class);
+ cl_or(pRExC_state, data->start_class, &this_class);
}
else if (flags & SCF_DO_STCLASS_AND) {
/* Switch to OR mode: cache the old value of
}
} else { /* Non-zero len */
if (flags & SCF_DO_STCLASS_OR) {
- cl_or(data->start_class, &this_class);
+ cl_or(pRExC_state, data->start_class, &this_class);
cl_and(data->start_class, and_withp);
}
else if (flags & SCF_DO_STCLASS_AND)
}
is_inf = is_inf_internal = 1;
if (flags & SCF_DO_STCLASS_OR)
- cl_anything(data->start_class);
+ cl_anything(pRExC_state, data->start_class);
flags &= ~SCF_DO_STCLASS;
break;
}
do_default:
/* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- cl_anything(data->start_class);
+ cl_anything(pRExC_state, data->start_class);
break;
case REG_ANY:
if (OP(scan) == SANY)
if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
|| ANYOF_CLASS_TEST_ANY_SET(data->start_class));
- cl_anything(data->start_class);
+ cl_anything(pRExC_state, data->start_class);
}
if (flags & SCF_DO_STCLASS_AND || !value)
ANYOF_BITMAP_CLEAR(data->start_class,'\n');
cl_and(data->start_class,
(struct regnode_charclass_class*)scan);
else
- cl_or(data->start_class,
+ cl_or(pRExC_state, data->start_class,
(struct regnode_charclass_class*)scan);
break;
case ALNUM:
}
is_inf = is_inf_internal = 1;
if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
- cl_anything(data->start_class);
+ cl_anything(pRExC_state, data->start_class);
flags &= ~SCF_DO_STCLASS;
}
else if (OP(scan) == GPOS) {
data->whilem_c = data_fake.whilem_c;
}
if (flags & SCF_DO_STCLASS)
- cl_or(&accum, &this_class);
+ cl_or(pRExC_state, &accum, &this_class);
}
}
if (flags & SCF_DO_SUBSTR) {
min += min1;
delta += max1 - min1;
if (flags & SCF_DO_STCLASS_OR) {
- cl_or(data->start_class, &accum);
+ cl_or(pRExC_state, data->start_class, &accum);
if (min1) {
cl_and(data->start_class, and_withp);
flags &= ~SCF_DO_STCLASS;
struct regexp *r;
register regexp_internal *ri;
STRLEN plen;
- char *exp;
+ VOL char *exp;
char* xend;
regnode *scan;
I32 flags;
DEBUG_r(if (!PL_colorset) reginitcolors());
- RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
+ exp = SvPV(pattern, plen);
+
+ if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
+ RExC_utf8 = RExC_orig_utf8 = 0;
+ }
+ else {
+ RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
+ }
RExC_uni_semantics = 0;
RExC_contains_locale = 0;
}
if (jump_ret == 0) { /* First time through */
- exp = SvPV(pattern, plen);
xend = exp + plen;
- /* ignore the utf8ness if the pattern is 0 length */
- if (plen == 0) {
- RExC_utf8 = RExC_orig_utf8 = 0;
- }
DEBUG_COMPILE_r({
SV *dsv= sv_newmortal();
-- dmq */
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
"UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
- exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
+ exp = (char*)Perl_bytes_to_utf8(aTHX_
+ (U8*)SvPV_nomg(pattern, plen),
+ &len);
xend = exp + len;
RExC_orig_utf8 = RExC_utf8 = 1;
SAVEFREEPV(exp);
RExC_seen_zerolen = *exp == '^' ? -1 : 0;
RExC_seen_evals = 0;
RExC_extralen = 0;
+ RExC_override_recoding = 0;
/* First pass: determine size, legality. */
RExC_parse = exp;
/* This section of code defines the inversion list object and its methods. The
* interfaces are highly subject to change, so as much as possible is static to
- * this file. An inversion list is here implemented as a malloc'd C array with
- * some added info. More will be coming when functionality is added later.
+ * this file. An inversion list is here implemented as a malloc'd C UV array
+ * with some added info that is placed as UVs at the beginning in a header
+ * portion. An inversion list for Unicode is an array of code points, sorted
+ * by ordinal number. The zeroth element is the first code point in the list.
+ * The 1th element is the first element beyond that not in the list. In other
+ * words, the first range is
+ * invlist[0]..(invlist[1]-1)
+ * The other ranges follow. Thus every element that is divisible by two marks
+ * the beginning of a range that is in the list, and every element not
+ * divisible by two marks the beginning of a range not in the list. A single
+ * element inversion list that contains the single code point N generally
+ * consists of two elements
+ * invlist[0] == N
+ * invlist[1] == N+1
+ * (The exception is when N is the highest representable value on the
+ * machine, in which case the list containing just it would be a single
+ * element, itself. By extension, if the last range in the list extends to
+ * infinity, then the first element of that range will be in the inversion list
+ * at a position that is divisible by two, and is the final element in the
+ * list.)
+ * Taking the complement (inverting) an inversion list is quite simple, if the
+ * first element is 0, remove it; otherwise add a 0 element at the beginning.
+ * This implementation reserves an element at the beginning of each inversion list
+ * to contain 0 when the list contains 0, and contains 1 otherwise. The actual
+ * beginning of the list is either that element if 0, or the next one if 1.
+ *
+ * More about inversion lists can be found in "Unicode Demystified"
+ * Chapter 13 by Richard Gillam, published by Addison-Wesley.
+ * More will be coming when functionality is added later.
+ *
+ * The inversion list data structure is currently implemented as an SV pointing
+ * to an array of UVs that the SV thinks are bytes. This allows us to have an
+ * array of UV whose memory management is automatically handled by the existing
+ * facilities for SV's.
*
* Some of the methods should always be private to the implementation, and some
* should eventually be made public */
+#define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
+#define INVLIST_ITER_OFFSET 1 /* Current iteration position */
+
+#define INVLIST_ZERO_OFFSET 2 /* 0 or 1; must be last element in header */
+/* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
+ * contains the code point U+00000, and begins here. If 1, the inversion list
+ * doesn't contain U+0000, and it begins at the next UV in the array.
+ * Inverting an inversion list consists of adding or removing the 0 at the
+ * beginning of it. By reserving a space for that 0, inversion can be made
+ * very fast */
+
+#define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
+
+/* Internally things are UVs */
+#define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
+#define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
+
#define INVLIST_INITIAL_LEN 10
-#define INVLIST_ARRAY_KEY "array"
-#define INVLIST_MAX_KEY "max"
-#define INVLIST_LEN_KEY "len"
PERL_STATIC_INLINE UV*
-S_invlist_array(pTHX_ HV* const invlist)
+S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
{
- /* Returns the pointer to the inversion list's array. Every time the
- * length changes, this needs to be called in case malloc or realloc moved
- * it */
+ /* Returns a pointer to the first element in the inversion list's array.
+ * This is called upon initialization of an inversion list. Where the
+ * array begins depends on whether the list has the code point U+0000
+ * in it or not. The other parameter tells it whether the code that
+ * follows this call is about to put a 0 in the inversion list or not.
+ * The first element is either the element with 0, if 0, or the next one,
+ * if 1 */
- SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
+ UV* zero = get_invlist_zero_addr(invlist);
- PERL_ARGS_ASSERT_INVLIST_ARRAY;
+ PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
- if (list_ptr == NULL) {
- Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
- INVLIST_ARRAY_KEY);
- }
+ /* Must be empty */
+ assert(! *get_invlist_len_addr(invlist));
- return INT2PTR(UV *, SvUV(*list_ptr));
+ /* 1^1 = 0; 1^0 = 1 */
+ *zero = 1 ^ will_have_0;
+ return zero + *zero;
}
-PERL_STATIC_INLINE void
-S_invlist_set_array(pTHX_ HV* const invlist, const UV* const array)
+PERL_STATIC_INLINE UV*
+S_invlist_array(pTHX_ SV* const invlist)
{
- PERL_ARGS_ASSERT_INVLIST_SET_ARRAY;
+ /* Returns the pointer to the inversion list's array. Every time the
+ * length changes, this needs to be called in case malloc or realloc moved
+ * it */
- /* Sets the array stored in the inversion list to the memory beginning with
- * the parameter */
+ PERL_ARGS_ASSERT_INVLIST_ARRAY;
- if (hv_stores(invlist, INVLIST_ARRAY_KEY, newSVuv(PTR2UV(array))) == NULL) {
- Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
- INVLIST_ARRAY_KEY);
- }
+ /* Must not be empty */
+ assert(*get_invlist_len_addr(invlist));
+ assert(*get_invlist_zero_addr(invlist) == 0
+ || *get_invlist_zero_addr(invlist) == 1);
+
+ /* The array begins either at the element reserved for zero if the
+ * list contains 0 (that element will be set to 0), or otherwise the next
+ * element (in which case the reserved element will be set to 1). */
+ return (UV *) (get_invlist_zero_addr(invlist)
+ + *get_invlist_zero_addr(invlist));
}
-PERL_STATIC_INLINE UV
-S_invlist_len(pTHX_ HV* const invlist)
+PERL_STATIC_INLINE UV*
+S_get_invlist_len_addr(pTHX_ SV* invlist)
{
- /* Returns the current number of elements in the inversion list's array */
+ /* Return the address of the UV that contains the current number
+ * of used elements in the inversion list */
- SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE);
+ PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
- PERL_ARGS_ASSERT_INVLIST_LEN;
-
- if (len_ptr == NULL) {
- Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
- INVLIST_LEN_KEY);
- }
-
- return SvUV(*len_ptr);
+ return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
}
PERL_STATIC_INLINE UV
-S_invlist_max(pTHX_ HV* const invlist)
+S_invlist_len(pTHX_ SV* const invlist)
{
- /* Returns the maximum number of elements storable in the inversion list's
- * array, without having to realloc() */
-
- SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE);
-
- PERL_ARGS_ASSERT_INVLIST_MAX;
+ /* Returns the current number of elements in the inversion list's array */
- if (max_ptr == NULL) {
- Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
- INVLIST_MAX_KEY);
- }
+ PERL_ARGS_ASSERT_INVLIST_LEN;
- return SvUV(*max_ptr);
+ return *get_invlist_len_addr(invlist);
}
PERL_STATIC_INLINE void
-S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
+S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
{
/* Sets the current number of elements stored in the inversion list */
PERL_ARGS_ASSERT_INVLIST_SET_LEN;
- if (len != 0 && len > invlist_max(invlist)) {
- Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' more than %s=%"UVuf" in inversion list", INVLIST_LEN_KEY, len, INVLIST_MAX_KEY, invlist_max(invlist));
- }
-
- if (hv_stores(invlist, INVLIST_LEN_KEY, newSVuv(len)) == NULL) {
- Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
- INVLIST_LEN_KEY);
- }
+ *get_invlist_len_addr(invlist) = len;
+
+ assert(len <= SvLEN(invlist));
+
+ SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
+ /* If the list contains U+0000, that element is part of the header,
+ * and should not be counted as part of the array. It will contain
+ * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
+ * subtract:
+ * SvCUR_set(invlist,
+ * TO_INTERNAL_SIZE(len
+ * - (*get_invlist_zero_addr(inv_list) ^ 1)));
+ * But, this is only valid if len is not 0. The consequences of not doing
+ * this is that the memory allocation code may think that 1 more UV is
+ * being used than actually is, and so might do an unnecessary grow. That
+ * seems worth not bothering to make this the precise amount.
+ *
+ * Note that when inverting, SvCUR shouldn't change */
}
-PERL_STATIC_INLINE void
-S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
+PERL_STATIC_INLINE UV
+S_invlist_max(pTHX_ SV* const invlist)
{
+ /* Returns the maximum number of elements storable in the inversion list's
+ * array, without having to realloc() */
- /* Sets the maximum number of elements storable in the inversion list
- * without having to realloc() */
+ PERL_ARGS_ASSERT_INVLIST_MAX;
- PERL_ARGS_ASSERT_INVLIST_SET_MAX;
+ return FROM_INTERNAL_SIZE(SvLEN(invlist));
+}
- if (max < invlist_len(invlist)) {
- Perl_croak(aTHX_ "panic: Can't make '%s=%"UVuf"' less than %s=%"UVuf" in inversion list", INVLIST_MAX_KEY, invlist_len(invlist), INVLIST_LEN_KEY, invlist_max(invlist));
- }
+PERL_STATIC_INLINE UV*
+S_get_invlist_zero_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that is reserved to hold 0 if the inversion
+ * list contains 0. This has to be the last element of the heading, as the
+ * list proper starts with either it if 0, or the next element if not.
+ * (But we force it to contain either 0 or 1) */
- if (hv_stores(invlist, INVLIST_MAX_KEY, newSVuv(max)) == NULL) {
- Perl_croak(aTHX_ "panic: can't store '%s' entry in inversion list",
- INVLIST_LEN_KEY);
- }
+ PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
}
#ifndef PERL_IN_XSUB_RE
-HV*
+SV*
Perl__new_invlist(pTHX_ IV initial_size)
{
* space to store 'initial_size' elements. If that number is negative, a
* system default is used instead */
- HV* invlist = newHV();
- UV* list;
+ SV* new_list;
if (initial_size < 0) {
initial_size = INVLIST_INITIAL_LEN;
}
/* Allocate the initial space */
- Newx(list, initial_size, UV);
- invlist_set_array(invlist, list);
-
- /* set_len has to come before set_max, as the latter inspects the len */
- invlist_set_len(invlist, 0);
- invlist_set_max(invlist, initial_size);
-
- return invlist;
-}
-#endif
+ new_list = newSV(TO_INTERNAL_SIZE(initial_size));
+ invlist_set_len(new_list, 0);
-PERL_STATIC_INLINE void
-S_invlist_destroy(pTHX_ HV* const invlist)
-{
- /* Inversion list destructor */
+ /* Force iterinit() to be used to get iteration to work */
+ *get_invlist_iter_addr(new_list) = UV_MAX;
- SV** list_ptr = hv_fetchs(invlist, INVLIST_ARRAY_KEY, FALSE);
+ /* This should force a segfault if a method doesn't initialize this
+ * properly */
+ *get_invlist_zero_addr(new_list) = UV_MAX;
- PERL_ARGS_ASSERT_INVLIST_DESTROY;
-
- if (list_ptr != NULL) {
- UV *list = INT2PTR(UV *, SvUV(*list_ptr)); /* PERL_POISON needs lvalue */
- Safefree(list);
- }
+ return new_list;
}
+#endif
STATIC void
-S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
+S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
{
- /* Change the maximum size of an inversion list (up or down) */
-
- UV* orig_array;
- UV* array;
- const UV old_max = invlist_max(invlist);
+ /* Grow the maximum size of an inversion list */
PERL_ARGS_ASSERT_INVLIST_EXTEND;
- if (old_max == new_max) { /* If a no-op */
- return;
- }
-
- array = orig_array = invlist_array(invlist);
- Renew(array, new_max, UV);
-
- /* If the size change moved the list in memory, set the new one */
- if (array != orig_array) {
- invlist_set_array(invlist, array);
- }
-
- invlist_set_max(invlist, new_max);
-
+ SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
}
PERL_STATIC_INLINE void
-S_invlist_trim(pTHX_ HV* const invlist)
+S_invlist_trim(pTHX_ SV* const invlist)
{
PERL_ARGS_ASSERT_INVLIST_TRIM;
/* Change the length of the inversion list to how many entries it currently
* has */
- invlist_extend(invlist, invlist_len(invlist));
+ SvPV_shrink_to_cur((SV *) invlist);
}
/* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
* etc */
#define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
+#define PREV_ELEMENT_IN_INVLIST_SET(i) (! ELEMENT_IN_INVLIST_SET(i))
#ifndef PERL_IN_XSUB_RE
void
-Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
+Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
{
/* Subject to change or removal. Append the range from 'start' to 'end' at
* the end of the inversion list. The range must be above any existing
* ones. */
- UV* array = invlist_array(invlist);
+ UV* array;
UV max = invlist_max(invlist);
UV len = invlist_len(invlist);
PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
- if (len > 0) {
-
+ if (len == 0) { /* Empty lists must be initialized */
+ array = _invlist_array_init(invlist, start == 0);
+ }
+ else {
/* Here, the existing list is non-empty. The current max entry in the
* list is generally the first value not in the set, except when the
* set extends to the end of permissible values, in which case it is
* append out-of-order */
UV final_element = len - 1;
+ array = invlist_array(invlist);
if (array[final_element] > start
|| ELEMENT_IN_INVLIST_SET(final_element))
{
* moved */
if (max < len) {
invlist_extend(invlist, len);
+ invlist_set_len(invlist, len); /* Have to set len here to avoid assert
+ failure in invlist_array() */
array = invlist_array(invlist);
}
-
- invlist_set_len(invlist, len);
+ else {
+ invlist_set_len(invlist, len);
+ }
/* The next item on the list starts the range, the one after that is
* one past the new range. */
invlist_set_len(invlist, len - 1);
}
}
-#endif
-STATIC HV*
-S_invlist_union(pTHX_ HV* const a, HV* const b)
+void
+Perl__invlist_union(pTHX_ SV* const a, SV* const b, SV** output)
{
- /* Return a new inversion list which is the union of two inversion lists.
+ /* Take the union of two inversion lists and point 'result' to it. If
+ * 'result' on input points to one of the two lists, the reference count to
+ * that list will be decremented.
* The basis for this comes from "Unicode Demystified" Chapter 13 by
* Richard Gillam, published by Addison-Wesley, and explained at some
* length there. The preface says to incorporate its examples into your
* XXX A potential performance improvement is to keep track as we go along
* if only one of the inputs contributes to the result, meaning the other
* is a subset of that one. In that case, we can skip the final copy and
- * return the larger of the input lists */
+ * return the larger of the input lists, but then outside code might need
+ * to keep track of whether to free the input list or not */
- UV* array_a = invlist_array(a); /* a's array */
- UV* array_b = invlist_array(b);
- UV len_a = invlist_len(a); /* length of a's array */
- UV len_b = invlist_len(b);
+ UV* array_a; /* a's array */
+ UV* array_b;
+ UV len_a; /* length of a's array */
+ UV len_b;
- HV* u; /* the resulting union */
+ SV* u; /* the resulting union */
UV* array_u;
UV len_u;
*/
UV count = 0;
- PERL_ARGS_ASSERT_INVLIST_UNION;
+ PERL_ARGS_ASSERT__INVLIST_UNION;
+
+ /* If either one is empty, the union is the other one */
+ len_a = invlist_len(a);
+ if (len_a == 0) {
+ if (output == &a) {
+ SvREFCNT_dec(a);
+ }
+ else if (output != &b) {
+ *output = invlist_clone(b);
+ }
+ /* else *output already = b; */
+ return;
+ }
+ else if ((len_b = invlist_len(b)) == 0) {
+ if (output == &b) {
+ SvREFCNT_dec(b);
+ }
+ else if (output != &a) {
+ *output = invlist_clone(a);
+ }
+ /* else *output already = a; */
+ return;
+ }
+
+ /* Here both lists exist and are non-empty */
+ array_a = invlist_array(a);
+ array_b = invlist_array(b);
/* Size the union for the worst case: that the sets are completely
* disjoint */
u = _new_invlist(len_a + len_b);
- array_u = invlist_array(u);
+
+ /* Will contain U+0000 if either component does */
+ array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
+ || (len_b > 0 && array_b[0] == 0));
/* Go through each list item by item, stopping when exhausted one of
* them */
/* Here, we are finished going through at least one of the lists, which
* means there is something remaining in at most one. We check if the list
* that hasn't been exhausted is positioned such that we are in the middle
- * of a range in its set or not. (We are in the set if the next item in
- * the array marks the beginning of something not in the set) If in the
- * set, we decrement 'count'; if 0, there is potentially more to output.
+ * of a range in its set or not. (i_a and i_b point to the element beyond
+ * the one we care about.) If in the set, we decrement 'count'; if 0, there
+ * is potentially more to output.
* There are four cases:
* 1) Both weren't in their sets, count is 0, and remains 0. What's left
* in the union is entirely from the non-exhausted set.
* that
* 3) the exhausted was in its set, non-exhausted isn't, count is 1.
* Nothing further should be output because the union includes
- * everything from the exhausted set. Not decrementing insures that.
+ * everything from the exhausted set. Not decrementing ensures that.
* 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
* decrementing to 0 insures that we look at the remainder of the
* non-exhausted set */
- if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
- || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
+ if ((i_a != len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
+ || (i_b != len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
{
count--;
}
}
}
- return u;
+ /* We may be removing a reference to one of the inputs */
+ if (&a == output || &b == output) {
+ SvREFCNT_dec(*output);
+ }
+
+ *output = u;
+ return;
}
-STATIC HV*
-S_invlist_intersection(pTHX_ HV* const a, HV* const b)
+void
+Perl__invlist_intersection(pTHX_ SV* const a, SV* const b, SV** i)
{
- /* Return the intersection of two inversion lists. The basis for this
- * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
- * by Addison-Wesley, and explained at some length there. The preface says
- * to incorporate its examples into your code at your own risk.
+ /* Take the intersection of two inversion lists and point 'i' to it. If
+ * 'i' on input points to one of the two lists, the reference count to that
+ * list will be decremented.
+ * The basis for this comes from "Unicode Demystified" Chapter 13 by
+ * Richard Gillam, published by Addison-Wesley, and explained at some
+ * length there. The preface says to incorporate its examples into your
+ * code at your own risk. In fact, it had bugs
*
* The algorithm is like a merge sort, and is essentially the same as the
* union above
*/
- UV* array_a = invlist_array(a); /* a's array */
- UV* array_b = invlist_array(b);
- UV len_a = invlist_len(a); /* length of a's array */
- UV len_b = invlist_len(b);
+ UV* array_a; /* a's array */
+ UV* array_b;
+ UV len_a; /* length of a's array */
+ UV len_b;
- HV* r; /* the resulting intersection */
+ SV* r; /* the resulting intersection */
UV* array_r;
UV len_r;
*/
UV count = 0;
- PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
+ PERL_ARGS_ASSERT__INVLIST_INTERSECTION;
+
+ /* If either one is empty, the intersection is null */
+ len_a = invlist_len(a);
+ if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
+ *i = _new_invlist(0);
+
+ /* If the result is the same as one of the inputs, the input is being
+ * overwritten */
+ if (i == &a) {
+ SvREFCNT_dec(a);
+ }
+ else if (i == &b) {
+ SvREFCNT_dec(b);
+ }
+ return;
+ }
+
+ /* Here both lists exist and are non-empty */
+ array_a = invlist_array(a);
+ array_b = invlist_array(b);
/* Size the intersection for the worst case: that the intersection ends up
* fragmenting everything to be completely disjoint */
r= _new_invlist(len_a + len_b);
- array_r = invlist_array(r);
+
+ /* Will contain U+0000 iff both components do */
+ array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
+ && len_b > 0 && array_b[0] == 0);
/* Go through each list item by item, stopping when exhausted one of
* them */
array */
bool cp_in_set; /* Is it in the input list's set or not */
- /* We need to take one or the other of the two inputs for the union.
- * Since we are merging two sorted lists, we take the smaller of the
- * next items. In case of a tie, we take the one that is not in its
- * set first (a difference from the union algorithm). If we took one
- * in the set first, it would increment the count, possibly to 2 which
- * would cause it to be output as starting a range in the intersection,
- * and the next time through we would take that same number, and output
- * it again as ending the set. By doing it the opposite of this, we
- * there is no possibility that the count will be momentarily
- * incremented to 2. (In a tie and both are in the set or both not in
- * the set, it doesn't matter which we take first.) */
+ /* We need to take one or the other of the two inputs for the
+ * intersection. Since we are merging two sorted lists, we take the
+ * smaller of the next items. In case of a tie, we take the one that
+ * is not in its set first (a difference from the union algorithm). If
+ * we took one in the set first, it would increment the count, possibly
+ * to 2 which would cause it to be output as starting a range in the
+ * intersection, and the next time through we would take that same
+ * number, and output it again as ending the set. By doing it the
+ * opposite of this, there is no possibility that the count will be
+ * momentarily incremented to 2. (In a tie and both are in the set or
+ * both not in the set, it doesn't matter which we take first.) */
if (array_a[i_a] < array_b[i_b]
|| (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
{
}
}
- /* Here, we are finished going through at least one of the sets, which
- * means there is something remaining in at most one. See the comments in
- * the union code */
- if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
- || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
+ /* Here, we are finished going through at least one of the lists, which
+ * means there is something remaining in at most one. We check if the list
+ * that has been exhausted is positioned such that we are in the middle
+ * of a range in its set or not. (i_a and i_b point to elements 1 beyond
+ * the ones we care about.) There are four cases:
+ * 1) Both weren't in their sets, count is 0, and remains 0. There's
+ * nothing left in the intersection.
+ * 2) Both were in their sets, count is 2 and perhaps is incremented to
+ * above 2. What should be output is exactly that which is in the
+ * non-exhausted set, as everything it has is also in the intersection
+ * set, and everything it doesn't have can't be in the intersection
+ * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
+ * gets incremented to 2. Like the previous case, the intersection is
+ * everything that remains in the non-exhausted set.
+ * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
+ * remains 1. And the intersection has nothing more. */
+ if ((i_a == len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
+ || (i_b == len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
{
- count--;
+ count++;
}
/* The final length is what we've output so far plus what else is in the
- * intersection. Only one of the subexpressions below will be non-zero */
+ * intersection. At most one of the subexpressions below will be non-zero */
len_r = i_r;
- if (count == 2) {
+ if (count >= 2) {
len_r += (len_a - i_a) + (len_b - i_b);
}
}
/* Finish outputting any remaining */
- if (count == 2) { /* Only one of will have a non-zero copy count */
+ if (count >= 2) { /* At most one will have a non-zero copy count */
IV copy_count;
if ((copy_count = len_a - i_a) > 0) {
Copy(array_a + i_a, array_r + i_r, copy_count, UV);
}
}
- return r;
+ /* We may be removing a reference to one of the inputs */
+ if (&a == i || &b == i) {
+ SvREFCNT_dec(*i);
+ }
+
+ *i = r;
+ return;
}
-STATIC HV*
-S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
+#endif
+
+STATIC SV*
+S_add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
{
/* Add the range from 'start' to 'end' inclusive to the inversion list's
* set. A pointer to the inversion list is returned. This may actually be
* passed in inversion list can be NULL, in which case a new one is created
* with just the one range in it */
- HV* range_invlist;
- HV* added_invlist;
+ SV* range_invlist;
UV len;
if (invlist == NULL) {
range_invlist = _new_invlist(2);
_append_range_to_invlist(range_invlist, start, end);
- added_invlist = invlist_union(invlist, range_invlist);
+ _invlist_union(invlist, range_invlist, &invlist);
- /* The passed in list can be freed, as well as our temporary */
- invlist_destroy(range_invlist);
- if (invlist != added_invlist) {
- invlist_destroy(invlist);
- }
+ /* The temporary can be freed */
+ SvREFCNT_dec(range_invlist);
- return added_invlist;
+ return invlist;
}
-PERL_STATIC_INLINE HV*
-S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
+PERL_STATIC_INLINE SV*
+S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
return add_range_to_invlist(invlist, cp, cp);
}
+#ifndef PERL_IN_XSUB_RE
+void
+Perl__invlist_invert(pTHX_ SV* const invlist)
+{
+ /* Complement the input inversion list. This adds a 0 if the list didn't
+ * have a zero; removes it otherwise. As described above, the data
+ * structure is set up so that this is very efficient */
+
+ UV* len_pos = get_invlist_len_addr(invlist);
+
+ PERL_ARGS_ASSERT__INVLIST_INVERT;
+
+ /* The inverse of matching nothing is matching everything */
+ if (*len_pos == 0) {
+ _append_range_to_invlist(invlist, 0, UV_MAX);
+ return;
+ }
+
+ /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
+ * zero element was a 0, so it is being removed, so the length decrements
+ * by 1; and vice-versa. SvCUR is unaffected */
+ if (*get_invlist_zero_addr(invlist) ^= 1) {
+ (*len_pos)--;
+ }
+ else {
+ (*len_pos)++;
+ }
+}
+
+void
+Perl__invlist_invert_prop(pTHX_ SV* const invlist)
+{
+ /* Complement the input inversion list (which must be a Unicode property,
+ * all of which don't match above the Unicode maximum code point.) And
+ * Perl has chosen to not have the inversion match above that either. This
+ * adds a 0x110000 if the list didn't end with it, and removes it if it did
+ */
+
+ UV len;
+ UV* array;
+
+ PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
+
+ _invlist_invert(invlist);
+
+ len = invlist_len(invlist);
+
+ if (len != 0) { /* If empty do nothing */
+ array = invlist_array(invlist);
+ if (array[len - 1] != PERL_UNICODE_MAX + 1) {
+ /* Add 0x110000. First, grow if necessary */
+ len++;
+ if (invlist_max(invlist) < len) {
+ invlist_extend(invlist, len);
+ array = invlist_array(invlist);
+ }
+ invlist_set_len(invlist, len);
+ array[len - 1] = PERL_UNICODE_MAX + 1;
+ }
+ else { /* Remove the 0x110000 */
+ invlist_set_len(invlist, len - 1);
+ }
+ }
+
+ return;
+}
+#endif
+
+PERL_STATIC_INLINE SV*
+S_invlist_clone(pTHX_ SV* const invlist)
+{
+
+ /* Return a new inversion list that is a copy of the input one, which is
+ * unchanged */
+
+ SV* new_invlist = _new_invlist(SvCUR(invlist));
+
+ PERL_ARGS_ASSERT_INVLIST_CLONE;
+
+ Copy(SvPVX(invlist), SvPVX(new_invlist), SvCUR(invlist), char);
+ return new_invlist;
+}
+
+#ifndef PERL_IN_XSUB_RE
+void
+Perl__invlist_subtract(pTHX_ SV* const a, SV* const b, SV** result)
+{
+ /* Point result to an inversion list which consists of all elements in 'a'
+ * that aren't also in 'b' */
+
+ PERL_ARGS_ASSERT__INVLIST_SUBTRACT;
+
+ /* Subtracting nothing retains the original */
+ if (invlist_len(b) == 0) {
+
+ /* If the result is not to be the same variable as the original, create
+ * a copy */
+ if (result != &a) {
+ *result = invlist_clone(a);
+ }
+ } else {
+ SV *b_copy = invlist_clone(b);
+ _invlist_invert(b_copy); /* Everything not in 'b' */
+ _invlist_intersection(a, b_copy, result); /* Everything in 'a' not in
+ 'b' */
+ SvREFCNT_dec(b_copy);
+ }
+
+ if (result == &b) {
+ SvREFCNT_dec(b);
+ }
+
+ return;
+}
+#endif
+
+PERL_STATIC_INLINE UV*
+S_get_invlist_iter_addr(pTHX_ SV* invlist)
+{
+ /* Return the address of the UV that contains the current iteration
+ * position */
+
+ PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
+
+ return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
+}
+
+PERL_STATIC_INLINE void
+S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
+{
+ PERL_ARGS_ASSERT_INVLIST_ITERINIT;
+
+ *get_invlist_iter_addr(invlist) = 0;
+}
+
+STATIC bool
+S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
+{
+ UV* pos = get_invlist_iter_addr(invlist);
+ UV len = invlist_len(invlist);
+ UV *array;
+
+ PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
+
+ if (*pos >= len) {
+ *pos = UV_MAX; /* Force iternit() to be required next time */
+ return FALSE;
+ }
+
+ array = invlist_array(invlist);
+
+ *start = array[(*pos)++];
+
+ if (*pos >= len) {
+ *end = UV_MAX;
+ }
+ else {
+ *end = array[(*pos)++] - 1;
+ }
+
+ return TRUE;
+}
+
+#if 0
+void
+S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
+{
+ /* Dumps out the ranges in an inversion list. The string 'header'
+ * if present is output on a line before the first range */
+
+ UV start, end;
+
+ if (header && strlen(header)) {
+ PerlIO_printf(Perl_debug_log, "%s\n", header);
+ }
+ invlist_iterinit(invlist);
+ while (invlist_iternext(invlist, &start, &end)) {
+ if (end == UV_MAX) {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
+ }
+ else {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
+ }
+ }
+}
+#endif
+
+#undef HEADER_LENGTH
+#undef INVLIST_INITIAL_LENGTH
+#undef TO_INTERNAL_SIZE
+#undef FROM_INTERNAL_SIZE
+#undef INVLIST_LEN_OFFSET
+#undef INVLIST_ZERO_OFFSET
+#undef INVLIST_ITER_OFFSET
+
/* End of inversion list object */
/*
SvIV_set(sv_dat, 1);
}
#ifdef DEBUGGING
+ /* Yes this does cause a memory leak in debugging Perls */
if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
SvREFCNT_dec(svname);
#endif
{
U32 posflags = 0, negflags = 0;
U32 *flagsp = &posflags;
- bool has_charset_modifier = 0;
+ char has_charset_modifier = '\0';
regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
? REGEX_UNICODE_CHARSET
: REGEX_DEPENDS_CHARSET;
switch (*RExC_parse) {
CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
case LOCALE_PAT_MOD:
- if (has_charset_modifier || flagsp == &negflags) {
- goto fail_modifiers;
+ if (has_charset_modifier) {
+ goto excess_modifier;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
}
cs = REGEX_LOCALE_CHARSET;
- has_charset_modifier = 1;
+ has_charset_modifier = LOCALE_PAT_MOD;
RExC_contains_locale = 1;
break;
case UNICODE_PAT_MOD:
- if (has_charset_modifier || flagsp == &negflags) {
- goto fail_modifiers;
+ if (has_charset_modifier) {
+ goto excess_modifier;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
}
cs = REGEX_UNICODE_CHARSET;
- has_charset_modifier = 1;
+ has_charset_modifier = UNICODE_PAT_MOD;
break;
case ASCII_RESTRICT_PAT_MOD:
- if (has_charset_modifier || flagsp == &negflags) {
- goto fail_modifiers;
+ if (flagsp == &negflags) {
+ goto neg_modifier;
}
- if (*(RExC_parse + 1) == ASCII_RESTRICT_PAT_MOD) {
+ if (has_charset_modifier) {
+ if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
+ goto excess_modifier;
+ }
/* Doubled modifier implies more restricted */
- cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
- RExC_parse++;
- }
+ cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
+ }
else {
cs = REGEX_ASCII_RESTRICTED_CHARSET;
}
- has_charset_modifier = 1;
+ has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
break;
case DEPENDS_PAT_MOD:
- if (has_use_defaults
- || has_charset_modifier
- || flagsp == &negflags)
- {
+ if (has_use_defaults) {
goto fail_modifiers;
+ }
+ else if (flagsp == &negflags) {
+ goto neg_modifier;
+ }
+ else if (has_charset_modifier) {
+ goto excess_modifier;
}
/* The dual charset means unicode semantics if the
cs = (RExC_utf8 || RExC_uni_semantics)
? REGEX_UNICODE_CHARSET
: REGEX_DEPENDS_CHARSET;
- has_charset_modifier = 1;
+ has_charset_modifier = DEPENDS_PAT_MOD;
break;
+ excess_modifier:
+ RExC_parse++;
+ if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
+ vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
+ }
+ else if (has_charset_modifier == *(RExC_parse - 1)) {
+ vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
+ }
+ else {
+ vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
+ }
+ /*NOTREACHED*/
+ neg_modifier:
+ RExC_parse++;
+ vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
+ /*NOTREACHED*/
case ONCE_PAT_MOD: /* 'o' */
case GLOBAL_PAT_MOD: /* 'g' */
if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
const char * const origparse = RExC_parse;
I32 min;
I32 max = REG_INFTY;
+#ifdef RE_TRACK_PATTERN_OFFSETS
char *parse_start;
+#endif
const char *maxpos = NULL;
GET_RE_DEBUG_FLAGS_DECL;
if (op == '{' && regcurly(RExC_parse)) {
maxpos = NULL;
+#ifdef RE_TRACK_PATTERN_OFFSETS
parse_start = RExC_parse; /* MJD */
+#endif
next = RExC_parse + 1;
while (isDIGIT(*next) || *next == ',') {
if (*next == ',') {
vFAIL("Regexp *+ operand could be empty");
#endif
+#ifdef RE_TRACK_PATTERN_OFFSETS
parse_start = RExC_parse;
+#endif
nextchar(pRExC_state);
*flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
}
-/* reg_namedseq(pRExC_state,UVp)
+/* reg_namedseq(pRExC_state,UVp, UV depth)
This is expected to be called by a parser routine that has
recognized '\N' and needs to handle the rest. RExC_parse is
Parsing failures will generate a fatal error via vFAIL(...)
*/
STATIC regnode *
-S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp)
+S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
{
char * endbrace; /* '}' following the name */
regnode *ret = NULL;
-#ifdef DEBUGGING
- char* parse_start = RExC_parse - 2; /* points to the '\N' */
-#endif
char* p;
GET_RE_DEBUG_FLAGS_DECL;
ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
}
else { /* Not a char class */
- char *s; /* String to put in generated EXACT node */
- STRLEN len = 0; /* Its current byte length */
+
+ /* What is done here is to convert this to a sub-pattern of the form
+ * (?:\x{char1}\x{char2}...)
+ * and then call reg recursively. That way, it retains its atomicness,
+ * while not having to worry about special handling that some code
+ * points may have. toke.c has converted the original Unicode values
+ * to native, so that we can just pass on the hex values unchanged. We
+ * do have to set a flag to keep recoding from happening in the
+ * recursion */
+
+ SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
+ STRLEN len;
char *endchar; /* Points to '.' or '}' ending cur char in the input
stream */
- ret = reg_node(pRExC_state,
- (U8) ((! FOLD) ? EXACT
- : (LOC)
- ? EXACTFL
- : (MORE_ASCII_RESTRICTED)
- ? EXACTFA
- : (AT_LEAST_UNI_SEMANTICS)
- ? EXACTFU
- : EXACTF));
- s= STRING(ret);
-
- /* Exact nodes can hold only a U8 length's of text = 255. Loop through
- * the input which is of the form now 'c1.c2.c3...}' until find the
- * ending brace or exceed length 255. The characters that exceed this
- * limit are dropped. The limit could be relaxed should it become
- * desirable by reparsing this as (?:\N{NAME}), so could generate
- * multiple EXACT nodes, as is done for just regular input. But this
- * is primarily a named character, and not intended to be a huge long
- * string, so 255 bytes should be good enough */
- while (1) {
- STRLEN length_of_hex;
- I32 grok_flags = PERL_SCAN_ALLOW_UNDERSCORES
- | PERL_SCAN_DISALLOW_PREFIX
- | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
- UV cp; /* Ord of current character */
- bool use_this_char_fold = FOLD;
+ char *orig_end = RExC_end;
+
+ while (RExC_parse < endbrace) {
/* Code points are separated by dots. If none, there is only one
* code point, and is terminated by the brace */
endchar = RExC_parse + strcspn(RExC_parse, ".}");
- /* The values are Unicode even on EBCDIC machines */
- length_of_hex = (STRLEN)(endchar - RExC_parse);
- cp = grok_hex(RExC_parse, &length_of_hex, &grok_flags, NULL);
- if ( length_of_hex == 0
- || length_of_hex != (STRLEN)(endchar - RExC_parse) )
- {
- RExC_parse += length_of_hex; /* Includes all the valid */
- RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
- ? UTF8SKIP(RExC_parse)
- : 1;
- /* Guard against malformed utf8 */
- if (RExC_parse >= endchar) RExC_parse = endchar;
- vFAIL("Invalid hexadecimal number in \\N{U+...}");
- }
-
- /* XXX ? Change to ANYOF node
- if (FOLD
- && (cp > 255 || (! MORE_ASCII_RESTRICTED && ! LOC))
- && is_TRICKYFOLD_cp(cp))
- {
- }
- */
-
- /* Under /aa, we can't mix ASCII with non- in a fold. If we are
- * folding, and the source isn't ASCII, look through all the
- * characters it folds to. If any one of them is ASCII, forbid
- * this fold. (cp is uni, so the 127 below is correct even for
- * EBCDIC). Similarly under locale rules, we don't mix under 256
- * with above 255. XXX It really doesn't make sense to have \N{}
- * which means a Unicode rules under locale. I (khw) think this
- * should be warned about, but the counter argument is that people
- * who have programmed around Perl's earlier lack of specifying the
- * rules and used \N{} to force Unicode things in a local
- * environment shouldn't get suddenly a warning */
- if (use_this_char_fold) {
- if (LOC && cp < 256) { /* Fold not known until run-time */
- use_this_char_fold = FALSE;
- }
- else if ((cp > 127 && MORE_ASCII_RESTRICTED)
- || (cp > 255 && LOC))
- {
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- U8* s = tmpbuf;
- U8* e;
- STRLEN foldlen;
-
- (void) toFOLD_uni(cp, tmpbuf, &foldlen);
- e = s + foldlen;
-
- while (s < e) {
- if (isASCII(*s)
- || (LOC && (UTF8_IS_INVARIANT(*s)
- || UTF8_IS_DOWNGRADEABLE_START(*s))))
- {
- use_this_char_fold = FALSE;
- break;
- }
- s += UTF8SKIP(s);
- }
- }
- }
-
- if (! use_this_char_fold) { /* Not folding, just append to the
- string */
- STRLEN unilen;
-
- /* Quit before adding this character if would exceed limit */
- if (len + UNISKIP(cp) > U8_MAX) break;
-
- unilen = reguni(pRExC_state, cp, s);
- if (unilen > 0) {
- s += unilen;
- len += unilen;
- }
- } else { /* Folding, output the folded equivalent */
- STRLEN foldlen,numlen;
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
- cp = toFOLD_uni(cp, tmpbuf, &foldlen);
-
- /* Quit before exceeding size limit */
- if (len + foldlen > U8_MAX) break;
-
- for (foldbuf = tmpbuf;
- foldlen;
- foldlen -= numlen)
- {
- cp = utf8_to_uvchr(foldbuf, &numlen);
- if (numlen > 0) {
- const STRLEN unilen = reguni(pRExC_state, cp, s);
- s += unilen;
- len += unilen;
- /* In EBCDIC the numlen and unilen can differ. */
- foldbuf += numlen;
- if (numlen >= foldlen)
- break;
- }
- else
- break; /* "Can't happen." */
- }
- }
+ /* Convert to notation the rest of the code understands */
+ sv_catpv(substitute_parse, "\\x{");
+ sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
+ sv_catpv(substitute_parse, "}");
/* Point to the beginning of the next character in the sequence. */
RExC_parse = endchar + 1;
-
- /* Quit if no more characters */
- if (RExC_parse >= endbrace) break;
}
+ sv_catpv(substitute_parse, ")");
+ RExC_parse = SvPV(substitute_parse, len);
- if (SIZE_ONLY) {
- if (RExC_parse < endbrace) {
- ckWARNreg(RExC_parse - 1,
- "Using just the first characters returned by \\N{}");
- }
-
- RExC_size += STR_SZ(len);
- } else {
- STR_LEN(ret) = len;
- RExC_emit += STR_SZ(len);
+ /* Don't allow empty number */
+ if (len < 8) {
+ vFAIL("Invalid hexadecimal number in \\N{U+...}");
}
+ RExC_end = RExC_parse + len;
- RExC_parse = endbrace + 1;
+ /* The values are Unicode, and therefore not subject to recoding */
+ RExC_override_recoding = 1;
+
+ ret = reg(pRExC_state, 1, flagp, depth+1);
+
+ RExC_parse = endbrace;
+ RExC_end = orig_end;
+ RExC_override_recoding = 0;
- *flagp |= HASWIDTH; /* Not SIMPLE, as that causes the engine to fail
- with malformed in t/re/pat_advanced.t */
- RExC_parse --;
- Set_Node_Cur_Length(ret); /* MJD */
nextchar(pRExC_state);
}
RExC_parse++;
vFAIL("Quantifier follows nothing");
break;
- case LATIN_SMALL_LETTER_SHARP_S:
- case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
- case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
-#if UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T) != UTF8_TWO_BYTE_HI_nocast(IOTA_D_T)
-#error The beginning utf8 byte of IOTA_D_T and UPSILON_D_T unexpectedly differ. Other instances in this code should have the case statement below.
- case UTF8_TWO_BYTE_HI_nocast(UPSILON_D_T):
-#endif
- do_foldchar:
- if (!LOC && FOLD) {
- U32 len,cp;
- len=0; /* silence a spurious compiler warning */
- if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) {
- *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
- RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */
- ret = reganode(pRExC_state, FOLDCHAR, cp);
- Set_Node_Length(ret, 1); /* MJD */
- nextchar(pRExC_state); /* kill whitespace under /x */
- return ret;
- }
- }
- goto outer_default;
case '\\':
/* Special Escapes
literal text handling code.
*/
switch ((U8)*++RExC_parse) {
- case LATIN_SMALL_LETTER_SHARP_S:
- case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
- case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
- goto do_foldchar;
/* Special Escapes */
case 'A':
RExC_seen_zerolen++;
Also this makes sure that things like /\N{BLAH}+/ and
\N{BLAH} being multi char Just Happen. dmq*/
++RExC_parse;
- ret= reg_namedseq(pRExC_state, NULL, flagp);
+ ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
break;
case 'k': /* Handle \k<NAME> and \k'NAME' */
parse_named_seq:
/* FALL THROUGH */
default:
- outer_default:{
+
+ parse_start = RExC_parse - 1;
+
+ RExC_parse++;
+
+ defchar: {
+ typedef enum {
+ generic_char = 0,
+ char_s,
+ upsilon_1,
+ upsilon_2,
+ iota_1,
+ iota_2,
+ } char_state;
+ char_state latest_char_state = generic_char;
register STRLEN len;
register UV ender;
register char *p;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
regnode * orig_emit;
- parse_start = RExC_parse - 1;
-
- RExC_parse++;
-
- defchar:
ender = 0;
orig_emit = RExC_emit; /* Save the original output node position in
case we need to output a different node
if (RExC_flags & RXf_PMf_EXTENDED)
p = regwhite( pRExC_state, p );
switch ((U8)*p) {
- case LATIN_SMALL_LETTER_SHARP_S:
- case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
- case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
- if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
- goto normal_default;
case '^':
case '$':
case '.':
switch ((U8)*++p) {
/* These are all the special escapes. */
- case LATIN_SMALL_LETTER_SHARP_S:
- case UTF8_TWO_BYTE_HI_nocast(LATIN_SMALL_LETTER_SHARP_S):
- case UTF8_TWO_BYTE_HI_nocast(IOTA_D_T):
- if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
- goto normal_default;
case 'A': /* Start assertion */
case 'b': case 'B': /* Word-boundary assertion*/
case 'C': /* Single char !DANGEROUS! */
goto recode_encoding;
break;
recode_encoding:
- {
+ if (! RExC_override_recoding) {
SV* enc = PL_encoding;
ender = reg_recode((const char)(U8)ender, &enc);
if (!enc && SIZE_ONLY)
* putting it in a special node keeps regexec from having to
* deal with a non-utf8 multi-char fold */
if (FOLD
- && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC))
- && is_TRICKYFOLD_cp(ender))
+ && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
{
- /* If is in middle of outputting characters into an
- * EXACTish node, go output what we have so far, and
- * position the parse so that this will be called again
- * immediately */
- if (len) {
- p = oldp;
- goto loopdone;
- }
- else {
+ /* We look for either side of the fold. For example \xDF
+ * folds to 'ss'. We look for both the single character
+ * \xDF and the sequence 'ss'. When we find something that
+ * could be one of those, we stop and flush whatever we
+ * have output so far into the EXACTish node that was being
+ * built. Then restore the input pointer to what it was.
+ * regatom will return that EXACT node, and will be called
+ * again, positioned so the first character is the one in
+ * question, which we return in a different node type.
+ * The multi-char folds are a sequence, so the occurrence
+ * of the first character in that sequence doesn't
+ * necessarily mean that what follows is the rest of the
+ * sequence. We keep track of that with a state machine,
+ * with the state being set to the latest character
+ * processed before the current one. Most characters will
+ * set the state to 0, but if one occurs that is part of a
+ * potential tricky fold sequence, the state is set to that
+ * character, and the next loop iteration sees if the state
+ * should progress towards the final folded-from character,
+ * or if it was a false alarm. If it turns out to be a
+ * false alarm, the character(s) will be output in a new
+ * EXACTish node, and join_exact() will later combine them.
+ * In the case of the 'ss' sequence, which is more common
+ * and more easily checked, some look-ahead is done to
+ * save time by ruling-out some false alarms */
+ switch (ender) {
+ default:
+ latest_char_state = generic_char;
+ break;
+ case 's':
+ case 'S':
+ case 0x17F: /* LATIN SMALL LETTER LONG S */
+ if (AT_LEAST_UNI_SEMANTICS) {
+ if (latest_char_state == char_s) { /* 'ss' */
+ ender = LATIN_SMALL_LETTER_SHARP_S;
+ goto do_tricky;
+ }
+ else if (p < RExC_end) {
+
+ /* Look-ahead at the next character. If it
+ * is also an s, we handle as a sharp s
+ * tricky regnode. */
+ if (*p == 's' || *p == 'S') {
+
+ /* But first flush anything in the
+ * EXACTish buffer */
+ if (len != 0) {
+ p = oldp;
+ goto loopdone;
+ }
+ p++; /* Account for swallowing this
+ 's' up */
+ ender = LATIN_SMALL_LETTER_SHARP_S;
+ goto do_tricky;
+ }
+ /* Here, the next character is not a
+ * literal 's', but still could
+ * evaluate to one if part of a \o{},
+ * \x or \OCTAL-DIGIT. The minimum
+ * length required for that is 4, eg
+ * \x53 or \123 */
+ else if (*p == '\\'
+ && p < RExC_end - 4
+ && (isDIGIT(*(p + 1))
+ || *(p + 1) == 'x'
+ || *(p + 1) == 'o' ))
+ {
+
+ /* Here, it could be an 's', too much
+ * bother to figure it out here. Flush
+ * the buffer if any; when come back
+ * here, set the state so know that the
+ * previous char was an 's' */
+ if (len != 0) {
+ latest_char_state = generic_char;
+ p = oldp;
+ goto loopdone;
+ }
+ latest_char_state = char_s;
+ break;
+ }
+ }
+ }
- /* Here we are ready to output our tricky fold
- * character. What's done is to pretend it's in a
- * [bracketed] class, and let the code that deals with
- * those handle it, as that code has all the
- * intelligence necessary. First save the current
- * parse state, get rid of the already allocated EXACT
- * node that the ANYOFV node will replace, and point
- * the parse to a buffer which we fill with the
- * character we want the regclass code to think is
- * being parsed */
- char* const oldregxend = RExC_end;
- char tmpbuf[2];
- RExC_emit = orig_emit;
- RExC_parse = tmpbuf;
- if (UTF) {
- tmpbuf[0] = UTF8_TWO_BYTE_HI(ender);
- tmpbuf[1] = UTF8_TWO_BYTE_LO(ender);
- RExC_end = RExC_parse + 2;
- }
- else {
- tmpbuf[0] = (char) ender;
- RExC_end = RExC_parse + 1;
- }
+ /* Here, can't be an 'ss' sequence, or at least not
+ * one that could fold to/from the sharp ss */
+ latest_char_state = generic_char;
+ break;
+ case 0x03C5: /* First char in upsilon series */
+ case 0x03A5: /* Also capital UPSILON, which folds to
+ 03C5, and hence exhibits the same
+ problem */
+ if (p < RExC_end - 4) { /* Need >= 4 bytes left */
+ latest_char_state = upsilon_1;
+ if (len != 0) {
+ p = oldp;
+ goto loopdone;
+ }
+ }
+ else {
+ latest_char_state = generic_char;
+ }
+ break;
+ case 0x03B9: /* First char in iota series */
+ case 0x0399: /* Also capital IOTA */
+ case 0x1FBE: /* GREEK PROSGEGRAMMENI folds to 3B9 */
+ case 0x0345: /* COMBINING GREEK YPOGEGRAMMENI folds
+ to 3B9 */
+ if (p < RExC_end - 4) {
+ latest_char_state = iota_1;
+ if (len != 0) {
+ p = oldp;
+ goto loopdone;
+ }
+ }
+ else {
+ latest_char_state = generic_char;
+ }
+ break;
+ case 0x0308:
+ if (latest_char_state == upsilon_1) {
+ latest_char_state = upsilon_2;
+ }
+ else if (latest_char_state == iota_1) {
+ latest_char_state = iota_2;
+ }
+ else {
+ latest_char_state = generic_char;
+ }
+ break;
+ case 0x301:
+ if (latest_char_state == upsilon_2) {
+ ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
+ goto do_tricky;
+ }
+ else if (latest_char_state == iota_2) {
+ ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
+ goto do_tricky;
+ }
+ latest_char_state = generic_char;
+ break;
- ret = regclass(pRExC_state,depth+1);
+ /* These are the tricky fold characters. Flush any
+ * buffer first. (When adding to this list, also should
+ * add them to fold_grind.t to make sure get tested) */
+ case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
+ case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
+ case LATIN_SMALL_LETTER_SHARP_S:
+ case LATIN_CAPITAL_LETTER_SHARP_S:
+ case 0x1FD3: /* GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA */
+ case 0x1FE3: /* GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA */
+ if (len != 0) {
+ p = oldp;
+ goto loopdone;
+ }
+ /* FALL THROUGH */
+ do_tricky: {
+ char* const oldregxend = RExC_end;
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+
+ /* Here, we know we need to generate a special
+ * regnode, and 'ender' contains the tricky
+ * character. What's done is to pretend it's in a
+ * [bracketed] class, and let the code that deals
+ * with those handle it, as that code has all the
+ * intelligence necessary. First save the current
+ * parse state, get rid of the already allocated
+ * but empty EXACT node that the ANYOFV node will
+ * replace, and point the parse to a buffer which
+ * we fill with the character we want the regclass
+ * code to think is being parsed */
+ RExC_emit = orig_emit;
+ RExC_parse = (char *) tmpbuf;
+ if (UTF) {
+ U8 *d = uvchr_to_utf8(tmpbuf, ender);
+ *d = '\0';
+ RExC_end = (char *) d;
+ }
+ else { /* ender above 255 already excluded */
+ tmpbuf[0] = (U8) ender;
+ tmpbuf[1] = '\0';
+ RExC_end = RExC_parse + 1;
+ }
- /* Here, have parsed the buffer. Reset the parse to
- * the actual input, and return */
- RExC_end = oldregxend;
- RExC_parse = p - 1;
+ ret = regclass(pRExC_state,depth+1);
+
+ /* Here, have parsed the buffer. Reset the parse to
+ * the actual input, and return */
+ RExC_end = oldregxend;
+ RExC_parse = p - 1;
- Set_Node_Offset(ret, RExC_parse);
- Set_Node_Cur_Length(ret);
- nextchar(pRExC_state);
- *flagp |= HASWIDTH|SIMPLE;
- return ret;
+ Set_Node_Offset(ret, RExC_parse);
+ Set_Node_Cur_Length(ret);
+ nextchar(pRExC_state);
+ *flagp |= HASWIDTH|SIMPLE;
+ return ret;
+ }
}
}
}
len--;
}
- else
+ else {
REGC((char)ender, s++);
+ }
}
loopdone: /* Jumped to when encounters something that shouldn't be in
the node */
}
}
-/* No locale test, and always Unicode semantics */
+/* No locale test, and always Unicode semantics, no ignore-case differences */
#define _C_C_T_NOLOC_(NAME,TEST,WORD) \
ANYOF_##NAME: \
for (value = 0; value < 256; value++) \
/* Like the above, but there are differences if we are in uni-8-bit or not, so
* there are two tests passed in, to use depending on that. There aren't any
* cases where the label is different from the name, so no need for that
- * parameter */
-#define _C_C_T_(NAME, TEST_8, TEST_7, WORD) \
+ * parameter.
+ * Sets 'what' to WORD which is the property name for non-bitmap code points;
+ * But, uses FOLD_WORD instead if /i has been selected, to allow a different
+ * property name */
+#define _C_C_T_(NAME, TEST_8, TEST_7, WORD, FOLD_WORD) \
ANYOF_##NAME: \
if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME); \
else if (UNI_SEMANTICS) { \
} \
} \
yesno = '+'; \
- what = WORD; \
+ if (FOLD) { \
+ what = FOLD_WORD; \
+ } \
+ else { \
+ what = WORD; \
+ } \
break; \
case ANYOF_N##NAME: \
if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME); \
} \
} \
yesno = '!'; \
- what = WORD; \
+ if (FOLD) { \
+ what = FOLD_WORD; \
+ } \
+ else { \
+ what = WORD; \
+ } \
break
STATIC U8
-S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
+S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
{
/* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
break;
case LATIN_SMALL_LETTER_SHARP_S:
- /* 0x1E9E is LATIN CAPITAL LETTER SHARP S */
- *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x1E9E);
+ *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
+ LATIN_CAPITAL_LETTER_SHARP_S);
/* Under /a, /d, and /u, this can match the two chars "ss" */
if (! MORE_ASCII_RESTRICTED) {
case 'I': case 'i':
case 'L': case 'l':
case 'T': case 't':
- /* These all are targets of multi-character folds, which can
- * occur with only non-Latin1 characters in the fold, so they
- * can match if the target string isn't UTF-8 */
- ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
- break;
case 'A': case 'a':
case 'H': case 'h':
case 'J': case 'j':
case 'N': case 'n':
case 'W': case 'w':
case 'Y': case 'y':
- /* These all are targets of multi-character folds, which occur
- * only with a non-Latin1 character as part of the fold, so
- * they can't match unless the target string is in UTF-8, so no
- * action here is necessary */
+ /* These all are targets of multi-character folds from code
+ * points that require UTF8 to express, so they can't match
+ * unless the target string is in UTF-8, so no action here is
+ * necessary, as regexec.c properly handles the general case
+ * for UTF-8 matching */
break;
default:
/* Use deprecated warning to increase the chances of this
PERL_STATIC_INLINE U8
-S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
+S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
{
/* This inline function sets a bit in the bitmap if not already set, and if
* appropriate, its fold, returning the number of bits that actually
IV namedclass;
char *rangebegin = NULL;
bool need_class = 0;
+ bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
SV *listsv = NULL;
STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
than just initialized. */
UV n;
/* code points this node matches that can't be stored in the bitmap */
- HV* nonbitmap = NULL;
+ SV* nonbitmap = NULL;
/* The items that are to match that aren't stored in the bitmap, but are a
* result of things that are stored there. This is the fold closure of
* that matches. A 2nd list is used so that the 'nonbitmap' list is kept
* empty unless there is something whose fold we don't know about, and will
* have to go out to the disk to find. */
- HV* l1_fold_invlist = NULL;
+ SV* l1_fold_invlist = NULL;
/* List of multi-character folds that are matched by this node */
AV* unicode_alternate = NULL;
RExC_parse++;
if (!SIZE_ONLY)
ANYOF_FLAGS(ret) |= ANYOF_INVERT;
+
+ /* We have decided to not allow multi-char folds in inverted character
+ * classes, due to the confusion that can happen, especially with
+ * classes that are designed for a non-Unicode world: You have the
+ * peculiar case that:
+ "s s" =~ /^[^\xDF]+$/i => Y
+ "ss" =~ /^[^\xDF]+$/i => N
+ *
+ * See [perl #89750] */
+ allow_full_fold = FALSE;
}
if (SIZE_ONLY) {
RExC_size += ANYOF_SKIP;
-#ifdef ANYOF_ADD_LOC_SKIP
- if (LOC) {
- RExC_size += ANYOF_ADD_LOC_SKIP;
- }
-#endif
listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
}
else {
RExC_emit += ANYOF_SKIP;
if (LOC) {
ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
-#ifdef ANYOF_ADD_LOC_SKIP
- RExC_emit += ANYOF_ADD_LOC_SKIP;
-#endif
}
ANYOF_BITMAP_ZERO(ret);
listsv = newSVpvs("# comment\n");
from earlier versions, OTOH that behaviour was broken
as well. */
UV v; /* value is register so we cant & it /grrr */
- if (reg_namedseq(pRExC_state, &v, NULL)) {
+ if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
goto parseit;
}
value= v;
break;
}
recode_encoding:
- {
+ if (! RExC_override_recoding) {
SV* enc = PL_encoding;
value = reg_recode((const char)(U8)value, &enc);
if (!enc && SIZE_ONLY)
if (LOC && namedclass < ANYOF_MAX && ! need_class) {
need_class = 1;
if (SIZE_ONLY) {
-#ifdef ANYOF_CLASS_ADD_SKIP
- RExC_size += ANYOF_CLASS_ADD_SKIP;
-#endif
+ RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
}
else {
-#ifdef ANYOF_CLASS_ADD_SKIP
- RExC_emit += ANYOF_CLASS_ADD_SKIP;
-#endif
+ RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
ANYOF_CLASS_ZERO(ret);
}
ANYOF_FLAGS(ret) |= ANYOF_CLASS;
* --jhi */
switch ((I32)namedclass) {
- case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
- case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
- case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
- case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
- case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
- case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
- case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
- case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
- case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
- case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
+ case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum", "XPosixAlnum");
+ case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha", "XPosixAlpha");
+ case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank", "XPosixBlank");
+ case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl", "XPosixCntrl");
+ case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph", "XPosixGraph");
+ case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower", "__XPosixLower_i");
+ case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint", "XPosixPrint");
+ case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace", "XPosixSpace");
+ case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct", "XPosixPunct");
+ case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper", "__XPosixUpper_i");
/* \s, \w match all unicode if utf8. */
- case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
- case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
- case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
+ case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl", "SpacePerl");
+ case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word", "Word");
+ case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit", "XPosixXDigit");
case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
case ANYOF_ASCII:
}
if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
/* Strings such as "+utf8::isWord\n" */
- Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
+ Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n", yesno, what);
}
continue;
}
else {
prevvalue = value; /* save the beginning of the range */
- if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
- RExC_parse[1] != ']') {
+ if (RExC_parse+1 < RExC_end
+ && *RExC_parse == '-'
+ && RExC_parse[1] != ']')
+ {
RExC_parse++;
/* a bad range like \w-, [:word:]- ? */
/* If folding and there are code points above 255, we calculate all
* characters that could fold to or from the ones already on the list */
if (FOLD && nonbitmap) {
- UV i;
+ UV start, end; /* End points of code point ranges */
- HV* fold_intersection;
- UV* fold_list;
+ SV* fold_intersection;
/* This is a list of all the characters that participate in folds
* (except marks, etc in multi-char folds */
* compilation of Perl itself before the Unicode tables are
* generated) */
if (invlist_len(PL_utf8_foldable) == 0) {
- PL_utf8_foldclosures = _new_invlist(0);
+ PL_utf8_foldclosures = newHV();
} else {
/* If the folds haven't been read in, call a fold function
* to force that */
if (! PL_utf8_tofold) {
U8 dummy[UTF8_MAXBYTES+1];
STRLEN dummy_len;
- to_utf8_fold((U8*) "A", dummy, &dummy_len);
+
+ /* This particular string is above \xff in both UTF-8 and
+ * UTFEBCDIC */
+ to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
+ assert(PL_utf8_tofold); /* Verify that worked */
}
PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
}
* be checked. Get the intersection of this class and all the
* possible characters that are foldable. This can quickly narrow
* down a large class */
- fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
+ _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
/* Now look at the foldable characters in this class individually */
- fold_list = invlist_array(fold_intersection);
- for (i = 0; i < invlist_len(fold_intersection); i++) {
+ invlist_iterinit(fold_intersection);
+ while (invlist_iternext(fold_intersection, &start, &end)) {
UV j;
- /* The next entry is the beginning of the range that is in the
- * class */
- UV start = fold_list[i++];
-
-
- /* The next entry is the beginning of the next range, which
- * isn't in the class, so the end of the current range is one
- * less than that */
- UV end = fold_list[i] - 1;
-
/* Look at every character in the range */
for (j = start; j <= end; j++) {
/* Get its fold */
U8 foldbuf[UTF8_MAXBYTES_CASE+1];
STRLEN foldlen;
- const UV f = to_uni_fold(j, foldbuf, &foldlen);
+ const UV f =
+ _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
if (foldlen > (STRLEN)UNISKIP(f)) {
add_alternate(&unicode_alternate, foldbuf, foldlen);
end_multi_fold: ;
}
+
+ /* This is special-cased, as it is the only letter which
+ * has both a multi-fold and single-fold in Latin1. All
+ * the other chars that have single and multi-folds are
+ * always in utf8, and the utf8 folding algorithm catches
+ * them */
+ if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
+ stored += set_regclass_bit(pRExC_state,
+ ret,
+ LATIN_SMALL_LETTER_SHARP_S,
+ &l1_fold_invlist, &unicode_alternate);
+ }
}
else {
/* Single character fold. Add everything in its fold
}
}
}
- invlist_destroy(fold_intersection);
+ SvREFCNT_dec(fold_intersection);
}
/* Combine the two lists into one. */
if (l1_fold_invlist) {
if (nonbitmap) {
- nonbitmap = invlist_union(nonbitmap, l1_fold_invlist);
+ _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
+ SvREFCNT_dec(l1_fold_invlist);
}
else {
nonbitmap = l1_fold_invlist;
* nothing like \w in it; some thought also would have to be given to the
* interaction with above 0x100 chars */
if (! LOC
- && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
+ && (ANYOF_FLAGS(ret) & ANYOF_INVERT)
&& ! unicode_alternate
- && ! nonbitmap
+ /* In case of /d, there are some things that should match only when in
+ * not in the bitmap, i.e., they require UTF8 to match. These are
+ * listed in nonbitmap. */
+ && (! nonbitmap
+ || ! DEPENDS_SEMANTICS
+ || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
&& SvCUR(listsv) == initial_listsv_len)
{
- for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
- ANYOF_BITMAP(ret)[value] ^= 0xFF;
+ if (! nonbitmap) {
+ for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
+ ANYOF_BITMAP(ret)[value] ^= 0xFF;
+ /* The inversion means that everything above 255 is matched */
+ ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
+ }
+ else {
+ /* Here, also has things outside the bitmap. Go through each bit
+ * individually and add it to the list to get rid of from those
+ * things not in the bitmap */
+ SV *remove_list = _new_invlist(2);
+ _invlist_invert(nonbitmap);
+ for (value = 0; value < 256; ++value) {
+ if (ANYOF_BITMAP_TEST(ret, value)) {
+ ANYOF_BITMAP_CLEAR(ret, value);
+ remove_list = add_cp_to_invlist(remove_list, value);
+ }
+ else {
+ ANYOF_BITMAP_SET(ret, value);
+ }
+ }
+ _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
+ SvREFCNT_dec(remove_list);
+ }
+
stored = 256 - stored;
- /* The inversion means that everything above 255 is matched; and at the
- * same time we clear the invert flag */
- ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
+ /* Clear the invert flag since have just done it here */
+ ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
}
/* Folding in the bitmap is taken care of above, but not for locale (for
else {
op = EXACT;
}
- } /* else 2 chars in the bit map: the folds of each other */
- else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
-
- /* To join adjacent nodes, they must be the exact EXACTish type.
- * Try to use the most likely type, by using EXACTFU if the regex
- * calls for them, or is required because the character is
- * non-ASCII */
- op = EXACTFU;
}
- else { /* Otherwise, more likely to be EXACTF type */
- op = EXACTF;
+ else { /* else 2 chars in the bit map: the folds of each other */
+
+ /* Use the folded value, which for the cases where we get here,
+ * is just the lower case of the current one (which may resolve to
+ * itself, or to the other one */
+ value = toLOWER_LATIN1(value);
+ if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
+
+ /* To join adjacent nodes, they must be the exact EXACTish
+ * type. Try to use the most likely type, by using EXACTFU if
+ * the regex calls for them, or is required because the
+ * character is non-ASCII */
+ op = EXACTFU;
+ }
+ else { /* Otherwise, more likely to be EXACTF type */
+ op = EXACTF;
+ }
}
ret = reg_node(pRExC_state, op);
}
if (nonbitmap) {
- UV* nonbitmap_array = invlist_array(nonbitmap);
- UV nonbitmap_len = invlist_len(nonbitmap);
- UV i;
-
- /* Here have the full list of items to match that aren't in the
- * bitmap. Convert to the structure that the rest of the code is
- * expecting. XXX That rest of the code should convert to this
- * structure */
- for (i = 0; i < nonbitmap_len; i++) {
-
- /* The next entry is the beginning of the range that is in the
- * class */
- UV start = nonbitmap_array[i++];
- UV end;
-
- /* The next entry is the beginning of the next range, which isn't
- * in the class, so the end of the current range is one less than
- * that. But if there is no next range, it means that the range
- * begun by 'start' extends to infinity, which for this platform
- * ends at UV_MAX */
- if (i == nonbitmap_len) {
- end = UV_MAX;
- }
- else {
- end = nonbitmap_array[i] - 1;
- }
-
+ UV start, end;
+ invlist_iterinit(nonbitmap);
+ while (invlist_iternext(nonbitmap, &start, &end)) {
if (start == end) {
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
}
start, end);
}
}
- invlist_destroy(nonbitmap);
+ SvREFCNT_dec(nonbitmap);
}
if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
* used later (regexec.c:S_reginclass()). */
av_store(av, 0, listsv);
av_store(av, 1, NULL);
- av_store(av, 2, MUTABLE_SV(unicode_alternate));
- if (unicode_alternate) { /* This node is variable length */
- OP(ret) = ANYOFV;
- }
+
+ /* Store any computed multi-char folds only if we are allowing
+ * them */
+ if (allow_full_fold) {
+ av_store(av, 2, MUTABLE_SV(unicode_alternate));
+ if (unicode_alternate) { /* This node is variable length */
+ OP(ret) = ANYOFV;
+ }
+ }
+ else {
+ av_store(av, 2, NULL);
+ }
rv = newRV_noinc(MUTABLE_SV(av));
n = add_data(pRExC_state, 1, "s");
RExC_rxi->data->data[n] = (void*)rv;
dVAR;
struct regexp *const r = (struct regexp *)SvANY(rx);
regexp_internal *reti;
- int len, npar;
+ int len;
RXi_GET_DECL(r,ri);
PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
- npar = r->nparens+1;
len = ProgLen(ri);
Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
https://perl5.git.perl.org / perl5.git / blobdiff