|= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
else
data->flags &= ~SF_FIX_BEFORE_EOL;
- data->minlen_fixed=minlenp;
+ data->minlen_fixed=minlenp;
data->lookbehind_fixed=0;
}
else { /* *data->longest == data->longest_float */
ANYOF_BITMAP_SETALL(cl);
cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
- |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL
- /* Even though no bitmap is in use here, we need to set
- * the flag below so an AND with a node that does have one
- * doesn't lose that one. The flag should get cleared if
- * the other one doesn't; and the code in regexec.c is
- * structured so this being set when not needed does no
- * harm. It seemed a little cleaner to set it here than do
- * a special case in cl_and() */
- |ANYOF_NONBITMAP_NON_UTF8;
+ |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
}
}
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;
}
}
scan += len; \
len = 0; \
} else { \
- uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
- uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
+ len = UTF8SKIP(uc);\
+ uvc = to_utf8_fold( uc, foldbuf, &foldlen); \
foldlen -= UNISKIP( uvc ); \
scan = foldbuf + UNISKIP( uvc ); \
} \
DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
"%*sCompiling trie using list compiler\n",
(int)depth * 2 + 2, ""));
-
+
trie->states = (reg_trie_state *)
PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
sizeof(reg_trie_state) );
}
#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
int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
int noff;
regnode *n = scan;
-
+
/* Skip NOTHING and LONGJMP. */
while ((n = regnext(n))
&& ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
next = regnext(scan);
code = OP(scan);
/* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
-
+
if (OP(next) == code || code == IFTHEN) {
/* NOTE - There is similar code to this block below for handling
TRIE nodes on a re-study. If you change stuff here check there
I32 max1 = 0, min1 = I32_MAX, num = 0;
struct regnode_charclass_class accum;
regnode * const startbranch=scan;
-
+
if (flags & SCF_DO_SUBSTR)
SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
if (flags & SCF_DO_STCLASS)
a nested if into a case structure of sorts.
*/
-
+
int made=0;
if (!re_trie_maxbuff) {
re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
}
} 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,
if ( last && TRIE_TYPE_IS_SAFE ) {
made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
-#ifdef TRIE_STUDY_OPT
+#ifdef TRIE_STUDY_OPT
if ( ((made == MADE_EXACT_TRIE &&
startbranch == first)
|| ( first_non_open == first )) &&
break;
CASE_SYNST_FNC(VERTWS);
CASE_SYNST_FNC(HORIZWS);
-
+
}
if (flags & SCF_DO_STCLASS_OR)
cl_and(data->start_class, and_withp);
flags &= ~SCF_DO_SUBSTR;
}
#endif /* old or new */
-#endif /* TRIE_STUDY_OPT */
+#endif /* TRIE_STUDY_OPT */
/* Else: zero-length, ignore. */
scan = regnext(scan);
struct regexp *r;
register regexp_internal *ri;
STRLEN plen;
- char *exp;
+ char* VOL 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);
* Clever compilers notice this and complain. --jhi */
REGC((U8)REG_MAGIC, (char*)RExC_emit);
#endif
- DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
+ DEBUG_PARSE_r(
+ PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
+ RExC_lastnum=0;
+ RExC_lastparse=NULL;
+ );
if (reg(pRExC_state, 0, &flags,1) == NULL) {
RExC_precomp = NULL;
return(NULL);
sawplus = 1;
else
first += regarglen[OP(first)];
-
+
first = NEXTOPER(first);
first_next= regnext(first);
}
else
ri->regstclass = first;
}
-#ifdef TRIE_STCLASS
+#ifdef TRIE_STCLASS
else if (PL_regkind[OP(first)] == TRIE &&
((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
{
make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
ri->regstclass = trie_op;
}
-#endif
+#endif
else if (REGNODE_SIMPLE(OP(first)))
ri->regstclass = first;
else if (PL_regkind[OP(first)] == BOUND ||
* it happens that c_offset_min has been invalidated, since the
* earlier string may buy us something the later one won't.]
*/
-
+
data.longest_fixed = newSVpvs("");
data.longest_float = newSVpvs("");
data.last_found = newSVpvs("");
&data, -1, NULL, NULL,
SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
-
+
CHECK_RESTUDY_GOTO;
I32 fake;
struct regnode_charclass_class ch_class;
I32 last_close = 0;
-
+
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
scan = ri->program + 1;
if (!retarray)
return ret;
} else {
- ret = newSVsv(&PL_sv_undef);
+ if (retarray)
+ ret = newSVsv(&PL_sv_undef);
}
if (retarray)
av_push(retarray, ret);
/* 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 whose index 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. If these fail, you probably didn't check for <len>
+ * being non-zero before trying to get the array */
+ 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 */
-
- SV** len_ptr = hv_fetchs(invlist, INVLIST_LEN_KEY, FALSE);
-
- PERL_ARGS_ASSERT_INVLIST_LEN;
+ /* Return the address of the UV that contains the current number
+ * of used elements in the inversion list */
- if (len_ptr == NULL) {
- Perl_croak(aTHX_ "panic: inversion list without a '%s' element",
- INVLIST_LEN_KEY);
- }
+ PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
- 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() */
+ /* Returns the current number of elements stored in the inversion list's
+ * array */
- SV** max_ptr = hv_fetchs(invlist, INVLIST_MAX_KEY, FALSE);
-
- PERL_ARGS_ASSERT_INVLIST_MAX;
-
- 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);
+ new_list = newSV(TO_INTERNAL_SIZE(initial_size));
+ invlist_set_len(new_list, 0);
- return invlist;
-}
-#endif
-
-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 ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
+#define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(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))
+ || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
{
Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
}
}
else {
/* But if the end is the maximum representable on the machine,
- * just let the range that this would extend have no end */
+ * just let the range that this would extend to have no end */
invlist_set_len(invlist, len - 1);
}
return;
* 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)
+STATIC IV
+S_invlist_search(pTHX_ SV* const invlist, const UV cp)
+{
+ /* Searches the inversion list for the entry that contains the input code
+ * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
+ * return value is the index into the list's array of the range that
+ * contains <cp> */
+
+ IV low = 0;
+ IV high = invlist_len(invlist);
+ const UV * const array = invlist_array(invlist);
+
+ PERL_ARGS_ASSERT_INVLIST_SEARCH;
+
+ /* If list is empty or the code point is before the first element, return
+ * failure. */
+ if (high == 0 || cp < array[0]) {
+ return -1;
+ }
+
+ /* Binary search. What we are looking for is <i> such that
+ * array[i] <= cp < array[i+1]
+ * The loop below converges on the i+1. */
+ while (low < high) {
+ IV mid = (low + high) / 2;
+ if (array[mid] <= cp) {
+ low = mid + 1;
+
+ /* We could do this extra test to exit the loop early.
+ if (cp < array[low]) {
+ return mid;
+ }
+ */
+ }
+ else { /* cp < array[mid] */
+ high = mid;
+ }
+ }
+
+ return high - 1;
+}
+
+void
+Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
+{
+ /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
+ * but is used when the swash has an inversion list. This makes this much
+ * faster, as it uses a binary search instead of a linear one. This is
+ * intimately tied to that function, and perhaps should be in utf8.c,
+ * except it is intimately tied to inversion lists as well. It assumes
+ * that <swatch> is all 0's on input */
+
+ UV current = start;
+ const IV len = invlist_len(invlist);
+ IV i;
+ const UV * array;
+
+ PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
+
+ if (len == 0) { /* Empty inversion list */
+ return;
+ }
+
+ array = invlist_array(invlist);
+
+ /* Find which element it is */
+ i = invlist_search(invlist, start);
+
+ /* We populate from <start> to <end> */
+ while (current < end) {
+ UV upper;
+
+ /* The inversion list gives the results for every possible code point
+ * after the first one in the list. Only those ranges whose index is
+ * even are ones that the inversion list matches. For the odd ones,
+ * and if the initial code point is not in the list, we have to skip
+ * forward to the next element */
+ if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
+ i++;
+ if (i >= len) { /* Finished if beyond the end of the array */
+ return;
+ }
+ current = array[i];
+ if (current >= end) { /* Finished if beyond the end of what we
+ are populating */
+ return;
+ }
+ }
+ assert(current >= start);
+
+ /* The current range ends one below the next one, except don't go past
+ * <end> */
+ i++;
+ upper = (i < len && array[i] < end) ? array[i] : end;
+
+ /* Here we are in a range that matches. Populate a bit in the 3-bit U8
+ * for each code point in it */
+ for (; current < upper; current++) {
+ const STRLEN offset = (STRLEN)(current - start);
+ swatch[offset >> 3] |= 1 << (offset & 7);
+ }
+
+ /* Quit if at the end of the list */
+ if (i >= len) {
+
+ /* But first, have to deal with the highest possible code point on
+ * the platform. The previous code assumes that <end> is one
+ * beyond where we want to populate, but that is impossible at the
+ * platform's infinity, so have to handle it specially */
+ if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
+ {
+ const STRLEN offset = (STRLEN)(end - start);
+ swatch[offset >> 3] |= 1 << (offset & 7);
+ }
+ return;
+ }
+
+ /* Advance to the next range, which will be for code points not in the
+ * inversion list */
+ current = array[i];
+ }
+
+ return;
+}
+
+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 <output> to it. *output
+ * should be defined upon input, and if it points to one of the two lists,
+ * the reference count to that list will be decremented.
* The 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;
+ assert(a != b);
+
+ /* 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);
+ }
+ 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);
+ }
+ 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 */
* be seamlessly merged. (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)))
+ || (array_a[i_a] == array_b[i_b]
+ && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
cp= array_a[i_a++];
}
else {
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
cp= array_b[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 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_RANGE_MATCHES_INVLIST(i_a))
+ || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(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. *i
+ * should be defined upon input, and if it points to one of the two lists,
+ * the reference count to that list will be decremented.
+ * The 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;
+ assert(a != b);
+
+ /* If either one is empty, the intersection is null */
+ len_a = invlist_len(a);
+ if ((len_a == 0) || ((len_b = invlist_len(b)) == 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);
+ }
+
+ *i = _new_invlist(0);
+ 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)))
+ || (array_a[i_a] == array_b[i_b]
+ && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
{
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
cp= array_a[i_a++];
}
else {
- cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
+ cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
cp= array_b[i_b++];
}
}
}
- /* 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_RANGE_MATCHES_INVLIST(i_a))
+ || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(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 */
+
+ /* Need to allocate extra space to accommodate Perl's addition of a
+ * trailing NUL to SvPV's, since it thinks they are always strings */
+ SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
+ STRLEN length = SvCUR(invlist);
+
+ PERL_ARGS_ASSERT_INVLIST_CLONE;
+
+ SvCUR_set(new_invlist, length); /* This isn't done automatically */
+ Copy(SvPVX(invlist), SvPVX(new_invlist), length, 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>. *result should be defined upon input, and
+ * if it points to C<b> its reference count will be decremented. */
+
+ PERL_ARGS_ASSERT__INVLIST_SUBTRACT;
+ assert(a != b);
+
+ /* Subtracting nothing retains the original */
+ if (invlist_len(b) == 0) {
+
+ if (*result == b) {
+ SvREFCNT_dec(b);
+ }
+
+ /* 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' */
+
+ if (*result == b) {
+ SvREFCNT_dec(b);
+ }
+
+ _invlist_intersection(a, b_copy, result); /* Everything in 'a' not in
+ 'b' */
+ SvREFCNT_dec(b_copy);
+ }
+
+ 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)
+{
+ /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
+ * This call sets in <*start> and <*end>, the next range in <invlist>.
+ * Returns <TRUE> if successful and the next call will return the next
+ * range; <FALSE> if was already at the end of the list. If the latter,
+ * <*start> and <*end> are unchanged, and the next call to this function
+ * will start over at the beginning of the list */
+
+ 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;
+}
+
+#ifndef PERL_IN_XSUB_RE
+SV *
+Perl__invlist_contents(pTHX_ SV* const invlist)
+{
+ /* Get the contents of an inversion list into a string SV so that they can
+ * be printed out. It uses the format traditionally done for debug tracing
+ */
+
+ UV start, end;
+ SV* output = newSVpvs("\n");
+
+ PERL_ARGS_ASSERT__INVLIST_CONTENTS;
+
+ invlist_iterinit(invlist);
+ while (invlist_iternext(invlist, &start, &end)) {
+ if (end == UV_MAX) {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
+ }
+ else if (end != start) {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
+ start, end);
+ }
+ else {
+ Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
+ }
+ }
+
+ return output;
+}
+#endif
+
+#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
RExC_parse++;
if (*RExC_parse!=')')
vFAIL("Expecting close bracket");
-
+
gen_recurse_regop:
if ( paren == '-' ) {
/*
RExC_parse++;
}
if (*RExC_parse != ')') {
- RExC_parse = s;
+ RExC_parse = s;
vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
}
if (!SIZE_ONLY) {
|| RExC_parse[1] == '<'
|| RExC_parse[1] == '{') { /* Lookahead or eval. */
I32 flag;
-
+
ret = reg_node(pRExC_state, LOGICAL);
if (!SIZE_ONLY)
ret->flags = 1;
{
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)) {
Set_Node_Length(ret, 1);
}
}
-
+
if (!first && SIZE_ONLY)
RExC_extralen += 1; /* BRANCHJ */
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);
break;
case 'p':
case 'P':
- {
+ {
char* const oldregxend = RExC_end;
#ifdef DEBUGGING
char* parse_start = RExC_parse - 2;
case 'x':
if (*++p == '{') {
char* const e = strchr(p, '}');
-
+
if (!e) {
RExC_parse = p + 1;
vFAIL("Missing right brace on \\x{}");
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;
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) {
}
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) {
break;
/* These are the tricky fold characters. Flush any
- * buffer first. */
+ * 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:
- case 0x1FE3:
+ 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;
*flagp |= HASWIDTH;
if (len == 1 && UNI_IS_INVARIANT(ender))
*flagp |= SIMPLE;
-
+
if (SIZE_ONLY)
RExC_size += STR_SZ(len);
else {
POSIXCC(UCHARAT(RExC_parse))) {
const char c = UCHARAT(RExC_parse);
char* const s = RExC_parse++;
-
+
while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
RExC_parse++;
if (RExC_parse == RExC_end)
}
}
-/* 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.
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. */
+ SV* properties = NULL; /* Code points that match \p{} \P{} */
+ UV element_count = 0; /* Number of distinct elements in the class.
+ Optimizations may be possible if this is tiny */
UV n;
+ /* Unicode properties are stored in a swash; this holds the current one
+ * being parsed. If this swash is the only above-latin1 component of the
+ * character class, an optimization is to pass it directly on to the
+ * execution engine. Otherwise, it is set to NULL to indicate that there
+ * are other things in the class that have to be dealt with at execution
+ * time */
+ SV* swash = NULL; /* Code points that match \p{} \P{} */
+
+ /* Set if a component of this character class is user-defined; just passed
+ * on to the engine */
+ UV has_user_defined_property = 0;
+
/* 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) {
namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
- if (!range)
+ if (!range) {
rangebegin = RExC_parse;
+ element_count++;
+ }
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
RExC_end - RExC_parse,
n = 1;
}
if (!SIZE_ONLY) {
+ SV** invlistsvp;
+ SV* invlist;
+ char* name;
if (UCHARAT(RExC_parse) == '^') {
RExC_parse++;
n--;
n--;
}
}
+ /* 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 */
+ Newx(name, n + sizeof("_i__\n"), char);
+
+ sprintf(name, "%s%.*s%s\n",
+ (FOLD) ? "__" : "",
+ (int)n,
+ RExC_parse,
+ (FOLD) ? "_i" : ""
+ );
+
+ /* Look up the property name, and get its swash and
+ * inversion list, if the property is found */
+ if (swash) {
+ SvREFCNT_dec(swash);
+ }
+ swash = _core_swash_init("utf8", name, &PL_sv_undef,
+ 1, /* binary */
+ 0, /* not tr/// */
+ TRUE, /* this routine will handle
+ undefined properties */
+ NULL, FALSE /* No inversion list */
+ );
+ if ( ! swash
+ || ! SvROK(swash)
+ || ! SvTYPE(SvRV(swash)) == SVt_PVHV
+ || ! (invlistsvp =
+ hv_fetchs(MUTABLE_HV(SvRV(swash)),
+ "INVLIST", FALSE))
+ || ! (invlist = *invlistsvp))
+ {
+ if (swash) {
+ SvREFCNT_dec(swash);
+ swash = NULL;
+ }
+
+ /* Here didn't find it. It could be a user-defined
+ * property that will be available at run-time. Add it
+ * to the list to look up then */
+ Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
+ (value == 'p' ? '+' : '!'),
+ name);
+ has_user_defined_property = 1;
+
+ /* We don't know yet, so have to assume that the
+ * property could match something in the Latin1 range,
+ * hence something that isn't utf8 */
+ ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
+ }
+ else {
+
+ /* 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 */
+ SV** user_defined_svp =
+ hv_fetchs(MUTABLE_HV(SvRV(swash)),
+ "USER_DEFINED", FALSE);
+ if (user_defined_svp) {
+ has_user_defined_property
+ |= SvUV(*user_defined_svp);
+ }
- /* Add the property name to the list. If /i matching, give
- * a different name which consists of the normal name
- * sandwiched between two underscores and '_i'. The design
- * is discussed in the commit message for this. */
- Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
- (value=='p' ? '+' : '!'),
- (FOLD) ? "__" : "",
- (int)n,
- RExC_parse,
- (FOLD) ? "_i" : ""
- );
+ /* Invert if asking for the complement */
+ if (value == 'P') {
+
+ /* Add to any existing list */
+ if (! properties) {
+ properties = invlist_clone(invlist);
+ _invlist_invert(properties);
+ }
+ else {
+ invlist = invlist_clone(invlist);
+ _invlist_invert(invlist);
+ _invlist_union(properties, invlist, &properties);
+ SvREFCNT_dec(invlist);
+ }
+
+ /* The swash can't be used as-is, because we've
+ * inverted things; delay removing it to here after
+ * have copied its invlist above */
+ SvREFCNT_dec(swash);
+ swash = NULL;
+ }
+ else {
+ if (! properties) {
+ properties = invlist_clone(invlist);
+ }
+ else {
+ _invlist_union(properties, invlist, &properties);
+ }
+ }
+ }
+ Safefree(name);
}
RExC_parse = e + 1;
-
- /* The \p could match something in the Latin1 range, hence
- * something that isn't utf8 */
- ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
namedclass = ANYOF_MAX; /* no official name, but it's named */
/* \p means they want Unicode semantics */
range = 0; /* this was not a true range */
}
-
-
if (!SIZE_ONLY) {
const char *what = NULL;
char yesno = 0;
* --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;
/* 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 = NULL;
/* This is a list of all the characters that participate in folds
* (except marks, etc in multi-char folds */
if (! PL_utf8_foldable) {
SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
PL_utf8_foldable = _swash_to_invlist(swash);
+ SvREFCNT_dec(swash);
}
/* This is a hash that for a particular fold gives all characters
* 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);
}
}
- /* Only the characters in this class that participate in folds need
- * 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);
+ /* Only the characters in this class that participate in folds need be
+ * checked. Get the intersection of this class and all the possible
+ * characters that are foldable. This can quickly narrow down a large
+ * class */
+ _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)) {
- /* Any multicharacter foldings (disallowed in
- * lookbehind patterns) require the following
- * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
- * E folds into "pq" and F folds into "rst", all other
- * characters fold to single characters. We save away
- * these multicharacter foldings, to be later saved as
- * part of the additional "s" data. */
+ /* Any multicharacter foldings (disallowed in lookbehind
+ * patterns) require the following transform: [ABCDEF] ->
+ * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
+ * folds into "rst", all other characters fold to single
+ * characters. We save away these multicharacter foldings,
+ * to be later saved as part of the additional "s" data. */
if (! RExC_in_lookbehind) {
U8* loc = foldbuf;
U8* e = foldbuf + foldlen;
- /* If any of the folded characters of this are in
- * the Latin1 range, tell the regex engine that
- * this can match a non-utf8 target string. The
- * only multi-byte fold whose source is in the
- * Latin1 range (U+00DF) applies only when the
- * target string is utf8, or under unicode rules */
+ /* If any of the folded characters of this are in the
+ * Latin1 range, tell the regex engine that this can
+ * match a non-utf8 target string. The only multi-byte
+ * fold whose source is in the Latin1 range (U+00DF)
+ * applies only when the target string is utf8, or
+ * under unicode rules */
if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
while (loc < e) {
if (UTF8_IS_INVARIANT(*loc)
|| UTF8_IS_DOWNGRADEABLE_START(*loc))
{
- /* Can't mix above and below 256 under
- * LOC */
+ /* Can't mix above and below 256 under LOC
+ */
if (LOC) {
goto end_multi_fold;
}
}
else {
/* Single character fold. Add everything in its fold
- * closure to the list that this node should match */
+ * closure to the list that this node should match */
SV** listp;
- /* The fold closures data structure is a hash with the
- * keys being every character that is folded to, like
- * 'k', and the values each an array of everything that
- * folds to its key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
+ /* The fold closures data structure is a hash with the keys
+ * being every character that is folded to, like 'k', and
+ * the values each an array of everything that folds to its
+ * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
if ((listp = hv_fetch(PL_utf8_foldclosures,
(char *) foldbuf, foldlen, FALSE)))
{
}
c = SvUV(*c_p);
- /* /aa doesn't allow folds between ASCII and
- * non-; /l doesn't allow them between above
- * and below 256 */
+ /* /aa doesn't allow folds between ASCII and non-;
+ * /l doesn't allow them between above and below
+ * 256 */
if ((MORE_ASCII_RESTRICTED
&& (isASCII(c) != isASCII(j)))
|| (LOC && ((c < 256) != (j < 256))))
(U8) c,
&l1_fold_invlist, &unicode_alternate);
}
- /* It may be that the code point is already
- * in this range or already in the bitmap,
- * in which case we need do nothing */
+ /* It may be that the code point is already in
+ * this range or already in the bitmap, in
+ * which case we need do nothing */
else if ((c < start || c > end)
&& (c > 255
|| ! ANYOF_BITMAP_TEST(ret, c)))
}
}
}
- 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;
}
}
+ /* And combine the result (if any) with any inversion list from properties.
+ * The lists are kept separate up to now because we don't want to fold the
+ * properties */
+ if (properties) {
+ if (nonbitmap) {
+ _invlist_union(nonbitmap, properties, &nonbitmap);
+ SvREFCNT_dec(properties);
+ }
+ else {
+ nonbitmap = properties;
+ }
+ }
+
+ /* Here, <nonbitmap> contains all the code points we can determine at
+ * compile time that we haven't put into the bitmap. Go through it, and
+ * for things that belong in the bitmap, put them there, and delete from
+ * <nonbitmap> */
+ if (nonbitmap) {
+
+ /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
+ * possibly only should match when the target string is UTF-8 */
+ UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
+
+ /* This gets set if we actually need to modify things */
+ bool change_invlist = FALSE;
+
+ UV start, end;
+
+ /* Start looking through <nonbitmap> */
+ invlist_iterinit(nonbitmap);
+ while (invlist_iternext(nonbitmap, &start, &end)) {
+ UV high;
+ int i;
+
+ /* Quit if are above what we should change */
+ if (start > max_cp_to_set) {
+ break;
+ }
+
+ change_invlist = TRUE;
+
+ /* Set all the bits in the range, up to the max that we are doing */
+ high = (end < max_cp_to_set) ? end : max_cp_to_set;
+ for (i = start; i <= (int) high; i++) {
+ if (! ANYOF_BITMAP_TEST(ret, i)) {
+ ANYOF_BITMAP_SET(ret, i);
+ stored++;
+ prevvalue = value;
+ value = i;
+ }
+ }
+ }
+
+ /* Done with loop; set <nonbitmap> to not include any code points that
+ * are in the bitmap */
+ if (change_invlist) {
+ SV* keep_list = _new_invlist(2);
+ _append_range_to_invlist(keep_list, max_cp_to_set + 1, UV_MAX);
+ _invlist_intersection(nonbitmap, keep_list, &nonbitmap);
+ SvREFCNT_dec(keep_list);
+ }
+
+ /* If have completely emptied it, remove it completely */
+ if (invlist_len(nonbitmap) == 0) {
+ SvREFCNT_dec(nonbitmap);
+ nonbitmap = NULL;
+ }
+ }
+
/* Here, we have calculated what code points should be in the character
- * class. Now we can see about various optimizations. Fold calculation
- * needs to take place before inversion. Otherwise /[^k]/i would invert to
- * include K, which under /i would match k. */
+ * class. <nonbitmap> does not overlap the bitmap except possibly in the
+ * case of DEPENDS rules.
+ *
+ * Now we can see about various optimizations. Fold calculation (which we
+ * did above) needs to take place before inversion. Otherwise /[^k]/i
+ * would invert to include K, which under /i would match k, which it
+ * shouldn't. */
/* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
- * set the FOLD flag yet, so this this does optimize those. It doesn't
+ * set the FOLD flag yet, so this does optimize those. It doesn't
* optimize locale. Doing so perhaps could be done as long as there is
* 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
+ if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
+ && ! LOC
&& ! 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, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
+ * case, they don't require UTF8, so can invert here */
+ && (! 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;
+ int i;
+ if (! nonbitmap) {
+ for (i = 0; i < 256; ++i) {
+ if (ANYOF_BITMAP_TEST(ret, i)) {
+ ANYOF_BITMAP_CLEAR(ret, i);
+ }
+ else {
+ ANYOF_BITMAP_SET(ret, i);
+ prevvalue = value;
+ value = i;
+ }
+ }
+ /* The inversion means that everything above 255 is matched */
+ ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
+ }
+ else {
+ /* Here, also has things outside the bitmap that may overlap with
+ * the bitmap. We have to sync them up, so that they get inverted
+ * in both places. Earlier, we removed all overlaps except in the
+ * case of /d rules, so no syncing is needed except for this case
+ */
+ SV *remove_list = NULL;
+
+ if (DEPENDS_SEMANTICS) {
+ UV start, end;
+
+ /* Set the bits that correspond to the ones that aren't in the
+ * bitmap. Otherwise, when we invert, we'll miss these.
+ * Earlier, we removed from the nonbitmap all code points
+ * < 128, so there is no extra work here */
+ invlist_iterinit(nonbitmap);
+ while (invlist_iternext(nonbitmap, &start, &end)) {
+ if (start > 255) { /* The bit map goes to 255 */
+ break;
+ }
+ if (end > 255) {
+ end = 255;
+ }
+ for (i = start; i <= (int) end; ++i) {
+ ANYOF_BITMAP_SET(ret, i);
+ prevvalue = value;
+ value = i;
+ }
+ }
+ }
+
+ /* Now invert both the bitmap and the nonbitmap. Anything in the
+ * bitmap has to also be removed from the non-bitmap, but again,
+ * there should not be overlap unless is /d rules. */
+ _invlist_invert(nonbitmap);
+
+ for (i = 0; i < 256; ++i) {
+ if (ANYOF_BITMAP_TEST(ret, i)) {
+ ANYOF_BITMAP_CLEAR(ret, i);
+ if (DEPENDS_SEMANTICS) {
+ if (! remove_list) {
+ remove_list = _new_invlist(2);
+ }
+ remove_list = add_cp_to_invlist(remove_list, i);
+ }
+ }
+ else {
+ ANYOF_BITMAP_SET(ret, i);
+ prevvalue = value;
+ value = i;
+ }
+ }
+
+ /* And do the removal */
+ if (DEPENDS_SEMANTICS) {
+ if (remove_list) {
+ _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
+ SvREFCNT_dec(remove_list);
+ }
+ }
+ else {
+ /* There is no overlap for non-/d, so just delete anything
+ * below 256 */
+ SV* keep_list = _new_invlist(2);
+ _append_range_to_invlist(keep_list, 256, UV_MAX);
+ _invlist_intersection(nonbitmap, keep_list, &nonbitmap);
+ SvREFCNT_dec(keep_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
* which we have to wait to see what folding is in effect at runtime), and
- * for things not in the bitmap. Set run-time fold flag for these */
- if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
+ * for some things not in the bitmap (only the upper latin folds in this
+ * case, as all other single-char folding has been set above). Set
+ * run-time fold flag for these */
+ if (FOLD && (LOC
+ || (DEPENDS_SEMANTICS
+ && nonbitmap
+ && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
+ || unicode_alternate))
+ {
ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
}
else {
op = EXACT;
}
- } /* else 2 chars in the bit map: the folds of each other */
- else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
+ }
+ 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);
/* 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;
+ * Try to use the most likely type, by using EXACTFA if possible,
+ * then EXACTFU if the regex calls for it, or is required because
+ * the character is non-ASCII. (If <value> is ASCII, its fold is
+ * also ASCII for the cases where we get here.) */
+ if (MORE_ASCII_RESTRICTED && isASCII(value)) {
+ op = EXACTFA;
+ }
+ else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
+ op = EXACTFU;
+ }
+ else { /* Otherwise, more likely to be EXACTF type */
+ op = EXACTF;
+ }
}
ret = reg_node(pRExC_state, op);
return ret;
}
- 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;
- }
-
- if (start == end) {
- Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
- }
- else {
- /* The \t sets the whole range */
- Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
- /* XXX EBCDIC */
- start, end);
- }
- }
- invlist_destroy(nonbitmap);
+ /* If there is a swash and more than one element, we can't use the swash in
+ * the optimization below. */
+ if (swash && element_count > 1) {
+ SvREFCNT_dec(swash);
+ swash = NULL;
}
-
- if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
+ if (! nonbitmap
+ && SvCUR(listsv) == initial_listsv_len
+ && ! unicode_alternate)
+ {
ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
SvREFCNT_dec(listsv);
SvREFCNT_dec(unicode_alternate);
}
else {
-
+ /* av[0] stores the character class description in its textual form:
+ * used later (regexec.c:Perl_regclass_swash()) to initialize the
+ * appropriate swash, and is also useful for dumping the regnode.
+ * av[1] if NULL, is a placeholder to later contain the swash computed
+ * from av[0]. But if no further computation need be done, the
+ * swash is stored there now.
+ * av[2] stores the multicharacter foldings, used later in
+ * regexec.c:S_reginclass().
+ * av[3] stores the nonbitmap inversion list for use in addition or
+ * instead of av[0]; not used if av[1] isn't NULL
+ * av[4] is set if any component of the class is from a user-defined
+ * property; not used if av[1] isn't NULL */
AV * const av = newAV();
SV *rv;
- /* The 0th element stores the character class description
- * in its textual form: used later (regexec.c:Perl_regclass_swash())
- * to initialize the appropriate swash (which gets stored in
- * the 1st element), and also useful for dumping the regnode.
- * The 2nd element stores the multicharacter foldings,
- * 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;
+
+ av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
+ ? &PL_sv_undef
+ : listsv);
+ if (swash) {
+ av_store(av, 1, swash);
+ SvREFCNT_dec(nonbitmap);
}
+ else {
+ av_store(av, 1, NULL);
+ if (nonbitmap) {
+ av_store(av, 3, nonbitmap);
+ av_store(av, 4, newSVuv(has_user_defined_property));
+ }
+ }
+
+ /* 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;
PERL_ARGS_ASSERT_NEXTCHAR;
for (;;) {
- if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
- RExC_parse[2] == '#') {
+ if (RExC_end - RExC_parse >= 3
+ && *RExC_parse == '('
+ && RExC_parse[1] == '?'
+ && RExC_parse[2] == '#')
+ {
while (*RExC_parse != ')') {
if (RExC_parse == RExC_end)
FAIL("Sequence (?#... not terminated");
We can't do this:
assert(2==regarglen[op]+1);
-
+
Anything larger than this has to allocate the extra amount.
If we changed this to be:
Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
if (flags & ANYOF_INVERT)
sv_catpvs(sv, "^");
-
+
/* output what the standard cp 0-255 bitmap matches */
for (i = 0; i <= 256; i++) {
if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
sv_catpvs(sv, "{outside bitmap}");
if (ANYOF_NONBITMAP(o)) {
- SV *lv;
+ SV *lv; /* Set if there is something outside the bit map */
SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
-
- if (lv) {
+ bool byte_output = FALSE; /* If something in the bitmap has been
+ output */
+
+ if (lv && lv != &PL_sv_undef) {
if (sw) {
U8 s[UTF8_MAXBYTES_CASE+1];
- for (i = 0; i <= 256; i++) { /* just the first 256 */
+ for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
uvchr_to_utf8(s, i);
-
- if (i < 256 && swash_fetch(sw, s, TRUE)) {
+
+ if (i < 256
+ && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
+ things already
+ output as part
+ of the bitmap */
+ && swash_fetch(sw, s, TRUE))
+ {
if (rangestart == -1)
rangestart = i;
} else if (rangestart != -1) {
+ byte_output = TRUE;
if (i <= rangestart + 3)
for (; rangestart < i; rangestart++) {
- const U8 * const e = uvchr_to_utf8(s,rangestart);
- U8 *p;
- for(p = s; p < e; p++)
- put_byte(sv, *p);
+ put_byte(sv, rangestart);
}
else {
- const U8 *e = uvchr_to_utf8(s,rangestart);
- U8 *p;
- for (p = s; p < e; p++)
- put_byte(sv, *p);
+ put_byte(sv, rangestart);
sv_catpvs(sv, "-");
- e = uvchr_to_utf8(s, i-1);
- for (p = s; p < e; p++)
- put_byte(sv, *p);
- }
- rangestart = -1;
+ put_byte(sv, i-1);
}
+ rangestart = -1;
}
-
- sv_catpvs(sv, "..."); /* et cetera */
+ }
}
{
char *s = savesvpv(lv);
char * const origs = s;
-
+
while (*s && *s != '\n')
s++;
-
+
if (*s == '\n') {
const char * const t = ++s;
-
+
+ if (byte_output) {
+ sv_catpvs(sv, " ");
+ }
+
while (*s) {
- if (*s == '\n')
+ if (*s == '\n') {
+
+ /* Truncate very long output */
+ if (s - origs > 256) {
+ Perl_sv_catpvf(aTHX_ sv,
+ "%.*s...",
+ (int) (s - origs - 1),
+ t);
+ goto out_dump;
+ }
*s = ' ';
+ }
+ else if (*s == '\t') {
+ *s = '-';
+ }
s++;
}
if (s[-1] == ' ')
s[-1] = 0;
-
+
sv_catpv(sv, t);
}
-
+
+ out_dump:
+
Safefree(origs);
}
+ SvREFCNT_dec(lv);
}
}
1: a buffer in a different thread
2: something we no longer hold a reference on
so we need to copy it locally. */
- /* Note we need to sue SvCUR() on our mother_re, because it, in
+ /* Note we need to use SvCUR(), rather than
+ SvLEN(), on our mother_re, because it, in
turn, may well be pointing to its own mother_re. */
SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
SvCUR(ret->mother_re)+1));
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);
}
#endif
-STATIC void
+STATIC void
S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
{
va_list args;
goto after_print;
} else
CLEAR_OPTSTART;
-
+
regprop(r, sv, node);
PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
(int)(2*indent + 1), "", SvPVX_const(sv));
sv_setpvs(sv, "");
for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
-
+
PerlIO_printf(Perl_debug_log, "%*s%s ",
(int)(2*(indent+3)), "",
elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
https://perl5.git.perl.org / perl5.git / blobdiff