This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5.26.2 today
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 EXTERN_C const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_inline.h"
90 #include "invlist_inline.h"
91 #include "unicode_constants.h"
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
94  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
96  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
97 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
98 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99
100 #ifndef STATIC
101 #define STATIC  static
102 #endif
103
104 /* this is a chain of data about sub patterns we are processing that
105    need to be handled separately/specially in study_chunk. Its so
106    we can simulate recursion without losing state.  */
107 struct scan_frame;
108 typedef struct scan_frame {
109     regnode *last_regnode;      /* last node to process in this frame */
110     regnode *next_regnode;      /* next node to process when last is reached */
111     U32 prev_recursed_depth;
112     I32 stopparen;              /* what stopparen do we use */
113
114     struct scan_frame *this_prev_frame; /* this previous frame */
115     struct scan_frame *prev_frame;      /* previous frame */
116     struct scan_frame *next_frame;      /* next frame */
117 } scan_frame;
118
119 /* Certain characters are output as a sequence with the first being a
120  * backslash. */
121 #define isBACKSLASHED_PUNCT(c)  strchr("-[]\\^", c)
122
123
124 struct RExC_state_t {
125     U32         flags;                  /* RXf_* are we folding, multilining? */
126     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
127     char        *precomp;               /* uncompiled string. */
128     char        *precomp_end;           /* pointer to end of uncompiled string. */
129     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
130     regexp      *rx;                    /* perl core regexp structure */
131     regexp_internal     *rxi;           /* internal data for regexp object
132                                            pprivate field */
133     char        *start;                 /* Start of input for compile */
134     char        *end;                   /* End of input for compile */
135     char        *parse;                 /* Input-scan pointer. */
136     char        *adjusted_start;        /* 'start', adjusted.  See code use */
137     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
138     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
139     regnode     *emit_start;            /* Start of emitted-code area */
140     regnode     *emit_bound;            /* First regnode outside of the
141                                            allocated space */
142     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
143                                            implies compiling, so don't emit */
144     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
145                                            large enough for the largest
146                                            non-EXACTish node, so can use it as
147                                            scratch in pass1 */
148     I32         naughty;                /* How bad is this pattern? */
149     I32         sawback;                /* Did we see \1, ...? */
150     U32         seen;
151     SSize_t     size;                   /* Code size. */
152     I32         npar;                   /* Capture buffer count, (OPEN) plus
153                                            one. ("par" 0 is the whole
154                                            pattern)*/
155     I32         nestroot;               /* root parens we are in - used by
156                                            accept */
157     I32         extralen;
158     I32         seen_zerolen;
159     regnode     **open_parens;          /* pointers to open parens */
160     regnode     **close_parens;         /* pointers to close parens */
161     regnode     *end_op;                /* END node in program */
162     I32         utf8;           /* whether the pattern is utf8 or not */
163     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
164                                 /* XXX use this for future optimisation of case
165                                  * where pattern must be upgraded to utf8. */
166     I32         uni_semantics;  /* If a d charset modifier should use unicode
167                                    rules, even if the pattern is not in
168                                    utf8 */
169     HV          *paren_names;           /* Paren names */
170
171     regnode     **recurse;              /* Recurse regops */
172     I32                recurse_count;                /* Number of recurse regops we have generated */
173     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
174                                            through */
175     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
176     I32         in_lookbehind;
177     I32         contains_locale;
178     I32         override_recoding;
179 #ifdef EBCDIC
180     I32         recode_x_to_native;
181 #endif
182     I32         in_multi_char_class;
183     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
184                                             within pattern */
185     int         code_index;             /* next code_blocks[] slot */
186     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
187     scan_frame *frame_head;
188     scan_frame *frame_last;
189     U32         frame_count;
190     AV         *warn_text;
191 #ifdef ADD_TO_REGEXEC
192     char        *starttry;              /* -Dr: where regtry was called. */
193 #define RExC_starttry   (pRExC_state->starttry)
194 #endif
195     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
196 #ifdef DEBUGGING
197     const char  *lastparse;
198     I32         lastnum;
199     AV          *paren_name_list;       /* idx -> name */
200     U32         study_chunk_recursed_count;
201     SV          *mysv1;
202     SV          *mysv2;
203 #define RExC_lastparse  (pRExC_state->lastparse)
204 #define RExC_lastnum    (pRExC_state->lastnum)
205 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
206 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
207 #define RExC_mysv       (pRExC_state->mysv1)
208 #define RExC_mysv1      (pRExC_state->mysv1)
209 #define RExC_mysv2      (pRExC_state->mysv2)
210
211 #endif
212     bool        seen_unfolded_sharp_s;
213     bool        strict;
214     bool        study_started;
215     bool        in_script_run;
216 };
217
218 #define RExC_flags      (pRExC_state->flags)
219 #define RExC_pm_flags   (pRExC_state->pm_flags)
220 #define RExC_precomp    (pRExC_state->precomp)
221 #define RExC_precomp_adj (pRExC_state->precomp_adj)
222 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
223 #define RExC_precomp_end (pRExC_state->precomp_end)
224 #define RExC_rx_sv      (pRExC_state->rx_sv)
225 #define RExC_rx         (pRExC_state->rx)
226 #define RExC_rxi        (pRExC_state->rxi)
227 #define RExC_start      (pRExC_state->start)
228 #define RExC_end        (pRExC_state->end)
229 #define RExC_parse      (pRExC_state->parse)
230 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
231
232 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
233  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
234  * something forces the pattern into using /ui rules, the sharp s should be
235  * folded into the sequence 'ss', which takes up more space than previously
236  * calculated.  This means that the sizing pass needs to be restarted.  (The
237  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
238  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
239  * so there is no need to resize [perl #125990]. */
240 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
241
242 #ifdef RE_TRACK_PATTERN_OFFSETS
243 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
244                                                          others */
245 #endif
246 #define RExC_emit       (pRExC_state->emit)
247 #define RExC_emit_dummy (pRExC_state->emit_dummy)
248 #define RExC_emit_start (pRExC_state->emit_start)
249 #define RExC_emit_bound (pRExC_state->emit_bound)
250 #define RExC_sawback    (pRExC_state->sawback)
251 #define RExC_seen       (pRExC_state->seen)
252 #define RExC_size       (pRExC_state->size)
253 #define RExC_maxlen        (pRExC_state->maxlen)
254 #define RExC_npar       (pRExC_state->npar)
255 #define RExC_nestroot   (pRExC_state->nestroot)
256 #define RExC_extralen   (pRExC_state->extralen)
257 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
258 #define RExC_utf8       (pRExC_state->utf8)
259 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
260 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
261 #define RExC_open_parens        (pRExC_state->open_parens)
262 #define RExC_close_parens       (pRExC_state->close_parens)
263 #define RExC_end_op     (pRExC_state->end_op)
264 #define RExC_paren_names        (pRExC_state->paren_names)
265 #define RExC_recurse    (pRExC_state->recurse)
266 #define RExC_recurse_count      (pRExC_state->recurse_count)
267 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
268 #define RExC_study_chunk_recursed_bytes  \
269                                    (pRExC_state->study_chunk_recursed_bytes)
270 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
271 #define RExC_contains_locale    (pRExC_state->contains_locale)
272 #ifdef EBCDIC
273 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
274 #endif
275 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
276 #define RExC_frame_head (pRExC_state->frame_head)
277 #define RExC_frame_last (pRExC_state->frame_last)
278 #define RExC_frame_count (pRExC_state->frame_count)
279 #define RExC_strict (pRExC_state->strict)
280 #define RExC_study_started      (pRExC_state->study_started)
281 #define RExC_warn_text (pRExC_state->warn_text)
282 #define RExC_in_script_run      (pRExC_state->in_script_run)
283
284 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
285  * a flag to disable back-off on the fixed/floating substrings - if it's
286  * a high complexity pattern we assume the benefit of avoiding a full match
287  * is worth the cost of checking for the substrings even if they rarely help.
288  */
289 #define RExC_naughty    (pRExC_state->naughty)
290 #define TOO_NAUGHTY (10)
291 #define MARK_NAUGHTY(add) \
292     if (RExC_naughty < TOO_NAUGHTY) \
293         RExC_naughty += (add)
294 #define MARK_NAUGHTY_EXP(exp, add) \
295     if (RExC_naughty < TOO_NAUGHTY) \
296         RExC_naughty += RExC_naughty / (exp) + (add)
297
298 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
299 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
300         ((*s) == '{' && regcurly(s)))
301
302 /*
303  * Flags to be passed up and down.
304  */
305 #define WORST           0       /* Worst case. */
306 #define HASWIDTH        0x01    /* Known to match non-null strings. */
307
308 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
309  * character.  (There needs to be a case: in the switch statement in regexec.c
310  * for any node marked SIMPLE.)  Note that this is not the same thing as
311  * REGNODE_SIMPLE */
312 #define SIMPLE          0x02
313 #define SPSTART         0x04    /* Starts with * or + */
314 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
315 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
316 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
317 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
318                                    calcuate sizes as UTF-8 */
319
320 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
321
322 /* whether trie related optimizations are enabled */
323 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
324 #define TRIE_STUDY_OPT
325 #define FULL_TRIE_STUDY
326 #define TRIE_STCLASS
327 #endif
328
329
330
331 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
332 #define PBITVAL(paren) (1 << ((paren) & 7))
333 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
334 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
335 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
336
337 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
338                                      if (!UTF) {                           \
339                                          assert(PASS1);                    \
340                                          *flagp = RESTART_PASS1|NEED_UTF8; \
341                                          return NULL;                      \
342                                      }                                     \
343                              } STMT_END
344
345 /* Change from /d into /u rules, and restart the parse if we've already seen
346  * something whose size would increase as a result, by setting *flagp and
347  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
348  * we've changed to /u during the parse.  */
349 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
350     STMT_START {                                                            \
351             if (DEPENDS_SEMANTICS) {                                        \
352                 assert(PASS1);                                              \
353                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
354                 RExC_uni_semantics = 1;                                     \
355                 if (RExC_seen_unfolded_sharp_s) {                           \
356                     *flagp |= RESTART_PASS1;                                \
357                     return restart_retval;                                  \
358                 }                                                           \
359             }                                                               \
360     } STMT_END
361
362 /* Executes a return statement with the value 'X', if 'flags' contains any of
363  * 'RESTART_PASS1', 'NEED_UTF8', or 'extra'.  If so, *flagp is set to those
364  * flags */
365 #define RETURN_X_ON_RESTART_OR_FLAGS(X, flags, flagp, extra)                \
366     STMT_START {                                                            \
367             if ((flags) & (RESTART_PASS1|NEED_UTF8|(extra))) {              \
368                 *(flagp) = (flags) & (RESTART_PASS1|NEED_UTF8|(extra));     \
369                 return X;                                                   \
370             }                                                               \
371     } STMT_END
372
373 #define RETURN_NULL_ON_RESTART_OR_FLAGS(flags,flagp,extra)                  \
374                     RETURN_X_ON_RESTART_OR_FLAGS(NULL,flags,flagp,extra)
375
376 #define RETURN_X_ON_RESTART(X, flags,flagp)                                 \
377                         RETURN_X_ON_RESTART_OR_FLAGS( X, flags, flagp, 0)
378
379
380 #define RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,extra)                  \
381             if (*(flagp) & (RESTART_PASS1|(extra))) return NULL
382
383 #define MUST_RESTART(flags) ((flags) & (RESTART_PASS1))
384
385 #define RETURN_NULL_ON_RESTART(flags,flagp)                                 \
386                                     RETURN_X_ON_RESTART(NULL, flags,flagp)
387 #define RETURN_NULL_ON_RESTART_FLAGP(flagp)                                 \
388                             RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,0)
389
390 /* This converts the named class defined in regcomp.h to its equivalent class
391  * number defined in handy.h. */
392 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
393 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
394
395 #define _invlist_union_complement_2nd(a, b, output) \
396                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
397 #define _invlist_intersection_complement_2nd(a, b, output) \
398                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
399
400 /* About scan_data_t.
401
402   During optimisation we recurse through the regexp program performing
403   various inplace (keyhole style) optimisations. In addition study_chunk
404   and scan_commit populate this data structure with information about
405   what strings MUST appear in the pattern. We look for the longest
406   string that must appear at a fixed location, and we look for the
407   longest string that may appear at a floating location. So for instance
408   in the pattern:
409
410     /FOO[xX]A.*B[xX]BAR/
411
412   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
413   strings (because they follow a .* construct). study_chunk will identify
414   both FOO and BAR as being the longest fixed and floating strings respectively.
415
416   The strings can be composites, for instance
417
418      /(f)(o)(o)/
419
420   will result in a composite fixed substring 'foo'.
421
422   For each string some basic information is maintained:
423
424   - min_offset
425     This is the position the string must appear at, or not before.
426     It also implicitly (when combined with minlenp) tells us how many
427     characters must match before the string we are searching for.
428     Likewise when combined with minlenp and the length of the string it
429     tells us how many characters must appear after the string we have
430     found.
431
432   - max_offset
433     Only used for floating strings. This is the rightmost point that
434     the string can appear at. If set to SSize_t_MAX it indicates that the
435     string can occur infinitely far to the right.
436     For fixed strings, it is equal to min_offset.
437
438   - minlenp
439     A pointer to the minimum number of characters of the pattern that the
440     string was found inside. This is important as in the case of positive
441     lookahead or positive lookbehind we can have multiple patterns
442     involved. Consider
443
444     /(?=FOO).*F/
445
446     The minimum length of the pattern overall is 3, the minimum length
447     of the lookahead part is 3, but the minimum length of the part that
448     will actually match is 1. So 'FOO's minimum length is 3, but the
449     minimum length for the F is 1. This is important as the minimum length
450     is used to determine offsets in front of and behind the string being
451     looked for.  Since strings can be composites this is the length of the
452     pattern at the time it was committed with a scan_commit. Note that
453     the length is calculated by study_chunk, so that the minimum lengths
454     are not known until the full pattern has been compiled, thus the
455     pointer to the value.
456
457   - lookbehind
458
459     In the case of lookbehind the string being searched for can be
460     offset past the start point of the final matching string.
461     If this value was just blithely removed from the min_offset it would
462     invalidate some of the calculations for how many chars must match
463     before or after (as they are derived from min_offset and minlen and
464     the length of the string being searched for).
465     When the final pattern is compiled and the data is moved from the
466     scan_data_t structure into the regexp structure the information
467     about lookbehind is factored in, with the information that would
468     have been lost precalculated in the end_shift field for the
469     associated string.
470
471   The fields pos_min and pos_delta are used to store the minimum offset
472   and the delta to the maximum offset at the current point in the pattern.
473
474 */
475
476 struct scan_data_substrs {
477     SV      *str;       /* longest substring found in pattern */
478     SSize_t min_offset; /* earliest point in string it can appear */
479     SSize_t max_offset; /* latest point in string it can appear */
480     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
481     SSize_t lookbehind; /* is the pos of the string modified by LB */
482     I32 flags;          /* per substring SF_* and SCF_* flags */
483 };
484
485 typedef struct scan_data_t {
486     /*I32 len_min;      unused */
487     /*I32 len_delta;    unused */
488     SSize_t pos_min;
489     SSize_t pos_delta;
490     SV *last_found;
491     SSize_t last_end;       /* min value, <0 unless valid. */
492     SSize_t last_start_min;
493     SSize_t last_start_max;
494     U8      cur_is_floating; /* whether the last_* values should be set as
495                               * the next fixed (0) or floating (1)
496                               * substring */
497
498     /* [0] is longest fixed substring so far, [1] is longest float so far */
499     struct scan_data_substrs  substrs[2];
500
501     I32 flags;             /* common SF_* and SCF_* flags */
502     I32 whilem_c;
503     SSize_t *last_closep;
504     regnode_ssc *start_class;
505 } scan_data_t;
506
507 /*
508  * Forward declarations for pregcomp()'s friends.
509  */
510
511 static const scan_data_t zero_scan_data = {
512     0, 0, NULL, 0, 0, 0, 0,
513     {
514         { NULL, 0, 0, 0, 0, 0 },
515         { NULL, 0, 0, 0, 0, 0 },
516     },
517     0, 0, NULL, NULL
518 };
519
520 /* study flags */
521
522 #define SF_BEFORE_SEOL          0x0001
523 #define SF_BEFORE_MEOL          0x0002
524 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
525
526 #define SF_IS_INF               0x0040
527 #define SF_HAS_PAR              0x0080
528 #define SF_IN_PAR               0x0100
529 #define SF_HAS_EVAL             0x0200
530
531
532 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
533  * longest substring in the pattern. When it is not set the optimiser keeps
534  * track of position, but does not keep track of the actual strings seen,
535  *
536  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
537  * /foo/i will not.
538  *
539  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
540  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
541  * turned off because of the alternation (BRANCH). */
542 #define SCF_DO_SUBSTR           0x0400
543
544 #define SCF_DO_STCLASS_AND      0x0800
545 #define SCF_DO_STCLASS_OR       0x1000
546 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
547 #define SCF_WHILEM_VISITED_POS  0x2000
548
549 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
550 #define SCF_SEEN_ACCEPT         0x8000
551 #define SCF_TRIE_DOING_RESTUDY 0x10000
552 #define SCF_IN_DEFINE          0x20000
553
554
555
556
557 #define UTF cBOOL(RExC_utf8)
558
559 /* The enums for all these are ordered so things work out correctly */
560 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
561 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
562                                                      == REGEX_DEPENDS_CHARSET)
563 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
564 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
565                                                      >= REGEX_UNICODE_CHARSET)
566 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
567                                             == REGEX_ASCII_RESTRICTED_CHARSET)
568 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
569                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
570 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
571                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
572
573 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
574
575 /* For programs that want to be strictly Unicode compatible by dying if any
576  * attempt is made to match a non-Unicode code point against a Unicode
577  * property.  */
578 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
579
580 #define OOB_NAMEDCLASS          -1
581
582 /* There is no code point that is out-of-bounds, so this is problematic.  But
583  * its only current use is to initialize a variable that is always set before
584  * looked at. */
585 #define OOB_UNICODE             0xDEADBEEF
586
587 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
588
589
590 /* length of regex to show in messages that don't mark a position within */
591 #define RegexLengthToShowInErrorMessages 127
592
593 /*
594  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
595  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
596  * op/pragma/warn/regcomp.
597  */
598 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
599 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
600
601 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
602                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
603
604 /* The code in this file in places uses one level of recursion with parsing
605  * rebased to an alternate string constructed by us in memory.  This can take
606  * the form of something that is completely different from the input, or
607  * something that uses the input as part of the alternate.  In the first case,
608  * there should be no possibility of an error, as we are in complete control of
609  * the alternate string.  But in the second case we don't control the input
610  * portion, so there may be errors in that.  Here's an example:
611  *      /[abc\x{DF}def]/ui
612  * is handled specially because \x{df} folds to a sequence of more than one
613  * character, 'ss'.  What is done is to create and parse an alternate string,
614  * which looks like this:
615  *      /(?:\x{DF}|[abc\x{DF}def])/ui
616  * where it uses the input unchanged in the middle of something it constructs,
617  * which is a branch for the DF outside the character class, and clustering
618  * parens around the whole thing. (It knows enough to skip the DF inside the
619  * class while in this substitute parse.) 'abc' and 'def' may have errors that
620  * need to be reported.  The general situation looks like this:
621  *
622  *              sI                       tI               xI       eI
623  * Input:       ----------------------------------------------------
624  * Constructed:         ---------------------------------------------------
625  *                      sC               tC               xC       eC     EC
626  *
627  * The input string sI..eI is the input pattern.  The string sC..EC is the
628  * constructed substitute parse string.  The portions sC..tC and eC..EC are
629  * constructed by us.  The portion tC..eC is an exact duplicate of the input
630  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
631  * while parsing, we find an error at xC.  We want to display a message showing
632  * the real input string.  Thus we need to find the point xI in it which
633  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
634  * been constructed by us, and so shouldn't have errors.  We get:
635  *
636  *      xI = sI + (tI - sI) + (xC - tC)
637  *
638  * and, the offset into sI is:
639  *
640  *      (xI - sI) = (tI - sI) + (xC - tC)
641  *
642  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
643  * and we save tC as RExC_adjusted_start.
644  *
645  * During normal processing of the input pattern, everything points to that,
646  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
647  */
648
649 #define tI_sI           RExC_precomp_adj
650 #define tC              RExC_adjusted_start
651 #define sC              RExC_precomp
652 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
653 #define xI(xC)          (sC + xI_offset(xC))
654 #define eC              RExC_precomp_end
655
656 #define REPORT_LOCATION_ARGS(xC)                                            \
657     UTF8fARG(UTF,                                                           \
658              (xI(xC) > eC) /* Don't run off end */                          \
659               ? eC - sC   /* Length before the <--HERE */                   \
660               : ( __ASSERT_(xI_offset(xC) >= 0) xI_offset(xC) ),            \
661              sC),         /* The input pattern printed up to the <--HERE */ \
662     UTF8fARG(UTF,                                                           \
663              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
664              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
665
666 /* Used to point after bad bytes for an error message, but avoid skipping
667  * past a nul byte. */
668 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
669
670 /*
671  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
672  * arg. Show regex, up to a maximum length. If it's too long, chop and add
673  * "...".
674  */
675 #define _FAIL(code) STMT_START {                                        \
676     const char *ellipses = "";                                          \
677     IV len = RExC_precomp_end - RExC_precomp;                                   \
678                                                                         \
679     if (!SIZE_ONLY)                                                     \
680         SAVEFREESV(RExC_rx_sv);                                         \
681     if (len > RegexLengthToShowInErrorMessages) {                       \
682         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
683         len = RegexLengthToShowInErrorMessages - 10;                    \
684         ellipses = "...";                                               \
685     }                                                                   \
686     code;                                                               \
687 } STMT_END
688
689 #define FAIL(msg) _FAIL(                            \
690     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
691             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
692
693 #define FAIL2(msg,arg) _FAIL(                       \
694     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
695             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
696
697 /*
698  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
699  */
700 #define Simple_vFAIL(m) STMT_START {                                    \
701     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
702             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
703 } STMT_END
704
705 /*
706  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
707  */
708 #define vFAIL(m) STMT_START {                           \
709     if (!SIZE_ONLY)                                     \
710         SAVEFREESV(RExC_rx_sv);                         \
711     Simple_vFAIL(m);                                    \
712 } STMT_END
713
714 /*
715  * Like Simple_vFAIL(), but accepts two arguments.
716  */
717 #define Simple_vFAIL2(m,a1) STMT_START {                        \
718     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
719                       REPORT_LOCATION_ARGS(RExC_parse));        \
720 } STMT_END
721
722 /*
723  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
724  */
725 #define vFAIL2(m,a1) STMT_START {                       \
726     if (!SIZE_ONLY)                                     \
727         SAVEFREESV(RExC_rx_sv);                         \
728     Simple_vFAIL2(m, a1);                               \
729 } STMT_END
730
731
732 /*
733  * Like Simple_vFAIL(), but accepts three arguments.
734  */
735 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
736     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
737             REPORT_LOCATION_ARGS(RExC_parse));                  \
738 } STMT_END
739
740 /*
741  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
742  */
743 #define vFAIL3(m,a1,a2) STMT_START {                    \
744     if (!SIZE_ONLY)                                     \
745         SAVEFREESV(RExC_rx_sv);                         \
746     Simple_vFAIL3(m, a1, a2);                           \
747 } STMT_END
748
749 /*
750  * Like Simple_vFAIL(), but accepts four arguments.
751  */
752 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
753     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
754             REPORT_LOCATION_ARGS(RExC_parse));                  \
755 } STMT_END
756
757 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
758     if (!SIZE_ONLY)                                     \
759         SAVEFREESV(RExC_rx_sv);                         \
760     Simple_vFAIL4(m, a1, a2, a3);                       \
761 } STMT_END
762
763 /* A specialized version of vFAIL2 that works with UTF8f */
764 #define vFAIL2utf8f(m, a1) STMT_START {             \
765     if (!SIZE_ONLY)                                 \
766         SAVEFREESV(RExC_rx_sv);                     \
767     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
768             REPORT_LOCATION_ARGS(RExC_parse));      \
769 } STMT_END
770
771 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
772     if (!SIZE_ONLY)                                     \
773         SAVEFREESV(RExC_rx_sv);                         \
774     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
775             REPORT_LOCATION_ARGS(RExC_parse));          \
776 } STMT_END
777
778 /* These have asserts in them because of [perl #122671] Many warnings in
779  * regcomp.c can occur twice.  If they get output in pass1 and later in that
780  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
781  * would get output again.  So they should be output in pass2, and these
782  * asserts make sure new warnings follow that paradigm. */
783
784 /* m is not necessarily a "literal string", in this macro */
785 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
786     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
787                                        "%s" REPORT_LOCATION,            \
788                                   m, REPORT_LOCATION_ARGS(loc));        \
789 } STMT_END
790
791 #define ckWARNreg(loc,m) STMT_START {                                   \
792     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
793                                           m REPORT_LOCATION,            \
794                                           REPORT_LOCATION_ARGS(loc));   \
795 } STMT_END
796
797 #define vWARN(loc, m) STMT_START {                                      \
798     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
799                                        m REPORT_LOCATION,               \
800                                        REPORT_LOCATION_ARGS(loc));      \
801 } STMT_END
802
803 #define vWARN_dep(loc, m) STMT_START {                                  \
804     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
805                                        m REPORT_LOCATION,               \
806                                        REPORT_LOCATION_ARGS(loc));      \
807 } STMT_END
808
809 #define ckWARNdep(loc,m) STMT_START {                                   \
810     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
811                                             m REPORT_LOCATION,          \
812                                             REPORT_LOCATION_ARGS(loc)); \
813 } STMT_END
814
815 #define ckWARNregdep(loc,m) STMT_START {                                    \
816     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
817                                                       WARN_REGEXP),         \
818                                              m REPORT_LOCATION,             \
819                                              REPORT_LOCATION_ARGS(loc));    \
820 } STMT_END
821
822 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
823     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
824                                             m REPORT_LOCATION,              \
825                                             a1, REPORT_LOCATION_ARGS(loc)); \
826 } STMT_END
827
828 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
829     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
830                                           m REPORT_LOCATION,                \
831                                           a1, REPORT_LOCATION_ARGS(loc));   \
832 } STMT_END
833
834 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
835     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
836                                        m REPORT_LOCATION,                   \
837                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
838 } STMT_END
839
840 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
841     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
842                                           m REPORT_LOCATION,                \
843                                           a1, a2,                           \
844                                           REPORT_LOCATION_ARGS(loc));       \
845 } STMT_END
846
847 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
848     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
849                                        m REPORT_LOCATION,               \
850                                        a1, a2, a3,                      \
851                                        REPORT_LOCATION_ARGS(loc));      \
852 } STMT_END
853
854 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
855     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
856                                           m REPORT_LOCATION,            \
857                                           a1, a2, a3,                   \
858                                           REPORT_LOCATION_ARGS(loc));   \
859 } STMT_END
860
861 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
862     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
863                                        m REPORT_LOCATION,               \
864                                        a1, a2, a3, a4,                  \
865                                        REPORT_LOCATION_ARGS(loc));      \
866 } STMT_END
867
868 /* Macros for recording node offsets.   20001227 mjd@plover.com
869  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
870  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
871  * Element 0 holds the number n.
872  * Position is 1 indexed.
873  */
874 #ifndef RE_TRACK_PATTERN_OFFSETS
875 #define Set_Node_Offset_To_R(node,byte)
876 #define Set_Node_Offset(node,byte)
877 #define Set_Cur_Node_Offset
878 #define Set_Node_Length_To_R(node,len)
879 #define Set_Node_Length(node,len)
880 #define Set_Node_Cur_Length(node,start)
881 #define Node_Offset(n)
882 #define Node_Length(n)
883 #define Set_Node_Offset_Length(node,offset,len)
884 #define ProgLen(ri) ri->u.proglen
885 #define SetProgLen(ri,x) ri->u.proglen = x
886 #else
887 #define ProgLen(ri) ri->u.offsets[0]
888 #define SetProgLen(ri,x) ri->u.offsets[0] = x
889 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
890     if (! SIZE_ONLY) {                                                  \
891         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
892                     __LINE__, (int)(node), (int)(byte)));               \
893         if((node) < 0) {                                                \
894             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
895                                          (int)(node));                  \
896         } else {                                                        \
897             RExC_offsets[2*(node)-1] = (byte);                          \
898         }                                                               \
899     }                                                                   \
900 } STMT_END
901
902 #define Set_Node_Offset(node,byte) \
903     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
904 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
905
906 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
907     if (! SIZE_ONLY) {                                                  \
908         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
909                 __LINE__, (int)(node), (int)(len)));                    \
910         if((node) < 0) {                                                \
911             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
912                                          (int)(node));                  \
913         } else {                                                        \
914             RExC_offsets[2*(node)] = (len);                             \
915         }                                                               \
916     }                                                                   \
917 } STMT_END
918
919 #define Set_Node_Length(node,len) \
920     Set_Node_Length_To_R((node)-RExC_emit_start, len)
921 #define Set_Node_Cur_Length(node, start)                \
922     Set_Node_Length(node, RExC_parse - start)
923
924 /* Get offsets and lengths */
925 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
926 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
927
928 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
929     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
930     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
931 } STMT_END
932 #endif
933
934 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
935 #define EXPERIMENTAL_INPLACESCAN
936 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
937
938 #ifdef DEBUGGING
939 int
940 Perl_re_printf(pTHX_ const char *fmt, ...)
941 {
942     va_list ap;
943     int result;
944     PerlIO *f= Perl_debug_log;
945     PERL_ARGS_ASSERT_RE_PRINTF;
946     va_start(ap, fmt);
947     result = PerlIO_vprintf(f, fmt, ap);
948     va_end(ap);
949     return result;
950 }
951
952 int
953 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
954 {
955     va_list ap;
956     int result;
957     PerlIO *f= Perl_debug_log;
958     PERL_ARGS_ASSERT_RE_INDENTF;
959     va_start(ap, depth);
960     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
961     result = PerlIO_vprintf(f, fmt, ap);
962     va_end(ap);
963     return result;
964 }
965 #endif /* DEBUGGING */
966
967 #define DEBUG_RExC_seen()                                                   \
968         DEBUG_OPTIMISE_MORE_r({                                             \
969             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
970                                                                             \
971             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
972                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
973                                                                             \
974             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
975                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
976                                                                             \
977             if (RExC_seen & REG_GPOS_SEEN)                                  \
978                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
979                                                                             \
980             if (RExC_seen & REG_RECURSE_SEEN)                               \
981                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
982                                                                             \
983             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
984                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
985                                                                             \
986             if (RExC_seen & REG_VERBARG_SEEN)                               \
987                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
988                                                                             \
989             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
990                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
991                                                                             \
992             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
993                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
994                                                                             \
995             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
996                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
997                                                                             \
998             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
999                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
1000                                                                             \
1001             Perl_re_printf( aTHX_ "\n");                                                \
1002         });
1003
1004 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
1005   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
1006
1007
1008 #ifdef DEBUGGING
1009 static void
1010 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
1011                                     const char *close_str)
1012 {
1013     if (!flags)
1014         return;
1015
1016     Perl_re_printf( aTHX_  "%s", open_str);
1017     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
1018     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
1019     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
1020     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
1021     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
1022     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
1023     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
1024     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
1025     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
1026     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
1027     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
1028     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1029     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1030     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1031     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1032     Perl_re_printf( aTHX_  "%s", close_str);
1033 }
1034
1035
1036 static void
1037 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1038                     U32 depth, int is_inf)
1039 {
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     DEBUG_OPTIMISE_MORE_r({
1043         if (!data)
1044             return;
1045         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1046             depth,
1047             where,
1048             (IV)data->pos_min,
1049             (IV)data->pos_delta,
1050             (UV)data->flags
1051         );
1052
1053         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1054
1055         Perl_re_printf( aTHX_
1056             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1057             (IV)data->whilem_c,
1058             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1059             is_inf ? "INF " : ""
1060         );
1061
1062         if (data->last_found) {
1063             int i;
1064             Perl_re_printf(aTHX_
1065                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1066                     SvPVX_const(data->last_found),
1067                     (IV)data->last_end,
1068                     (IV)data->last_start_min,
1069                     (IV)data->last_start_max
1070             );
1071
1072             for (i = 0; i < 2; i++) {
1073                 Perl_re_printf(aTHX_
1074                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1075                     data->cur_is_floating == i ? "*" : "",
1076                     i ? "Float" : "Fixed",
1077                     SvPVX_const(data->substrs[i].str),
1078                     (IV)data->substrs[i].min_offset,
1079                     (IV)data->substrs[i].max_offset
1080                 );
1081                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1082             }
1083         }
1084
1085         Perl_re_printf( aTHX_ "\n");
1086     });
1087 }
1088
1089
1090 static void
1091 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1092                 regnode *scan, U32 depth, U32 flags)
1093 {
1094     GET_RE_DEBUG_FLAGS_DECL;
1095
1096     DEBUG_OPTIMISE_r({
1097         regnode *Next;
1098
1099         if (!scan)
1100             return;
1101         Next = regnext(scan);
1102         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1103         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1104             depth,
1105             str,
1106             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1107             Next ? (REG_NODE_NUM(Next)) : 0 );
1108         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1109         Perl_re_printf( aTHX_  "\n");
1110    });
1111 }
1112
1113
1114 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1115                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1116
1117 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1118                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1119
1120 #else
1121 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1122 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1123 #endif
1124
1125
1126 /* =========================================================
1127  * BEGIN edit_distance stuff.
1128  *
1129  * This calculates how many single character changes of any type are needed to
1130  * transform a string into another one.  It is taken from version 3.1 of
1131  *
1132  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1133  */
1134
1135 /* Our unsorted dictionary linked list.   */
1136 /* Note we use UVs, not chars. */
1137
1138 struct dictionary{
1139   UV key;
1140   UV value;
1141   struct dictionary* next;
1142 };
1143 typedef struct dictionary item;
1144
1145
1146 PERL_STATIC_INLINE item*
1147 push(UV key,item* curr)
1148 {
1149     item* head;
1150     Newx(head, 1, item);
1151     head->key = key;
1152     head->value = 0;
1153     head->next = curr;
1154     return head;
1155 }
1156
1157
1158 PERL_STATIC_INLINE item*
1159 find(item* head, UV key)
1160 {
1161     item* iterator = head;
1162     while (iterator){
1163         if (iterator->key == key){
1164             return iterator;
1165         }
1166         iterator = iterator->next;
1167     }
1168
1169     return NULL;
1170 }
1171
1172 PERL_STATIC_INLINE item*
1173 uniquePush(item* head,UV key)
1174 {
1175     item* iterator = head;
1176
1177     while (iterator){
1178         if (iterator->key == key) {
1179             return head;
1180         }
1181         iterator = iterator->next;
1182     }
1183
1184     return push(key,head);
1185 }
1186
1187 PERL_STATIC_INLINE void
1188 dict_free(item* head)
1189 {
1190     item* iterator = head;
1191
1192     while (iterator) {
1193         item* temp = iterator;
1194         iterator = iterator->next;
1195         Safefree(temp);
1196     }
1197
1198     head = NULL;
1199 }
1200
1201 /* End of Dictionary Stuff */
1202
1203 /* All calculations/work are done here */
1204 STATIC int
1205 S_edit_distance(const UV* src,
1206                 const UV* tgt,
1207                 const STRLEN x,             /* length of src[] */
1208                 const STRLEN y,             /* length of tgt[] */
1209                 const SSize_t maxDistance
1210 )
1211 {
1212     item *head = NULL;
1213     UV swapCount,swapScore,targetCharCount,i,j;
1214     UV *scores;
1215     UV score_ceil = x + y;
1216
1217     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1218
1219     /* intialize matrix start values */
1220     Newx(scores, ( (x + 2) * (y + 2)), UV);
1221     scores[0] = score_ceil;
1222     scores[1 * (y + 2) + 0] = score_ceil;
1223     scores[0 * (y + 2) + 1] = score_ceil;
1224     scores[1 * (y + 2) + 1] = 0;
1225     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1226
1227     /* work loops    */
1228     /* i = src index */
1229     /* j = tgt index */
1230     for (i=1;i<=x;i++) {
1231         if (i < x)
1232             head = uniquePush(head,src[i]);
1233         scores[(i+1) * (y + 2) + 1] = i;
1234         scores[(i+1) * (y + 2) + 0] = score_ceil;
1235         swapCount = 0;
1236
1237         for (j=1;j<=y;j++) {
1238             if (i == 1) {
1239                 if(j < y)
1240                 head = uniquePush(head,tgt[j]);
1241                 scores[1 * (y + 2) + (j + 1)] = j;
1242                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1243             }
1244
1245             targetCharCount = find(head,tgt[j-1])->value;
1246             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1247
1248             if (src[i-1] != tgt[j-1]){
1249                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(swapScore,(MIN(scores[i * (y + 2) + j], MIN(scores[(i+1) * (y + 2) + j], scores[i * (y + 2) + (j + 1)])) + 1));
1250             }
1251             else {
1252                 swapCount = j;
1253                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1254             }
1255         }
1256
1257         find(head,src[i-1])->value = i;
1258     }
1259
1260     {
1261         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1262         dict_free(head);
1263         Safefree(scores);
1264         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1265     }
1266 }
1267
1268 /* END of edit_distance() stuff
1269  * ========================================================= */
1270
1271 /* is c a control character for which we have a mnemonic? */
1272 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1273
1274 STATIC const char *
1275 S_cntrl_to_mnemonic(const U8 c)
1276 {
1277     /* Returns the mnemonic string that represents character 'c', if one
1278      * exists; NULL otherwise.  The only ones that exist for the purposes of
1279      * this routine are a few control characters */
1280
1281     switch (c) {
1282         case '\a':       return "\\a";
1283         case '\b':       return "\\b";
1284         case ESC_NATIVE: return "\\e";
1285         case '\f':       return "\\f";
1286         case '\n':       return "\\n";
1287         case '\r':       return "\\r";
1288         case '\t':       return "\\t";
1289     }
1290
1291     return NULL;
1292 }
1293
1294 /* Mark that we cannot extend a found fixed substring at this point.
1295    Update the longest found anchored substring or the longest found
1296    floating substrings if needed. */
1297
1298 STATIC void
1299 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1300                     SSize_t *minlenp, int is_inf)
1301 {
1302     const STRLEN l = CHR_SVLEN(data->last_found);
1303     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1304     const STRLEN old_l = CHR_SVLEN(longest_sv);
1305     GET_RE_DEBUG_FLAGS_DECL;
1306
1307     PERL_ARGS_ASSERT_SCAN_COMMIT;
1308
1309     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1310         const U8 i = data->cur_is_floating;
1311         SvSetMagicSV(longest_sv, data->last_found);
1312         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1313
1314         if (!i) /* fixed */
1315             data->substrs[0].max_offset = data->substrs[0].min_offset;
1316         else { /* float */
1317             data->substrs[1].max_offset = (l
1318                           ? data->last_start_max
1319                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1320                                          ? SSize_t_MAX
1321                                          : data->pos_min + data->pos_delta));
1322             if (is_inf
1323                  || (STRLEN)data->substrs[1].max_offset > (STRLEN)SSize_t_MAX)
1324                 data->substrs[1].max_offset = SSize_t_MAX;
1325         }
1326
1327         if (data->flags & SF_BEFORE_EOL)
1328             data->substrs[i].flags |= (data->flags & SF_BEFORE_EOL);
1329         else
1330             data->substrs[i].flags &= ~SF_BEFORE_EOL;
1331         data->substrs[i].minlenp = minlenp;
1332         data->substrs[i].lookbehind = 0;
1333     }
1334
1335     SvCUR_set(data->last_found, 0);
1336     {
1337         SV * const sv = data->last_found;
1338         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1339             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1340             if (mg)
1341                 mg->mg_len = 0;
1342         }
1343     }
1344     data->last_end = -1;
1345     data->flags &= ~SF_BEFORE_EOL;
1346     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1347 }
1348
1349 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1350  * list that describes which code points it matches */
1351
1352 STATIC void
1353 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1354 {
1355     /* Set the SSC 'ssc' to match an empty string or any code point */
1356
1357     PERL_ARGS_ASSERT_SSC_ANYTHING;
1358
1359     assert(is_ANYOF_SYNTHETIC(ssc));
1360
1361     /* mortalize so won't leak */
1362     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1363     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1364 }
1365
1366 STATIC int
1367 S_ssc_is_anything(const regnode_ssc *ssc)
1368 {
1369     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1370      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1371      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1372      * in any way, so there's no point in using it */
1373
1374     UV start, end;
1375     bool ret;
1376
1377     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1378
1379     assert(is_ANYOF_SYNTHETIC(ssc));
1380
1381     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1382         return FALSE;
1383     }
1384
1385     /* See if the list consists solely of the range 0 - Infinity */
1386     invlist_iterinit(ssc->invlist);
1387     ret = invlist_iternext(ssc->invlist, &start, &end)
1388           && start == 0
1389           && end == UV_MAX;
1390
1391     invlist_iterfinish(ssc->invlist);
1392
1393     if (ret) {
1394         return TRUE;
1395     }
1396
1397     /* If e.g., both \w and \W are set, matches everything */
1398     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1399         int i;
1400         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1401             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1402                 return TRUE;
1403             }
1404         }
1405     }
1406
1407     return FALSE;
1408 }
1409
1410 STATIC void
1411 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1412 {
1413     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1414      * string, any code point, or any posix class under locale */
1415
1416     PERL_ARGS_ASSERT_SSC_INIT;
1417
1418     Zero(ssc, 1, regnode_ssc);
1419     set_ANYOF_SYNTHETIC(ssc);
1420     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1421     ssc_anything(ssc);
1422
1423     /* If any portion of the regex is to operate under locale rules that aren't
1424      * fully known at compile time, initialization includes it.  The reason
1425      * this isn't done for all regexes is that the optimizer was written under
1426      * the assumption that locale was all-or-nothing.  Given the complexity and
1427      * lack of documentation in the optimizer, and that there are inadequate
1428      * test cases for locale, many parts of it may not work properly, it is
1429      * safest to avoid locale unless necessary. */
1430     if (RExC_contains_locale) {
1431         ANYOF_POSIXL_SETALL(ssc);
1432     }
1433     else {
1434         ANYOF_POSIXL_ZERO(ssc);
1435     }
1436 }
1437
1438 STATIC int
1439 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1440                         const regnode_ssc *ssc)
1441 {
1442     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1443      * to the list of code points matched, and locale posix classes; hence does
1444      * not check its flags) */
1445
1446     UV start, end;
1447     bool ret;
1448
1449     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1450
1451     assert(is_ANYOF_SYNTHETIC(ssc));
1452
1453     invlist_iterinit(ssc->invlist);
1454     ret = invlist_iternext(ssc->invlist, &start, &end)
1455           && start == 0
1456           && end == UV_MAX;
1457
1458     invlist_iterfinish(ssc->invlist);
1459
1460     if (! ret) {
1461         return FALSE;
1462     }
1463
1464     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1465         return FALSE;
1466     }
1467
1468     return TRUE;
1469 }
1470
1471 STATIC SV*
1472 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1473                                const regnode_charclass* const node)
1474 {
1475     /* Returns a mortal inversion list defining which code points are matched
1476      * by 'node', which is of type ANYOF.  Handles complementing the result if
1477      * appropriate.  If some code points aren't knowable at this time, the
1478      * returned list must, and will, contain every code point that is a
1479      * possibility. */
1480
1481     SV* invlist = NULL;
1482     SV* only_utf8_locale_invlist = NULL;
1483     unsigned int i;
1484     const U32 n = ARG(node);
1485     bool new_node_has_latin1 = FALSE;
1486
1487     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1488
1489     /* Look at the data structure created by S_set_ANYOF_arg() */
1490     if (n != ANYOF_ONLY_HAS_BITMAP) {
1491         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1492         AV * const av = MUTABLE_AV(SvRV(rv));
1493         SV **const ary = AvARRAY(av);
1494         assert(RExC_rxi->data->what[n] == 's');
1495
1496         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1497             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1498         }
1499         else if (ary[0] && ary[0] != &PL_sv_undef) {
1500
1501             /* Here, no compile-time swash, and there are things that won't be
1502              * known until runtime -- we have to assume it could be anything */
1503             invlist = sv_2mortal(_new_invlist(1));
1504             return _add_range_to_invlist(invlist, 0, UV_MAX);
1505         }
1506         else if (ary[3] && ary[3] != &PL_sv_undef) {
1507
1508             /* Here no compile-time swash, and no run-time only data.  Use the
1509              * node's inversion list */
1510             invlist = sv_2mortal(invlist_clone(ary[3]));
1511         }
1512
1513         /* Get the code points valid only under UTF-8 locales */
1514         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1515             && ary[2] && ary[2] != &PL_sv_undef)
1516         {
1517             only_utf8_locale_invlist = ary[2];
1518         }
1519     }
1520
1521     if (! invlist) {
1522         invlist = sv_2mortal(_new_invlist(0));
1523     }
1524
1525     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1526      * code points, and an inversion list for the others, but if there are code
1527      * points that should match only conditionally on the target string being
1528      * UTF-8, those are placed in the inversion list, and not the bitmap.
1529      * Since there are circumstances under which they could match, they are
1530      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1531      * to exclude them here, so that when we invert below, the end result
1532      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1533      * have to do this here before we add the unconditionally matched code
1534      * points */
1535     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1536         _invlist_intersection_complement_2nd(invlist,
1537                                              PL_UpperLatin1,
1538                                              &invlist);
1539     }
1540
1541     /* Add in the points from the bit map */
1542     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1543         if (ANYOF_BITMAP_TEST(node, i)) {
1544             unsigned int start = i++;
1545
1546             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1547                 /* empty */
1548             }
1549             invlist = _add_range_to_invlist(invlist, start, i-1);
1550             new_node_has_latin1 = TRUE;
1551         }
1552     }
1553
1554     /* If this can match all upper Latin1 code points, have to add them
1555      * as well.  But don't add them if inverting, as when that gets done below,
1556      * it would exclude all these characters, including the ones it shouldn't
1557      * that were added just above */
1558     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1559         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1560     {
1561         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1562     }
1563
1564     /* Similarly for these */
1565     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1566         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1567     }
1568
1569     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1570         _invlist_invert(invlist);
1571     }
1572     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1573
1574         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1575          * locale.  We can skip this if there are no 0-255 at all. */
1576         _invlist_union(invlist, PL_Latin1, &invlist);
1577     }
1578
1579     /* Similarly add the UTF-8 locale possible matches.  These have to be
1580      * deferred until after the non-UTF-8 locale ones are taken care of just
1581      * above, or it leads to wrong results under ANYOF_INVERT */
1582     if (only_utf8_locale_invlist) {
1583         _invlist_union_maybe_complement_2nd(invlist,
1584                                             only_utf8_locale_invlist,
1585                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1586                                             &invlist);
1587     }
1588
1589     return invlist;
1590 }
1591
1592 /* These two functions currently do the exact same thing */
1593 #define ssc_init_zero           ssc_init
1594
1595 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1596 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1597
1598 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1599  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1600  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1601
1602 STATIC void
1603 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1604                 const regnode_charclass *and_with)
1605 {
1606     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1607      * another SSC or a regular ANYOF class.  Can create false positives. */
1608
1609     SV* anded_cp_list;
1610     U8  anded_flags;
1611
1612     PERL_ARGS_ASSERT_SSC_AND;
1613
1614     assert(is_ANYOF_SYNTHETIC(ssc));
1615
1616     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1617      * the code point inversion list and just the relevant flags */
1618     if (is_ANYOF_SYNTHETIC(and_with)) {
1619         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1620         anded_flags = ANYOF_FLAGS(and_with);
1621
1622         /* XXX This is a kludge around what appears to be deficiencies in the
1623          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1624          * there are paths through the optimizer where it doesn't get weeded
1625          * out when it should.  And if we don't make some extra provision for
1626          * it like the code just below, it doesn't get added when it should.
1627          * This solution is to add it only when AND'ing, which is here, and
1628          * only when what is being AND'ed is the pristine, original node
1629          * matching anything.  Thus it is like adding it to ssc_anything() but
1630          * only when the result is to be AND'ed.  Probably the same solution
1631          * could be adopted for the same problem we have with /l matching,
1632          * which is solved differently in S_ssc_init(), and that would lead to
1633          * fewer false positives than that solution has.  But if this solution
1634          * creates bugs, the consequences are only that a warning isn't raised
1635          * that should be; while the consequences for having /l bugs is
1636          * incorrect matches */
1637         if (ssc_is_anything((regnode_ssc *)and_with)) {
1638             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1639         }
1640     }
1641     else {
1642         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1643         if (OP(and_with) == ANYOFD) {
1644             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1645         }
1646         else {
1647             anded_flags = ANYOF_FLAGS(and_with)
1648             &( ANYOF_COMMON_FLAGS
1649               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1650               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1651             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1652                 anded_flags &=
1653                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1654             }
1655         }
1656     }
1657
1658     ANYOF_FLAGS(ssc) &= anded_flags;
1659
1660     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1661      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1662      * 'and_with' may be inverted.  When not inverted, we have the situation of
1663      * computing:
1664      *  (C1 | P1) & (C2 | P2)
1665      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1666      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1667      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1668      *                    <=  ((C1 & C2) | P1 | P2)
1669      * Alternatively, the last few steps could be:
1670      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1671      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1672      *                    <=  (C1 | C2 | (P1 & P2))
1673      * We favor the second approach if either P1 or P2 is non-empty.  This is
1674      * because these components are a barrier to doing optimizations, as what
1675      * they match cannot be known until the moment of matching as they are
1676      * dependent on the current locale, 'AND"ing them likely will reduce or
1677      * eliminate them.
1678      * But we can do better if we know that C1,P1 are in their initial state (a
1679      * frequent occurrence), each matching everything:
1680      *  (<everything>) & (C2 | P2) =  C2 | P2
1681      * Similarly, if C2,P2 are in their initial state (again a frequent
1682      * occurrence), the result is a no-op
1683      *  (C1 | P1) & (<everything>) =  C1 | P1
1684      *
1685      * Inverted, we have
1686      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1687      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1688      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1689      * */
1690
1691     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1692         && ! is_ANYOF_SYNTHETIC(and_with))
1693     {
1694         unsigned int i;
1695
1696         ssc_intersection(ssc,
1697                          anded_cp_list,
1698                          FALSE /* Has already been inverted */
1699                          );
1700
1701         /* If either P1 or P2 is empty, the intersection will be also; can skip
1702          * the loop */
1703         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1704             ANYOF_POSIXL_ZERO(ssc);
1705         }
1706         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1707
1708             /* Note that the Posix class component P from 'and_with' actually
1709              * looks like:
1710              *      P = Pa | Pb | ... | Pn
1711              * where each component is one posix class, such as in [\w\s].
1712              * Thus
1713              *      ~P = ~(Pa | Pb | ... | Pn)
1714              *         = ~Pa & ~Pb & ... & ~Pn
1715              *        <= ~Pa | ~Pb | ... | ~Pn
1716              * The last is something we can easily calculate, but unfortunately
1717              * is likely to have many false positives.  We could do better
1718              * in some (but certainly not all) instances if two classes in
1719              * P have known relationships.  For example
1720              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1721              * So
1722              *      :lower: & :print: = :lower:
1723              * And similarly for classes that must be disjoint.  For example,
1724              * since \s and \w can have no elements in common based on rules in
1725              * the POSIX standard,
1726              *      \w & ^\S = nothing
1727              * Unfortunately, some vendor locales do not meet the Posix
1728              * standard, in particular almost everything by Microsoft.
1729              * The loop below just changes e.g., \w into \W and vice versa */
1730
1731             regnode_charclass_posixl temp;
1732             int add = 1;    /* To calculate the index of the complement */
1733
1734             Zero(&temp, 1, regnode_charclass_posixl);
1735             ANYOF_POSIXL_ZERO(&temp);
1736             for (i = 0; i < ANYOF_MAX; i++) {
1737                 assert(i % 2 != 0
1738                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1739                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1740
1741                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1742                     ANYOF_POSIXL_SET(&temp, i + add);
1743                 }
1744                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1745             }
1746             ANYOF_POSIXL_AND(&temp, ssc);
1747
1748         } /* else ssc already has no posixes */
1749     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1750          in its initial state */
1751     else if (! is_ANYOF_SYNTHETIC(and_with)
1752              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1753     {
1754         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1755          * copy it over 'ssc' */
1756         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1757             if (is_ANYOF_SYNTHETIC(and_with)) {
1758                 StructCopy(and_with, ssc, regnode_ssc);
1759             }
1760             else {
1761                 ssc->invlist = anded_cp_list;
1762                 ANYOF_POSIXL_ZERO(ssc);
1763                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1764                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1765                 }
1766             }
1767         }
1768         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1769                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1770         {
1771             /* One or the other of P1, P2 is non-empty. */
1772             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1773                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1774             }
1775             ssc_union(ssc, anded_cp_list, FALSE);
1776         }
1777         else { /* P1 = P2 = empty */
1778             ssc_intersection(ssc, anded_cp_list, FALSE);
1779         }
1780     }
1781 }
1782
1783 STATIC void
1784 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1785                const regnode_charclass *or_with)
1786 {
1787     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1788      * another SSC or a regular ANYOF class.  Can create false positives if
1789      * 'or_with' is to be inverted. */
1790
1791     SV* ored_cp_list;
1792     U8 ored_flags;
1793
1794     PERL_ARGS_ASSERT_SSC_OR;
1795
1796     assert(is_ANYOF_SYNTHETIC(ssc));
1797
1798     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1799      * the code point inversion list and just the relevant flags */
1800     if (is_ANYOF_SYNTHETIC(or_with)) {
1801         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1802         ored_flags = ANYOF_FLAGS(or_with);
1803     }
1804     else {
1805         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1806         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1807         if (OP(or_with) != ANYOFD) {
1808             ored_flags
1809             |= ANYOF_FLAGS(or_with)
1810              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1811                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1812             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1813                 ored_flags |=
1814                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1815             }
1816         }
1817     }
1818
1819     ANYOF_FLAGS(ssc) |= ored_flags;
1820
1821     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1822      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1823      * 'or_with' may be inverted.  When not inverted, we have the simple
1824      * situation of computing:
1825      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1826      * If P1|P2 yields a situation with both a class and its complement are
1827      * set, like having both \w and \W, this matches all code points, and we
1828      * can delete these from the P component of the ssc going forward.  XXX We
1829      * might be able to delete all the P components, but I (khw) am not certain
1830      * about this, and it is better to be safe.
1831      *
1832      * Inverted, we have
1833      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1834      *                         <=  (C1 | P1) | ~C2
1835      *                         <=  (C1 | ~C2) | P1
1836      * (which results in actually simpler code than the non-inverted case)
1837      * */
1838
1839     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1840         && ! is_ANYOF_SYNTHETIC(or_with))
1841     {
1842         /* We ignore P2, leaving P1 going forward */
1843     }   /* else  Not inverted */
1844     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1845         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1846         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1847             unsigned int i;
1848             for (i = 0; i < ANYOF_MAX; i += 2) {
1849                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1850                 {
1851                     ssc_match_all_cp(ssc);
1852                     ANYOF_POSIXL_CLEAR(ssc, i);
1853                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1854                 }
1855             }
1856         }
1857     }
1858
1859     ssc_union(ssc,
1860               ored_cp_list,
1861               FALSE /* Already has been inverted */
1862               );
1863 }
1864
1865 PERL_STATIC_INLINE void
1866 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1867 {
1868     PERL_ARGS_ASSERT_SSC_UNION;
1869
1870     assert(is_ANYOF_SYNTHETIC(ssc));
1871
1872     _invlist_union_maybe_complement_2nd(ssc->invlist,
1873                                         invlist,
1874                                         invert2nd,
1875                                         &ssc->invlist);
1876 }
1877
1878 PERL_STATIC_INLINE void
1879 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1880                          SV* const invlist,
1881                          const bool invert2nd)
1882 {
1883     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1884
1885     assert(is_ANYOF_SYNTHETIC(ssc));
1886
1887     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1888                                                invlist,
1889                                                invert2nd,
1890                                                &ssc->invlist);
1891 }
1892
1893 PERL_STATIC_INLINE void
1894 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1895 {
1896     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1897
1898     assert(is_ANYOF_SYNTHETIC(ssc));
1899
1900     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1901 }
1902
1903 PERL_STATIC_INLINE void
1904 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1905 {
1906     /* AND just the single code point 'cp' into the SSC 'ssc' */
1907
1908     SV* cp_list = _new_invlist(2);
1909
1910     PERL_ARGS_ASSERT_SSC_CP_AND;
1911
1912     assert(is_ANYOF_SYNTHETIC(ssc));
1913
1914     cp_list = add_cp_to_invlist(cp_list, cp);
1915     ssc_intersection(ssc, cp_list,
1916                      FALSE /* Not inverted */
1917                      );
1918     SvREFCNT_dec_NN(cp_list);
1919 }
1920
1921 PERL_STATIC_INLINE void
1922 S_ssc_clear_locale(regnode_ssc *ssc)
1923 {
1924     /* Set the SSC 'ssc' to not match any locale things */
1925     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1926
1927     assert(is_ANYOF_SYNTHETIC(ssc));
1928
1929     ANYOF_POSIXL_ZERO(ssc);
1930     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1931 }
1932
1933 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1934
1935 STATIC bool
1936 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1937 {
1938     /* The synthetic start class is used to hopefully quickly winnow down
1939      * places where a pattern could start a match in the target string.  If it
1940      * doesn't really narrow things down that much, there isn't much point to
1941      * having the overhead of using it.  This function uses some very crude
1942      * heuristics to decide if to use the ssc or not.
1943      *
1944      * It returns TRUE if 'ssc' rules out more than half what it considers to
1945      * be the "likely" possible matches, but of course it doesn't know what the
1946      * actual things being matched are going to be; these are only guesses
1947      *
1948      * For /l matches, it assumes that the only likely matches are going to be
1949      *      in the 0-255 range, uniformly distributed, so half of that is 127
1950      * For /a and /d matches, it assumes that the likely matches will be just
1951      *      the ASCII range, so half of that is 63
1952      * For /u and there isn't anything matching above the Latin1 range, it
1953      *      assumes that that is the only range likely to be matched, and uses
1954      *      half that as the cut-off: 127.  If anything matches above Latin1,
1955      *      it assumes that all of Unicode could match (uniformly), except for
1956      *      non-Unicode code points and things in the General Category "Other"
1957      *      (unassigned, private use, surrogates, controls and formats).  This
1958      *      is a much large number. */
1959
1960     U32 count = 0;      /* Running total of number of code points matched by
1961                            'ssc' */
1962     UV start, end;      /* Start and end points of current range in inversion
1963                            list */
1964     const U32 max_code_points = (LOC)
1965                                 ?  256
1966                                 : ((   ! UNI_SEMANTICS
1967                                      || invlist_highest(ssc->invlist) < 256)
1968                                   ? 128
1969                                   : NON_OTHER_COUNT);
1970     const U32 max_match = max_code_points / 2;
1971
1972     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1973
1974     invlist_iterinit(ssc->invlist);
1975     while (invlist_iternext(ssc->invlist, &start, &end)) {
1976         if (start >= max_code_points) {
1977             break;
1978         }
1979         end = MIN(end, max_code_points - 1);
1980         count += end - start + 1;
1981         if (count >= max_match) {
1982             invlist_iterfinish(ssc->invlist);
1983             return FALSE;
1984         }
1985     }
1986
1987     return TRUE;
1988 }
1989
1990
1991 STATIC void
1992 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1993 {
1994     /* The inversion list in the SSC is marked mortal; now we need a more
1995      * permanent copy, which is stored the same way that is done in a regular
1996      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1997      * map */
1998
1999     SV* invlist = invlist_clone(ssc->invlist);
2000
2001     PERL_ARGS_ASSERT_SSC_FINALIZE;
2002
2003     assert(is_ANYOF_SYNTHETIC(ssc));
2004
2005     /* The code in this file assumes that all but these flags aren't relevant
2006      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
2007      * by the time we reach here */
2008     assert(! (ANYOF_FLAGS(ssc)
2009         & ~( ANYOF_COMMON_FLAGS
2010             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2011             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
2012
2013     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
2014
2015     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
2016                                 NULL, NULL, NULL, FALSE);
2017
2018     /* Make sure is clone-safe */
2019     ssc->invlist = NULL;
2020
2021     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2022         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
2023     }
2024
2025     if (RExC_contains_locale) {
2026         OP(ssc) = ANYOFL;
2027     }
2028
2029     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2030 }
2031
2032 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2033 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2034 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2035 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2036                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2037                                : 0 )
2038
2039
2040 #ifdef DEBUGGING
2041 /*
2042    dump_trie(trie,widecharmap,revcharmap)
2043    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2044    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2045
2046    These routines dump out a trie in a somewhat readable format.
2047    The _interim_ variants are used for debugging the interim
2048    tables that are used to generate the final compressed
2049    representation which is what dump_trie expects.
2050
2051    Part of the reason for their existence is to provide a form
2052    of documentation as to how the different representations function.
2053
2054 */
2055
2056 /*
2057   Dumps the final compressed table form of the trie to Perl_debug_log.
2058   Used for debugging make_trie().
2059 */
2060
2061 STATIC void
2062 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2063             AV *revcharmap, U32 depth)
2064 {
2065     U32 state;
2066     SV *sv=sv_newmortal();
2067     int colwidth= widecharmap ? 6 : 4;
2068     U16 word;
2069     GET_RE_DEBUG_FLAGS_DECL;
2070
2071     PERL_ARGS_ASSERT_DUMP_TRIE;
2072
2073     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2074         depth+1, "Match","Base","Ofs" );
2075
2076     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2077         SV ** const tmp = av_fetch( revcharmap, state, 0);
2078         if ( tmp ) {
2079             Perl_re_printf( aTHX_  "%*s",
2080                 colwidth,
2081                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2082                             PL_colors[0], PL_colors[1],
2083                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2084                             PERL_PV_ESCAPE_FIRSTCHAR
2085                 )
2086             );
2087         }
2088     }
2089     Perl_re_printf( aTHX_  "\n");
2090     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2091
2092     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2093         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2094     Perl_re_printf( aTHX_  "\n");
2095
2096     for( state = 1 ; state < trie->statecount ; state++ ) {
2097         const U32 base = trie->states[ state ].trans.base;
2098
2099         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2100
2101         if ( trie->states[ state ].wordnum ) {
2102             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2103         } else {
2104             Perl_re_printf( aTHX_  "%6s", "" );
2105         }
2106
2107         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2108
2109         if ( base ) {
2110             U32 ofs = 0;
2111
2112             while( ( base + ofs  < trie->uniquecharcount ) ||
2113                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2114                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2115                                                                     != state))
2116                     ofs++;
2117
2118             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2119
2120             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2121                 if ( ( base + ofs >= trie->uniquecharcount )
2122                         && ( base + ofs - trie->uniquecharcount
2123                                                         < trie->lasttrans )
2124                         && trie->trans[ base + ofs
2125                                     - trie->uniquecharcount ].check == state )
2126                 {
2127                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2128                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2129                    );
2130                 } else {
2131                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2132                 }
2133             }
2134
2135             Perl_re_printf( aTHX_  "]");
2136
2137         }
2138         Perl_re_printf( aTHX_  "\n" );
2139     }
2140     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2141                                 depth);
2142     for (word=1; word <= trie->wordcount; word++) {
2143         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2144             (int)word, (int)(trie->wordinfo[word].prev),
2145             (int)(trie->wordinfo[word].len));
2146     }
2147     Perl_re_printf( aTHX_  "\n" );
2148 }
2149 /*
2150   Dumps a fully constructed but uncompressed trie in list form.
2151   List tries normally only are used for construction when the number of
2152   possible chars (trie->uniquecharcount) is very high.
2153   Used for debugging make_trie().
2154 */
2155 STATIC void
2156 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2157                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2158                          U32 depth)
2159 {
2160     U32 state;
2161     SV *sv=sv_newmortal();
2162     int colwidth= widecharmap ? 6 : 4;
2163     GET_RE_DEBUG_FLAGS_DECL;
2164
2165     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2166
2167     /* print out the table precompression.  */
2168     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2169             depth+1 );
2170     Perl_re_indentf( aTHX_  "%s",
2171             depth+1, "------:-----+-----------------\n" );
2172
2173     for( state=1 ; state < next_alloc ; state ++ ) {
2174         U16 charid;
2175
2176         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2177             depth+1, (UV)state  );
2178         if ( ! trie->states[ state ].wordnum ) {
2179             Perl_re_printf( aTHX_  "%5s| ","");
2180         } else {
2181             Perl_re_printf( aTHX_  "W%4x| ",
2182                 trie->states[ state ].wordnum
2183             );
2184         }
2185         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2186             SV ** const tmp = av_fetch( revcharmap,
2187                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2188             if ( tmp ) {
2189                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2190                     colwidth,
2191                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2192                               colwidth,
2193                               PL_colors[0], PL_colors[1],
2194                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2195                               | PERL_PV_ESCAPE_FIRSTCHAR
2196                     ) ,
2197                     TRIE_LIST_ITEM(state,charid).forid,
2198                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2199                 );
2200                 if (!(charid % 10))
2201                     Perl_re_printf( aTHX_  "\n%*s| ",
2202                         (int)((depth * 2) + 14), "");
2203             }
2204         }
2205         Perl_re_printf( aTHX_  "\n");
2206     }
2207 }
2208
2209 /*
2210   Dumps a fully constructed but uncompressed trie in table form.
2211   This is the normal DFA style state transition table, with a few
2212   twists to facilitate compression later.
2213   Used for debugging make_trie().
2214 */
2215 STATIC void
2216 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2217                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2218                           U32 depth)
2219 {
2220     U32 state;
2221     U16 charid;
2222     SV *sv=sv_newmortal();
2223     int colwidth= widecharmap ? 6 : 4;
2224     GET_RE_DEBUG_FLAGS_DECL;
2225
2226     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2227
2228     /*
2229        print out the table precompression so that we can do a visual check
2230        that they are identical.
2231      */
2232
2233     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2234
2235     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2236         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2237         if ( tmp ) {
2238             Perl_re_printf( aTHX_  "%*s",
2239                 colwidth,
2240                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2241                             PL_colors[0], PL_colors[1],
2242                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2243                             PERL_PV_ESCAPE_FIRSTCHAR
2244                 )
2245             );
2246         }
2247     }
2248
2249     Perl_re_printf( aTHX_ "\n");
2250     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2251
2252     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2253         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2254     }
2255
2256     Perl_re_printf( aTHX_  "\n" );
2257
2258     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2259
2260         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2261             depth+1,
2262             (UV)TRIE_NODENUM( state ) );
2263
2264         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2265             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2266             if (v)
2267                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2268             else
2269                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2270         }
2271         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2272             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2273                                             (UV)trie->trans[ state ].check );
2274         } else {
2275             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2276                                             (UV)trie->trans[ state ].check,
2277             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2278         }
2279     }
2280 }
2281
2282 #endif
2283
2284
2285 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2286   startbranch: the first branch in the whole branch sequence
2287   first      : start branch of sequence of branch-exact nodes.
2288                May be the same as startbranch
2289   last       : Thing following the last branch.
2290                May be the same as tail.
2291   tail       : item following the branch sequence
2292   count      : words in the sequence
2293   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2294   depth      : indent depth
2295
2296 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2297
2298 A trie is an N'ary tree where the branches are determined by digital
2299 decomposition of the key. IE, at the root node you look up the 1st character and
2300 follow that branch repeat until you find the end of the branches. Nodes can be
2301 marked as "accepting" meaning they represent a complete word. Eg:
2302
2303   /he|she|his|hers/
2304
2305 would convert into the following structure. Numbers represent states, letters
2306 following numbers represent valid transitions on the letter from that state, if
2307 the number is in square brackets it represents an accepting state, otherwise it
2308 will be in parenthesis.
2309
2310       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2311       |    |
2312       |   (2)
2313       |    |
2314      (1)   +-i->(6)-+-s->[7]
2315       |
2316       +-s->(3)-+-h->(4)-+-e->[5]
2317
2318       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2319
2320 This shows that when matching against the string 'hers' we will begin at state 1
2321 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2322 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2323 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2324 single traverse. We store a mapping from accepting to state to which word was
2325 matched, and then when we have multiple possibilities we try to complete the
2326 rest of the regex in the order in which they occurred in the alternation.
2327
2328 The only prior NFA like behaviour that would be changed by the TRIE support is
2329 the silent ignoring of duplicate alternations which are of the form:
2330
2331  / (DUPE|DUPE) X? (?{ ... }) Y /x
2332
2333 Thus EVAL blocks following a trie may be called a different number of times with
2334 and without the optimisation. With the optimisations dupes will be silently
2335 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2336 the following demonstrates:
2337
2338  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2339
2340 which prints out 'word' three times, but
2341
2342  'words'=~/(word|word|word)(?{ print $1 })S/
2343
2344 which doesnt print it out at all. This is due to other optimisations kicking in.
2345
2346 Example of what happens on a structural level:
2347
2348 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2349
2350    1: CURLYM[1] {1,32767}(18)
2351    5:   BRANCH(8)
2352    6:     EXACT <ac>(16)
2353    8:   BRANCH(11)
2354    9:     EXACT <ad>(16)
2355   11:   BRANCH(14)
2356   12:     EXACT <ab>(16)
2357   16:   SUCCEED(0)
2358   17:   NOTHING(18)
2359   18: END(0)
2360
2361 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2362 and should turn into:
2363
2364    1: CURLYM[1] {1,32767}(18)
2365    5:   TRIE(16)
2366         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2367           <ac>
2368           <ad>
2369           <ab>
2370   16:   SUCCEED(0)
2371   17:   NOTHING(18)
2372   18: END(0)
2373
2374 Cases where tail != last would be like /(?foo|bar)baz/:
2375
2376    1: BRANCH(4)
2377    2:   EXACT <foo>(8)
2378    4: BRANCH(7)
2379    5:   EXACT <bar>(8)
2380    7: TAIL(8)
2381    8: EXACT <baz>(10)
2382   10: END(0)
2383
2384 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2385 and would end up looking like:
2386
2387     1: TRIE(8)
2388       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2389         <foo>
2390         <bar>
2391    7: TAIL(8)
2392    8: EXACT <baz>(10)
2393   10: END(0)
2394
2395     d = uvchr_to_utf8_flags(d, uv, 0);
2396
2397 is the recommended Unicode-aware way of saying
2398
2399     *(d++) = uv;
2400 */
2401
2402 #define TRIE_STORE_REVCHAR(val)                                            \
2403     STMT_START {                                                           \
2404         if (UTF) {                                                         \
2405             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2406             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2407             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2408             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2409             SvPOK_on(zlopp);                                               \
2410             SvUTF8_on(zlopp);                                              \
2411             av_push(revcharmap, zlopp);                                    \
2412         } else {                                                           \
2413             char ooooff = (char)val;                                           \
2414             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2415         }                                                                  \
2416         } STMT_END
2417
2418 /* This gets the next character from the input, folding it if not already
2419  * folded. */
2420 #define TRIE_READ_CHAR STMT_START {                                           \
2421     wordlen++;                                                                \
2422     if ( UTF ) {                                                              \
2423         /* if it is UTF then it is either already folded, or does not need    \
2424          * folding */                                                         \
2425         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2426     }                                                                         \
2427     else if (folder == PL_fold_latin1) {                                      \
2428         /* This folder implies Unicode rules, which in the range expressible  \
2429          *  by not UTF is the lower case, with the two exceptions, one of     \
2430          *  which should have been taken care of before calling this */       \
2431         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2432         uvc = toLOWER_L1(*uc);                                                \
2433         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2434         len = 1;                                                              \
2435     } else {                                                                  \
2436         /* raw data, will be folded later if needed */                        \
2437         uvc = (U32)*uc;                                                       \
2438         len = 1;                                                              \
2439     }                                                                         \
2440 } STMT_END
2441
2442
2443
2444 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2445     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2446         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2447         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2448         TRIE_LIST_LEN( state ) = ging;                          \
2449     }                                                           \
2450     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2451     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2452     TRIE_LIST_CUR( state )++;                                   \
2453 } STMT_END
2454
2455 #define TRIE_LIST_NEW(state) STMT_START {                       \
2456     Newx( trie->states[ state ].trans.list,                     \
2457         4, reg_trie_trans_le );                                 \
2458      TRIE_LIST_CUR( state ) = 1;                                \
2459      TRIE_LIST_LEN( state ) = 4;                                \
2460 } STMT_END
2461
2462 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2463     U16 dupe= trie->states[ state ].wordnum;                    \
2464     regnode * const noper_next = regnext( noper );              \
2465                                                                 \
2466     DEBUG_r({                                                   \
2467         /* store the word for dumping */                        \
2468         SV* tmp;                                                \
2469         if (OP(noper) != NOTHING)                               \
2470             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2471         else                                                    \
2472             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2473         av_push( trie_words, tmp );                             \
2474     });                                                         \
2475                                                                 \
2476     curword++;                                                  \
2477     trie->wordinfo[curword].prev   = 0;                         \
2478     trie->wordinfo[curword].len    = wordlen;                   \
2479     trie->wordinfo[curword].accept = state;                     \
2480                                                                 \
2481     if ( noper_next < tail ) {                                  \
2482         if (!trie->jump)                                        \
2483             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2484                                                  sizeof(U16) ); \
2485         trie->jump[curword] = (U16)(noper_next - convert);      \
2486         if (!jumper)                                            \
2487             jumper = noper_next;                                \
2488         if (!nextbranch)                                        \
2489             nextbranch= regnext(cur);                           \
2490     }                                                           \
2491                                                                 \
2492     if ( dupe ) {                                               \
2493         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2494         /* chain, so that when the bits of chain are later    */\
2495         /* linked together, the dups appear in the chain      */\
2496         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2497         trie->wordinfo[dupe].prev = curword;                    \
2498     } else {                                                    \
2499         /* we haven't inserted this word yet.                */ \
2500         trie->states[ state ].wordnum = curword;                \
2501     }                                                           \
2502 } STMT_END
2503
2504
2505 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2506      ( ( base + charid >=  ucharcount                                   \
2507          && base + charid < ubound                                      \
2508          && state == trie->trans[ base - ucharcount + charid ].check    \
2509          && trie->trans[ base - ucharcount + charid ].next )            \
2510            ? trie->trans[ base - ucharcount + charid ].next             \
2511            : ( state==1 ? special : 0 )                                 \
2512       )
2513
2514 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2515 STMT_START {                                                \
2516     TRIE_BITMAP_SET(trie, uvc);                             \
2517     /* store the folded codepoint */                        \
2518     if ( folder )                                           \
2519         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2520                                                             \
2521     if ( !UTF ) {                                           \
2522         /* store first byte of utf8 representation of */    \
2523         /* variant codepoints */                            \
2524         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2525             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2526         }                                                   \
2527     }                                                       \
2528 } STMT_END
2529 #define MADE_TRIE       1
2530 #define MADE_JUMP_TRIE  2
2531 #define MADE_EXACT_TRIE 4
2532
2533 STATIC I32
2534 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2535                   regnode *first, regnode *last, regnode *tail,
2536                   U32 word_count, U32 flags, U32 depth)
2537 {
2538     /* first pass, loop through and scan words */
2539     reg_trie_data *trie;
2540     HV *widecharmap = NULL;
2541     AV *revcharmap = newAV();
2542     regnode *cur;
2543     STRLEN len = 0;
2544     UV uvc = 0;
2545     U16 curword = 0;
2546     U32 next_alloc = 0;
2547     regnode *jumper = NULL;
2548     regnode *nextbranch = NULL;
2549     regnode *convert = NULL;
2550     U32 *prev_states; /* temp array mapping each state to previous one */
2551     /* we just use folder as a flag in utf8 */
2552     const U8 * folder = NULL;
2553
2554     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2555      * which stands for one trie structure, one hash, optionally followed
2556      * by two arrays */
2557 #ifdef DEBUGGING
2558     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2559     AV *trie_words = NULL;
2560     /* along with revcharmap, this only used during construction but both are
2561      * useful during debugging so we store them in the struct when debugging.
2562      */
2563 #else
2564     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2565     STRLEN trie_charcount=0;
2566 #endif
2567     SV *re_trie_maxbuff;
2568     GET_RE_DEBUG_FLAGS_DECL;
2569
2570     PERL_ARGS_ASSERT_MAKE_TRIE;
2571 #ifndef DEBUGGING
2572     PERL_UNUSED_ARG(depth);
2573 #endif
2574
2575     switch (flags) {
2576         case EXACT: case EXACTL: break;
2577         case EXACTFAA:
2578         case EXACTFU_SS:
2579         case EXACTFU:
2580         case EXACTFLU8: folder = PL_fold_latin1; break;
2581         case EXACTF:  folder = PL_fold; break;
2582         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2583     }
2584
2585     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2586     trie->refcount = 1;
2587     trie->startstate = 1;
2588     trie->wordcount = word_count;
2589     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2590     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2591     if (flags == EXACT || flags == EXACTL)
2592         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2593     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2594                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2595
2596     DEBUG_r({
2597         trie_words = newAV();
2598     });
2599
2600     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2601     assert(re_trie_maxbuff);
2602     if (!SvIOK(re_trie_maxbuff)) {
2603         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2604     }
2605     DEBUG_TRIE_COMPILE_r({
2606         Perl_re_indentf( aTHX_
2607           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2608           depth+1,
2609           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2610           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2611     });
2612
2613    /* Find the node we are going to overwrite */
2614     if ( first == startbranch && OP( last ) != BRANCH ) {
2615         /* whole branch chain */
2616         convert = first;
2617     } else {
2618         /* branch sub-chain */
2619         convert = NEXTOPER( first );
2620     }
2621
2622     /*  -- First loop and Setup --
2623
2624        We first traverse the branches and scan each word to determine if it
2625        contains widechars, and how many unique chars there are, this is
2626        important as we have to build a table with at least as many columns as we
2627        have unique chars.
2628
2629        We use an array of integers to represent the character codes 0..255
2630        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2631        the native representation of the character value as the key and IV's for
2632        the coded index.
2633
2634        *TODO* If we keep track of how many times each character is used we can
2635        remap the columns so that the table compression later on is more
2636        efficient in terms of memory by ensuring the most common value is in the
2637        middle and the least common are on the outside.  IMO this would be better
2638        than a most to least common mapping as theres a decent chance the most
2639        common letter will share a node with the least common, meaning the node
2640        will not be compressible. With a middle is most common approach the worst
2641        case is when we have the least common nodes twice.
2642
2643      */
2644
2645     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2646         regnode *noper = NEXTOPER( cur );
2647         const U8 *uc;
2648         const U8 *e;
2649         int foldlen = 0;
2650         U32 wordlen      = 0;         /* required init */
2651         STRLEN minchars = 0;
2652         STRLEN maxchars = 0;
2653         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2654                                                bitmap?*/
2655
2656         if (OP(noper) == NOTHING) {
2657             /* skip past a NOTHING at the start of an alternation
2658              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2659              */
2660             regnode *noper_next= regnext(noper);
2661             if (noper_next < tail)
2662                 noper= noper_next;
2663         }
2664
2665         if ( noper < tail &&
2666                 (
2667                     OP(noper) == flags ||
2668                     (
2669                         flags == EXACTFU &&
2670                         OP(noper) == EXACTFU_SS
2671                     )
2672                 )
2673         ) {
2674             uc= (U8*)STRING(noper);
2675             e= uc + STR_LEN(noper);
2676         } else {
2677             trie->minlen= 0;
2678             continue;
2679         }
2680
2681
2682         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2683             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2684                                           regardless of encoding */
2685             if (OP( noper ) == EXACTFU_SS) {
2686                 /* false positives are ok, so just set this */
2687                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2688             }
2689         }
2690
2691         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2692                                            branch */
2693             TRIE_CHARCOUNT(trie)++;
2694             TRIE_READ_CHAR;
2695
2696             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2697              * is in effect.  Under /i, this character can match itself, or
2698              * anything that folds to it.  If not under /i, it can match just
2699              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2700              * all fold to k, and all are single characters.   But some folds
2701              * expand to more than one character, so for example LATIN SMALL
2702              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2703              * the string beginning at 'uc' is 'ffi', it could be matched by
2704              * three characters, or just by the one ligature character. (It
2705              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2706              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2707              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2708              * match.)  The trie needs to know the minimum and maximum number
2709              * of characters that could match so that it can use size alone to
2710              * quickly reject many match attempts.  The max is simple: it is
2711              * the number of folded characters in this branch (since a fold is
2712              * never shorter than what folds to it. */
2713
2714             maxchars++;
2715
2716             /* And the min is equal to the max if not under /i (indicated by
2717              * 'folder' being NULL), or there are no multi-character folds.  If
2718              * there is a multi-character fold, the min is incremented just
2719              * once, for the character that folds to the sequence.  Each
2720              * character in the sequence needs to be added to the list below of
2721              * characters in the trie, but we count only the first towards the
2722              * min number of characters needed.  This is done through the
2723              * variable 'foldlen', which is returned by the macros that look
2724              * for these sequences as the number of bytes the sequence
2725              * occupies.  Each time through the loop, we decrement 'foldlen' by
2726              * how many bytes the current char occupies.  Only when it reaches
2727              * 0 do we increment 'minchars' or look for another multi-character
2728              * sequence. */
2729             if (folder == NULL) {
2730                 minchars++;
2731             }
2732             else if (foldlen > 0) {
2733                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2734             }
2735             else {
2736                 minchars++;
2737
2738                 /* See if *uc is the beginning of a multi-character fold.  If
2739                  * so, we decrement the length remaining to look at, to account
2740                  * for the current character this iteration.  (We can use 'uc'
2741                  * instead of the fold returned by TRIE_READ_CHAR because for
2742                  * non-UTF, the latin1_safe macro is smart enough to account
2743                  * for all the unfolded characters, and because for UTF, the
2744                  * string will already have been folded earlier in the
2745                  * compilation process */
2746                 if (UTF) {
2747                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2748                         foldlen -= UTF8SKIP(uc);
2749                     }
2750                 }
2751                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2752                     foldlen--;
2753                 }
2754             }
2755
2756             /* The current character (and any potential folds) should be added
2757              * to the possible matching characters for this position in this
2758              * branch */
2759             if ( uvc < 256 ) {
2760                 if ( folder ) {
2761                     U8 folded= folder[ (U8) uvc ];
2762                     if ( !trie->charmap[ folded ] ) {
2763                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2764                         TRIE_STORE_REVCHAR( folded );
2765                     }
2766                 }
2767                 if ( !trie->charmap[ uvc ] ) {
2768                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2769                     TRIE_STORE_REVCHAR( uvc );
2770                 }
2771                 if ( set_bit ) {
2772                     /* store the codepoint in the bitmap, and its folded
2773                      * equivalent. */
2774                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2775                     set_bit = 0; /* We've done our bit :-) */
2776                 }
2777             } else {
2778
2779                 /* XXX We could come up with the list of code points that fold
2780                  * to this using PL_utf8_foldclosures, except not for
2781                  * multi-char folds, as there may be multiple combinations
2782                  * there that could work, which needs to wait until runtime to
2783                  * resolve (The comment about LIGATURE FFI above is such an
2784                  * example */
2785
2786                 SV** svpp;
2787                 if ( !widecharmap )
2788                     widecharmap = newHV();
2789
2790                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2791
2792                 if ( !svpp )
2793                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2794
2795                 if ( !SvTRUE( *svpp ) ) {
2796                     sv_setiv( *svpp, ++trie->uniquecharcount );
2797                     TRIE_STORE_REVCHAR(uvc);
2798                 }
2799             }
2800         } /* end loop through characters in this branch of the trie */
2801
2802         /* We take the min and max for this branch and combine to find the min
2803          * and max for all branches processed so far */
2804         if( cur == first ) {
2805             trie->minlen = minchars;
2806             trie->maxlen = maxchars;
2807         } else if (minchars < trie->minlen) {
2808             trie->minlen = minchars;
2809         } else if (maxchars > trie->maxlen) {
2810             trie->maxlen = maxchars;
2811         }
2812     } /* end first pass */
2813     DEBUG_TRIE_COMPILE_r(
2814         Perl_re_indentf( aTHX_
2815                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2816                 depth+1,
2817                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2818                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2819                 (int)trie->minlen, (int)trie->maxlen )
2820     );
2821
2822     /*
2823         We now know what we are dealing with in terms of unique chars and
2824         string sizes so we can calculate how much memory a naive
2825         representation using a flat table  will take. If it's over a reasonable
2826         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2827         conservative but potentially much slower representation using an array
2828         of lists.
2829
2830         At the end we convert both representations into the same compressed
2831         form that will be used in regexec.c for matching with. The latter
2832         is a form that cannot be used to construct with but has memory
2833         properties similar to the list form and access properties similar
2834         to the table form making it both suitable for fast searches and
2835         small enough that its feasable to store for the duration of a program.
2836
2837         See the comment in the code where the compressed table is produced
2838         inplace from the flat tabe representation for an explanation of how
2839         the compression works.
2840
2841     */
2842
2843
2844     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2845     prev_states[1] = 0;
2846
2847     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2848                                                     > SvIV(re_trie_maxbuff) )
2849     {
2850         /*
2851             Second Pass -- Array Of Lists Representation
2852
2853             Each state will be represented by a list of charid:state records
2854             (reg_trie_trans_le) the first such element holds the CUR and LEN
2855             points of the allocated array. (See defines above).
2856
2857             We build the initial structure using the lists, and then convert
2858             it into the compressed table form which allows faster lookups
2859             (but cant be modified once converted).
2860         */
2861
2862         STRLEN transcount = 1;
2863
2864         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2865             depth+1));
2866
2867         trie->states = (reg_trie_state *)
2868             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2869                                   sizeof(reg_trie_state) );
2870         TRIE_LIST_NEW(1);
2871         next_alloc = 2;
2872
2873         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2874
2875             regnode *noper   = NEXTOPER( cur );
2876             U32 state        = 1;         /* required init */
2877             U16 charid       = 0;         /* sanity init */
2878             U32 wordlen      = 0;         /* required init */
2879
2880             if (OP(noper) == NOTHING) {
2881                 regnode *noper_next= regnext(noper);
2882                 if (noper_next < tail)
2883                     noper= noper_next;
2884             }
2885
2886             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2887                 const U8 *uc= (U8*)STRING(noper);
2888                 const U8 *e= uc + STR_LEN(noper);
2889
2890                 for ( ; uc < e ; uc += len ) {
2891
2892                     TRIE_READ_CHAR;
2893
2894                     if ( uvc < 256 ) {
2895                         charid = trie->charmap[ uvc ];
2896                     } else {
2897                         SV** const svpp = hv_fetch( widecharmap,
2898                                                     (char*)&uvc,
2899                                                     sizeof( UV ),
2900                                                     0);
2901                         if ( !svpp ) {
2902                             charid = 0;
2903                         } else {
2904                             charid=(U16)SvIV( *svpp );
2905                         }
2906                     }
2907                     /* charid is now 0 if we dont know the char read, or
2908                      * nonzero if we do */
2909                     if ( charid ) {
2910
2911                         U16 check;
2912                         U32 newstate = 0;
2913
2914                         charid--;
2915                         if ( !trie->states[ state ].trans.list ) {
2916                             TRIE_LIST_NEW( state );
2917                         }
2918                         for ( check = 1;
2919                               check <= TRIE_LIST_USED( state );
2920                               check++ )
2921                         {
2922                             if ( TRIE_LIST_ITEM( state, check ).forid
2923                                                                     == charid )
2924                             {
2925                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2926                                 break;
2927                             }
2928                         }
2929                         if ( ! newstate ) {
2930                             newstate = next_alloc++;
2931                             prev_states[newstate] = state;
2932                             TRIE_LIST_PUSH( state, charid, newstate );
2933                             transcount++;
2934                         }
2935                         state = newstate;
2936                     } else {
2937                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2938                     }
2939                 }
2940             }
2941             TRIE_HANDLE_WORD(state);
2942
2943         } /* end second pass */
2944
2945         /* next alloc is the NEXT state to be allocated */
2946         trie->statecount = next_alloc;
2947         trie->states = (reg_trie_state *)
2948             PerlMemShared_realloc( trie->states,
2949                                    next_alloc
2950                                    * sizeof(reg_trie_state) );
2951
2952         /* and now dump it out before we compress it */
2953         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2954                                                          revcharmap, next_alloc,
2955                                                          depth+1)
2956         );
2957
2958         trie->trans = (reg_trie_trans *)
2959             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2960         {
2961             U32 state;
2962             U32 tp = 0;
2963             U32 zp = 0;
2964
2965
2966             for( state=1 ; state < next_alloc ; state ++ ) {
2967                 U32 base=0;
2968
2969                 /*
2970                 DEBUG_TRIE_COMPILE_MORE_r(
2971                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2972                 );
2973                 */
2974
2975                 if (trie->states[state].trans.list) {
2976                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2977                     U16 maxid=minid;
2978                     U16 idx;
2979
2980                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2981                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2982                         if ( forid < minid ) {
2983                             minid=forid;
2984                         } else if ( forid > maxid ) {
2985                             maxid=forid;
2986                         }
2987                     }
2988                     if ( transcount < tp + maxid - minid + 1) {
2989                         transcount *= 2;
2990                         trie->trans = (reg_trie_trans *)
2991                             PerlMemShared_realloc( trie->trans,
2992                                                      transcount
2993                                                      * sizeof(reg_trie_trans) );
2994                         Zero( trie->trans + (transcount / 2),
2995                               transcount / 2,
2996                               reg_trie_trans );
2997                     }
2998                     base = trie->uniquecharcount + tp - minid;
2999                     if ( maxid == minid ) {
3000                         U32 set = 0;
3001                         for ( ; zp < tp ; zp++ ) {
3002                             if ( ! trie->trans[ zp ].next ) {
3003                                 base = trie->uniquecharcount + zp - minid;
3004                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
3005                                                                    1).newstate;
3006                                 trie->trans[ zp ].check = state;
3007                                 set = 1;
3008                                 break;
3009                             }
3010                         }
3011                         if ( !set ) {
3012                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
3013                                                                    1).newstate;
3014                             trie->trans[ tp ].check = state;
3015                             tp++;
3016                             zp = tp;
3017                         }
3018                     } else {
3019                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3020                             const U32 tid = base
3021                                            - trie->uniquecharcount
3022                                            + TRIE_LIST_ITEM( state, idx ).forid;
3023                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
3024                                                                 idx ).newstate;
3025                             trie->trans[ tid ].check = state;
3026                         }
3027                         tp += ( maxid - minid + 1 );
3028                     }
3029                     Safefree(trie->states[ state ].trans.list);
3030                 }
3031                 /*
3032                 DEBUG_TRIE_COMPILE_MORE_r(
3033                     Perl_re_printf( aTHX_  " base: %d\n",base);
3034                 );
3035                 */
3036                 trie->states[ state ].trans.base=base;
3037             }
3038             trie->lasttrans = tp + 1;
3039         }
3040     } else {
3041         /*
3042            Second Pass -- Flat Table Representation.
3043
3044            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3045            each.  We know that we will need Charcount+1 trans at most to store
3046            the data (one row per char at worst case) So we preallocate both
3047            structures assuming worst case.
3048
3049            We then construct the trie using only the .next slots of the entry
3050            structs.
3051
3052            We use the .check field of the first entry of the node temporarily
3053            to make compression both faster and easier by keeping track of how
3054            many non zero fields are in the node.
3055
3056            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3057            transition.
3058
3059            There are two terms at use here: state as a TRIE_NODEIDX() which is
3060            a number representing the first entry of the node, and state as a
3061            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3062            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3063            if there are 2 entrys per node. eg:
3064
3065              A B       A B
3066           1. 2 4    1. 3 7
3067           2. 0 3    3. 0 5
3068           3. 0 0    5. 0 0
3069           4. 0 0    7. 0 0
3070
3071            The table is internally in the right hand, idx form. However as we
3072            also have to deal with the states array which is indexed by nodenum
3073            we have to use TRIE_NODENUM() to convert.
3074
3075         */
3076         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3077             depth+1));
3078
3079         trie->trans = (reg_trie_trans *)
3080             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3081                                   * trie->uniquecharcount + 1,
3082                                   sizeof(reg_trie_trans) );
3083         trie->states = (reg_trie_state *)
3084             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3085                                   sizeof(reg_trie_state) );
3086         next_alloc = trie->uniquecharcount + 1;
3087
3088
3089         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3090
3091             regnode *noper   = NEXTOPER( cur );
3092
3093             U32 state        = 1;         /* required init */
3094
3095             U16 charid       = 0;         /* sanity init */
3096             U32 accept_state = 0;         /* sanity init */
3097
3098             U32 wordlen      = 0;         /* required init */
3099
3100             if (OP(noper) == NOTHING) {
3101                 regnode *noper_next= regnext(noper);
3102                 if (noper_next < tail)
3103                     noper= noper_next;
3104             }
3105
3106             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3107                 const U8 *uc= (U8*)STRING(noper);
3108                 const U8 *e= uc + STR_LEN(noper);
3109
3110                 for ( ; uc < e ; uc += len ) {
3111
3112                     TRIE_READ_CHAR;
3113
3114                     if ( uvc < 256 ) {
3115                         charid = trie->charmap[ uvc ];
3116                     } else {
3117                         SV* const * const svpp = hv_fetch( widecharmap,
3118                                                            (char*)&uvc,
3119                                                            sizeof( UV ),
3120                                                            0);
3121                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3122                     }
3123                     if ( charid ) {
3124                         charid--;
3125                         if ( !trie->trans[ state + charid ].next ) {
3126                             trie->trans[ state + charid ].next = next_alloc;
3127                             trie->trans[ state ].check++;
3128                             prev_states[TRIE_NODENUM(next_alloc)]
3129                                     = TRIE_NODENUM(state);
3130                             next_alloc += trie->uniquecharcount;
3131                         }
3132                         state = trie->trans[ state + charid ].next;
3133                     } else {
3134                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3135                     }
3136                     /* charid is now 0 if we dont know the char read, or
3137                      * nonzero if we do */
3138                 }
3139             }
3140             accept_state = TRIE_NODENUM( state );
3141             TRIE_HANDLE_WORD(accept_state);
3142
3143         } /* end second pass */
3144
3145         /* and now dump it out before we compress it */
3146         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3147                                                           revcharmap,
3148                                                           next_alloc, depth+1));
3149
3150         {
3151         /*
3152            * Inplace compress the table.*
3153
3154            For sparse data sets the table constructed by the trie algorithm will
3155            be mostly 0/FAIL transitions or to put it another way mostly empty.
3156            (Note that leaf nodes will not contain any transitions.)
3157
3158            This algorithm compresses the tables by eliminating most such
3159            transitions, at the cost of a modest bit of extra work during lookup:
3160
3161            - Each states[] entry contains a .base field which indicates the
3162            index in the state[] array wheres its transition data is stored.
3163
3164            - If .base is 0 there are no valid transitions from that node.
3165
3166            - If .base is nonzero then charid is added to it to find an entry in
3167            the trans array.
3168
3169            -If trans[states[state].base+charid].check!=state then the
3170            transition is taken to be a 0/Fail transition. Thus if there are fail
3171            transitions at the front of the node then the .base offset will point
3172            somewhere inside the previous nodes data (or maybe even into a node
3173            even earlier), but the .check field determines if the transition is
3174            valid.
3175
3176            XXX - wrong maybe?
3177            The following process inplace converts the table to the compressed
3178            table: We first do not compress the root node 1,and mark all its
3179            .check pointers as 1 and set its .base pointer as 1 as well. This
3180            allows us to do a DFA construction from the compressed table later,
3181            and ensures that any .base pointers we calculate later are greater
3182            than 0.
3183
3184            - We set 'pos' to indicate the first entry of the second node.
3185
3186            - We then iterate over the columns of the node, finding the first and
3187            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3188            and set the .check pointers accordingly, and advance pos
3189            appropriately and repreat for the next node. Note that when we copy
3190            the next pointers we have to convert them from the original
3191            NODEIDX form to NODENUM form as the former is not valid post
3192            compression.
3193
3194            - If a node has no transitions used we mark its base as 0 and do not
3195            advance the pos pointer.
3196
3197            - If a node only has one transition we use a second pointer into the
3198            structure to fill in allocated fail transitions from other states.
3199            This pointer is independent of the main pointer and scans forward
3200            looking for null transitions that are allocated to a state. When it
3201            finds one it writes the single transition into the "hole".  If the
3202            pointer doesnt find one the single transition is appended as normal.
3203
3204            - Once compressed we can Renew/realloc the structures to release the
3205            excess space.
3206
3207            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3208            specifically Fig 3.47 and the associated pseudocode.
3209
3210            demq
3211         */
3212         const U32 laststate = TRIE_NODENUM( next_alloc );
3213         U32 state, charid;
3214         U32 pos = 0, zp=0;
3215         trie->statecount = laststate;
3216
3217         for ( state = 1 ; state < laststate ; state++ ) {
3218             U8 flag = 0;
3219             const U32 stateidx = TRIE_NODEIDX( state );
3220             const U32 o_used = trie->trans[ stateidx ].check;
3221             U32 used = trie->trans[ stateidx ].check;
3222             trie->trans[ stateidx ].check = 0;
3223
3224             for ( charid = 0;
3225                   used && charid < trie->uniquecharcount;
3226                   charid++ )
3227             {
3228                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3229                     if ( trie->trans[ stateidx + charid ].next ) {
3230                         if (o_used == 1) {
3231                             for ( ; zp < pos ; zp++ ) {
3232                                 if ( ! trie->trans[ zp ].next ) {
3233                                     break;
3234                                 }
3235                             }
3236                             trie->states[ state ].trans.base
3237                                                     = zp
3238                                                       + trie->uniquecharcount
3239                                                       - charid ;
3240                             trie->trans[ zp ].next
3241                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3242                                                              + charid ].next );
3243                             trie->trans[ zp ].check = state;
3244                             if ( ++zp > pos ) pos = zp;
3245                             break;
3246                         }
3247                         used--;
3248                     }
3249                     if ( !flag ) {
3250                         flag = 1;
3251                         trie->states[ state ].trans.base
3252                                        = pos + trie->uniquecharcount - charid ;
3253                     }
3254                     trie->trans[ pos ].next
3255                         = SAFE_TRIE_NODENUM(
3256                                        trie->trans[ stateidx + charid ].next );
3257                     trie->trans[ pos ].check = state;
3258                     pos++;
3259                 }
3260             }
3261         }
3262         trie->lasttrans = pos + 1;
3263         trie->states = (reg_trie_state *)
3264             PerlMemShared_realloc( trie->states, laststate
3265                                    * sizeof(reg_trie_state) );
3266         DEBUG_TRIE_COMPILE_MORE_r(
3267             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3268                 depth+1,
3269                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3270                        + 1 ),
3271                 (IV)next_alloc,
3272                 (IV)pos,
3273                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3274             );
3275
3276         } /* end table compress */
3277     }
3278     DEBUG_TRIE_COMPILE_MORE_r(
3279             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3280                 depth+1,
3281                 (UV)trie->statecount,
3282                 (UV)trie->lasttrans)
3283     );
3284     /* resize the trans array to remove unused space */
3285     trie->trans = (reg_trie_trans *)
3286         PerlMemShared_realloc( trie->trans, trie->lasttrans
3287                                * sizeof(reg_trie_trans) );
3288
3289     {   /* Modify the program and insert the new TRIE node */
3290         U8 nodetype =(U8)(flags & 0xFF);
3291         char *str=NULL;
3292
3293 #ifdef DEBUGGING
3294         regnode *optimize = NULL;
3295 #ifdef RE_TRACK_PATTERN_OFFSETS
3296
3297         U32 mjd_offset = 0;
3298         U32 mjd_nodelen = 0;
3299 #endif /* RE_TRACK_PATTERN_OFFSETS */
3300 #endif /* DEBUGGING */
3301         /*
3302            This means we convert either the first branch or the first Exact,
3303            depending on whether the thing following (in 'last') is a branch
3304            or not and whther first is the startbranch (ie is it a sub part of
3305            the alternation or is it the whole thing.)
3306            Assuming its a sub part we convert the EXACT otherwise we convert
3307            the whole branch sequence, including the first.
3308          */
3309         /* Find the node we are going to overwrite */
3310         if ( first != startbranch || OP( last ) == BRANCH ) {
3311             /* branch sub-chain */
3312             NEXT_OFF( first ) = (U16)(last - first);
3313 #ifdef RE_TRACK_PATTERN_OFFSETS
3314             DEBUG_r({
3315                 mjd_offset= Node_Offset((convert));
3316                 mjd_nodelen= Node_Length((convert));
3317             });
3318 #endif
3319             /* whole branch chain */
3320         }
3321 #ifdef RE_TRACK_PATTERN_OFFSETS
3322         else {
3323             DEBUG_r({
3324                 const  regnode *nop = NEXTOPER( convert );
3325                 mjd_offset= Node_Offset((nop));
3326                 mjd_nodelen= Node_Length((nop));
3327             });
3328         }
3329         DEBUG_OPTIMISE_r(
3330             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3331                 depth+1,
3332                 (UV)mjd_offset, (UV)mjd_nodelen)
3333         );
3334 #endif
3335         /* But first we check to see if there is a common prefix we can
3336            split out as an EXACT and put in front of the TRIE node.  */
3337         trie->startstate= 1;
3338         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3339             /* we want to find the first state that has more than
3340              * one transition, if that state is not the first state
3341              * then we have a common prefix which we can remove.
3342              */
3343             U32 state;
3344             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3345                 U32 ofs = 0;
3346                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3347                                        transition, -1 means none */
3348                 U32 count = 0;
3349                 const U32 base = trie->states[ state ].trans.base;
3350
3351                 /* does this state terminate an alternation? */
3352                 if ( trie->states[state].wordnum )
3353                         count = 1;
3354
3355                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3356                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3357                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3358                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3359                     {
3360                         if ( ++count > 1 ) {
3361                             /* we have more than one transition */
3362                             SV **tmp;
3363                             U8 *ch;
3364                             /* if this is the first state there is no common prefix
3365                              * to extract, so we can exit */
3366                             if ( state == 1 ) break;
3367                             tmp = av_fetch( revcharmap, ofs, 0);
3368                             ch = (U8*)SvPV_nolen_const( *tmp );
3369
3370                             /* if we are on count 2 then we need to initialize the
3371                              * bitmap, and store the previous char if there was one
3372                              * in it*/
3373                             if ( count == 2 ) {
3374                                 /* clear the bitmap */
3375                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3376                                 DEBUG_OPTIMISE_r(
3377                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3378                                         depth+1,
3379                                         (UV)state));
3380                                 if (first_ofs >= 0) {
3381                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3382                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3383
3384                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3385                                     DEBUG_OPTIMISE_r(
3386                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3387                                     );
3388                                 }
3389                             }
3390                             /* store the current firstchar in the bitmap */
3391                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3392                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3393                         }
3394                         first_ofs = ofs;
3395                     }
3396                 }
3397                 if ( count == 1 ) {
3398                     /* This state has only one transition, its transition is part
3399                      * of a common prefix - we need to concatenate the char it
3400                      * represents to what we have so far. */
3401                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3402                     STRLEN len;
3403                     char *ch = SvPV( *tmp, len );
3404                     DEBUG_OPTIMISE_r({
3405                         SV *sv=sv_newmortal();
3406                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3407                             depth+1,
3408                             (UV)state, (UV)first_ofs,
3409                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3410                                 PL_colors[0], PL_colors[1],
3411                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3412                                 PERL_PV_ESCAPE_FIRSTCHAR
3413                             )
3414                         );
3415                     });
3416                     if ( state==1 ) {
3417                         OP( convert ) = nodetype;
3418                         str=STRING(convert);
3419                         STR_LEN(convert)=0;
3420                     }
3421                     STR_LEN(convert) += len;
3422                     while (len--)
3423                         *str++ = *ch++;
3424                 } else {
3425 #ifdef DEBUGGING
3426                     if (state>1)
3427                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3428 #endif
3429                     break;
3430                 }
3431             }
3432             trie->prefixlen = (state-1);
3433             if (str) {
3434                 regnode *n = convert+NODE_SZ_STR(convert);
3435                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3436                 trie->startstate = state;
3437                 trie->minlen -= (state - 1);
3438                 trie->maxlen -= (state - 1);
3439 #ifdef DEBUGGING
3440                /* At least the UNICOS C compiler choked on this
3441                 * being argument to DEBUG_r(), so let's just have
3442                 * it right here. */
3443                if (
3444 #ifdef PERL_EXT_RE_BUILD
3445                    1
3446 #else
3447                    DEBUG_r_TEST
3448 #endif
3449                    ) {
3450                    regnode *fix = convert;
3451                    U32 word = trie->wordcount;
3452                    mjd_nodelen++;
3453                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3454                    while( ++fix < n ) {
3455                        Set_Node_Offset_Length(fix, 0, 0);
3456                    }
3457                    while (word--) {
3458                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3459                        if (tmp) {
3460                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3461                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3462                            else
3463                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3464                        }
3465                    }
3466                }
3467 #endif
3468                 if (trie->maxlen) {
3469                     convert = n;
3470                 } else {
3471                     NEXT_OFF(convert) = (U16)(tail - convert);
3472                     DEBUG_r(optimize= n);
3473                 }
3474             }
3475         }
3476         if (!jumper)
3477             jumper = last;
3478         if ( trie->maxlen ) {
3479             NEXT_OFF( convert ) = (U16)(tail - convert);
3480             ARG_SET( convert, data_slot );
3481             /* Store the offset to the first unabsorbed branch in
3482                jump[0], which is otherwise unused by the jump logic.
3483                We use this when dumping a trie and during optimisation. */
3484             if (trie->jump)
3485                 trie->jump[0] = (U16)(nextbranch - convert);
3486
3487             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3488              *   and there is a bitmap
3489              *   and the first "jump target" node we found leaves enough room
3490              * then convert the TRIE node into a TRIEC node, with the bitmap
3491              * embedded inline in the opcode - this is hypothetically faster.
3492              */
3493             if ( !trie->states[trie->startstate].wordnum
3494                  && trie->bitmap
3495                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3496             {
3497                 OP( convert ) = TRIEC;
3498                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3499                 PerlMemShared_free(trie->bitmap);
3500                 trie->bitmap= NULL;
3501             } else
3502                 OP( convert ) = TRIE;
3503
3504             /* store the type in the flags */
3505             convert->flags = nodetype;
3506             DEBUG_r({
3507             optimize = convert
3508                       + NODE_STEP_REGNODE
3509                       + regarglen[ OP( convert ) ];
3510             });
3511             /* XXX We really should free up the resource in trie now,
3512                    as we won't use them - (which resources?) dmq */
3513         }
3514         /* needed for dumping*/
3515         DEBUG_r(if (optimize) {
3516             regnode *opt = convert;
3517
3518             while ( ++opt < optimize) {
3519                 Set_Node_Offset_Length(opt,0,0);
3520             }
3521             /*
3522                 Try to clean up some of the debris left after the
3523                 optimisation.
3524              */
3525             while( optimize < jumper ) {
3526                 mjd_nodelen += Node_Length((optimize));
3527                 OP( optimize ) = OPTIMIZED;
3528                 Set_Node_Offset_Length(optimize,0,0);
3529                 optimize++;
3530             }
3531             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3532         });
3533     } /* end node insert */
3534
3535     /*  Finish populating the prev field of the wordinfo array.  Walk back
3536      *  from each accept state until we find another accept state, and if
3537      *  so, point the first word's .prev field at the second word. If the
3538      *  second already has a .prev field set, stop now. This will be the
3539      *  case either if we've already processed that word's accept state,
3540      *  or that state had multiple words, and the overspill words were
3541      *  already linked up earlier.
3542      */
3543     {
3544         U16 word;
3545         U32 state;
3546         U16 prev;
3547
3548         for (word=1; word <= trie->wordcount; word++) {
3549             prev = 0;
3550             if (trie->wordinfo[word].prev)
3551                 continue;
3552             state = trie->wordinfo[word].accept;
3553             while (state) {
3554                 state = prev_states[state];
3555                 if (!state)
3556                     break;
3557                 prev = trie->states[state].wordnum;
3558                 if (prev)
3559                     break;
3560             }
3561             trie->wordinfo[word].prev = prev;
3562         }
3563         Safefree(prev_states);
3564     }
3565
3566
3567     /* and now dump out the compressed format */
3568     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3569
3570     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3571 #ifdef DEBUGGING
3572     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3573     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3574 #else
3575     SvREFCNT_dec_NN(revcharmap);
3576 #endif
3577     return trie->jump
3578            ? MADE_JUMP_TRIE
3579            : trie->startstate>1
3580              ? MADE_EXACT_TRIE
3581              : MADE_TRIE;
3582 }
3583
3584 STATIC regnode *
3585 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3586 {
3587 /* The Trie is constructed and compressed now so we can build a fail array if
3588  * it's needed
3589
3590    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3591    3.32 in the
3592    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3593    Ullman 1985/88
3594    ISBN 0-201-10088-6
3595
3596    We find the fail state for each state in the trie, this state is the longest
3597    proper suffix of the current state's 'word' that is also a proper prefix of
3598    another word in our trie. State 1 represents the word '' and is thus the
3599    default fail state. This allows the DFA not to have to restart after its
3600    tried and failed a word at a given point, it simply continues as though it
3601    had been matching the other word in the first place.
3602    Consider
3603       'abcdgu'=~/abcdefg|cdgu/
3604    When we get to 'd' we are still matching the first word, we would encounter
3605    'g' which would fail, which would bring us to the state representing 'd' in
3606    the second word where we would try 'g' and succeed, proceeding to match
3607    'cdgu'.
3608  */
3609  /* add a fail transition */
3610     const U32 trie_offset = ARG(source);
3611     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3612     U32 *q;
3613     const U32 ucharcount = trie->uniquecharcount;
3614     const U32 numstates = trie->statecount;
3615     const U32 ubound = trie->lasttrans + ucharcount;
3616     U32 q_read = 0;
3617     U32 q_write = 0;
3618     U32 charid;
3619     U32 base = trie->states[ 1 ].trans.base;
3620     U32 *fail;
3621     reg_ac_data *aho;
3622     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3623     regnode *stclass;
3624     GET_RE_DEBUG_FLAGS_DECL;
3625
3626     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3627     PERL_UNUSED_CONTEXT;
3628 #ifndef DEBUGGING
3629     PERL_UNUSED_ARG(depth);
3630 #endif
3631
3632     if ( OP(source) == TRIE ) {
3633         struct regnode_1 *op = (struct regnode_1 *)
3634             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3635         StructCopy(source,op,struct regnode_1);
3636         stclass = (regnode *)op;
3637     } else {
3638         struct regnode_charclass *op = (struct regnode_charclass *)
3639             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3640         StructCopy(source,op,struct regnode_charclass);
3641         stclass = (regnode *)op;
3642     }
3643     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3644
3645     ARG_SET( stclass, data_slot );
3646     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3647     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3648     aho->trie=trie_offset;
3649     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3650     Copy( trie->states, aho->states, numstates, reg_trie_state );
3651     Newx( q, numstates, U32);
3652     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3653     aho->refcount = 1;
3654     fail = aho->fail;
3655     /* initialize fail[0..1] to be 1 so that we always have
3656        a valid final fail state */
3657     fail[ 0 ] = fail[ 1 ] = 1;
3658
3659     for ( charid = 0; charid < ucharcount ; charid++ ) {
3660         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3661         if ( newstate ) {
3662             q[ q_write ] = newstate;
3663             /* set to point at the root */
3664             fail[ q[ q_write++ ] ]=1;
3665         }
3666     }
3667     while ( q_read < q_write) {
3668         const U32 cur = q[ q_read++ % numstates ];
3669         base = trie->states[ cur ].trans.base;
3670
3671         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3672             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3673             if (ch_state) {
3674                 U32 fail_state = cur;
3675                 U32 fail_base;
3676                 do {
3677                     fail_state = fail[ fail_state ];
3678                     fail_base = aho->states[ fail_state ].trans.base;
3679                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3680
3681                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3682                 fail[ ch_state ] = fail_state;
3683                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3684                 {
3685                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3686                 }
3687                 q[ q_write++ % numstates] = ch_state;
3688             }
3689         }
3690     }
3691     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3692        when we fail in state 1, this allows us to use the
3693        charclass scan to find a valid start char. This is based on the principle
3694        that theres a good chance the string being searched contains lots of stuff
3695        that cant be a start char.
3696      */
3697     fail[ 0 ] = fail[ 1 ] = 0;
3698     DEBUG_TRIE_COMPILE_r({
3699         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3700                       depth, (UV)numstates
3701         );
3702         for( q_read=1; q_read<numstates; q_read++ ) {
3703             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3704         }
3705         Perl_re_printf( aTHX_  "\n");
3706     });
3707     Safefree(q);
3708     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3709     return stclass;
3710 }
3711
3712
3713 /* The below joins as many adjacent EXACTish nodes as possible into a single
3714  * one.  The regop may be changed if the node(s) contain certain sequences that
3715  * require special handling.  The joining is only done if:
3716  * 1) there is room in the current conglomerated node to entirely contain the
3717  *    next one.
3718  * 2) they are the exact same node type
3719  *
3720  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3721  * these get optimized out
3722  *
3723  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3724  * as possible, even if that means splitting an existing node so that its first
3725  * part is moved to the preceeding node.  This would maximise the efficiency of
3726  * memEQ during matching.
3727  *
3728  * If a node is to match under /i (folded), the number of characters it matches
3729  * can be different than its character length if it contains a multi-character
3730  * fold.  *min_subtract is set to the total delta number of characters of the
3731  * input nodes.
3732  *
3733  * And *unfolded_multi_char is set to indicate whether or not the node contains
3734  * an unfolded multi-char fold.  This happens when it won't be known until
3735  * runtime whether the fold is valid or not; namely
3736  *  1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
3737  *      target string being matched against turns out to be UTF-8 is that fold
3738  *      valid; or
3739  *  2) for EXACTFL nodes whose folding rules depend on the locale in force at
3740  *      runtime.
3741  * (Multi-char folds whose components are all above the Latin1 range are not
3742  * run-time locale dependent, and have already been folded by the time this
3743  * function is called.)
3744  *
3745  * This is as good a place as any to discuss the design of handling these
3746  * multi-character fold sequences.  It's been wrong in Perl for a very long
3747  * time.  There are three code points in Unicode whose multi-character folds
3748  * were long ago discovered to mess things up.  The previous designs for
3749  * dealing with these involved assigning a special node for them.  This
3750  * approach doesn't always work, as evidenced by this example:
3751  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3752  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3753  * would match just the \xDF, it won't be able to handle the case where a
3754  * successful match would have to cross the node's boundary.  The new approach
3755  * that hopefully generally solves the problem generates an EXACTFU_SS node
3756  * that is "sss" in this case.
3757  *
3758  * It turns out that there are problems with all multi-character folds, and not
3759  * just these three.  Now the code is general, for all such cases.  The
3760  * approach taken is:
3761  * 1)   This routine examines each EXACTFish node that could contain multi-
3762  *      character folded sequences.  Since a single character can fold into
3763  *      such a sequence, the minimum match length for this node is less than
3764  *      the number of characters in the node.  This routine returns in
3765  *      *min_subtract how many characters to subtract from the the actual
3766  *      length of the string to get a real minimum match length; it is 0 if
3767  *      there are no multi-char foldeds.  This delta is used by the caller to
3768  *      adjust the min length of the match, and the delta between min and max,
3769  *      so that the optimizer doesn't reject these possibilities based on size
3770  *      constraints.
3771  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3772  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3773  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3774  *      there is a possible fold length change.  That means that a regular
3775  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3776  *      with length changes, and so can be processed faster.  regexec.c takes
3777  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3778  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3779  *      known until runtime).  This saves effort in regex matching.  However,
3780  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3781  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3782  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3783  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3784  *      possibilities for the non-UTF8 patterns are quite simple, except for
3785  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3786  *      members of a fold-pair, and arrays are set up for all of them so that
3787  *      the other member of the pair can be found quickly.  Code elsewhere in
3788  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3789  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3790  *      described in the next item.
3791  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3792  *      validity of the fold won't be known until runtime, and so must remain
3793  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFAA
3794  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3795  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3796  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3797  *      The reason this is a problem is that the optimizer part of regexec.c
3798  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3799  *      that a character in the pattern corresponds to at most a single
3800  *      character in the target string.  (And I do mean character, and not byte
3801  *      here, unlike other parts of the documentation that have never been
3802  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3803  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
3804  *      nodes it can match "\x{17F}\x{17F}".  These, along with other ones in
3805  *      EXACTFL nodes, violate the assumption, and they are the only instances
3806  *      where it is violated.  I'm reluctant to try to change the assumption,
3807  *      as the code involved is impenetrable to me (khw), so instead the code
3808  *      here punts.  This routine examines EXACTFL nodes, and (when the pattern
3809  *      isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
3810  *      boolean indicating whether or not the node contains such a fold.  When
3811  *      it is true, the caller sets a flag that later causes the optimizer in
3812  *      this file to not set values for the floating and fixed string lengths,
3813  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3814  *      assumption.  Thus, there is no optimization based on string lengths for
3815  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3816  *      EXACTF and EXACTFAA nodes that contain the sharp s.  (The reason the
3817  *      assumption is wrong only in these cases is that all other non-UTF-8
3818  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3819  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3820  *      EXACTF nodes because we don't know at compile time if it actually
3821  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3822  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3823  *      always matches; and EXACTFAA where it never does.  In an EXACTFAA node
3824  *      in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3825  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3826  *      string would require the pattern to be forced into UTF-8, the overhead
3827  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3828  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3829  *      locale.)
3830  *
3831  *      Similarly, the code that generates tries doesn't currently handle
3832  *      not-already-folded multi-char folds, and it looks like a pain to change
3833  *      that.  Therefore, trie generation of EXACTFAA nodes with the sharp s
3834  *      doesn't work.  Instead, such an EXACTFAA is turned into a new regnode,
3835  *      EXACTFAA_NO_TRIE, which the trie code knows not to handle.  Most people
3836  *      using /iaa matching will be doing so almost entirely with ASCII
3837  *      strings, so this should rarely be encountered in practice */
3838
3839 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3840     if (PL_regkind[OP(scan)] == EXACT) \
3841         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3842
3843 STATIC U32
3844 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3845                    UV *min_subtract, bool *unfolded_multi_char,
3846                    U32 flags,regnode *val, U32 depth)
3847 {
3848     /* Merge several consecutive EXACTish nodes into one. */
3849     regnode *n = regnext(scan);
3850     U32 stringok = 1;
3851     regnode *next = scan + NODE_SZ_STR(scan);
3852     U32 merged = 0;
3853     U32 stopnow = 0;
3854 #ifdef DEBUGGING
3855     regnode *stop = scan;
3856     GET_RE_DEBUG_FLAGS_DECL;
3857 #else
3858     PERL_UNUSED_ARG(depth);
3859 #endif
3860
3861     PERL_ARGS_ASSERT_JOIN_EXACT;
3862 #ifndef EXPERIMENTAL_INPLACESCAN
3863     PERL_UNUSED_ARG(flags);
3864     PERL_UNUSED_ARG(val);
3865 #endif
3866     DEBUG_PEEP("join", scan, depth, 0);
3867
3868     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3869      * EXACT ones that are mergeable to the current one. */
3870     while (n
3871            && (PL_regkind[OP(n)] == NOTHING
3872                || (stringok && OP(n) == OP(scan)))
3873            && NEXT_OFF(n)
3874            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3875     {
3876
3877         if (OP(n) == TAIL || n > next)
3878             stringok = 0;
3879         if (PL_regkind[OP(n)] == NOTHING) {
3880             DEBUG_PEEP("skip:", n, depth, 0);
3881             NEXT_OFF(scan) += NEXT_OFF(n);
3882             next = n + NODE_STEP_REGNODE;
3883 #ifdef DEBUGGING
3884             if (stringok)
3885                 stop = n;
3886 #endif
3887             n = regnext(n);
3888         }
3889         else if (stringok) {
3890             const unsigned int oldl = STR_LEN(scan);
3891             regnode * const nnext = regnext(n);
3892
3893             /* XXX I (khw) kind of doubt that this works on platforms (should
3894              * Perl ever run on one) where U8_MAX is above 255 because of lots
3895              * of other assumptions */
3896             /* Don't join if the sum can't fit into a single node */
3897             if (oldl + STR_LEN(n) > U8_MAX)
3898                 break;
3899
3900             DEBUG_PEEP("merg", n, depth, 0);
3901             merged++;
3902
3903             NEXT_OFF(scan) += NEXT_OFF(n);
3904             STR_LEN(scan) += STR_LEN(n);
3905             next = n + NODE_SZ_STR(n);
3906             /* Now we can overwrite *n : */
3907             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3908 #ifdef DEBUGGING
3909             stop = next - 1;
3910 #endif
3911             n = nnext;
3912             if (stopnow) break;
3913         }
3914
3915 #ifdef EXPERIMENTAL_INPLACESCAN
3916         if (flags && !NEXT_OFF(n)) {
3917             DEBUG_PEEP("atch", val, depth, 0);
3918             if (reg_off_by_arg[OP(n)]) {
3919                 ARG_SET(n, val - n);
3920             }
3921             else {
3922                 NEXT_OFF(n) = val - n;
3923             }
3924             stopnow = 1;
3925         }
3926 #endif
3927     }
3928
3929     *min_subtract = 0;
3930     *unfolded_multi_char = FALSE;
3931
3932     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3933      * can now analyze for sequences of problematic code points.  (Prior to
3934      * this final joining, sequences could have been split over boundaries, and
3935      * hence missed).  The sequences only happen in folding, hence for any
3936      * non-EXACT EXACTish node */
3937     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3938         U8* s0 = (U8*) STRING(scan);
3939         U8* s = s0;
3940         U8* s_end = s0 + STR_LEN(scan);
3941
3942         int total_count_delta = 0;  /* Total delta number of characters that
3943                                        multi-char folds expand to */
3944
3945         /* One pass is made over the node's string looking for all the
3946          * possibilities.  To avoid some tests in the loop, there are two main
3947          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3948          * non-UTF-8 */
3949         if (UTF) {
3950             U8* folded = NULL;
3951
3952             if (OP(scan) == EXACTFL) {
3953                 U8 *d;
3954
3955                 /* An EXACTFL node would already have been changed to another
3956                  * node type unless there is at least one character in it that
3957                  * is problematic; likely a character whose fold definition
3958                  * won't be known until runtime, and so has yet to be folded.
3959                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3960                  * to handle the UTF-8 case, we need to create a temporary
3961                  * folded copy using UTF-8 locale rules in order to analyze it.
3962                  * This is because our macros that look to see if a sequence is
3963                  * a multi-char fold assume everything is folded (otherwise the
3964                  * tests in those macros would be too complicated and slow).
3965                  * Note that here, the non-problematic folds will have already
3966                  * been done, so we can just copy such characters.  We actually
3967                  * don't completely fold the EXACTFL string.  We skip the
3968                  * unfolded multi-char folds, as that would just create work
3969                  * below to figure out the size they already are */
3970
3971                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3972                 d = folded;
3973                 while (s < s_end) {
3974                     STRLEN s_len = UTF8SKIP(s);
3975                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3976                         Copy(s, d, s_len, U8);
3977                         d += s_len;
3978                     }
3979                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3980                         *unfolded_multi_char = TRUE;
3981                         Copy(s, d, s_len, U8);
3982                         d += s_len;
3983                     }
3984                     else if (isASCII(*s)) {
3985                         *(d++) = toFOLD(*s);
3986                     }
3987                     else {
3988                         STRLEN len;
3989                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3990                         d += len;
3991                     }
3992                     s += s_len;
3993                 }
3994
3995                 /* Point the remainder of the routine to look at our temporary
3996                  * folded copy */
3997                 s = folded;
3998                 s_end = d;
3999             } /* End of creating folded copy of EXACTFL string */
4000
4001             /* Examine the string for a multi-character fold sequence.  UTF-8
4002              * patterns have all characters pre-folded by the time this code is
4003              * executed */
4004             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
4005                                      length sequence we are looking for is 2 */
4006             {
4007                 int count = 0;  /* How many characters in a multi-char fold */
4008                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
4009                 if (! len) {    /* Not a multi-char fold: get next char */
4010                     s += UTF8SKIP(s);
4011                     continue;
4012                 }
4013
4014                 /* Nodes with 'ss' require special handling, except for
4015                  * EXACTFAA-ish for which there is no multi-char fold to this */
4016                 if (len == 2 && *s == 's' && *(s+1) == 's'
4017                     && OP(scan) != EXACTFAA
4018                     && OP(scan) != EXACTFAA_NO_TRIE)
4019                 {
4020                     count = 2;
4021                     if (OP(scan) != EXACTFL) {
4022                         OP(scan) = EXACTFU_SS;
4023                     }
4024                     s += 2;
4025                 }
4026                 else { /* Here is a generic multi-char fold. */
4027                     U8* multi_end  = s + len;
4028
4029                     /* Count how many characters are in it.  In the case of
4030                      * /aa, no folds which contain ASCII code points are
4031                      * allowed, so check for those, and skip if found. */
4032                     if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
4033                         count = utf8_length(s, multi_end);
4034                         s = multi_end;
4035                     }
4036                     else {
4037                         while (s < multi_end) {
4038                             if (isASCII(*s)) {
4039                                 s++;
4040                                 goto next_iteration;
4041                             }
4042                             else {
4043                                 s += UTF8SKIP(s);
4044                             }
4045                             count++;
4046                         }
4047                     }
4048                 }
4049
4050                 /* The delta is how long the sequence is minus 1 (1 is how long
4051                  * the character that folds to the sequence is) */
4052                 total_count_delta += count - 1;
4053               next_iteration: ;
4054             }
4055
4056             /* We created a temporary folded copy of the string in EXACTFL
4057              * nodes.  Therefore we need to be sure it doesn't go below zero,
4058              * as the real string could be shorter */
4059             if (OP(scan) == EXACTFL) {
4060                 int total_chars = utf8_length((U8*) STRING(scan),
4061                                            (U8*) STRING(scan) + STR_LEN(scan));
4062                 if (total_count_delta > total_chars) {
4063                     total_count_delta = total_chars;
4064                 }
4065             }
4066
4067             *min_subtract += total_count_delta;
4068             Safefree(folded);
4069         }
4070         else if (OP(scan) == EXACTFAA) {
4071
4072             /* Non-UTF-8 pattern, EXACTFAA node.  There can't be a multi-char
4073              * fold to the ASCII range (and there are no existing ones in the
4074              * upper latin1 range).  But, as outlined in the comments preceding
4075              * this function, we need to flag any occurrences of the sharp s.
4076              * This character forbids trie formation (because of added
4077              * complexity) */
4078 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4079    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4080                                       || UNICODE_DOT_DOT_VERSION > 0)
4081             while (s < s_end) {
4082                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4083                     OP(scan) = EXACTFAA_NO_TRIE;
4084                     *unfolded_multi_char = TRUE;
4085                     break;
4086                 }
4087                 s++;
4088             }
4089         }
4090         else {
4091
4092             /* Non-UTF-8 pattern, not EXACTFAA node.  Look for the multi-char
4093              * folds that are all Latin1.  As explained in the comments
4094              * preceding this function, we look also for the sharp s in EXACTF
4095              * and EXACTFL nodes; it can be in the final position.  Otherwise
4096              * we can stop looking 1 byte earlier because have to find at least
4097              * two characters for a multi-fold */
4098             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4099                               ? s_end
4100                               : s_end -1;
4101
4102             while (s < upper) {
4103                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4104                 if (! len) {    /* Not a multi-char fold. */
4105                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4106                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4107                     {
4108                         *unfolded_multi_char = TRUE;
4109                     }
4110                     s++;
4111                     continue;
4112                 }
4113
4114                 if (len == 2
4115                     && isALPHA_FOLD_EQ(*s, 's')
4116                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4117                 {
4118
4119                     /* EXACTF nodes need to know that the minimum length
4120                      * changed so that a sharp s in the string can match this
4121                      * ss in the pattern, but they remain EXACTF nodes, as they
4122                      * won't match this unless the target string is is UTF-8,
4123                      * which we don't know until runtime.  EXACTFL nodes can't
4124                      * transform into EXACTFU nodes */
4125                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4126                         OP(scan) = EXACTFU_SS;
4127                     }
4128                 }
4129
4130                 *min_subtract += len - 1;
4131                 s += len;
4132             }
4133 #endif
4134         }
4135     }
4136
4137 #ifdef DEBUGGING
4138     /* Allow dumping but overwriting the collection of skipped
4139      * ops and/or strings with fake optimized ops */
4140     n = scan + NODE_SZ_STR(scan);
4141     while (n <= stop) {
4142         OP(n) = OPTIMIZED;
4143         FLAGS(n) = 0;
4144         NEXT_OFF(n) = 0;
4145         n++;
4146     }
4147 #endif
4148     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4149     return stopnow;
4150 }
4151
4152 /* REx optimizer.  Converts nodes into quicker variants "in place".
4153    Finds fixed substrings.  */
4154
4155 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4156    to the position after last scanned or to NULL. */
4157
4158 #define INIT_AND_WITHP \
4159     assert(!and_withp); \
4160     Newx(and_withp,1, regnode_ssc); \
4161     SAVEFREEPV(and_withp)
4162
4163
4164 static void
4165 S_unwind_scan_frames(pTHX_ const void *p)
4166 {
4167     scan_frame *f= (scan_frame *)p;
4168     do {
4169         scan_frame *n= f->next_frame;
4170         Safefree(f);
4171         f= n;
4172     } while (f);
4173 }
4174
4175 /* the return from this sub is the minimum length that could possibly match */
4176 STATIC SSize_t
4177 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4178                         SSize_t *minlenp, SSize_t *deltap,
4179                         regnode *last,
4180                         scan_data_t *data,
4181                         I32 stopparen,
4182                         U32 recursed_depth,
4183                         regnode_ssc *and_withp,
4184                         U32 flags, U32 depth)
4185                         /* scanp: Start here (read-write). */
4186                         /* deltap: Write maxlen-minlen here. */
4187                         /* last: Stop before this one. */
4188                         /* data: string data about the pattern */
4189                         /* stopparen: treat close N as END */
4190                         /* recursed: which subroutines have we recursed into */
4191                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4192 {
4193     /* There must be at least this number of characters to match */
4194     SSize_t min = 0;
4195     I32 pars = 0, code;
4196     regnode *scan = *scanp, *next;
4197     SSize_t delta = 0;
4198     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4199     int is_inf_internal = 0;            /* The studied chunk is infinite */
4200     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4201     scan_data_t data_fake;
4202     SV *re_trie_maxbuff = NULL;
4203     regnode *first_non_open = scan;
4204     SSize_t stopmin = SSize_t_MAX;
4205     scan_frame *frame = NULL;
4206     GET_RE_DEBUG_FLAGS_DECL;
4207
4208     PERL_ARGS_ASSERT_STUDY_CHUNK;
4209     RExC_study_started= 1;
4210
4211     Zero(&data_fake, 1, scan_data_t);
4212
4213     if ( depth == 0 ) {
4214         while (first_non_open && OP(first_non_open) == OPEN)
4215             first_non_open=regnext(first_non_open);
4216     }
4217
4218
4219   fake_study_recurse:
4220     DEBUG_r(
4221         RExC_study_chunk_recursed_count++;
4222     );
4223     DEBUG_OPTIMISE_MORE_r(
4224     {
4225         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4226             depth, (long)stopparen,
4227             (unsigned long)RExC_study_chunk_recursed_count,
4228             (unsigned long)depth, (unsigned long)recursed_depth,
4229             scan,
4230             last);
4231         if (recursed_depth) {
4232             U32 i;
4233             U32 j;
4234             for ( j = 0 ; j < recursed_depth ; j++ ) {
4235                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4236                     if (
4237                         PAREN_TEST(RExC_study_chunk_recursed +
4238                                    ( j * RExC_study_chunk_recursed_bytes), i )
4239                         && (
4240                             !j ||
4241                             !PAREN_TEST(RExC_study_chunk_recursed +
4242                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4243                         )
4244                     ) {
4245                         Perl_re_printf( aTHX_ " %d",(int)i);
4246                         break;
4247                     }
4248                 }
4249                 if ( j + 1 < recursed_depth ) {
4250                     Perl_re_printf( aTHX_  ",");
4251                 }
4252             }
4253         }
4254         Perl_re_printf( aTHX_ "\n");
4255     }
4256     );
4257     while ( scan && OP(scan) != END && scan < last ){
4258         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4259                                    node length to get a real minimum (because
4260                                    the folded version may be shorter) */
4261         bool unfolded_multi_char = FALSE;
4262         /* Peephole optimizer: */
4263         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4264         DEBUG_PEEP("Peep", scan, depth, flags);
4265
4266
4267         /* The reason we do this here is that we need to deal with things like
4268          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4269          * parsing code, as each (?:..) is handled by a different invocation of
4270          * reg() -- Yves
4271          */
4272         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4273
4274         /* Follow the next-chain of the current node and optimize
4275            away all the NOTHINGs from it.  */
4276         if (OP(scan) != CURLYX) {
4277             const int max = (reg_off_by_arg[OP(scan)]
4278                        ? I32_MAX
4279                        /* I32 may be smaller than U16 on CRAYs! */
4280                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4281             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4282             int noff;
4283             regnode *n = scan;
4284
4285             /* Skip NOTHING and LONGJMP. */
4286             while ((n = regnext(n))
4287                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4288                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4289                    && off + noff < max)
4290                 off += noff;
4291             if (reg_off_by_arg[OP(scan)])
4292                 ARG(scan) = off;
4293             else
4294                 NEXT_OFF(scan) = off;
4295         }
4296
4297         /* The principal pseudo-switch.  Cannot be a switch, since we
4298            look into several different things.  */
4299         if ( OP(scan) == DEFINEP ) {
4300             SSize_t minlen = 0;
4301             SSize_t deltanext = 0;
4302             SSize_t fake_last_close = 0;
4303             I32 f = SCF_IN_DEFINE;
4304
4305             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4306             scan = regnext(scan);
4307             assert( OP(scan) == IFTHEN );
4308             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4309
4310             data_fake.last_closep= &fake_last_close;
4311             minlen = *minlenp;
4312             next = regnext(scan);
4313             scan = NEXTOPER(NEXTOPER(scan));
4314             DEBUG_PEEP("scan", scan, depth, flags);
4315             DEBUG_PEEP("next", next, depth, flags);
4316
4317             /* we suppose the run is continuous, last=next...
4318              * NOTE we dont use the return here! */
4319             /* DEFINEP study_chunk() recursion */
4320             (void)study_chunk(pRExC_state, &scan, &minlen,
4321                               &deltanext, next, &data_fake, stopparen,
4322                               recursed_depth, NULL, f, depth+1);
4323
4324             scan = next;
4325         } else
4326         if (
4327             OP(scan) == BRANCH  ||
4328             OP(scan) == BRANCHJ ||
4329             OP(scan) == IFTHEN
4330         ) {
4331             next = regnext(scan);
4332             code = OP(scan);
4333
4334             /* The op(next)==code check below is to see if we
4335              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4336              * IFTHEN is special as it might not appear in pairs.
4337              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4338              * we dont handle it cleanly. */
4339             if (OP(next) == code || code == IFTHEN) {
4340                 /* NOTE - There is similar code to this block below for
4341                  * handling TRIE nodes on a re-study.  If you change stuff here
4342                  * check there too. */
4343                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4344                 regnode_ssc accum;
4345                 regnode * const startbranch=scan;
4346
4347                 if (flags & SCF_DO_SUBSTR) {
4348                     /* Cannot merge strings after this. */
4349                     scan_commit(pRExC_state, data, minlenp, is_inf);
4350                 }
4351
4352                 if (flags & SCF_DO_STCLASS)
4353                     ssc_init_zero(pRExC_state, &accum);
4354
4355                 while (OP(scan) == code) {
4356                     SSize_t deltanext, minnext, fake;
4357                     I32 f = 0;
4358                     regnode_ssc this_class;
4359
4360                     DEBUG_PEEP("Branch", scan, depth, flags);
4361
4362                     num++;
4363                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4364                     if (data) {
4365                         data_fake.whilem_c = data->whilem_c;
4366                         data_fake.last_closep = data->last_closep;
4367                     }
4368                     else
4369                         data_fake.last_closep = &fake;
4370
4371                     data_fake.pos_delta = delta;
4372                     next = regnext(scan);
4373
4374                     scan = NEXTOPER(scan); /* everything */
4375                     if (code != BRANCH)    /* everything but BRANCH */
4376                         scan = NEXTOPER(scan);
4377
4378                     if (flags & SCF_DO_STCLASS) {
4379                         ssc_init(pRExC_state, &this_class);
4380                         data_fake.start_class = &this_class;
4381                         f = SCF_DO_STCLASS_AND;
4382                     }
4383                     if (flags & SCF_WHILEM_VISITED_POS)
4384                         f |= SCF_WHILEM_VISITED_POS;
4385
4386                     /* we suppose the run is continuous, last=next...*/
4387                     /* recurse study_chunk() for each BRANCH in an alternation */
4388                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4389                                       &deltanext, next, &data_fake, stopparen,
4390                                       recursed_depth, NULL, f,depth+1);
4391
4392                     if (min1 > minnext)
4393                         min1 = minnext;
4394                     if (deltanext == SSize_t_MAX) {
4395                         is_inf = is_inf_internal = 1;
4396                         max1 = SSize_t_MAX;
4397                     } else if (max1 < minnext + deltanext)
4398                         max1 = minnext + deltanext;
4399                     scan = next;
4400                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4401                         pars++;
4402                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4403                         if ( stopmin > minnext)
4404                             stopmin = min + min1;
4405                         flags &= ~SCF_DO_SUBSTR;
4406                         if (data)
4407                             data->flags |= SCF_SEEN_ACCEPT;
4408                     }
4409                     if (data) {
4410                         if (data_fake.flags & SF_HAS_EVAL)
4411                             data->flags |= SF_HAS_EVAL;
4412                         data->whilem_c = data_fake.whilem_c;
4413                     }
4414                     if (flags & SCF_DO_STCLASS)
4415                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4416                 }
4417                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4418                     min1 = 0;
4419                 if (flags & SCF_DO_SUBSTR) {
4420                     data->pos_min += min1;
4421                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4422                         data->pos_delta = SSize_t_MAX;
4423                     else
4424                         data->pos_delta += max1 - min1;
4425                     if (max1 != min1 || is_inf)
4426                         data->cur_is_floating = 1;
4427                 }
4428                 min += min1;
4429                 if (delta == SSize_t_MAX
4430                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4431                     delta = SSize_t_MAX;
4432                 else
4433                     delta += max1 - min1;
4434                 if (flags & SCF_DO_STCLASS_OR) {
4435                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4436                     if (min1) {
4437                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4438                         flags &= ~SCF_DO_STCLASS;
4439                     }
4440                 }
4441                 else if (flags & SCF_DO_STCLASS_AND) {
4442                     if (min1) {
4443                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4444                         flags &= ~SCF_DO_STCLASS;
4445                     }
4446                     else {
4447                         /* Switch to OR mode: cache the old value of
4448                          * data->start_class */
4449                         INIT_AND_WITHP;
4450                         StructCopy(data->start_class, and_withp, regnode_ssc);
4451                         flags &= ~SCF_DO_STCLASS_AND;
4452                         StructCopy(&accum, data->start_class, regnode_ssc);
4453                         flags |= SCF_DO_STCLASS_OR;
4454                     }
4455                 }
4456
4457                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4458                         OP( startbranch ) == BRANCH )
4459                 {
4460                 /* demq.
4461
4462                    Assuming this was/is a branch we are dealing with: 'scan'
4463                    now points at the item that follows the branch sequence,
4464                    whatever it is. We now start at the beginning of the
4465                    sequence and look for subsequences of
4466
4467                    BRANCH->EXACT=>x1
4468                    BRANCH->EXACT=>x2
4469                    tail
4470
4471                    which would be constructed from a pattern like
4472                    /A|LIST|OF|WORDS/
4473
4474                    If we can find such a subsequence we need to turn the first
4475                    element into a trie and then add the subsequent branch exact
4476                    strings to the trie.
4477
4478                    We have two cases
4479
4480                      1. patterns where the whole set of branches can be
4481                         converted.
4482
4483                      2. patterns where only a subset can be converted.
4484
4485                    In case 1 we can replace the whole set with a single regop
4486                    for the trie. In case 2 we need to keep the start and end
4487                    branches so
4488
4489                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4490                      becomes BRANCH TRIE; BRANCH X;
4491
4492                   There is an additional case, that being where there is a
4493                   common prefix, which gets split out into an EXACT like node
4494                   preceding the TRIE node.
4495
4496                   If x(1..n)==tail then we can do a simple trie, if not we make
4497                   a "jump" trie, such that when we match the appropriate word
4498                   we "jump" to the appropriate tail node. Essentially we turn
4499                   a nested if into a case structure of sorts.
4500
4501                 */
4502
4503                     int made=0;
4504                     if (!re_trie_maxbuff) {
4505                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4506                         if (!SvIOK(re_trie_maxbuff))
4507                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4508                     }
4509                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4510                         regnode *cur;
4511                         regnode *first = (regnode *)NULL;
4512                         regnode *last = (regnode *)NULL;
4513                         regnode *tail = scan;
4514                         U8 trietype = 0;
4515                         U32 count=0;
4516
4517                         /* var tail is used because there may be a TAIL
4518                            regop in the way. Ie, the exacts will point to the
4519                            thing following the TAIL, but the last branch will
4520                            point at the TAIL. So we advance tail. If we
4521                            have nested (?:) we may have to move through several
4522                            tails.
4523                          */
4524
4525                         while ( OP( tail ) == TAIL ) {
4526                             /* this is the TAIL generated by (?:) */
4527                             tail = regnext( tail );
4528                         }
4529
4530
4531                         DEBUG_TRIE_COMPILE_r({
4532                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4533                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4534                               depth+1,
4535                               "Looking for TRIE'able sequences. Tail node is ",
4536                               (UV)(tail - RExC_emit_start),
4537                               SvPV_nolen_const( RExC_mysv )
4538                             );
4539                         });
4540
4541                         /*
4542
4543                             Step through the branches
4544                                 cur represents each branch,
4545                                 noper is the first thing to be matched as part
4546                                       of that branch
4547                                 noper_next is the regnext() of that node.
4548
4549                             We normally handle a case like this
4550                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4551                             support building with NOJUMPTRIE, which restricts
4552                             the trie logic to structures like /FOO|BAR/.
4553
4554                             If noper is a trieable nodetype then the branch is
4555                             a possible optimization target. If we are building
4556                             under NOJUMPTRIE then we require that noper_next is
4557                             the same as scan (our current position in the regex
4558                             program).
4559
4560                             Once we have two or more consecutive such branches
4561                             we can create a trie of the EXACT's contents and
4562                             stitch it in place into the program.
4563
4564                             If the sequence represents all of the branches in
4565                             the alternation we replace the entire thing with a
4566                             single TRIE node.
4567
4568                             Otherwise when it is a subsequence we need to
4569                             stitch it in place and replace only the relevant
4570                             branches. This means the first branch has to remain
4571                             as it is used by the alternation logic, and its
4572                             next pointer, and needs to be repointed at the item
4573                             on the branch chain following the last branch we
4574                             have optimized away.
4575
4576                             This could be either a BRANCH, in which case the
4577                             subsequence is internal, or it could be the item
4578                             following the branch sequence in which case the
4579                             subsequence is at the end (which does not
4580                             necessarily mean the first node is the start of the
4581                             alternation).
4582
4583                             TRIE_TYPE(X) is a define which maps the optype to a
4584                             trietype.
4585
4586                                 optype          |  trietype
4587                                 ----------------+-----------
4588                                 NOTHING         | NOTHING
4589                                 EXACT           | EXACT
4590                                 EXACTFU         | EXACTFU
4591                                 EXACTFU_SS      | EXACTFU
4592                                 EXACTFAA         | EXACTFAA
4593                                 EXACTL          | EXACTL
4594                                 EXACTFLU8       | EXACTFLU8
4595
4596
4597                         */
4598 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4599                        ? NOTHING                                            \
4600                        : ( EXACT == (X) )                                   \
4601                          ? EXACT                                            \
4602                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4603                            ? EXACTFU                                        \
4604                            : ( EXACTFAA == (X) )                             \
4605                              ? EXACTFAA                                      \
4606                              : ( EXACTL == (X) )                            \
4607                                ? EXACTL                                     \
4608                                : ( EXACTFLU8 == (X) )                        \
4609                                  ? EXACTFLU8                                 \
4610                                  : 0 )
4611
4612                         /* dont use tail as the end marker for this traverse */
4613                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4614                             regnode * const noper = NEXTOPER( cur );
4615                             U8 noper_type = OP( noper );
4616                             U8 noper_trietype = TRIE_TYPE( noper_type );
4617 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4618                             regnode * const noper_next = regnext( noper );
4619                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4620                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4621 #endif
4622
4623                             DEBUG_TRIE_COMPILE_r({
4624                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4625                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4626                                    depth+1,
4627                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4628
4629                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4630                                 Perl_re_printf( aTHX_  " -> %d:%s",
4631                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4632
4633                                 if ( noper_next ) {
4634                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4635                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4636                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4637                                 }
4638                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4639                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4640                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4641                                 );
4642                             });
4643
4644                             /* Is noper a trieable nodetype that can be merged
4645                              * with the current trie (if there is one)? */
4646                             if ( noper_trietype
4647                                   &&
4648                                   (
4649                                         ( noper_trietype == NOTHING )
4650                                         || ( trietype == NOTHING )
4651                                         || ( trietype == noper_trietype )
4652                                   )
4653 #ifdef NOJUMPTRIE
4654                                   && noper_next >= tail
4655 #endif
4656                                   && count < U16_MAX)
4657                             {
4658                                 /* Handle mergable triable node Either we are
4659                                  * the first node in a new trieable sequence,
4660                                  * in which case we do some bookkeeping,
4661                                  * otherwise we update the end pointer. */
4662                                 if ( !first ) {
4663                                     first = cur;
4664                                     if ( noper_trietype == NOTHING ) {
4665 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4666                                         regnode * const noper_next = regnext( noper );
4667                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4668                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4669 #endif
4670
4671                                         if ( noper_next_trietype ) {
4672                                             trietype = noper_next_trietype;
4673                                         } else if (noper_next_type)  {
4674                                             /* a NOTHING regop is 1 regop wide.
4675                                              * We need at least two for a trie
4676                                              * so we can't merge this in */
4677                                             first = NULL;
4678                                         }
4679                                     } else {
4680                                         trietype = noper_trietype;
4681                                     }
4682                                 } else {
4683                                     if ( trietype == NOTHING )
4684                                         trietype = noper_trietype;
4685                                     last = cur;
4686                                 }
4687                                 if (first)
4688                                     count++;
4689                             } /* end handle mergable triable node */
4690                             else {
4691                                 /* handle unmergable node -
4692                                  * noper may either be a triable node which can
4693                                  * not be tried together with the current trie,
4694                                  * or a non triable node */
4695                                 if ( last ) {
4696                                     /* If last is set and trietype is not
4697                                      * NOTHING then we have found at least two
4698                                      * triable branch sequences in a row of a
4699                                      * similar trietype so we can turn them
4700                                      * into a trie. If/when we allow NOTHING to
4701                                      * start a trie sequence this condition
4702                                      * will be required, and it isn't expensive
4703                                      * so we leave it in for now. */
4704                                     if ( trietype && trietype != NOTHING )
4705                                         make_trie( pRExC_state,
4706                                                 startbranch, first, cur, tail,
4707                                                 count, trietype, depth+1 );
4708                                     last = NULL; /* note: we clear/update
4709                                                     first, trietype etc below,
4710                                                     so we dont do it here */
4711                                 }
4712                                 if ( noper_trietype
4713 #ifdef NOJUMPTRIE
4714                                      && noper_next >= tail
4715 #endif
4716                                 ){
4717                                     /* noper is triable, so we can start a new
4718                                      * trie sequence */
4719                                     count = 1;
4720                                     first = cur;
4721                                     trietype = noper_trietype;
4722                                 } else if (first) {
4723                                     /* if we already saw a first but the
4724                                      * current node is not triable then we have
4725                                      * to reset the first information. */
4726                                     count = 0;
4727                                     first = NULL;
4728                                     trietype = 0;
4729                                 }
4730                             } /* end handle unmergable node */
4731                         } /* loop over branches */
4732                         DEBUG_TRIE_COMPILE_r({
4733                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4734                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4735                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4736                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4737                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4738                                PL_reg_name[trietype]
4739                             );
4740
4741                         });
4742                         if ( last && trietype ) {
4743                             if ( trietype != NOTHING ) {
4744                                 /* the last branch of the sequence was part of
4745                                  * a trie, so we have to construct it here
4746                                  * outside of the loop */
4747                                 made= make_trie( pRExC_state, startbranch,
4748                                                  first, scan, tail, count,
4749                                                  trietype, depth+1 );
4750 #ifdef TRIE_STUDY_OPT
4751                                 if ( ((made == MADE_EXACT_TRIE &&
4752                                      startbranch == first)
4753                                      || ( first_non_open == first )) &&
4754                                      depth==0 ) {
4755                                     flags |= SCF_TRIE_RESTUDY;
4756                                     if ( startbranch == first
4757                                          && scan >= tail )
4758                                     {
4759                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4760                                     }
4761                                 }
4762 #endif
4763                             } else {
4764                                 /* at this point we know whatever we have is a
4765                                  * NOTHING sequence/branch AND if 'startbranch'
4766                                  * is 'first' then we can turn the whole thing
4767                                  * into a NOTHING
4768                                  */
4769                                 if ( startbranch == first ) {
4770                                     regnode *opt;
4771                                     /* the entire thing is a NOTHING sequence,
4772                                      * something like this: (?:|) So we can
4773                                      * turn it into a plain NOTHING op. */
4774                                     DEBUG_TRIE_COMPILE_r({
4775                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4776                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4777                                           depth+1,
4778                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4779
4780                                     });
4781                                     OP(startbranch)= NOTHING;
4782                                     NEXT_OFF(startbranch)= tail - startbranch;
4783                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4784                                         OP(opt)= OPTIMIZED;
4785                                 }
4786                             }
4787                         } /* end if ( last) */
4788                     } /* TRIE_MAXBUF is non zero */
4789
4790                 } /* do trie */
4791
4792             }
4793             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4794                 scan = NEXTOPER(NEXTOPER(scan));
4795             } else                      /* single branch is optimized. */
4796                 scan = NEXTOPER(scan);
4797             continue;
4798         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4799             I32 paren = 0;
4800             regnode *start = NULL;
4801             regnode *end = NULL;
4802             U32 my_recursed_depth= recursed_depth;
4803
4804             if (OP(scan) != SUSPEND) { /* GOSUB */
4805                 /* Do setup, note this code has side effects beyond
4806                  * the rest of this block. Specifically setting
4807                  * RExC_recurse[] must happen at least once during
4808                  * study_chunk(). */
4809                 paren = ARG(scan);
4810                 RExC_recurse[ARG2L(scan)] = scan;
4811                 start = RExC_open_parens[paren];
4812                 end   = RExC_close_parens[paren];
4813
4814                 /* NOTE we MUST always execute the above code, even
4815                  * if we do nothing with a GOSUB */
4816                 if (
4817                     ( flags & SCF_IN_DEFINE )
4818                     ||
4819                     (
4820                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4821                         &&
4822                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4823                     )
4824                 ) {
4825                     /* no need to do anything here if we are in a define. */
4826                     /* or we are after some kind of infinite construct
4827                      * so we can skip recursing into this item.
4828                      * Since it is infinite we will not change the maxlen
4829                      * or delta, and if we miss something that might raise
4830                      * the minlen it will merely pessimise a little.
4831                      *
4832                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4833                      * might result in a minlen of 1 and not of 4,
4834                      * but this doesn't make us mismatch, just try a bit
4835                      * harder than we should.
4836                      * */
4837                     scan= regnext(scan);
4838                     continue;
4839                 }
4840
4841                 if (
4842                     !recursed_depth
4843                     ||
4844                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4845                 ) {
4846                     /* it is quite possible that there are more efficient ways
4847                      * to do this. We maintain a bitmap per level of recursion
4848                      * of which patterns we have entered so we can detect if a
4849                      * pattern creates a possible infinite loop. When we
4850                      * recurse down a level we copy the previous levels bitmap
4851                      * down. When we are at recursion level 0 we zero the top
4852                      * level bitmap. It would be nice to implement a different
4853                      * more efficient way of doing this. In particular the top
4854                      * level bitmap may be unnecessary.
4855                      */
4856                     if (!recursed_depth) {
4857                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4858                     } else {
4859                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4860                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4861                              RExC_study_chunk_recursed_bytes, U8);
4862                     }
4863                     /* we havent recursed into this paren yet, so recurse into it */
4864                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
4865                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4866                     my_recursed_depth= recursed_depth + 1;
4867                 } else {
4868                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
4869                     /* some form of infinite recursion, assume infinite length
4870                      * */
4871                     if (flags & SCF_DO_SUBSTR) {
4872                         scan_commit(pRExC_state, data, minlenp, is_inf);
4873                         data->cur_is_floating = 1;
4874                     }
4875                     is_inf = is_inf_internal = 1;
4876                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4877                         ssc_anything(data->start_class);
4878                     flags &= ~SCF_DO_STCLASS;
4879
4880                     start= NULL; /* reset start so we dont recurse later on. */
4881                 }
4882             } else {
4883                 paren = stopparen;
4884                 start = scan + 2;
4885                 end = regnext(scan);
4886             }
4887             if (start) {
4888                 scan_frame *newframe;
4889                 assert(end);
4890                 if (!RExC_frame_last) {
4891                     Newxz(newframe, 1, scan_frame);
4892                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4893                     RExC_frame_head= newframe;
4894                     RExC_frame_count++;
4895                 } else if (!RExC_frame_last->next_frame) {
4896                     Newxz(newframe,1,scan_frame);
4897                     RExC_frame_last->next_frame= newframe;
4898                     newframe->prev_frame= RExC_frame_last;
4899                     RExC_frame_count++;
4900                 } else {
4901                     newframe= RExC_frame_last->next_frame;
4902                 }
4903                 RExC_frame_last= newframe;
4904
4905                 newframe->next_regnode = regnext(scan);
4906                 newframe->last_regnode = last;
4907                 newframe->stopparen = stopparen;
4908                 newframe->prev_recursed_depth = recursed_depth;
4909                 newframe->this_prev_frame= frame;
4910
4911                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
4912                 DEBUG_PEEP("fnew", scan, depth, flags);
4913
4914                 frame = newframe;
4915                 scan =  start;
4916                 stopparen = paren;
4917                 last = end;
4918                 depth = depth + 1;
4919                 recursed_depth= my_recursed_depth;
4920
4921                 continue;
4922             }
4923         }
4924         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4925             SSize_t l = STR_LEN(scan);
4926             UV uc;
4927             assert(l);
4928             if (UTF) {
4929                 const U8 * const s = (U8*)STRING(scan);
4930                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4931                 l = utf8_length(s, s + l);
4932             } else {
4933                 uc = *((U8*)STRING(scan));
4934             }
4935             min += l;
4936             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4937                 /* The code below prefers earlier match for fixed
4938                    offset, later match for variable offset.  */
4939                 if (data->last_end == -1) { /* Update the start info. */
4940                     data->last_start_min = data->pos_min;
4941                     data->last_start_max = is_inf
4942                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4943                 }
4944                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4945                 if (UTF)
4946                     SvUTF8_on(data->last_found);
4947                 {
4948                     SV * const sv = data->last_found;
4949                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4950                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4951                     if (mg && mg->mg_len >= 0)
4952                         mg->mg_len += utf8_length((U8*)STRING(scan),
4953                                               (U8*)STRING(scan)+STR_LEN(scan));
4954                 }
4955                 data->last_end = data->pos_min + l;
4956                 data->pos_min += l; /* As in the first entry. */
4957                 data->flags &= ~SF_BEFORE_EOL;
4958             }
4959
4960             /* ANDing the code point leaves at most it, and not in locale, and
4961              * can't match null string */
4962             if (flags & SCF_DO_STCLASS_AND) {
4963                 ssc_cp_and(data->start_class, uc);
4964                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4965                 ssc_clear_locale(data->start_class);
4966             }
4967             else if (flags & SCF_DO_STCLASS_OR) {
4968                 ssc_add_cp(data->start_class, uc);
4969                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4970
4971                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4972                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4973             }
4974             flags &= ~SCF_DO_STCLASS;
4975         }
4976         else if (PL_regkind[OP(scan)] == EXACT) {
4977             /* But OP != EXACT!, so is EXACTFish */
4978             SSize_t l = STR_LEN(scan);
4979             const U8 * s = (U8*)STRING(scan);
4980
4981             /* Search for fixed substrings supports EXACT only. */
4982             if (flags & SCF_DO_SUBSTR) {
4983                 assert(data);
4984                 scan_commit(pRExC_state, data, minlenp, is_inf);
4985             }
4986             if (UTF) {
4987                 l = utf8_length(s, s + l);
4988             }
4989             if (unfolded_multi_char) {
4990                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4991             }
4992             min += l - min_subtract;
4993             assert (min >= 0);
4994             delta += min_subtract;
4995             if (flags & SCF_DO_SUBSTR) {
4996                 data->pos_min += l - min_subtract;
4997                 if (data->pos_min < 0) {
4998                     data->pos_min = 0;
4999                 }
5000                 data->pos_delta += min_subtract;
5001                 if (min_subtract) {
5002                     data->cur_is_floating = 1; /* float */
5003                 }
5004             }
5005
5006             if (flags & SCF_DO_STCLASS) {
5007                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
5008
5009                 assert(EXACTF_invlist);
5010                 if (flags & SCF_DO_STCLASS_AND) {
5011                     if (OP(scan) != EXACTFL)
5012                         ssc_clear_locale(data->start_class);
5013                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5014                     ANYOF_POSIXL_ZERO(data->start_class);
5015                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
5016                 }
5017                 else {  /* SCF_DO_STCLASS_OR */
5018                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
5019                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5020
5021                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5022                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5023                 }
5024                 flags &= ~SCF_DO_STCLASS;
5025                 SvREFCNT_dec(EXACTF_invlist);
5026             }
5027         }
5028         else if (REGNODE_VARIES(OP(scan))) {
5029             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
5030             I32 fl = 0, f = flags;
5031             regnode * const oscan = scan;
5032             regnode_ssc this_class;
5033             regnode_ssc *oclass = NULL;
5034             I32 next_is_eval = 0;
5035
5036             switch (PL_regkind[OP(scan)]) {
5037             case WHILEM:                /* End of (?:...)* . */
5038                 scan = NEXTOPER(scan);
5039                 goto finish;
5040             case PLUS:
5041                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5042                     next = NEXTOPER(scan);
5043                     if (OP(next) == EXACT
5044                         || OP(next) == EXACTL
5045                         || (flags & SCF_DO_STCLASS))
5046                     {
5047                         mincount = 1;
5048                         maxcount = REG_INFTY;
5049                         next = regnext(scan);
5050                         scan = NEXTOPER(scan);
5051                         goto do_curly;
5052                     }
5053                 }
5054                 if (flags & SCF_DO_SUBSTR)
5055                     data->pos_min++;
5056                 min++;
5057                 /* FALLTHROUGH */
5058             case STAR:
5059                 if (flags & SCF_DO_STCLASS) {
5060                     mincount = 0;
5061                     maxcount = REG_INFTY;
5062                     next = regnext(scan);
5063                     scan = NEXTOPER(scan);
5064                     goto do_curly;
5065                 }
5066                 if (flags & SCF_DO_SUBSTR) {
5067                     scan_commit(pRExC_state, data, minlenp, is_inf);
5068                     /* Cannot extend fixed substrings */
5069                     data->cur_is_floating = 1; /* float */
5070                 }
5071                 is_inf = is_inf_internal = 1;
5072                 scan = regnext(scan);
5073                 goto optimize_curly_tail;
5074             case CURLY:
5075                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5076                     && (scan->flags == stopparen))
5077                 {
5078                     mincount = 1;
5079                     maxcount = 1;
5080                 } else {
5081                     mincount = ARG1(scan);
5082                     maxcount = ARG2(scan);
5083                 }
5084                 next = regnext(scan);
5085                 if (OP(scan) == CURLYX) {
5086                     I32 lp = (data ? *(data->last_closep) : 0);
5087                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5088                 }
5089                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5090                 next_is_eval = (OP(scan) == EVAL);
5091               do_curly:
5092                 if (flags & SCF_DO_SUBSTR) {
5093                     if (mincount == 0)
5094                         scan_commit(pRExC_state, data, minlenp, is_inf);
5095                     /* Cannot extend fixed substrings */
5096                     pos_before = data->pos_min;
5097                 }
5098                 if (data) {
5099                     fl = data->flags;
5100                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5101                     if (is_inf)
5102                         data->flags |= SF_IS_INF;
5103                 }
5104                 if (flags & SCF_DO_STCLASS) {
5105                     ssc_init(pRExC_state, &this_class);
5106                     oclass = data->start_class;
5107                     data->start_class = &this_class;
5108                     f |= SCF_DO_STCLASS_AND;
5109                     f &= ~SCF_DO_STCLASS_OR;
5110                 }
5111                 /* Exclude from super-linear cache processing any {n,m}
5112                    regops for which the combination of input pos and regex
5113                    pos is not enough information to determine if a match
5114                    will be possible.
5115
5116                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5117                    regex pos at the \s*, the prospects for a match depend not
5118                    only on the input position but also on how many (bar\s*)
5119                    repeats into the {4,8} we are. */
5120                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5121                     f &= ~SCF_WHILEM_VISITED_POS;
5122
5123                 /* This will finish on WHILEM, setting scan, or on NULL: */
5124                 /* recurse study_chunk() on loop bodies */
5125                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5126                                   last, data, stopparen, recursed_depth, NULL,
5127                                   (mincount == 0
5128                                    ? (f & ~SCF_DO_SUBSTR)
5129                                    : f)
5130                                   ,depth+1);
5131
5132                 if (flags & SCF_DO_STCLASS)
5133                     data->start_class = oclass;
5134                 if (mincount == 0 || minnext == 0) {
5135                     if (flags & SCF_DO_STCLASS_OR) {
5136                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5137                     }
5138                     else if (flags & SCF_DO_STCLASS_AND) {
5139                         /* Switch to OR mode: cache the old value of
5140                          * data->start_class */
5141                         INIT_AND_WITHP;
5142                         StructCopy(data->start_class, and_withp, regnode_ssc);
5143                         flags &= ~SCF_DO_STCLASS_AND;
5144                         StructCopy(&this_class, data->start_class, regnode_ssc);
5145                         flags |= SCF_DO_STCLASS_OR;
5146                         ANYOF_FLAGS(data->start_class)
5147                                                 |= SSC_MATCHES_EMPTY_STRING;
5148                     }
5149                 } else {                /* Non-zero len */
5150                     if (flags & SCF_DO_STCLASS_OR) {
5151                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5152                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5153                     }
5154                     else if (flags & SCF_DO_STCLASS_AND)
5155                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5156                     flags &= ~SCF_DO_STCLASS;
5157                 }
5158                 if (!scan)              /* It was not CURLYX, but CURLY. */
5159                     scan = next;
5160                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5161                     /* ? quantifier ok, except for (?{ ... }) */
5162                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5163                     && (minnext == 0) && (deltanext == 0)
5164                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5165                     && maxcount <= REG_INFTY/3) /* Complement check for big
5166                                                    count */
5167                 {
5168                     /* Fatal warnings may leak the regexp without this: */
5169                     SAVEFREESV(RExC_rx_sv);
5170                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5171                         "Quantifier unexpected on zero-length expression "
5172                         "in regex m/%" UTF8f "/",
5173                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5174                                   RExC_precomp));
5175                     (void)ReREFCNT_inc(RExC_rx_sv);
5176                 }
5177
5178                 min += minnext * mincount;
5179                 is_inf_internal |= deltanext == SSize_t_MAX
5180                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5181                 is_inf |= is_inf_internal;
5182                 if (is_inf) {
5183                     delta = SSize_t_MAX;
5184                 } else {
5185                     delta += (minnext + deltanext) * maxcount
5186                              - minnext * mincount;
5187                 }
5188                 /* Try powerful optimization CURLYX => CURLYN. */
5189                 if (  OP(oscan) == CURLYX && data
5190                       && data->flags & SF_IN_PAR
5191                       && !(data->flags & SF_HAS_EVAL)
5192                       && !deltanext && minnext == 1 ) {
5193                     /* Try to optimize to CURLYN.  */
5194                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5195                     regnode * const nxt1 = nxt;
5196 #ifdef DEBUGGING
5197                     regnode *nxt2;
5198 #endif
5199
5200                     /* Skip open. */
5201                     nxt = regnext(nxt);
5202                     if (!REGNODE_SIMPLE(OP(nxt))
5203                         && !(PL_regkind[OP(nxt)] == EXACT
5204                              && STR_LEN(nxt) == 1))
5205                         goto nogo;
5206 #ifdef DEBUGGING
5207                     nxt2 = nxt;
5208 #endif
5209                     nxt = regnext(nxt);
5210                     if (OP(nxt) != CLOSE)
5211                         goto nogo;
5212                     if (RExC_open_parens) {
5213                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5214                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5215                     }
5216                     /* Now we know that nxt2 is the only contents: */
5217                     oscan->flags = (U8)ARG(nxt);
5218                     OP(oscan) = CURLYN;
5219                     OP(nxt1) = NOTHING; /* was OPEN. */
5220
5221 #ifdef DEBUGGING
5222                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5223                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5224                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5225                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5226                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5227                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5228 #endif
5229                 }
5230               nogo:
5231
5232                 /* Try optimization CURLYX => CURLYM. */
5233                 if (  OP(oscan) == CURLYX && data
5234                       && !(data->flags & SF_HAS_PAR)
5235                       && !(data->flags & SF_HAS_EVAL)
5236                       && !deltanext     /* atom is fixed width */
5237                       && minnext != 0   /* CURLYM can't handle zero width */
5238
5239                          /* Nor characters whose fold at run-time may be
5240                           * multi-character */
5241                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5242                 ) {
5243                     /* XXXX How to optimize if data == 0? */
5244                     /* Optimize to a simpler form.  */
5245                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5246                     regnode *nxt2;
5247
5248                     OP(oscan) = CURLYM;
5249                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5250                             && (OP(nxt2) != WHILEM))
5251                         nxt = nxt2;
5252                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5253                     /* Need to optimize away parenths. */
5254                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5255                         /* Set the parenth number.  */
5256                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5257
5258                         oscan->flags = (U8)ARG(nxt);
5259                         if (RExC_open_parens) {
5260                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5261                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5262                         }
5263                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5264                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5265
5266 #ifdef DEBUGGING
5267                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5268                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5269                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5270                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5271 #endif
5272 #if 0
5273                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5274                             regnode *nnxt = regnext(nxt1);
5275                             if (nnxt == nxt) {
5276                                 if (reg_off_by_arg[OP(nxt1)])
5277                                     ARG_SET(nxt1, nxt2 - nxt1);
5278                                 else if (nxt2 - nxt1 < U16_MAX)
5279                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5280                                 else
5281                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5282                             }
5283                             nxt1 = nnxt;
5284                         }
5285 #endif
5286                         /* Optimize again: */
5287                         /* recurse study_chunk() on optimised CURLYX => CURLYM */
5288                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5289                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5290                     }
5291                     else
5292                         oscan->flags = 0;
5293                 }
5294                 else if ((OP(oscan) == CURLYX)
5295                          && (flags & SCF_WHILEM_VISITED_POS)
5296                          /* See the comment on a similar expression above.
5297                             However, this time it's not a subexpression
5298                             we care about, but the expression itself. */
5299                          && (maxcount == REG_INFTY)
5300                          && data) {
5301                     /* This stays as CURLYX, we can put the count/of pair. */
5302                     /* Find WHILEM (as in regexec.c) */
5303                     regnode *nxt = oscan + NEXT_OFF(oscan);
5304
5305                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5306                         nxt += ARG(nxt);
5307                     nxt = PREVOPER(nxt);
5308                     if (nxt->flags & 0xf) {
5309                         /* we've already set whilem count on this node */
5310                     } else if (++data->whilem_c < 16) {
5311                         assert(data->whilem_c <= RExC_whilem_seen);
5312                         nxt->flags = (U8)(data->whilem_c
5313                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5314                     }
5315                 }
5316                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5317                     pars++;
5318                 if (flags & SCF_DO_SUBSTR) {
5319                     SV *last_str = NULL;
5320                     STRLEN last_chrs = 0;
5321                     int counted = mincount != 0;
5322
5323                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5324                                                                   string. */
5325                         SSize_t b = pos_before >= data->last_start_min
5326                             ? pos_before : data->last_start_min;
5327                         STRLEN l;
5328                         const char * const s = SvPV_const(data->last_found, l);
5329                         SSize_t old = b - data->last_start_min;
5330
5331                         if (UTF)
5332                             old = utf8_hop((U8*)s, old) - (U8*)s;
5333                         l -= old;
5334                         /* Get the added string: */
5335                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5336                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5337                                             (U8*)(s + old + l)) : l;
5338                         if (deltanext == 0 && pos_before == b) {
5339                             /* What was added is a constant string */
5340                             if (mincount > 1) {
5341
5342                                 SvGROW(last_str, (mincount * l) + 1);
5343                                 repeatcpy(SvPVX(last_str) + l,
5344                                           SvPVX_const(last_str), l,
5345                                           mincount - 1);
5346                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5347                                 /* Add additional parts. */
5348                                 SvCUR_set(data->last_found,
5349                                           SvCUR(data->last_found) - l);
5350                                 sv_catsv(data->last_found, last_str);
5351                                 {
5352                                     SV * sv = data->last_found;
5353                                     MAGIC *mg =
5354                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5355                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5356                                     if (mg && mg->mg_len >= 0)
5357                                         mg->mg_len += last_chrs * (mincount-1);
5358                                 }
5359                                 last_chrs *= mincount;
5360                                 data->last_end += l * (mincount - 1);
5361                             }
5362                         } else {
5363                             /* start offset must point into the last copy */
5364                             data->last_start_min += minnext * (mincount - 1);
5365                             data->last_start_max =
5366                               is_inf
5367                                ? SSize_t_MAX
5368                                : data->last_start_max +
5369                                  (maxcount - 1) * (minnext + data->pos_delta);
5370                         }
5371                     }
5372                     /* It is counted once already... */
5373                     data->pos_min += minnext * (mincount - counted);
5374 #if 0
5375 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5376                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5377                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5378     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5379     (UV)mincount);
5380 if (deltanext != SSize_t_MAX)
5381 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5382     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5383           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5384 #endif
5385                     if (deltanext == SSize_t_MAX
5386                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5387                         data->pos_delta = SSize_t_MAX;
5388                     else
5389                         data->pos_delta += - counted * deltanext +
5390                         (minnext + deltanext) * maxcount - minnext * mincount;
5391                     if (mincount != maxcount) {
5392                          /* Cannot extend fixed substrings found inside
5393                             the group.  */
5394                         scan_commit(pRExC_state, data, minlenp, is_inf);
5395                         if (mincount && last_str) {
5396                             SV * const sv = data->last_found;
5397                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5398                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5399
5400                             if (mg)
5401                                 mg->mg_len = -1;
5402                             sv_setsv(sv, last_str);
5403                             data->last_end = data->pos_min;
5404                             data->last_start_min = data->pos_min - last_chrs;
5405                             data->last_start_max = is_inf
5406                                 ? SSize_t_MAX
5407                                 : data->pos_min + data->pos_delta - last_chrs;
5408                         }
5409                         data->cur_is_floating = 1; /* float */
5410                     }
5411                     SvREFCNT_dec(last_str);
5412                 }
5413                 if (data && (fl & SF_HAS_EVAL))
5414                     data->flags |= SF_HAS_EVAL;
5415               optimize_curly_tail:
5416                 if (OP(oscan) != CURLYX) {
5417                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5418                            && NEXT_OFF(next))
5419                         NEXT_OFF(oscan) += NEXT_OFF(next);
5420                 }
5421                 continue;
5422
5423             default:
5424 #ifdef DEBUGGING
5425                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5426                                                                     OP(scan));
5427 #endif
5428             case REF:
5429             case CLUMP:
5430                 if (flags & SCF_DO_SUBSTR) {
5431                     /* Cannot expect anything... */
5432                     scan_commit(pRExC_state, data, minlenp, is_inf);
5433                     data->cur_is_floating = 1; /* float */
5434                 }
5435                 is_inf = is_inf_internal = 1;
5436                 if (flags & SCF_DO_STCLASS_OR) {
5437                     if (OP(scan) == CLUMP) {
5438                         /* Actually is any start char, but very few code points
5439                          * aren't start characters */
5440                         ssc_match_all_cp(data->start_class);
5441                     }
5442                     else {
5443                         ssc_anything(data->start_class);
5444                     }
5445                 }
5446                 flags &= ~SCF_DO_STCLASS;
5447                 break;
5448             }
5449         }
5450         else if (OP(scan) == LNBREAK) {
5451             if (flags & SCF_DO_STCLASS) {
5452                 if (flags & SCF_DO_STCLASS_AND) {
5453                     ssc_intersection(data->start_class,
5454                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5455                     ssc_clear_locale(data->start_class);
5456                     ANYOF_FLAGS(data->start_class)
5457                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5458                 }
5459                 else if (flags & SCF_DO_STCLASS_OR) {
5460                     ssc_union(data->start_class,
5461                               PL_XPosix_ptrs[_CC_VERTSPACE],
5462                               FALSE);
5463                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5464
5465                     /* See commit msg for
5466                      * 749e076fceedeb708a624933726e7989f2302f6a */
5467                     ANYOF_FLAGS(data->start_class)
5468                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5469                 }
5470                 flags &= ~SCF_DO_STCLASS;
5471             }
5472             min++;
5473             if (delta != SSize_t_MAX)
5474                 delta++;    /* Because of the 2 char string cr-lf */
5475             if (flags & SCF_DO_SUBSTR) {
5476                 /* Cannot expect anything... */
5477                 scan_commit(pRExC_state, data, minlenp, is_inf);
5478                 data->pos_min += 1;
5479                 data->pos_delta += 1;
5480                 data->cur_is_floating = 1; /* float */
5481             }
5482         }
5483         else if (REGNODE_SIMPLE(OP(scan))) {
5484
5485             if (flags & SCF_DO_SUBSTR) {
5486                 scan_commit(pRExC_state, data, minlenp, is_inf);
5487                 data->pos_min++;
5488             }
5489             min++;
5490             if (flags & SCF_DO_STCLASS) {
5491                 bool invert = 0;
5492                 SV* my_invlist = NULL;
5493                 U8 namedclass;
5494
5495                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5496                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5497
5498                 /* Some of the logic below assumes that switching
5499                    locale on will only add false positives. */
5500                 switch (OP(scan)) {
5501
5502                 default:
5503 #ifdef DEBUGGING
5504                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5505                                                                      OP(scan));
5506 #endif
5507                 case SANY:
5508                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5509                         ssc_match_all_cp(data->start_class);
5510                     break;
5511
5512                 case REG_ANY:
5513                     {
5514                         SV* REG_ANY_invlist = _new_invlist(2);
5515                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5516                                                             '\n');
5517                         if (flags & SCF_DO_STCLASS_OR) {
5518                             ssc_union(data->start_class,
5519                                       REG_ANY_invlist,
5520                                       TRUE /* TRUE => invert, hence all but \n
5521                                             */
5522                                       );
5523                         }
5524                         else if (flags & SCF_DO_STCLASS_AND) {
5525                             ssc_intersection(data->start_class,
5526                                              REG_ANY_invlist,
5527                                              TRUE  /* TRUE => invert */
5528                                              );
5529                             ssc_clear_locale(data->start_class);
5530                         }
5531                         SvREFCNT_dec_NN(REG_ANY_invlist);
5532                     }
5533                     break;
5534
5535                 case ANYOFD:
5536                 case ANYOFL:
5537                 case ANYOF:
5538                     if (flags & SCF_DO_STCLASS_AND)
5539                         ssc_and(pRExC_state, data->start_class,
5540                                 (regnode_charclass *) scan);
5541                     else
5542                         ssc_or(pRExC_state, data->start_class,
5543                                                           (regnode_charclass *) scan);
5544                     break;
5545
5546                 case ANYOFM:
5547                   {
5548                     SV* cp_list = get_ANYOFM_contents(scan);
5549
5550                     if (flags & SCF_DO_STCLASS_OR) {
5551                         ssc_union(data->start_class,
5552                                   cp_list,
5553                                   FALSE /* don't invert */
5554                                   );
5555                     }
5556                     else if (flags & SCF_DO_STCLASS_AND) {
5557                         ssc_intersection(data->start_class,
5558                                          cp_list,
5559                                          FALSE /* don't invert */
5560                                          );
5561                     }
5562
5563                     SvREFCNT_dec_NN(cp_list);
5564                     break;
5565                   }
5566
5567                 case NPOSIXL:
5568                     invert = 1;
5569                     /* FALLTHROUGH */
5570
5571                 case POSIXL:
5572                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5573                     if (flags & SCF_DO_STCLASS_AND) {
5574                         bool was_there = cBOOL(
5575                                           ANYOF_POSIXL_TEST(data->start_class,
5576                                                                  namedclass));
5577                         ANYOF_POSIXL_ZERO(data->start_class);
5578                         if (was_there) {    /* Do an AND */
5579                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5580                         }
5581                         /* No individual code points can now match */
5582                         data->start_class->invlist
5583                                                 = sv_2mortal(_new_invlist(0));
5584                     }
5585                     else {
5586                         int complement = namedclass + ((invert) ? -1 : 1);
5587
5588                         assert(flags & SCF_DO_STCLASS_OR);
5589
5590                         /* If the complement of this class was already there,
5591                          * the result is that they match all code points,
5592                          * (\d + \D == everything).  Remove the classes from
5593                          * future consideration.  Locale is not relevant in
5594                          * this case */
5595                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5596                             ssc_match_all_cp(data->start_class);
5597                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5598                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5599                         }
5600                         else {  /* The usual case; just add this class to the
5601                                    existing set */
5602                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5603                         }
5604                     }
5605                     break;
5606
5607                 case NASCII:
5608                     invert = 1;
5609                     /* FALLTHROUGH */
5610                 case ASCII:
5611                     my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5612
5613                     /* This can be handled as a Posix class */
5614                     goto join_posix_and_ascii;
5615
5616                 case NPOSIXA:   /* For these, we always know the exact set of
5617                                    what's matched */
5618                     invert = 1;
5619                     /* FALLTHROUGH */
5620                 case POSIXA:
5621                     assert(FLAGS(scan) != _CC_ASCII);
5622                     _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5623                                           PL_XPosix_ptrs[_CC_ASCII],
5624                                           &my_invlist);
5625                     goto join_posix_and_ascii;
5626
5627                 case NPOSIXD:
5628                 case NPOSIXU:
5629                     invert = 1;
5630                     /* FALLTHROUGH */
5631                 case POSIXD:
5632                 case POSIXU:
5633                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5634
5635                     /* NPOSIXD matches all upper Latin1 code points unless the
5636                      * target string being matched is UTF-8, which is
5637                      * unknowable until match time.  Since we are going to
5638                      * invert, we want to get rid of all of them so that the
5639                      * inversion will match all */
5640                     if (OP(scan) == NPOSIXD) {
5641                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5642                                           &my_invlist);
5643                     }
5644
5645                   join_posix_and_ascii:
5646
5647                     if (flags & SCF_DO_STCLASS_AND) {
5648                         ssc_intersection(data->start_class, my_invlist, invert);
5649                         ssc_clear_locale(data->start_class);
5650                     }
5651                     else {
5652                         assert(flags & SCF_DO_STCLASS_OR);
5653                         ssc_union(data->start_class, my_invlist, invert);
5654                     }
5655                     SvREFCNT_dec(my_invlist);
5656                 }
5657                 if (flags & SCF_DO_STCLASS_OR)
5658                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5659                 flags &= ~SCF_DO_STCLASS;
5660             }
5661         }
5662         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5663             data->flags |= (OP(scan) == MEOL
5664                             ? SF_BEFORE_MEOL
5665                             : SF_BEFORE_SEOL);
5666             scan_commit(pRExC_state, data, minlenp, is_inf);
5667
5668         }
5669         else if (  PL_regkind[OP(scan)] == BRANCHJ
5670                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5671                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5672                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5673         {
5674             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5675                 || OP(scan) == UNLESSM )
5676             {
5677                 /* Negative Lookahead/lookbehind
5678                    In this case we can't do fixed string optimisation.
5679                 */
5680
5681                 SSize_t deltanext, minnext, fake = 0;
5682                 regnode *nscan;
5683                 regnode_ssc intrnl;
5684                 int f = 0;
5685
5686                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5687                 if (data) {
5688                     data_fake.whilem_c = data->whilem_c;
5689                     data_fake.last_closep = data->last_closep;
5690                 }
5691                 else
5692                     data_fake.last_closep = &fake;
5693                 data_fake.pos_delta = delta;
5694                 if ( flags & SCF_DO_STCLASS && !scan->flags
5695                      && OP(scan) == IFMATCH ) { /* Lookahead */
5696                     ssc_init(pRExC_state, &intrnl);
5697                     data_fake.start_class = &intrnl;
5698                     f |= SCF_DO_STCLASS_AND;
5699                 }
5700                 if (flags & SCF_WHILEM_VISITED_POS)
5701                     f |= SCF_WHILEM_VISITED_POS;
5702                 next = regnext(scan);
5703                 nscan = NEXTOPER(NEXTOPER(scan));
5704
5705                 /* recurse study_chunk() for lookahead body */
5706                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5707                                       last, &data_fake, stopparen,
5708                                       recursed_depth, NULL, f, depth+1);
5709                 if (scan->flags) {
5710                     if (deltanext) {
5711                         FAIL("Variable length lookbehind not implemented");
5712                     }
5713                     else if (minnext > (I32)U8_MAX) {
5714                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5715                               (UV)U8_MAX);
5716                     }
5717                     scan->flags = (U8)minnext;
5718                 }
5719                 if (data) {
5720                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5721                         pars++;
5722                     if (data_fake.flags & SF_HAS_EVAL)
5723                         data->flags |= SF_HAS_EVAL;
5724                     data->whilem_c = data_fake.whilem_c;
5725                 }
5726                 if (f & SCF_DO_STCLASS_AND) {
5727                     if (flags & SCF_DO_STCLASS_OR) {
5728                         /* OR before, AND after: ideally we would recurse with
5729                          * data_fake to get the AND applied by study of the
5730                          * remainder of the pattern, and then derecurse;
5731                          * *** HACK *** for now just treat as "no information".
5732                          * See [perl #56690].
5733                          */
5734                         ssc_init(pRExC_state, data->start_class);
5735                     }  else {
5736                         /* AND before and after: combine and continue.  These
5737                          * assertions are zero-length, so can match an EMPTY
5738                          * string */
5739                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5740                         ANYOF_FLAGS(data->start_class)
5741                                                    |= SSC_MATCHES_EMPTY_STRING;
5742                     }
5743                 }
5744             }
5745 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5746             else {
5747                 /* Positive Lookahead/lookbehind
5748                    In this case we can do fixed string optimisation,
5749                    but we must be careful about it. Note in the case of
5750                    lookbehind the positions will be offset by the minimum
5751                    length of the pattern, something we won't know about
5752                    until after the recurse.
5753                 */
5754                 SSize_t deltanext, fake = 0;
5755                 regnode *nscan;
5756                 regnode_ssc intrnl;
5757                 int f = 0;
5758                 /* We use SAVEFREEPV so that when the full compile
5759                     is finished perl will clean up the allocated
5760                     minlens when it's all done. This way we don't
5761                     have to worry about freeing them when we know
5762                     they wont be used, which would be a pain.
5763                  */
5764                 SSize_t *minnextp;
5765                 Newx( minnextp, 1, SSize_t );
5766                 SAVEFREEPV(minnextp);
5767
5768                 if (data) {
5769                     StructCopy(data, &data_fake, scan_data_t);
5770                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5771                         f |= SCF_DO_SUBSTR;
5772                         if (scan->flags)
5773                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5774                         data_fake.last_found=newSVsv(data->last_found);
5775                     }
5776                 }
5777                 else
5778                     data_fake.last_closep = &fake;
5779                 data_fake.flags = 0;
5780                 data_fake.substrs[0].flags = 0;
5781                 data_fake.substrs[1].flags = 0;
5782                 data_fake.pos_delta = delta;
5783                 if (is_inf)
5784                     data_fake.flags |= SF_IS_INF;
5785                 if ( flags & SCF_DO_STCLASS && !scan->flags
5786                      && OP(scan) == IFMATCH ) { /* Lookahead */
5787                     ssc_init(pRExC_state, &intrnl);
5788                     data_fake.start_class = &intrnl;
5789                     f |= SCF_DO_STCLASS_AND;
5790                 }
5791                 if (flags & SCF_WHILEM_VISITED_POS)
5792                     f |= SCF_WHILEM_VISITED_POS;
5793                 next = regnext(scan);
5794                 nscan = NEXTOPER(NEXTOPER(scan));
5795
5796                 /* positive lookahead study_chunk() recursion */
5797                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5798                                         &deltanext, last, &data_fake,
5799                                         stopparen, recursed_depth, NULL,
5800                                         f,depth+1);
5801                 if (scan->flags) {
5802                     if (deltanext) {
5803                         FAIL("Variable length lookbehind not implemented");
5804                     }
5805                     else if (*minnextp > (I32)U8_MAX) {
5806                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5807                               (UV)U8_MAX);
5808                     }
5809                     scan->flags = (U8)*minnextp;
5810                 }
5811
5812                 *minnextp += min;
5813
5814                 if (f & SCF_DO_STCLASS_AND) {
5815                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5816                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5817                 }
5818                 if (data) {
5819                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5820                         pars++;
5821                     if (data_fake.flags & SF_HAS_EVAL)
5822                         data->flags |= SF_HAS_EVAL;
5823                     data->whilem_c = data_fake.whilem_c;
5824                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5825                         int i;
5826                         if (RExC_rx->minlen<*minnextp)
5827                             RExC_rx->minlen=*minnextp;
5828                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5829                         SvREFCNT_dec_NN(data_fake.last_found);
5830
5831                         for (i = 0; i < 2; i++) {
5832                             if (data_fake.substrs[i].minlenp != minlenp) {
5833                                 data->substrs[i].min_offset =
5834                                             data_fake.substrs[i].min_offset;
5835                                 data->substrs[i].max_offset =
5836                                             data_fake.substrs[i].max_offset;
5837                                 data->substrs[i].minlenp =
5838                                             data_fake.substrs[i].minlenp;
5839                                 data->substrs[i].lookbehind += scan->flags;
5840                             }
5841                         }
5842                     }
5843                 }
5844             }
5845 #endif
5846         }
5847
5848         else if (OP(scan) == OPEN) {
5849             if (stopparen != (I32)ARG(scan))
5850                 pars++;
5851         }
5852         else if (OP(scan) == CLOSE) {
5853             if (stopparen == (I32)ARG(scan)) {
5854                 break;
5855             }
5856             if ((I32)ARG(scan) == is_par) {
5857                 next = regnext(scan);
5858
5859                 if ( next && (OP(next) != WHILEM) && next < last)
5860                     is_par = 0;         /* Disable optimization */
5861             }
5862             if (data)
5863                 *(data->last_closep) = ARG(scan);
5864         }
5865         else if (OP(scan) == EVAL) {
5866                 if (data)
5867                     data->flags |= SF_HAS_EVAL;
5868         }
5869         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5870             if (flags & SCF_DO_SUBSTR) {
5871                 scan_commit(pRExC_state, data, minlenp, is_inf);
5872                 flags &= ~SCF_DO_SUBSTR;
5873             }
5874             if (data && OP(scan)==ACCEPT) {
5875                 data->flags |= SCF_SEEN_ACCEPT;
5876                 if (stopmin > min)
5877                     stopmin = min;
5878             }
5879         }
5880         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5881         {
5882                 if (flags & SCF_DO_SUBSTR) {
5883                     scan_commit(pRExC_state, data, minlenp, is_inf);
5884                     data->cur_is_floating = 1; /* float */
5885                 }
5886                 is_inf = is_inf_internal = 1;
5887                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5888                     ssc_anything(data->start_class);
5889                 flags &= ~SCF_DO_STCLASS;
5890         }
5891         else if (OP(scan) == GPOS) {
5892             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5893                 !(delta || is_inf || (data && data->pos_delta)))
5894             {
5895                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5896                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5897                 if (RExC_rx->gofs < (STRLEN)min)
5898                     RExC_rx->gofs = min;
5899             } else {
5900                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5901                 RExC_rx->gofs = 0;
5902             }
5903         }
5904 #ifdef TRIE_STUDY_OPT
5905 #ifdef FULL_TRIE_STUDY
5906         else if (PL_regkind[OP(scan)] == TRIE) {
5907             /* NOTE - There is similar code to this block above for handling
5908                BRANCH nodes on the initial study.  If you change stuff here
5909                check there too. */
5910             regnode *trie_node= scan;
5911             regnode *tail= regnext(scan);
5912             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5913             SSize_t max1 = 0, min1 = SSize_t_MAX;
5914             regnode_ssc accum;
5915
5916             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5917                 /* Cannot merge strings after this. */
5918                 scan_commit(pRExC_state, data, minlenp, is_inf);
5919             }
5920             if (flags & SCF_DO_STCLASS)
5921                 ssc_init_zero(pRExC_state, &accum);
5922
5923             if (!trie->jump) {
5924                 min1= trie->minlen;
5925                 max1= trie->maxlen;
5926             } else {
5927                 const regnode *nextbranch= NULL;
5928                 U32 word;
5929
5930                 for ( word=1 ; word <= trie->wordcount ; word++)
5931                 {
5932                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5933                     regnode_ssc this_class;
5934
5935                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5936                     if (data) {
5937                         data_fake.whilem_c = data->whilem_c;
5938                         data_fake.last_closep = data->last_closep;
5939                     }
5940                     else
5941                         data_fake.last_closep = &fake;
5942                     data_fake.pos_delta = delta;
5943                     if (flags & SCF_DO_STCLASS) {
5944                         ssc_init(pRExC_state, &this_class);
5945                         data_fake.start_class = &this_class;
5946                         f = SCF_DO_STCLASS_AND;
5947                     }
5948                     if (flags & SCF_WHILEM_VISITED_POS)
5949                         f |= SCF_WHILEM_VISITED_POS;
5950
5951                     if (trie->jump[word]) {
5952                         if (!nextbranch)
5953                             nextbranch = trie_node + trie->jump[0];
5954                         scan= trie_node + trie->jump[word];
5955                         /* We go from the jump point to the branch that follows
5956                            it. Note this means we need the vestigal unused
5957                            branches even though they arent otherwise used. */
5958                         /* optimise study_chunk() for TRIE */
5959                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5960                             &deltanext, (regnode *)nextbranch, &data_fake,
5961                             stopparen, recursed_depth, NULL, f,depth+1);
5962                     }
5963                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5964                         nextbranch= regnext((regnode*)nextbranch);
5965
5966                     if (min1 > (SSize_t)(minnext + trie->minlen))
5967                         min1 = minnext + trie->minlen;
5968                     if (deltanext == SSize_t_MAX) {
5969                         is_inf = is_inf_internal = 1;
5970                         max1 = SSize_t_MAX;
5971                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5972                         max1 = minnext + deltanext + trie->maxlen;
5973
5974                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5975                         pars++;
5976                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5977                         if ( stopmin > min + min1)
5978                             stopmin = min + min1;
5979                         flags &= ~SCF_DO_SUBSTR;
5980                         if (data)
5981                             data->flags |= SCF_SEEN_ACCEPT;
5982                     }
5983                     if (data) {
5984                         if (data_fake.flags & SF_HAS_EVAL)
5985                             data->flags |= SF_HAS_EVAL;
5986                         data->whilem_c = data_fake.whilem_c;
5987                     }
5988                     if (flags & SCF_DO_STCLASS)
5989                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5990                 }
5991             }
5992             if (flags & SCF_DO_SUBSTR) {
5993                 data->pos_min += min1;
5994                 data->pos_delta += max1 - min1;
5995                 if (max1 != min1 || is_inf)
5996                     data->cur_is_floating = 1; /* float */
5997             }
5998             min += min1;
5999             if (delta != SSize_t_MAX) {
6000                 if (SSize_t_MAX - (max1 - min1) >= delta)
6001                     delta += max1 - min1;
6002                 else
6003                     delta = SSize_t_MAX;
6004             }
6005             if (flags & SCF_DO_STCLASS_OR) {
6006                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6007                 if (min1) {
6008                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6009                     flags &= ~SCF_DO_STCLASS;
6010                 }
6011             }
6012             else if (flags & SCF_DO_STCLASS_AND) {
6013                 if (min1) {
6014                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6015                     flags &= ~SCF_DO_STCLASS;
6016                 }
6017                 else {
6018                     /* Switch to OR mode: cache the old value of
6019                      * data->start_class */
6020                     INIT_AND_WITHP;
6021                     StructCopy(data->start_class, and_withp, regnode_ssc);
6022                     flags &= ~SCF_DO_STCLASS_AND;
6023                     StructCopy(&accum, data->start_class, regnode_ssc);
6024                     flags |= SCF_DO_STCLASS_OR;
6025                 }
6026             }
6027             scan= tail;
6028             continue;
6029         }
6030 #else
6031         else if (PL_regkind[OP(scan)] == TRIE) {
6032             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6033             U8*bang=NULL;
6034
6035             min += trie->minlen;
6036             delta += (trie->maxlen - trie->minlen);
6037             flags &= ~SCF_DO_STCLASS; /* xxx */
6038             if (flags & SCF_DO_SUBSTR) {
6039                 /* Cannot expect anything... */
6040                 scan_commit(pRExC_state, data, minlenp, is_inf);
6041                 data->pos_min += trie->minlen;
6042                 data->pos_delta += (trie->maxlen - trie->minlen);
6043                 if (trie->maxlen != trie->minlen)
6044                     data->cur_is_floating = 1; /* float */
6045             }
6046             if (trie->jump) /* no more substrings -- for now /grr*/
6047                flags &= ~SCF_DO_SUBSTR;
6048         }
6049 #endif /* old or new */
6050 #endif /* TRIE_STUDY_OPT */
6051
6052         /* Else: zero-length, ignore. */
6053         scan = regnext(scan);
6054     }
6055
6056   finish:
6057     if (frame) {
6058         /* we need to unwind recursion. */
6059         depth = depth - 1;
6060
6061         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
6062         DEBUG_PEEP("fend", scan, depth, flags);
6063
6064         /* restore previous context */
6065         last = frame->last_regnode;
6066         scan = frame->next_regnode;
6067         stopparen = frame->stopparen;
6068         recursed_depth = frame->prev_recursed_depth;
6069
6070         RExC_frame_last = frame->prev_frame;
6071         frame = frame->this_prev_frame;
6072         goto fake_study_recurse;
6073     }
6074
6075     assert(!frame);
6076     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6077
6078     *scanp = scan;
6079     *deltap = is_inf_internal ? SSize_t_MAX : delta;
6080
6081     if (flags & SCF_DO_SUBSTR && is_inf)
6082         data->pos_delta = SSize_t_MAX - data->pos_min;
6083     if (is_par > (I32)U8_MAX)
6084         is_par = 0;
6085     if (is_par && pars==1 && data) {
6086         data->flags |= SF_IN_PAR;
6087         data->flags &= ~SF_HAS_PAR;
6088     }
6089     else if (pars && data) {
6090         data->flags |= SF_HAS_PAR;
6091         data->flags &= ~SF_IN_PAR;
6092     }
6093     if (flags & SCF_DO_STCLASS_OR)
6094         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6095     if (flags & SCF_TRIE_RESTUDY)
6096         data->flags |=  SCF_TRIE_RESTUDY;
6097
6098     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6099
6100     {
6101         SSize_t final_minlen= min < stopmin ? min : stopmin;
6102
6103         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6104             if (final_minlen > SSize_t_MAX - delta)
6105                 RExC_maxlen = SSize_t_MAX;
6106             else if (RExC_maxlen < final_minlen + delta)
6107                 RExC_maxlen = final_minlen + delta;
6108         }
6109         return final_minlen;
6110     }
6111     NOT_REACHED; /* NOTREACHED */
6112 }
6113
6114 STATIC U32
6115 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6116 {
6117     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6118
6119     PERL_ARGS_ASSERT_ADD_DATA;
6120
6121     Renewc(RExC_rxi->data,
6122            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6123            char, struct reg_data);
6124     if(count)
6125         Renew(RExC_rxi->data->what, count + n, U8);
6126     else
6127         Newx(RExC_rxi->data->what, n, U8);
6128     RExC_rxi->data->count = count + n;
6129     Copy(s, RExC_rxi->data->what + count, n, U8);
6130     return count;
6131 }
6132
6133 /*XXX: todo make this not included in a non debugging perl, but appears to be
6134  * used anyway there, in 'use re' */
6135 #ifndef PERL_IN_XSUB_RE
6136 void
6137 Perl_reginitcolors(pTHX)
6138 {
6139     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6140     if (s) {
6141         char *t = savepv(s);
6142         int i = 0;
6143         PL_colors[0] = t;
6144         while (++i < 6) {
6145             t = strchr(t, '\t');
6146             if (t) {
6147                 *t = '\0';
6148                 PL_colors[i] = ++t;
6149             }
6150             else
6151                 PL_colors[i] = t = (char *)"";
6152         }
6153     } else {
6154         int i = 0;
6155         while (i < 6)
6156             PL_colors[i++] = (char *)"";
6157     }
6158     PL_colorset = 1;
6159 }
6160 #endif
6161
6162
6163 #ifdef TRIE_STUDY_OPT
6164 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6165     STMT_START {                                            \
6166         if (                                                \
6167               (data.flags & SCF_TRIE_RESTUDY)               \
6168               && ! restudied++                              \
6169         ) {                                                 \
6170             dOsomething;                                    \
6171             goto reStudy;                                   \
6172         }                                                   \
6173     } STMT_END
6174 #else
6175 #define CHECK_RESTUDY_GOTO_butfirst
6176 #endif
6177
6178 /*
6179  * pregcomp - compile a regular expression into internal code
6180  *
6181  * Decides which engine's compiler to call based on the hint currently in
6182  * scope
6183  */
6184
6185 #ifndef PERL_IN_XSUB_RE
6186
6187 /* return the currently in-scope regex engine (or the default if none)  */
6188
6189 regexp_engine const *
6190 Perl_current_re_engine(pTHX)
6191 {
6192     if (IN_PERL_COMPILETIME) {
6193         HV * const table = GvHV(PL_hintgv);
6194         SV **ptr;
6195
6196         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6197             return &PL_core_reg_engine;
6198         ptr = hv_fetchs(table, "regcomp", FALSE);
6199         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6200             return &PL_core_reg_engine;
6201         return INT2PTR(regexp_engine*,SvIV(*ptr));
6202     }
6203     else {
6204         SV *ptr;
6205         if (!PL_curcop->cop_hints_hash)
6206             return &PL_core_reg_engine;
6207         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6208         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6209             return &PL_core_reg_engine;
6210         return INT2PTR(regexp_engine*,SvIV(ptr));
6211     }
6212 }
6213
6214
6215 REGEXP *
6216 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6217 {
6218     regexp_engine const *eng = current_re_engine();
6219     GET_RE_DEBUG_FLAGS_DECL;
6220
6221     PERL_ARGS_ASSERT_PREGCOMP;
6222
6223     /* Dispatch a request to compile a regexp to correct regexp engine. */
6224     DEBUG_COMPILE_r({
6225         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6226                         PTR2UV(eng));
6227     });
6228     return CALLREGCOMP_ENG(eng, pattern, flags);
6229 }
6230 #endif
6231
6232 /* public(ish) entry point for the perl core's own regex compiling code.
6233  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6234  * pattern rather than a list of OPs, and uses the internal engine rather
6235  * than the current one */
6236
6237 REGEXP *
6238 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6239 {
6240     SV *pat = pattern; /* defeat constness! */
6241     PERL_ARGS_ASSERT_RE_COMPILE;
6242     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6243 #ifdef PERL_IN_XSUB_RE
6244                                 &my_reg_engine,
6245 #else
6246                                 &PL_core_reg_engine,
6247 #endif
6248                                 NULL, NULL, rx_flags, 0);
6249 }
6250
6251
6252 static void
6253 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6254 {
6255     int n;
6256
6257     if (--cbs->refcnt > 0)
6258         return;
6259     for (n = 0; n < cbs->count; n++) {
6260         REGEXP *rx = cbs->cb[n].src_regex;
6261         cbs->cb[n].src_regex = NULL;
6262         SvREFCNT_dec(rx);
6263     }
6264     Safefree(cbs->cb);
6265     Safefree(cbs);
6266 }
6267
6268
6269 static struct reg_code_blocks *
6270 S_alloc_code_blocks(pTHX_  int ncode)
6271 {
6272      struct reg_code_blocks *cbs;
6273     Newx(cbs, 1, struct reg_code_blocks);
6274     cbs->count = ncode;
6275     cbs->refcnt = 1;
6276     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6277     if (ncode)
6278         Newx(cbs->cb, ncode, struct reg_code_block);
6279     else
6280         cbs->cb = NULL;
6281     return cbs;
6282 }
6283
6284
6285 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6286  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6287  * point to the realloced string and length.
6288  *
6289  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6290  * stuff added */
6291
6292 static void
6293 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6294                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6295 {
6296     U8 *const src = (U8*)*pat_p;
6297     U8 *dst, *d;
6298     int n=0;
6299     STRLEN s = 0;
6300     bool do_end = 0;
6301     GET_RE_DEBUG_FLAGS_DECL;
6302
6303     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6304         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6305
6306     Newx(dst, *plen_p * 2 + 1, U8);
6307     d = dst;
6308
6309     while (s < *plen_p) {
6310         append_utf8_from_native_byte(src[s], &d);
6311
6312         if (n < num_code_blocks) {
6313             assert(pRExC_state->code_blocks);
6314             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6315                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6316                 assert(*(d - 1) == '(');
6317                 do_end = 1;
6318             }
6319             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6320                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6321                 assert(*(d - 1) == ')');
6322                 do_end = 0;
6323                 n++;
6324             }
6325         }
6326         s++;
6327     }
6328     *d = '\0';
6329     *plen_p = d - dst;
6330     *pat_p = (char*) dst;
6331     SAVEFREEPV(*pat_p);
6332     RExC_orig_utf8 = RExC_utf8 = 1;
6333 }
6334
6335
6336
6337 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6338  * while recording any code block indices, and handling overloading,
6339  * nested qr// objects etc.  If pat is null, it will allocate a new
6340  * string, or just return the first arg, if there's only one.
6341  *
6342  * Returns the malloced/updated pat.
6343  * patternp and pat_count is the array of SVs to be concatted;
6344  * oplist is the optional list of ops that generated the SVs;
6345  * recompile_p is a pointer to a boolean that will be set if
6346  *   the regex will need to be recompiled.
6347  * delim, if non-null is an SV that will be inserted between each element
6348  */
6349
6350 static SV*
6351 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6352                 SV *pat, SV ** const patternp, int pat_count,
6353                 OP *oplist, bool *recompile_p, SV *delim)
6354 {
6355     SV **svp;
6356     int n = 0;
6357     bool use_delim = FALSE;
6358     bool alloced = FALSE;
6359
6360     /* if we know we have at least two args, create an empty string,
6361      * then concatenate args to that. For no args, return an empty string */
6362     if (!pat && pat_count != 1) {
6363         pat = newSVpvs("");
6364         SAVEFREESV(pat);
6365         alloced = TRUE;
6366     }
6367
6368     for (svp = patternp; svp < patternp + pat_count; svp++) {
6369         SV *sv;
6370         SV *rx  = NULL;
6371         STRLEN orig_patlen = 0;
6372         bool code = 0;
6373         SV *msv = use_delim ? delim : *svp;
6374         if (!msv) msv = &PL_sv_undef;
6375
6376         /* if we've got a delimiter, we go round the loop twice for each
6377          * svp slot (except the last), using the delimiter the second
6378          * time round */
6379         if (use_delim) {
6380             svp--;
6381             use_delim = FALSE;
6382         }
6383         else if (delim)
6384             use_delim = TRUE;
6385
6386         if (SvTYPE(msv) == SVt_PVAV) {
6387             /* we've encountered an interpolated array within
6388              * the pattern, e.g. /...@a..../. Expand the list of elements,
6389              * then recursively append elements.
6390              * The code in this block is based on S_pushav() */
6391
6392             AV *const av = (AV*)msv;
6393             const SSize_t maxarg = AvFILL(av) + 1;
6394             SV **array;
6395
6396             if (oplist) {
6397                 assert(oplist->op_type == OP_PADAV
6398                     || oplist->op_type == OP_RV2AV);
6399                 oplist = OpSIBLING(oplist);
6400             }
6401
6402             if (SvRMAGICAL(av)) {
6403                 SSize_t i;
6404
6405                 Newx(array, maxarg, SV*);
6406                 SAVEFREEPV(array);
6407                 for (i=0; i < maxarg; i++) {
6408                     SV ** const svp = av_fetch(av, i, FALSE);
6409                     array[i] = svp ? *svp : &PL_sv_undef;
6410                 }
6411             }
6412             else
6413                 array = AvARRAY(av);
6414
6415             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6416                                 array, maxarg, NULL, recompile_p,
6417                                 /* $" */
6418                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6419
6420             continue;
6421         }
6422
6423
6424         /* we make the assumption here that each op in the list of
6425          * op_siblings maps to one SV pushed onto the stack,
6426          * except for code blocks, with have both an OP_NULL and
6427          * and OP_CONST.
6428          * This allows us to match up the list of SVs against the
6429          * list of OPs to find the next code block.
6430          *
6431          * Note that       PUSHMARK PADSV PADSV ..
6432          * is optimised to
6433          *                 PADRANGE PADSV  PADSV  ..
6434          * so the alignment still works. */
6435
6436         if (oplist) {
6437             if (oplist->op_type == OP_NULL
6438                 && (oplist->op_flags & OPf_SPECIAL))
6439             {
6440                 assert(n < pRExC_state->code_blocks->count);
6441                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6442                 pRExC_state->code_blocks->cb[n].block = oplist;
6443                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6444                 n++;
6445                 code = 1;
6446                 oplist = OpSIBLING(oplist); /* skip CONST */
6447                 assert(oplist);
6448             }
6449             oplist = OpSIBLING(oplist);;
6450         }
6451
6452         /* apply magic and QR overloading to arg */
6453
6454         SvGETMAGIC(msv);
6455         if (SvROK(msv) && SvAMAGIC(msv)) {
6456             SV *sv = AMG_CALLunary(msv, regexp_amg);
6457             if (sv) {
6458                 if (SvROK(sv))
6459                     sv = SvRV(sv);
6460                 if (SvTYPE(sv) != SVt_REGEXP)
6461                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6462                 msv = sv;
6463             }
6464         }
6465
6466         /* try concatenation overload ... */
6467         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6468                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6469         {
6470             sv_setsv(pat, sv);
6471             /* overloading involved: all bets are off over literal
6472              * code. Pretend we haven't seen it */
6473             if (n)
6474                 pRExC_state->code_blocks->count -= n;
6475             n = 0;
6476         }
6477         else  {
6478             /* ... or failing that, try "" overload */
6479             while (SvAMAGIC(msv)
6480                     && (sv = AMG_CALLunary(msv, string_amg))
6481                     && sv != msv
6482                     &&  !(   SvROK(msv)
6483                           && SvROK(sv)
6484                           && SvRV(msv) == SvRV(sv))
6485             ) {
6486                 msv = sv;
6487                 SvGETMAGIC(msv);
6488             }
6489             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6490                 msv = SvRV(msv);
6491
6492             if (pat) {
6493                 /* this is a partially unrolled
6494                  *     sv_catsv_nomg(pat, msv);
6495                  * that allows us to adjust code block indices if
6496                  * needed */
6497                 STRLEN dlen;
6498                 char *dst = SvPV_force_nomg(pat, dlen);
6499                 orig_patlen = dlen;
6500                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6501                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6502                     sv_setpvn(pat, dst, dlen);
6503                     SvUTF8_on(pat);
6504                 }
6505                 sv_catsv_nomg(pat, msv);
6506                 rx = msv;
6507             }
6508             else {
6509                 /* We have only one SV to process, but we need to verify
6510                  * it is properly null terminated or we will fail asserts
6511                  * later. In theory we probably shouldn't get such SV's,
6512                  * but if we do we should handle it gracefully. */
6513                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
6514                     /* not a string, or a string with a trailing null */
6515                     pat = msv;
6516                 } else {
6517                     /* a string with no trailing null, we need to copy it
6518                      * so it has a trailing null */
6519                     pat = sv_2mortal(newSVsv(msv));
6520                 }
6521             }
6522
6523             if (code)
6524                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6525         }
6526
6527         /* extract any code blocks within any embedded qr//'s */
6528         if (rx && SvTYPE(rx) == SVt_REGEXP
6529             && RX_ENGINE((REGEXP*)rx)->op_comp)
6530         {
6531
6532             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6533             if (ri->code_blocks && ri->code_blocks->count) {
6534                 int i;
6535                 /* the presence of an embedded qr// with code means
6536                  * we should always recompile: the text of the
6537                  * qr// may not have changed, but it may be a
6538                  * different closure than last time */
6539                 *recompile_p = 1;
6540                 if (pRExC_state->code_blocks) {
6541                     int new_count = pRExC_state->code_blocks->count
6542                             + ri->code_blocks->count;
6543                     Renew(pRExC_state->code_blocks->cb,
6544                             new_count, struct reg_code_block);
6545                     pRExC_state->code_blocks->count = new_count;
6546                 }
6547                 else
6548                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6549                                                     ri->code_blocks->count);
6550
6551                 for (i=0; i < ri->code_blocks->count; i++) {
6552                     struct reg_code_block *src, *dst;
6553                     STRLEN offset =  orig_patlen
6554                         + ReANY((REGEXP *)rx)->pre_prefix;
6555                     assert(n < pRExC_state->code_blocks->count);
6556                     src = &ri->code_blocks->cb[i];
6557                     dst = &pRExC_state->code_blocks->cb[n];
6558                     dst->start      = src->start + offset;
6559                     dst->end        = src->end   + offset;
6560                     dst->block      = src->block;
6561                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6562                                             src->src_regex
6563                                                 ? src->src_regex
6564                                                 : (REGEXP*)rx);
6565                     n++;
6566                 }
6567             }
6568         }
6569     }
6570     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6571     if (alloced)
6572         SvSETMAGIC(pat);
6573
6574     return pat;
6575 }
6576
6577
6578
6579 /* see if there are any run-time code blocks in the pattern.
6580  * False positives are allowed */
6581
6582 static bool
6583 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6584                     char *pat, STRLEN plen)
6585 {
6586     int n = 0;
6587     STRLEN s;
6588     
6589     PERL_UNUSED_CONTEXT;
6590
6591     for (s = 0; s < plen; s++) {
6592         if (   pRExC_state->code_blocks
6593             && n < pRExC_state->code_blocks->count
6594             && s == pRExC_state->code_blocks->cb[n].start)
6595         {
6596             s = pRExC_state->code_blocks->cb[n].end;
6597             n++;
6598             continue;
6599         }
6600         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6601          * positives here */
6602         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6603             (pat[s+2] == '{'
6604                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6605         )
6606             return 1;
6607     }
6608     return 0;
6609 }
6610
6611 /* Handle run-time code blocks. We will already have compiled any direct
6612  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6613  * copy of it, but with any literal code blocks blanked out and
6614  * appropriate chars escaped; then feed it into
6615  *
6616  *    eval "qr'modified_pattern'"
6617  *
6618  * For example,
6619  *
6620  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6621  *
6622  * becomes
6623  *
6624  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6625  *
6626  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6627  * and merge them with any code blocks of the original regexp.
6628  *
6629  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6630  * instead, just save the qr and return FALSE; this tells our caller that
6631  * the original pattern needs upgrading to utf8.
6632  */
6633
6634 static bool
6635 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6636     char *pat, STRLEN plen)
6637 {
6638     SV *qr;
6639
6640     GET_RE_DEBUG_FLAGS_DECL;
6641
6642     if (pRExC_state->runtime_code_qr) {
6643         /* this is the second time we've been called; this should
6644          * only happen if the main pattern got upgraded to utf8
6645          * during compilation; re-use the qr we compiled first time
6646          * round (which should be utf8 too)
6647          */
6648         qr = pRExC_state->runtime_code_qr;
6649         pRExC_state->runtime_code_qr = NULL;
6650         assert(RExC_utf8 && SvUTF8(qr));
6651     }
6652     else {
6653         int n = 0;
6654         STRLEN s;
6655         char *p, *newpat;
6656         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6657         SV *sv, *qr_ref;
6658         dSP;
6659
6660         /* determine how many extra chars we need for ' and \ escaping */
6661         for (s = 0; s < plen; s++) {
6662             if (pat[s] == '\'' || pat[s] == '\\')
6663                 newlen++;
6664         }
6665
6666         Newx(newpat, newlen, char);
6667         p = newpat;
6668         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6669
6670         for (s = 0; s < plen; s++) {
6671             if (   pRExC_state->code_blocks
6672                 && n < pRExC_state->code_blocks->count
6673                 && s == pRExC_state->code_blocks->cb[n].start)
6674             {
6675                 /* blank out literal code block */
6676                 assert(pat[s] == '(');
6677                 while (s <= pRExC_state->code_blocks->cb[n].end) {
6678                     *p++ = '_';
6679                     s++;
6680                 }
6681                 s--;
6682                 n++;
6683                 continue;
6684             }
6685             if (pat[s] == '\'' || pat[s] == '\\')
6686                 *p++ = '\\';
6687             *p++ = pat[s];
6688         }
6689         *p++ = '\'';
6690         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
6691             *p++ = 'x';
6692             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
6693                 *p++ = 'x';
6694             }
6695         }
6696         *p++ = '\0';
6697         DEBUG_COMPILE_r({
6698             Perl_re_printf( aTHX_
6699                 "%sre-parsing pattern for runtime code:%s %s\n",
6700                 PL_colors[4],PL_colors[5],newpat);
6701         });
6702
6703         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6704         Safefree(newpat);
6705
6706         ENTER;
6707         SAVETMPS;
6708         save_re_context();
6709         PUSHSTACKi(PERLSI_REQUIRE);
6710         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6711          * parsing qr''; normally only q'' does this. It also alters
6712          * hints handling */
6713         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6714         SvREFCNT_dec_NN(sv);
6715         SPAGAIN;
6716         qr_ref = POPs;
6717         PUTBACK;
6718         {
6719             SV * const errsv = ERRSV;
6720             if (SvTRUE_NN(errsv))
6721                 /* use croak_sv ? */
6722                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6723         }
6724         assert(SvROK(qr_ref));
6725         qr = SvRV(qr_ref);
6726         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6727         /* the leaving below frees the tmp qr_ref.
6728          * Give qr a life of its own */
6729         SvREFCNT_inc(qr);
6730         POPSTACK;
6731         FREETMPS;
6732         LEAVE;
6733
6734     }
6735
6736     if (!RExC_utf8 && SvUTF8(qr)) {
6737         /* first time through; the pattern got upgraded; save the
6738          * qr for the next time through */
6739         assert(!pRExC_state->runtime_code_qr);
6740         pRExC_state->runtime_code_qr = qr;
6741         return 0;
6742     }
6743
6744
6745     /* extract any code blocks within the returned qr//  */
6746
6747
6748     /* merge the main (r1) and run-time (r2) code blocks into one */
6749     {
6750         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6751         struct reg_code_block *new_block, *dst;
6752         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6753         int i1 = 0, i2 = 0;
6754         int r1c, r2c;
6755
6756         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
6757         {
6758             SvREFCNT_dec_NN(qr);
6759             return 1;
6760         }
6761
6762         if (!r1->code_blocks)
6763             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
6764
6765         r1c = r1->code_blocks->count;
6766         r2c = r2->code_blocks->count;
6767
6768         Newx(new_block, r1c + r2c, struct reg_code_block);
6769
6770         dst = new_block;
6771
6772         while (i1 < r1c || i2 < r2c) {
6773             struct reg_code_block *src;
6774             bool is_qr = 0;
6775
6776             if (i1 == r1c) {
6777                 src = &r2->code_blocks->cb[i2++];
6778                 is_qr = 1;
6779             }
6780             else if (i2 == r2c)
6781                 src = &r1->code_blocks->cb[i1++];
6782             else if (  r1->code_blocks->cb[i1].start
6783                      < r2->code_blocks->cb[i2].start)
6784             {
6785                 src = &r1->code_blocks->cb[i1++];
6786                 assert(src->end < r2->code_blocks->cb[i2].start);
6787             }
6788             else {
6789                 assert(  r1->code_blocks->cb[i1].start
6790                        > r2->code_blocks->cb[i2].start);
6791                 src = &r2->code_blocks->cb[i2++];
6792                 is_qr = 1;
6793                 assert(src->end < r1->code_blocks->cb[i1].start);
6794             }
6795
6796             assert(pat[src->start] == '(');
6797             assert(pat[src->end]   == ')');
6798             dst->start      = src->start;
6799             dst->end        = src->end;
6800             dst->block      = src->block;
6801             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6802                                     : src->src_regex;
6803             dst++;
6804         }
6805         r1->code_blocks->count += r2c;
6806         Safefree(r1->code_blocks->cb);
6807         r1->code_blocks->cb = new_block;
6808     }
6809
6810     SvREFCNT_dec_NN(qr);
6811     return 1;
6812 }
6813
6814
6815 STATIC bool
6816 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
6817                       struct reg_substr_datum  *rsd,
6818                       struct scan_data_substrs *sub,
6819                       STRLEN longest_length)
6820 {
6821     /* This is the common code for setting up the floating and fixed length
6822      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6823      * as to whether succeeded or not */
6824
6825     I32 t;
6826     SSize_t ml;
6827     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
6828     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
6829
6830     if (! (longest_length
6831            || (eol /* Can't have SEOL and MULTI */
6832                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6833           )
6834             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6835         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6836     {
6837         return FALSE;
6838     }
6839
6840     /* copy the information about the longest from the reg_scan_data
6841         over to the program. */
6842     if (SvUTF8(sub->str)) {
6843         rsd->substr      = NULL;
6844         rsd->utf8_substr = sub->str;
6845     } else {
6846         rsd->substr      = sub->str;
6847         rsd->utf8_substr = NULL;
6848     }
6849     /* end_shift is how many chars that must be matched that
6850         follow this item. We calculate it ahead of time as once the
6851         lookbehind offset is added in we lose the ability to correctly
6852         calculate it.*/
6853     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
6854     rsd->end_shift = ml - sub->min_offset
6855         - longest_length
6856             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6857              * intead? - DAPM
6858             + (SvTAIL(sub->str) != 0)
6859             */
6860         + sub->lookbehind;
6861
6862     t = (eol/* Can't have SEOL and MULTI */
6863          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6864     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
6865
6866     return TRUE;
6867 }
6868
6869 /*
6870  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6871  * regular expression into internal code.
6872  * The pattern may be passed either as:
6873  *    a list of SVs (patternp plus pat_count)
6874  *    a list of OPs (expr)
6875  * If both are passed, the SV list is used, but the OP list indicates
6876  * which SVs are actually pre-compiled code blocks
6877  *
6878  * The SVs in the list have magic and qr overloading applied to them (and
6879  * the list may be modified in-place with replacement SVs in the latter
6880  * case).
6881  *
6882  * If the pattern hasn't changed from old_re, then old_re will be
6883  * returned.
6884  *
6885  * eng is the current engine. If that engine has an op_comp method, then
6886  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6887  * do the initial concatenation of arguments and pass on to the external
6888  * engine.
6889  *
6890  * If is_bare_re is not null, set it to a boolean indicating whether the
6891  * arg list reduced (after overloading) to a single bare regex which has
6892  * been returned (i.e. /$qr/).
6893  *
6894  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6895  *
6896  * pm_flags contains the PMf_* flags, typically based on those from the
6897  * pm_flags field of the related PMOP. Currently we're only interested in
6898  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6899  *
6900  * We can't allocate space until we know how big the compiled form will be,
6901  * but we can't compile it (and thus know how big it is) until we've got a
6902  * place to put the code.  So we cheat:  we compile it twice, once with code
6903  * generation turned off and size counting turned on, and once "for real".
6904  * This also means that we don't allocate space until we are sure that the
6905  * thing really will compile successfully, and we never have to move the
6906  * code and thus invalidate pointers into it.  (Note that it has to be in
6907  * one piece because free() must be able to free it all.) [NB: not true in perl]
6908  *
6909  * Beware that the optimization-preparation code in here knows about some
6910  * of the structure of the compiled regexp.  [I'll say.]
6911  */
6912
6913 REGEXP *
6914 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6915                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6916                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6917 {
6918     REGEXP *rx;
6919     struct regexp *r;
6920     regexp_internal *ri;
6921     STRLEN plen;
6922     char *exp;
6923     regnode *scan;
6924     I32 flags;
6925     SSize_t minlen = 0;
6926     U32 rx_flags;
6927     SV *pat;
6928     SV** new_patternp = patternp;
6929
6930     /* these are all flags - maybe they should be turned
6931      * into a single int with different bit masks */
6932     I32 sawlookahead = 0;
6933     I32 sawplus = 0;
6934     I32 sawopen = 0;
6935     I32 sawminmod = 0;
6936
6937     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6938     bool recompile = 0;
6939     bool runtime_code = 0;
6940     scan_data_t data;
6941     RExC_state_t RExC_state;
6942     RExC_state_t * const pRExC_state = &RExC_state;
6943 #ifdef TRIE_STUDY_OPT
6944     int restudied = 0;
6945     RExC_state_t copyRExC_state;
6946 #endif
6947     GET_RE_DEBUG_FLAGS_DECL;
6948
6949     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6950
6951     DEBUG_r(if (!PL_colorset) reginitcolors());
6952
6953     /* Initialize these here instead of as-needed, as is quick and avoids
6954      * having to test them each time otherwise */
6955     if (! PL_InBitmap) {
6956 #ifdef DEBUGGING
6957         char * dump_len_string;
6958 #endif
6959
6960         /* This is calculated here, because the Perl program that generates the
6961          * static global ones doesn't currently have access to
6962          * NUM_ANYOF_CODE_POINTS */
6963         PL_InBitmap = _new_invlist(2);
6964         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6965                                                     NUM_ANYOF_CODE_POINTS - 1);
6966 #ifdef DEBUGGING
6967         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6968         if (   ! dump_len_string
6969             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6970         {
6971             PL_dump_re_max_len = 60;    /* A reasonable default */
6972         }
6973 #endif
6974     }
6975
6976     pRExC_state->warn_text = NULL;
6977     pRExC_state->code_blocks = NULL;
6978
6979     if (is_bare_re)
6980         *is_bare_re = FALSE;
6981
6982     if (expr && (expr->op_type == OP_LIST ||
6983                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6984         /* allocate code_blocks if needed */
6985         OP *o;
6986         int ncode = 0;
6987
6988         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6989             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6990                 ncode++; /* count of DO blocks */
6991
6992         if (ncode)
6993             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
6994     }
6995
6996     if (!pat_count) {
6997         /* compile-time pattern with just OP_CONSTs and DO blocks */
6998
6999         int n;
7000         OP *o;
7001
7002         /* find how many CONSTs there are */
7003         assert(expr);
7004         n = 0;
7005         if (expr->op_type == OP_CONST)
7006             n = 1;
7007         else
7008             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7009                 if (o->op_type == OP_CONST)
7010                     n++;
7011             }
7012
7013         /* fake up an SV array */
7014
7015         assert(!new_patternp);
7016         Newx(new_patternp, n, SV*);
7017         SAVEFREEPV(new_patternp);
7018         pat_count = n;
7019
7020         n = 0;
7021         if (expr->op_type == OP_CONST)
7022             new_patternp[n] = cSVOPx_sv(expr);
7023         else
7024             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7025                 if (o->op_type == OP_CONST)
7026                     new_patternp[n++] = cSVOPo_sv;
7027             }
7028
7029     }
7030
7031     DEBUG_PARSE_r(Perl_re_printf( aTHX_
7032         "Assembling pattern from %d elements%s\n", pat_count,
7033             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7034
7035     /* set expr to the first arg op */
7036
7037     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
7038          && expr->op_type != OP_CONST)
7039     {
7040             expr = cLISTOPx(expr)->op_first;
7041             assert(   expr->op_type == OP_PUSHMARK
7042                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
7043                    || expr->op_type == OP_PADRANGE);
7044             expr = OpSIBLING(expr);
7045     }
7046
7047     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
7048                         expr, &recompile, NULL);
7049
7050     /* handle bare (possibly after overloading) regex: foo =~ $re */
7051     {
7052         SV *re = pat;
7053         if (SvROK(re))
7054             re = SvRV(re);
7055         if (SvTYPE(re) == SVt_REGEXP) {
7056             if (is_bare_re)
7057                 *is_bare_re = TRUE;
7058             SvREFCNT_inc(re);
7059             DEBUG_PARSE_r(Perl_re_printf( aTHX_
7060                 "Precompiled pattern%s\n",
7061                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7062
7063             return (REGEXP*)re;
7064         }
7065     }
7066
7067     exp = SvPV_nomg(pat, plen);
7068
7069     if (!eng->op_comp) {
7070         if ((SvUTF8(pat) && IN_BYTES)
7071                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7072         {
7073             /* make a temporary copy; either to convert to bytes,
7074              * or to avoid repeating get-magic / overloaded stringify */
7075             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7076                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7077         }
7078         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7079     }
7080
7081     /* ignore the utf8ness if the pattern is 0 length */
7082     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7083
7084     RExC_uni_semantics = 0;
7085     RExC_seen_unfolded_sharp_s = 0;
7086     RExC_contains_locale = 0;
7087     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7088     RExC_in_script_run = 0;
7089     RExC_study_started = 0;
7090     pRExC_state->runtime_code_qr = NULL;
7091     RExC_frame_head= NULL;
7092     RExC_frame_last= NULL;
7093     RExC_frame_count= 0;
7094
7095     DEBUG_r({
7096         RExC_mysv1= sv_newmortal();
7097         RExC_mysv2= sv_newmortal();
7098     });
7099     DEBUG_COMPILE_r({
7100             SV *dsv= sv_newmortal();
7101             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7102             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7103                           PL_colors[4],PL_colors[5],s);
7104         });
7105
7106   redo_first_pass:
7107     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7108      * to utf8 */
7109
7110     if ((pm_flags & PMf_USE_RE_EVAL)
7111                 /* this second condition covers the non-regex literal case,
7112                  * i.e.  $foo =~ '(?{})'. */
7113                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7114     )
7115         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7116
7117     /* return old regex if pattern hasn't changed */
7118     /* XXX: note in the below we have to check the flags as well as the
7119      * pattern.
7120      *
7121      * Things get a touch tricky as we have to compare the utf8 flag
7122      * independently from the compile flags.  */
7123
7124     if (   old_re
7125         && !recompile
7126         && !!RX_UTF8(old_re) == !!RExC_utf8
7127         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7128         && RX_PRECOMP(old_re)
7129         && RX_PRELEN(old_re) == plen
7130         && memEQ(RX_PRECOMP(old_re), exp, plen)
7131         && !runtime_code /* with runtime code, always recompile */ )
7132     {
7133         return old_re;
7134     }
7135
7136     rx_flags = orig_rx_flags;
7137
7138     if (   initial_charset == REGEX_DEPENDS_CHARSET
7139         && (RExC_utf8 ||RExC_uni_semantics))
7140     {
7141
7142         /* Set to use unicode semantics if the pattern is in utf8 and has the
7143          * 'depends' charset specified, as it means unicode when utf8  */
7144         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7145     }
7146
7147     RExC_precomp = exp;
7148     RExC_precomp_adj = 0;
7149     RExC_flags = rx_flags;
7150     RExC_pm_flags = pm_flags;
7151
7152     if (runtime_code) {
7153         assert(TAINTING_get || !TAINT_get);
7154         if (TAINT_get)
7155             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7156
7157         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7158             /* whoops, we have a non-utf8 pattern, whilst run-time code
7159              * got compiled as utf8. Try again with a utf8 pattern */
7160             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7161                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7162             goto redo_first_pass;
7163         }
7164     }
7165     assert(!pRExC_state->runtime_code_qr);
7166
7167     RExC_sawback = 0;
7168
7169     RExC_seen = 0;
7170     RExC_maxlen = 0;
7171     RExC_in_lookbehind = 0;
7172     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7173     RExC_extralen = 0;
7174 #ifdef EBCDIC
7175     RExC_recode_x_to_native = 0;
7176 #endif
7177     RExC_in_multi_char_class = 0;
7178
7179     /* First pass: determine size, legality. */
7180     RExC_parse = exp;
7181     RExC_start = RExC_adjusted_start = exp;
7182     RExC_end = exp + plen;
7183     RExC_precomp_end = RExC_end;
7184     RExC_naughty = 0;
7185     RExC_npar = 1;
7186     RExC_nestroot = 0;
7187     RExC_size = 0L;
7188     RExC_emit = (regnode *) &RExC_emit_dummy;
7189     RExC_whilem_seen = 0;
7190     RExC_open_parens = NULL;
7191     RExC_close_parens = NULL;
7192     RExC_end_op = NULL;
7193     RExC_paren_names = NULL;
7194 #ifdef DEBUGGING
7195     RExC_paren_name_list = NULL;
7196 #endif
7197     RExC_recurse = NULL;
7198     RExC_study_chunk_recursed = NULL;
7199     RExC_study_chunk_recursed_bytes= 0;
7200     RExC_recurse_count = 0;
7201     pRExC_state->code_index = 0;
7202
7203     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7204      * code makes sure the final byte is an uncounted NUL.  But should this
7205      * ever not be the case, lots of things could read beyond the end of the
7206      * buffer: loops like
7207      *      while(isFOO(*RExC_parse)) RExC_parse++;
7208      *      strchr(RExC_parse, "foo");
7209      * etc.  So it is worth noting. */
7210     assert(*RExC_end == '\0');
7211
7212     DEBUG_PARSE_r(
7213         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7214         RExC_lastnum=0;
7215         RExC_lastparse=NULL;
7216     );
7217
7218     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7219         /* It's possible to write a regexp in ascii that represents Unicode
7220         codepoints outside of the byte range, such as via \x{100}. If we
7221         detect such a sequence we have to convert the entire pattern to utf8
7222         and then recompile, as our sizing calculation will have been based
7223         on 1 byte == 1 character, but we will need to use utf8 to encode
7224         at least some part of the pattern, and therefore must convert the whole
7225         thing.
7226         -- dmq */
7227         if (MUST_RESTART(flags)) {
7228             if (flags & NEED_UTF8) {
7229                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7230                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7231                 DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo pass 1 after upgrade\n"));
7232             }
7233             else {
7234                 DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo pass 1\n"));
7235             }
7236
7237             goto redo_first_pass;
7238         }
7239         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7240     }
7241
7242     DEBUG_PARSE_r({
7243         Perl_re_printf( aTHX_
7244             "Required size %" IVdf " nodes\n"
7245             "Starting second pass (creation)\n",
7246             (IV)RExC_size);
7247         RExC_lastnum=0;
7248         RExC_lastparse=NULL;
7249     });
7250
7251     /* The first pass could have found things that force Unicode semantics */
7252     if ((RExC_utf8 || RExC_uni_semantics)
7253          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7254     {
7255         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7256     }
7257
7258     /* Small enough for pointer-storage convention?
7259        If extralen==0, this means that we will not need long jumps. */
7260     if (RExC_size >= 0x10000L && RExC_extralen)
7261         RExC_size += RExC_extralen;
7262     else
7263         RExC_extralen = 0;
7264     if (RExC_whilem_seen > 15)
7265         RExC_whilem_seen = 15;
7266
7267     /* Allocate space and zero-initialize. Note, the two step process
7268        of zeroing when in debug mode, thus anything assigned has to
7269        happen after that */
7270     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7271     r = ReANY(rx);
7272     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7273          char, regexp_internal);
7274     if ( r == NULL || ri == NULL )
7275         FAIL("Regexp out of space");
7276 #ifdef DEBUGGING
7277     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7278     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7279          char);
7280 #else
7281     /* bulk initialize base fields with 0. */
7282     Zero(ri, sizeof(regexp_internal), char);
7283 #endif
7284
7285     /* non-zero initialization begins here */
7286     RXi_SET( r, ri );
7287     r->engine= eng;
7288     r->extflags = rx_flags;
7289     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7290
7291     if (pm_flags & PMf_IS_QR) {
7292         ri->code_blocks = pRExC_state->code_blocks;
7293         if (ri->code_blocks)
7294             ri->code_blocks->refcnt++;
7295     }
7296
7297     {
7298         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7299         bool has_charset = (get_regex_charset(r->extflags)
7300                                                     != REGEX_DEPENDS_CHARSET);
7301
7302         /* The caret is output if there are any defaults: if not all the STD
7303          * flags are set, or if no character set specifier is needed */
7304         bool has_default =
7305                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7306                     || ! has_charset);
7307         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7308                                                    == REG_RUN_ON_COMMENT_SEEN);
7309         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7310                             >> RXf_PMf_STD_PMMOD_SHIFT);
7311         const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7312         char *p;
7313
7314         /* We output all the necessary flags; we never output a minus, as all
7315          * those are defaults, so are
7316          * covered by the caret */
7317         const STRLEN wraplen = plen + has_p + has_runon
7318             + has_default       /* If needs a caret */
7319             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7320
7321                 /* If needs a character set specifier */
7322             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7323             + (sizeof("(?:)") - 1);
7324
7325         /* make sure PL_bitcount bounds not exceeded */
7326         assert(sizeof(STD_PAT_MODS) <= 8);
7327
7328         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
7329         SvPOK_on(rx);
7330         if (RExC_utf8)
7331             SvFLAGS(rx) |= SVf_UTF8;
7332         *p++='('; *p++='?';
7333
7334         /* If a default, cover it using the caret */
7335         if (has_default) {
7336             *p++= DEFAULT_PAT_MOD;
7337         }
7338         if (has_charset) {
7339             STRLEN len;
7340             const char* const name = get_regex_charset_name(r->extflags, &len);
7341             Copy(name, p, len, char);
7342             p += len;
7343         }
7344         if (has_p)
7345             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7346         {
7347             char ch;
7348             while((ch = *fptr++)) {
7349                 if(reganch & 1)
7350                     *p++ = ch;
7351                 reganch >>= 1;
7352             }
7353         }
7354
7355         *p++ = ':';
7356         Copy(RExC_precomp, p, plen, char);
7357         assert ((RX_WRAPPED(rx) - p) < 16);
7358         r->pre_prefix = p - RX_WRAPPED(rx);
7359         p += plen;
7360         if (has_runon)
7361             *p++ = '\n';
7362         *p++ = ')';
7363         *p = 0;
7364         SvCUR_set(rx, p - RX_WRAPPED(rx));
7365     }
7366
7367     r->intflags = 0;
7368     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7369
7370     /* Useful during FAIL. */
7371 #ifdef RE_TRACK_PATTERN_OFFSETS
7372     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7373     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7374                           "%s %" UVuf " bytes for offset annotations.\n",
7375                           ri->u.offsets ? "Got" : "Couldn't get",
7376                           (UV)((2*RExC_size+1) * sizeof(U32))));
7377 #endif
7378     SetProgLen(ri,RExC_size);
7379     RExC_rx_sv = rx;
7380     RExC_rx = r;
7381     RExC_rxi = ri;
7382
7383     /* Second pass: emit code. */
7384     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7385     RExC_pm_flags = pm_flags;
7386     RExC_parse = exp;
7387     RExC_end = exp + plen;
7388     RExC_naughty = 0;
7389     RExC_emit_start = ri->program;
7390     RExC_emit = ri->program;
7391     RExC_emit_bound = ri->program + RExC_size + 1;
7392     pRExC_state->code_index = 0;
7393
7394     *((char*) RExC_emit++) = (char) REG_MAGIC;
7395     /* setup various meta data about recursion, this all requires
7396      * RExC_npar to be correctly set, and a bit later on we clear it */
7397     if (RExC_seen & REG_RECURSE_SEEN) {
7398         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7399             "%*s%*s Setting up open/close parens\n",
7400                   22, "|    |", (int)(0 * 2 + 1), ""));
7401
7402         /* setup RExC_open_parens, which holds the address of each
7403          * OPEN tag, and to make things simpler for the 0 index
7404          * the start of the program - this is used later for offsets */
7405         Newxz(RExC_open_parens, RExC_npar,regnode *);
7406         SAVEFREEPV(RExC_open_parens);
7407         RExC_open_parens[0] = RExC_emit;
7408
7409         /* setup RExC_close_parens, which holds the address of each
7410          * CLOSE tag, and to make things simpler for the 0 index
7411          * the end of the program - this is used later for offsets */
7412         Newxz(RExC_close_parens, RExC_npar,regnode *);
7413         SAVEFREEPV(RExC_close_parens);
7414         /* we dont know where end op starts yet, so we dont
7415          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7416
7417         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7418          * So its 1 if there are no parens. */
7419         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7420                                          ((RExC_npar & 0x07) != 0);
7421         Newx(RExC_study_chunk_recursed,
7422              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7423         SAVEFREEPV(RExC_study_chunk_recursed);
7424     }
7425     RExC_npar = 1;
7426     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7427         ReREFCNT_dec(rx);
7428         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7429     }
7430     DEBUG_OPTIMISE_r(
7431         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7432     );
7433
7434     /* XXXX To minimize changes to RE engine we always allocate
7435        3-units-long substrs field. */
7436     Newx(r->substrs, 1, struct reg_substr_data);
7437     if (RExC_recurse_count) {
7438         Newx(RExC_recurse,RExC_recurse_count,regnode *);
7439         SAVEFREEPV(RExC_recurse);
7440     }
7441
7442   reStudy:
7443     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7444     DEBUG_r(
7445         RExC_study_chunk_recursed_count= 0;
7446     );
7447     Zero(r->substrs, 1, struct reg_substr_data);
7448     if (RExC_study_chunk_recursed) {
7449         Zero(RExC_study_chunk_recursed,
7450              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7451     }
7452
7453
7454 #ifdef TRIE_STUDY_OPT
7455     if (!restudied) {
7456         StructCopy(&zero_scan_data, &data, scan_data_t);
7457         copyRExC_state = RExC_state;
7458     } else {
7459         U32 seen=RExC_seen;
7460         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7461
7462         RExC_state = copyRExC_state;
7463         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7464             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7465         else
7466             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7467         StructCopy(&zero_scan_data, &data, scan_data_t);
7468     }
7469 #else
7470     StructCopy(&zero_scan_data, &data, scan_data_t);
7471 #endif
7472
7473     /* Dig out information for optimizations. */
7474     r->extflags = RExC_flags; /* was pm_op */
7475     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7476
7477     if (UTF)
7478         SvUTF8_on(rx);  /* Unicode in it? */
7479     ri->regstclass = NULL;
7480     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7481         r->intflags |= PREGf_NAUGHTY;
7482     scan = ri->program + 1;             /* First BRANCH. */
7483
7484     /* testing for BRANCH here tells us whether there is "must appear"
7485        data in the pattern. If there is then we can use it for optimisations */
7486     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7487                                                   */
7488         SSize_t fake;
7489         STRLEN longest_length[2];
7490         regnode_ssc ch_class; /* pointed to by data */
7491         int stclass_flag;
7492         SSize_t last_close = 0; /* pointed to by data */
7493         regnode *first= scan;
7494         regnode *first_next= regnext(first);
7495         int i;
7496
7497         /*
7498          * Skip introductions and multiplicators >= 1
7499          * so that we can extract the 'meat' of the pattern that must
7500          * match in the large if() sequence following.
7501          * NOTE that EXACT is NOT covered here, as it is normally
7502          * picked up by the optimiser separately.
7503          *
7504          * This is unfortunate as the optimiser isnt handling lookahead
7505          * properly currently.
7506          *
7507          */
7508         while ((OP(first) == OPEN && (sawopen = 1)) ||
7509                /* An OR of *one* alternative - should not happen now. */
7510             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7511             /* for now we can't handle lookbehind IFMATCH*/
7512             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7513             (OP(first) == PLUS) ||
7514             (OP(first) == MINMOD) ||
7515                /* An {n,m} with n>0 */
7516             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7517             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7518         {
7519                 /*
7520                  * the only op that could be a regnode is PLUS, all the rest
7521                  * will be regnode_1 or regnode_2.
7522                  *
7523                  * (yves doesn't think this is true)
7524                  */
7525                 if (OP(first) == PLUS)
7526                     sawplus = 1;
7527                 else {
7528                     if (OP(first) == MINMOD)
7529                         sawminmod = 1;
7530                     first += regarglen[OP(first)];
7531                 }
7532                 first = NEXTOPER(first);
7533                 first_next= regnext(first);
7534         }
7535
7536         /* Starting-point info. */
7537       again:
7538         DEBUG_PEEP("first:", first, 0, 0);
7539         /* Ignore EXACT as we deal with it later. */
7540         if (PL_regkind[OP(first)] == EXACT) {
7541             if (OP(first) == EXACT || OP(first) == EXACTL)
7542                 NOOP;   /* Empty, get anchored substr later. */
7543             else
7544                 ri->regstclass = first;
7545         }
7546 #ifdef TRIE_STCLASS
7547         else if (PL_regkind[OP(first)] == TRIE &&
7548                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7549         {
7550             /* this can happen only on restudy */
7551             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7552         }
7553 #endif
7554         else if (REGNODE_SIMPLE(OP(first)))
7555             ri->regstclass = first;
7556         else if (PL_regkind[OP(first)] == BOUND ||
7557                  PL_regkind[OP(first)] == NBOUND)
7558             ri->regstclass = first;
7559         else if (PL_regkind[OP(first)] == BOL) {
7560             r->intflags |= (OP(first) == MBOL
7561                            ? PREGf_ANCH_MBOL
7562                            : PREGf_ANCH_SBOL);
7563             first = NEXTOPER(first);
7564             goto again;
7565         }
7566         else if (OP(first) == GPOS) {
7567             r->intflags |= PREGf_ANCH_GPOS;
7568             first = NEXTOPER(first);
7569             goto again;
7570         }
7571         else if ((!sawopen || !RExC_sawback) &&
7572             !sawlookahead &&
7573             (OP(first) == STAR &&
7574             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7575             !(r->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7576         {
7577             /* turn .* into ^.* with an implied $*=1 */
7578             const int type =
7579                 (OP(NEXTOPER(first)) == REG_ANY)
7580                     ? PREGf_ANCH_MBOL
7581                     : PREGf_ANCH_SBOL;
7582             r->intflags |= (type | PREGf_IMPLICIT);
7583             first = NEXTOPER(first);
7584             goto again;
7585         }
7586         if (sawplus && !sawminmod && !sawlookahead
7587             && (!sawopen || !RExC_sawback)
7588             && !pRExC_state->code_blocks) /* May examine pos and $& */
7589             /* x+ must match at the 1st pos of run of x's */
7590             r->intflags |= PREGf_SKIP;
7591
7592         /* Scan is after the zeroth branch, first is atomic matcher. */
7593 #ifdef TRIE_STUDY_OPT
7594         DEBUG_PARSE_r(
7595             if (!restudied)
7596                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7597                               (IV)(first - scan + 1))
7598         );
7599 #else
7600         DEBUG_PARSE_r(
7601             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7602                 (IV)(first - scan + 1))
7603         );
7604 #endif
7605
7606
7607         /*
7608         * If there's something expensive in the r.e., find the
7609         * longest literal string that must appear and make it the
7610         * regmust.  Resolve ties in favor of later strings, since
7611         * the regstart check works with the beginning of the r.e.
7612         * and avoiding duplication strengthens checking.  Not a
7613         * strong reason, but sufficient in the absence of others.
7614         * [Now we resolve ties in favor of the earlier string if
7615         * it happens that c_offset_min has been invalidated, since the
7616         * earlier string may buy us something the later one won't.]
7617         */
7618
7619         data.substrs[0].str = newSVpvs("");
7620         data.substrs[1].str = newSVpvs("");
7621         data.last_found = newSVpvs("");
7622         data.cur_is_floating = 0; /* initially any found substring is fixed */
7623         ENTER_with_name("study_chunk");
7624         SAVEFREESV(data.substrs[0].str);
7625         SAVEFREESV(data.substrs[1].str);
7626         SAVEFREESV(data.last_found);
7627         first = scan;
7628         if (!ri->regstclass) {
7629             ssc_init(pRExC_state, &ch_class);
7630             data.start_class = &ch_class;
7631             stclass_flag = SCF_DO_STCLASS_AND;
7632         } else                          /* XXXX Check for BOUND? */
7633             stclass_flag = 0;
7634         data.last_closep = &last_close;
7635
7636         DEBUG_RExC_seen();
7637         /*
7638          * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
7639          * (NO top level branches)
7640          */
7641         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7642                              scan + RExC_size, /* Up to end */
7643             &data, -1, 0, NULL,
7644             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7645                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7646             0);
7647
7648
7649         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7650
7651
7652         if ( RExC_npar == 1 && !data.cur_is_floating
7653              && data.last_start_min == 0 && data.last_end > 0
7654              && !RExC_seen_zerolen
7655              && !(RExC_seen & REG_VERBARG_SEEN)
7656              && !(RExC_seen & REG_GPOS_SEEN)
7657         ){
7658             r->extflags |= RXf_CHECK_ALL;
7659         }
7660         scan_commit(pRExC_state, &data,&minlen,0);
7661
7662
7663         /* XXX this is done in reverse order because that's the way the
7664          * code was before it was parameterised. Don't know whether it
7665          * actually needs doing in reverse order. DAPM */
7666         for (i = 1; i >= 0; i--) {
7667             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
7668
7669             if (   !(   i
7670                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
7671                      &&    data.substrs[0].min_offset
7672                         == data.substrs[1].min_offset
7673                      &&    SvCUR(data.substrs[0].str)
7674                         == SvCUR(data.substrs[1].str)
7675                     )
7676                 && S_setup_longest (aTHX_ pRExC_state,
7677                                         &(r->substrs->data[i]),
7678                                         &(data.substrs[i]),
7679                                         longest_length[i]))
7680             {
7681                 r->substrs->data[i].min_offset =
7682                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
7683
7684                 r->substrs->data[i].max_offset = data.substrs[i].max_offset;
7685                 /* Don't offset infinity */
7686                 if (data.substrs[i].max_offset < SSize_t_MAX)
7687                     r->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
7688                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
7689             }
7690             else {
7691                 r->substrs->data[i].substr      = NULL;
7692                 r->substrs->data[i].utf8_substr = NULL;
7693                 longest_length[i] = 0;
7694             }
7695         }
7696
7697         LEAVE_with_name("study_chunk");
7698
7699         if (ri->regstclass
7700             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7701             ri->regstclass = NULL;
7702
7703         if ((!(r->substrs->data[0].substr || r->substrs->data[0].utf8_substr)
7704               || r->substrs->data[0].min_offset)
7705             && stclass_flag
7706             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7707             && is_ssc_worth_it(pRExC_state, data.start_class))
7708         {
7709             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7710
7711             ssc_finalize(pRExC_state, data.start_class);
7712
7713             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7714             StructCopy(data.start_class,
7715                        (regnode_ssc*)RExC_rxi->data->data[n],
7716                        regnode_ssc);
7717             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7718             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7719             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7720                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7721                       Perl_re_printf( aTHX_
7722                                     "synthetic stclass \"%s\".\n",
7723                                     SvPVX_const(sv));});
7724             data.start_class = NULL;
7725         }
7726
7727         /* A temporary algorithm prefers floated substr to fixed one of
7728          * same length to dig more info. */
7729         i = (longest_length[0] <= longest_length[1]);
7730         r->substrs->check_ix = i;
7731         r->check_end_shift  = r->substrs->data[i].end_shift;
7732         r->check_substr     = r->substrs->data[i].substr;
7733         r->check_utf8       = r->substrs->data[i].utf8_substr;
7734         r->check_offset_min = r->substrs->data[i].min_offset;
7735         r->check_offset_max = r->substrs->data[i].max_offset;
7736         if (!i && (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
7737             r->intflags |= PREGf_NOSCAN;
7738
7739         if ((r->check_substr || r->check_utf8) ) {
7740             r->extflags |= RXf_USE_INTUIT;
7741             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7742                 r->extflags |= RXf_INTUIT_TAIL;
7743         }
7744
7745         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7746         if ( (STRLEN)minlen < longest_length[1] )
7747             minlen= longest_length[1];
7748         if ( (STRLEN)minlen < longest_length[0] )
7749             minlen= longest_length[0];
7750         */
7751     }
7752     else {
7753         /* Several toplevels. Best we can is to set minlen. */
7754         SSize_t fake;
7755         regnode_ssc ch_class;
7756         SSize_t last_close = 0;
7757
7758         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7759
7760         scan = ri->program + 1;
7761         ssc_init(pRExC_state, &ch_class);
7762         data.start_class = &ch_class;
7763         data.last_closep = &last_close;
7764
7765         DEBUG_RExC_seen();
7766         /*
7767          * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
7768          * (patterns WITH top level branches)
7769          */
7770         minlen = study_chunk(pRExC_state,
7771             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7772             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7773                                                       ? SCF_TRIE_DOING_RESTUDY
7774                                                       : 0),
7775             0);
7776
7777         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7778
7779         r->check_substr = NULL;
7780         r->check_utf8 = NULL;
7781         r->substrs->data[0].substr      = NULL;
7782         r->substrs->data[0].utf8_substr = NULL;
7783         r->substrs->data[1].substr      = NULL;
7784         r->substrs->data[1].utf8_substr = NULL;
7785
7786         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7787             && is_ssc_worth_it(pRExC_state, data.start_class))
7788         {
7789             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7790
7791             ssc_finalize(pRExC_state, data.start_class);
7792
7793             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7794             StructCopy(data.start_class,
7795                        (regnode_ssc*)RExC_rxi->data->data[n],
7796                        regnode_ssc);
7797             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7798             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7799             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7800                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7801                       Perl_re_printf( aTHX_
7802                                     "synthetic stclass \"%s\".\n",
7803                                     SvPVX_const(sv));});
7804             data.start_class = NULL;
7805         }
7806     }
7807
7808     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7809         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7810         r->maxlen = REG_INFTY;
7811     }
7812     else {
7813         r->maxlen = RExC_maxlen;
7814     }
7815
7816     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7817        the "real" pattern. */
7818     DEBUG_OPTIMISE_r({
7819         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7820                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7821     });
7822     r->minlenret = minlen;
7823     if (r->minlen < minlen)
7824         r->minlen = minlen;
7825
7826     if (RExC_seen & REG_RECURSE_SEEN ) {
7827         r->intflags |= PREGf_RECURSE_SEEN;
7828         Newx(r->recurse_locinput, r->nparens + 1, char *);
7829     }
7830     if (RExC_seen & REG_GPOS_SEEN)
7831         r->intflags |= PREGf_GPOS_SEEN;
7832     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7833         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7834                                                 lookbehind */
7835     if (pRExC_state->code_blocks)
7836         r->extflags |= RXf_EVAL_SEEN;
7837     if (RExC_seen & REG_VERBARG_SEEN)
7838     {
7839         r->intflags |= PREGf_VERBARG_SEEN;
7840         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7841     }
7842     if (RExC_seen & REG_CUTGROUP_SEEN)
7843         r->intflags |= PREGf_CUTGROUP_SEEN;
7844     if (pm_flags & PMf_USE_RE_EVAL)
7845         r->intflags |= PREGf_USE_RE_EVAL;
7846     if (RExC_paren_names)
7847         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7848     else
7849         RXp_PAREN_NAMES(r) = NULL;
7850
7851     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7852      * so it can be used in pp.c */
7853     if (r->intflags & PREGf_ANCH)
7854         r->extflags |= RXf_IS_ANCHORED;
7855
7856
7857     {
7858         /* this is used to identify "special" patterns that might result
7859          * in Perl NOT calling the regex engine and instead doing the match "itself",
7860          * particularly special cases in split//. By having the regex compiler
7861          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7862          * we avoid weird issues with equivalent patterns resulting in different behavior,
7863          * AND we allow non Perl engines to get the same optimizations by the setting the
7864          * flags appropriately - Yves */
7865         regnode *first = ri->program + 1;
7866         U8 fop = OP(first);
7867         regnode *next = regnext(first);
7868         U8 nop = OP(next);
7869
7870         if (PL_regkind[fop] == NOTHING && nop == END)
7871             r->extflags |= RXf_NULL;
7872         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7873             /* when fop is SBOL first->flags will be true only when it was
7874              * produced by parsing /\A/, and not when parsing /^/. This is
7875              * very important for the split code as there we want to
7876              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7877              * See rt #122761 for more details. -- Yves */
7878             r->extflags |= RXf_START_ONLY;
7879         else if (fop == PLUS
7880                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7881                  && nop == END)
7882             r->extflags |= RXf_WHITE;
7883         else if ( r->extflags & RXf_SPLIT
7884                   && (fop == EXACT || fop == EXACTL)
7885                   && STR_LEN(first) == 1
7886                   && *(STRING(first)) == ' '
7887                   && nop == END )
7888             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7889
7890     }
7891
7892     if (RExC_contains_locale) {
7893         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7894     }
7895
7896 #ifdef DEBUGGING
7897     if (RExC_paren_names) {
7898         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7899         ri->data->data[ri->name_list_idx]
7900                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7901     } else
7902 #endif
7903     ri->name_list_idx = 0;
7904
7905     while ( RExC_recurse_count > 0 ) {
7906         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7907         /*
7908          * This data structure is set up in study_chunk() and is used
7909          * to calculate the distance between a GOSUB regopcode and
7910          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
7911          * it refers to.
7912          *
7913          * If for some reason someone writes code that optimises
7914          * away a GOSUB opcode then the assert should be changed to
7915          * an if(scan) to guard the ARG2L_SET() - Yves
7916          *
7917          */
7918         assert(scan && OP(scan) == GOSUB);
7919         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7920     }
7921
7922     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7923     /* assume we don't need to swap parens around before we match */
7924     DEBUG_TEST_r({
7925         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7926             (unsigned long)RExC_study_chunk_recursed_count);
7927     });
7928     DEBUG_DUMP_r({
7929         DEBUG_RExC_seen();
7930         Perl_re_printf( aTHX_ "Final program:\n");
7931         regdump(r);
7932     });
7933 #ifdef RE_TRACK_PATTERN_OFFSETS
7934     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7935         const STRLEN len = ri->u.offsets[0];
7936         STRLEN i;
7937         GET_RE_DEBUG_FLAGS_DECL;
7938         Perl_re_printf( aTHX_
7939                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7940         for (i = 1; i <= len; i++) {
7941             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7942                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7943                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7944             }
7945         Perl_re_printf( aTHX_  "\n");
7946     });
7947 #endif
7948
7949 #ifdef USE_ITHREADS
7950     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7951      * by setting the regexp SV to readonly-only instead. If the
7952      * pattern's been recompiled, the USEDness should remain. */
7953     if (old_re && SvREADONLY(old_re))
7954         SvREADONLY_on(rx);
7955 #endif
7956     return rx;
7957 }
7958
7959
7960 SV*
7961 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7962                     const U32 flags)
7963 {
7964     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7965
7966     PERL_UNUSED_ARG(value);
7967
7968     if (flags & RXapif_FETCH) {
7969         return reg_named_buff_fetch(rx, key, flags);
7970     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7971         Perl_croak_no_modify();
7972         return NULL;
7973     } else if (flags & RXapif_EXISTS) {
7974         return reg_named_buff_exists(rx, key, flags)
7975             ? &PL_sv_yes
7976             : &PL_sv_no;
7977     } else if (flags & RXapif_REGNAMES) {
7978         return reg_named_buff_all(rx, flags);
7979     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7980         return reg_named_buff_scalar(rx, flags);
7981     } else {
7982         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7983         return NULL;
7984     }
7985 }
7986
7987 SV*
7988 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7989                          const U32 flags)
7990 {
7991     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7992     PERL_UNUSED_ARG(lastkey);
7993
7994     if (flags & RXapif_FIRSTKEY)
7995         return reg_named_buff_firstkey(rx, flags);
7996     else if (flags & RXapif_NEXTKEY)
7997         return reg_named_buff_nextkey(rx, flags);
7998     else {
7999         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
8000                                             (int)flags);
8001         return NULL;
8002     }
8003 }
8004
8005 SV*
8006 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
8007                           const U32 flags)
8008 {
8009     SV *ret;
8010     struct regexp *const rx = ReANY(r);
8011
8012     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
8013
8014     if (rx && RXp_PAREN_NAMES(rx)) {
8015         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
8016         if (he_str) {
8017             IV i;
8018             SV* sv_dat=HeVAL(he_str);
8019             I32 *nums=(I32*)SvPVX(sv_dat);
8020             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
8021             for ( i=0; i<SvIVX(sv_dat); i++ ) {
8022                 if ((I32)(rx->nparens) >= nums[i]
8023                     && rx->offs[nums[i]].start != -1
8024                     && rx->offs[nums[i]].end != -1)
8025                 {
8026                     ret = newSVpvs("");
8027                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
8028                     if (!retarray)
8029                         return ret;
8030                 } else {
8031                     if (retarray)
8032                         ret = newSVsv(&PL_sv_undef);
8033                 }
8034                 if (retarray)
8035                     av_push(retarray, ret);
8036             }
8037             if (retarray)
8038                 return newRV_noinc(MUTABLE_SV(retarray));
8039         }
8040     }
8041     return NULL;
8042 }
8043
8044 bool
8045 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
8046                            const U32 flags)
8047 {
8048     struct regexp *const rx = ReANY(r);
8049
8050     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
8051
8052     if (rx && RXp_PAREN_NAMES(rx)) {
8053         if (flags & RXapif_ALL) {
8054             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
8055         } else {
8056             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
8057             if (sv) {
8058                 SvREFCNT_dec_NN(sv);
8059                 return TRUE;
8060             } else {
8061                 return FALSE;
8062             }
8063         }
8064     } else {
8065         return FALSE;
8066     }
8067 }
8068
8069 SV*
8070 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8071 {
8072     struct regexp *const rx = ReANY(r);
8073
8074     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8075
8076     if ( rx && RXp_PAREN_NAMES(rx) ) {
8077         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8078
8079         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8080     } else {
8081         return FALSE;
8082     }
8083 }
8084
8085 SV*
8086 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8087 {
8088     struct regexp *const rx = ReANY(r);
8089     GET_RE_DEBUG_FLAGS_DECL;
8090
8091     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8092
8093     if (rx && RXp_PAREN_NAMES(rx)) {
8094         HV *hv = RXp_PAREN_NAMES(rx);
8095         HE *temphe;
8096         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8097             IV i;
8098             IV parno = 0;
8099             SV* sv_dat = HeVAL(temphe);
8100             I32 *nums = (I32*)SvPVX(sv_dat);
8101             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8102                 if ((I32)(rx->lastparen) >= nums[i] &&
8103                     rx->offs[nums[i]].start != -1 &&
8104                     rx->offs[nums[i]].end != -1)
8105                 {
8106                     parno = nums[i];
8107                     break;
8108                 }
8109             }
8110             if (parno || flags & RXapif_ALL) {
8111                 return newSVhek(HeKEY_hek(temphe));
8112             }
8113         }
8114     }
8115     return NULL;
8116 }
8117
8118 SV*
8119 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8120 {
8121     SV *ret;
8122     AV *av;
8123     SSize_t length;
8124     struct regexp *const rx = ReANY(r);
8125
8126     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8127
8128     if (rx && RXp_PAREN_NAMES(rx)) {
8129         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8130             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8131         } else if (flags & RXapif_ONE) {
8132             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8133             av = MUTABLE_AV(SvRV(ret));
8134             length = av_tindex(av);
8135             SvREFCNT_dec_NN(ret);
8136             return newSViv(length + 1);
8137         } else {
8138             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8139                                                 (int)flags);
8140             return NULL;
8141         }
8142     }
8143     return &PL_sv_undef;
8144 }
8145
8146 SV*
8147 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8148 {
8149     struct regexp *const rx = ReANY(r);
8150     AV *av = newAV();
8151
8152     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8153
8154     if (rx && RXp_PAREN_NAMES(rx)) {
8155         HV *hv= RXp_PAREN_NAMES(rx);
8156         HE *temphe;
8157         (void)hv_iterinit(hv);
8158         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8159             IV i;
8160             IV parno = 0;
8161             SV* sv_dat = HeVAL(temphe);
8162             I32 *nums = (I32*)SvPVX(sv_dat);
8163             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8164                 if ((I32)(rx->lastparen) >= nums[i] &&
8165                     rx->offs[nums[i]].start != -1 &&
8166                     rx->offs[nums[i]].end != -1)
8167                 {
8168                     parno = nums[i];
8169                     break;
8170                 }
8171             }
8172             if (parno || flags & RXapif_ALL) {
8173                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8174             }
8175         }
8176     }
8177
8178     return newRV_noinc(MUTABLE_SV(av));
8179 }
8180
8181 void
8182 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8183                              SV * const sv)
8184 {
8185     struct regexp *const rx = ReANY(r);
8186     char *s = NULL;
8187     SSize_t i = 0;
8188     SSize_t s1, t1;
8189     I32 n = paren;
8190
8191     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8192
8193     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8194            || n == RX_BUFF_IDX_CARET_FULLMATCH
8195            || n == RX_BUFF_IDX_CARET_POSTMATCH
8196        )
8197     {
8198         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8199         if (!keepcopy) {
8200             /* on something like
8201              *    $r = qr/.../;
8202              *    /$qr/p;
8203              * the KEEPCOPY is set on the PMOP rather than the regex */
8204             if (PL_curpm && r == PM_GETRE(PL_curpm))
8205                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8206         }
8207         if (!keepcopy)
8208             goto ret_undef;
8209     }
8210
8211     if (!rx->subbeg)
8212         goto ret_undef;
8213
8214     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8215         /* no need to distinguish between them any more */
8216         n = RX_BUFF_IDX_FULLMATCH;
8217
8218     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8219         && rx->offs[0].start != -1)
8220     {
8221         /* $`, ${^PREMATCH} */
8222         i = rx->offs[0].start;
8223         s = rx->subbeg;
8224     }
8225     else
8226     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8227         && rx->offs[0].end != -1)
8228     {
8229         /* $', ${^POSTMATCH} */
8230         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8231         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8232     }
8233     else
8234     if ( 0 <= n && n <= (I32)rx->nparens &&
8235         (s1 = rx->offs[n].start) != -1 &&
8236         (t1 = rx->offs[n].end) != -1)
8237     {
8238         /* $&, ${^MATCH},  $1 ... */
8239         i = t1 - s1;
8240         s = rx->subbeg + s1 - rx->suboffset;
8241     } else {
8242         goto ret_undef;
8243     }
8244
8245     assert(s >= rx->subbeg);
8246     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8247     if (i >= 0) {
8248 #ifdef NO_TAINT_SUPPORT
8249         sv_setpvn(sv, s, i);
8250 #else
8251         const int oldtainted = TAINT_get;
8252         TAINT_NOT;
8253         sv_setpvn(sv, s, i);
8254         TAINT_set(oldtainted);
8255 #endif
8256         if (RXp_MATCH_UTF8(rx))
8257             SvUTF8_on(sv);
8258         else
8259             SvUTF8_off(sv);
8260         if (TAINTING_get) {
8261             if (RXp_MATCH_TAINTED(rx)) {
8262                 if (SvTYPE(sv) >= SVt_PVMG) {
8263                     MAGIC* const mg = SvMAGIC(sv);
8264                     MAGIC* mgt;
8265                     TAINT;
8266                     SvMAGIC_set(sv, mg->mg_moremagic);
8267                     SvTAINT(sv);
8268                     if ((mgt = SvMAGIC(sv))) {
8269                         mg->mg_moremagic = mgt;
8270                         SvMAGIC_set(sv, mg);
8271                     }
8272                 } else {
8273                     TAINT;
8274                     SvTAINT(sv);
8275                 }
8276             } else
8277                 SvTAINTED_off(sv);
8278         }
8279     } else {
8280       ret_undef:
8281         sv_set_undef(sv);
8282         return;
8283     }
8284 }
8285
8286 void
8287 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8288                                                          SV const * const value)
8289 {
8290     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8291
8292     PERL_UNUSED_ARG(rx);
8293     PERL_UNUSED_ARG(paren);
8294     PERL_UNUSED_ARG(value);
8295
8296     if (!PL_localizing)
8297         Perl_croak_no_modify();
8298 }
8299
8300 I32
8301 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8302                               const I32 paren)
8303 {
8304     struct regexp *const rx = ReANY(r);
8305     I32 i;
8306     I32 s1, t1;
8307
8308     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8309
8310     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8311         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8312         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8313     )
8314     {
8315         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8316         if (!keepcopy) {
8317             /* on something like
8318              *    $r = qr/.../;
8319              *    /$qr/p;
8320              * the KEEPCOPY is set on the PMOP rather than the regex */
8321             if (PL_curpm && r == PM_GETRE(PL_curpm))
8322                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8323         }
8324         if (!keepcopy)
8325             goto warn_undef;
8326     }
8327
8328     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8329     switch (paren) {
8330       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8331       case RX_BUFF_IDX_PREMATCH:       /* $` */
8332         if (rx->offs[0].start != -1) {
8333                         i = rx->offs[0].start;
8334                         if (i > 0) {
8335                                 s1 = 0;
8336                                 t1 = i;
8337                                 goto getlen;
8338                         }
8339             }
8340         return 0;
8341
8342       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8343       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8344             if (rx->offs[0].end != -1) {
8345                         i = rx->sublen - rx->offs[0].end;
8346                         if (i > 0) {
8347                                 s1 = rx->offs[0].end;
8348                                 t1 = rx->sublen;
8349                                 goto getlen;
8350                         }
8351             }
8352         return 0;
8353
8354       default: /* $& / ${^MATCH}, $1, $2, ... */
8355             if (paren <= (I32)rx->nparens &&
8356             (s1 = rx->offs[paren].start) != -1 &&
8357             (t1 = rx->offs[paren].end) != -1)
8358             {
8359             i = t1 - s1;
8360             goto getlen;
8361         } else {
8362           warn_undef:
8363             if (ckWARN(WARN_UNINITIALIZED))
8364                 report_uninit((const SV *)sv);
8365             return 0;
8366         }
8367     }
8368   getlen:
8369     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8370         const char * const s = rx->subbeg - rx->suboffset + s1;
8371         const U8 *ep;
8372         STRLEN el;
8373
8374         i = t1 - s1;
8375         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8376                         i = el;
8377     }
8378     return i;
8379 }
8380
8381 SV*
8382 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8383 {
8384     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8385         PERL_UNUSED_ARG(rx);
8386         if (0)
8387             return NULL;
8388         else
8389             return newSVpvs("Regexp");
8390 }
8391
8392 /* Scans the name of a named buffer from the pattern.
8393  * If flags is REG_RSN_RETURN_NULL returns null.
8394  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8395  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8396  * to the parsed name as looked up in the RExC_paren_names hash.
8397  * If there is an error throws a vFAIL().. type exception.
8398  */
8399
8400 #define REG_RSN_RETURN_NULL    0
8401 #define REG_RSN_RETURN_NAME    1
8402 #define REG_RSN_RETURN_DATA    2
8403
8404 STATIC SV*
8405 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8406 {
8407     char *name_start = RExC_parse;
8408
8409     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8410
8411     assert (RExC_parse <= RExC_end);
8412     if (RExC_parse == RExC_end) NOOP;
8413     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8414          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8415           * using do...while */
8416         if (UTF)
8417             do {
8418                 RExC_parse += UTF8SKIP(RExC_parse);
8419             } while (   RExC_parse < RExC_end
8420                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8421         else
8422             do {
8423                 RExC_parse++;
8424             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8425     } else {
8426         RExC_parse++; /* so the <- from the vFAIL is after the offending
8427                          character */
8428         vFAIL("Group name must start with a non-digit word character");
8429     }
8430     if ( flags ) {
8431         SV* sv_name
8432             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8433                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8434         if ( flags == REG_RSN_RETURN_NAME)
8435             return sv_name;
8436         else if (flags==REG_RSN_RETURN_DATA) {
8437             HE *he_str = NULL;
8438             SV *sv_dat = NULL;
8439             if ( ! sv_name )      /* should not happen*/
8440                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8441             if (RExC_paren_names)
8442                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8443             if ( he_str )
8444                 sv_dat = HeVAL(he_str);
8445             if ( ! sv_dat )
8446                 vFAIL("Reference to nonexistent named group");
8447             return sv_dat;
8448         }
8449         else {
8450             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8451                        (unsigned long) flags);
8452         }
8453         NOT_REACHED; /* NOTREACHED */
8454     }
8455     return NULL;
8456 }
8457
8458 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8459     int num;                                                    \
8460     if (RExC_lastparse!=RExC_parse) {                           \
8461         Perl_re_printf( aTHX_  "%s",                                        \
8462             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8463                 RExC_end - RExC_parse, 16,                      \
8464                 "", "",                                         \
8465                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8466                 PERL_PV_PRETTY_ELLIPSES   |                     \
8467                 PERL_PV_PRETTY_LTGT       |                     \
8468                 PERL_PV_ESCAPE_RE         |                     \
8469                 PERL_PV_PRETTY_EXACTSIZE                        \
8470             )                                                   \
8471         );                                                      \
8472     } else                                                      \
8473         Perl_re_printf( aTHX_ "%16s","");                                   \
8474                                                                 \
8475     if (SIZE_ONLY)                                              \
8476        num = RExC_size + 1;                                     \
8477     else                                                        \
8478        num=REG_NODE_NUM(RExC_emit);                             \
8479     if (RExC_lastnum!=num)                                      \
8480        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8481     else                                                        \
8482        Perl_re_printf( aTHX_ "|%4s","");                                    \
8483     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8484         (int)((depth*2)), "",                                   \
8485         (funcname)                                              \
8486     );                                                          \
8487     RExC_lastnum=num;                                           \
8488     RExC_lastparse=RExC_parse;                                  \
8489 })
8490
8491
8492
8493 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8494     DEBUG_PARSE_MSG((funcname));                            \
8495     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8496 })
8497 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8498     DEBUG_PARSE_MSG((funcname));                            \
8499     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8500 })
8501
8502 /* This section of code defines the inversion list object and its methods.  The
8503  * interfaces are highly subject to change, so as much as possible is static to
8504  * this file.  An inversion list is here implemented as a malloc'd C UV array
8505  * as an SVt_INVLIST scalar.
8506  *
8507  * An inversion list for Unicode is an array of code points, sorted by ordinal
8508  * number.  Each element gives the code point that begins a range that extends
8509  * up-to but not including the code point given by the next element.  The final
8510  * element gives the first code point of a range that extends to the platform's
8511  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8512  * ...) give ranges whose code points are all in the inversion list.  We say
8513  * that those ranges are in the set.  The odd-numbered elements give ranges
8514  * whose code points are not in the inversion list, and hence not in the set.
8515  * Thus, element [0] is the first code point in the list.  Element [1]
8516  * is the first code point beyond that not in the list; and element [2] is the
8517  * first code point beyond that that is in the list.  In other words, the first
8518  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8519  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8520  * all code points in that range are not in the inversion list.  The third
8521  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8522  * list, and so forth.  Thus every element whose index is divisible by two
8523  * gives the beginning of a range that is in the list, and every element whose
8524  * index is not divisible by two gives the beginning of a range not in the
8525  * list.  If the final element's index is divisible by two, the inversion list
8526  * extends to the platform's infinity; otherwise the highest code point in the
8527  * inversion list is the contents of that element minus 1.
8528  *
8529  * A range that contains just a single code point N will look like
8530  *  invlist[i]   == N
8531  *  invlist[i+1] == N+1
8532  *
8533  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8534  * impossible to represent, so element [i+1] is omitted.  The single element
8535  * inversion list
8536  *  invlist[0] == UV_MAX
8537  * contains just UV_MAX, but is interpreted as matching to infinity.
8538  *
8539  * Taking the complement (inverting) an inversion list is quite simple, if the
8540  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8541  * This implementation reserves an element at the beginning of each inversion
8542  * list to always contain 0; there is an additional flag in the header which
8543  * indicates if the list begins at the 0, or is offset to begin at the next
8544  * element.  This means that the inversion list can be inverted without any
8545  * copying; just flip the flag.
8546  *
8547  * More about inversion lists can be found in "Unicode Demystified"
8548  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8549  *
8550  * The inversion list data structure is currently implemented as an SV pointing
8551  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8552  * array of UV whose memory management is automatically handled by the existing
8553  * facilities for SV's.
8554  *
8555  * Some of the methods should always be private to the implementation, and some
8556  * should eventually be made public */
8557
8558 /* The header definitions are in F<invlist_inline.h> */
8559
8560 #ifndef PERL_IN_XSUB_RE
8561
8562 PERL_STATIC_INLINE UV*
8563 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8564 {
8565     /* Returns a pointer to the first element in the inversion list's array.
8566      * This is called upon initialization of an inversion list.  Where the
8567      * array begins depends on whether the list has the code point U+0000 in it
8568      * or not.  The other parameter tells it whether the code that follows this
8569      * call is about to put a 0 in the inversion list or not.  The first
8570      * element is either the element reserved for 0, if TRUE, or the element
8571      * after it, if FALSE */
8572
8573     bool* offset = get_invlist_offset_addr(invlist);
8574     UV* zero_addr = (UV *) SvPVX(invlist);
8575
8576     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8577
8578     /* Must be empty */
8579     assert(! _invlist_len(invlist));
8580
8581     *zero_addr = 0;
8582
8583     /* 1^1 = 0; 1^0 = 1 */
8584     *offset = 1 ^ will_have_0;
8585     return zero_addr + *offset;
8586 }
8587
8588 #endif
8589
8590 PERL_STATIC_INLINE void
8591 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8592 {
8593     /* Sets the current number of elements stored in the inversion list.
8594      * Updates SvCUR correspondingly */
8595     PERL_UNUSED_CONTEXT;
8596     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8597
8598     assert(SvTYPE(invlist) == SVt_INVLIST);
8599
8600     SvCUR_set(invlist,
8601               (len == 0)
8602                ? 0
8603                : TO_INTERNAL_SIZE(len + offset));
8604     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8605 }
8606
8607 #ifndef PERL_IN_XSUB_RE
8608
8609 STATIC void
8610 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8611 {
8612     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8613      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8614      * is similar to what SvSetMagicSV() would do, if it were implemented on
8615      * inversion lists, though this routine avoids a copy */
8616
8617     const UV src_len          = _invlist_len(src);
8618     const bool src_offset     = *get_invlist_offset_addr(src);
8619     const STRLEN src_byte_len = SvLEN(src);
8620     char * array              = SvPVX(src);
8621
8622     const int oldtainted = TAINT_get;
8623
8624     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8625
8626     assert(SvTYPE(src) == SVt_INVLIST);
8627     assert(SvTYPE(dest) == SVt_INVLIST);
8628     assert(! invlist_is_iterating(src));
8629     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8630
8631     /* Make sure it ends in the right place with a NUL, as our inversion list
8632      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8633      * asserts it */
8634     array[src_byte_len - 1] = '\0';
8635
8636     TAINT_NOT;      /* Otherwise it breaks */
8637     sv_usepvn_flags(dest,
8638                     (char *) array,
8639                     src_byte_len - 1,
8640
8641                     /* This flag is documented to cause a copy to be avoided */
8642                     SV_HAS_TRAILING_NUL);
8643     TAINT_set(oldtainted);
8644     SvPV_set(src, 0);
8645     SvLEN_set(src, 0);
8646     SvCUR_set(src, 0);
8647
8648     /* Finish up copying over the other fields in an inversion list */
8649     *get_invlist_offset_addr(dest) = src_offset;
8650     invlist_set_len(dest, src_len, src_offset);
8651     *get_invlist_previous_index_addr(dest) = 0;
8652     invlist_iterfinish(dest);
8653 }
8654
8655 PERL_STATIC_INLINE IV*
8656 S_get_invlist_previous_index_addr(SV* invlist)
8657 {
8658     /* Return the address of the IV that is reserved to hold the cached index
8659      * */
8660     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8661
8662     assert(SvTYPE(invlist) == SVt_INVLIST);
8663
8664     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8665 }
8666
8667 PERL_STATIC_INLINE IV
8668 S_invlist_previous_index(SV* const invlist)
8669 {
8670     /* Returns cached index of previous search */
8671
8672     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8673
8674     return *get_invlist_previous_index_addr(invlist);
8675 }
8676
8677 PERL_STATIC_INLINE void
8678 S_invlist_set_previous_index(SV* const invlist, const IV index)
8679 {
8680     /* Caches <index> for later retrieval */
8681
8682     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8683
8684     assert(index == 0 || index < (int) _invlist_len(invlist));
8685
8686     *get_invlist_previous_index_addr(invlist) = index;
8687 }
8688
8689 PERL_STATIC_INLINE void
8690 S_invlist_trim(SV* invlist)
8691 {
8692     /* Free the not currently-being-used space in an inversion list */
8693
8694     /* But don't free up the space needed for the 0 UV that is always at the
8695      * beginning of the list, nor the trailing NUL */
8696     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8697
8698     PERL_ARGS_ASSERT_INVLIST_TRIM;
8699
8700     assert(SvTYPE(invlist) == SVt_INVLIST);
8701
8702     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8703 }
8704
8705 PERL_STATIC_INLINE void
8706 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8707 {
8708     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8709
8710     assert(SvTYPE(invlist) == SVt_INVLIST);
8711
8712     invlist_set_len(invlist, 0, 0);
8713     invlist_trim(invlist);
8714 }
8715
8716 #endif /* ifndef PERL_IN_XSUB_RE */
8717
8718 PERL_STATIC_INLINE bool
8719 S_invlist_is_iterating(SV* const invlist)
8720 {
8721     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8722
8723     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8724 }
8725
8726 #ifndef PERL_IN_XSUB_RE
8727
8728 PERL_STATIC_INLINE UV
8729 S_invlist_max(SV* const invlist)
8730 {
8731     /* Returns the maximum number of elements storable in the inversion list's
8732      * array, without having to realloc() */
8733
8734     PERL_ARGS_ASSERT_INVLIST_MAX;
8735
8736     assert(SvTYPE(invlist) == SVt_INVLIST);
8737
8738     /* Assumes worst case, in which the 0 element is not counted in the
8739      * inversion list, so subtracts 1 for that */
8740     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8741            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8742            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8743 }
8744 SV*
8745 Perl__new_invlist(pTHX_ IV initial_size)
8746 {
8747
8748     /* Return a pointer to a newly constructed inversion list, with enough
8749      * space to store 'initial_size' elements.  If that number is negative, a
8750      * system default is used instead */
8751
8752     SV* new_list;
8753
8754     if (initial_size < 0) {
8755         initial_size = 10;
8756     }
8757
8758     /* Allocate the initial space */
8759     new_list = newSV_type(SVt_INVLIST);
8760
8761     /* First 1 is in case the zero element isn't in the list; second 1 is for
8762      * trailing NUL */
8763     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8764     invlist_set_len(new_list, 0, 0);
8765
8766     /* Force iterinit() to be used to get iteration to work */
8767     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8768
8769     *get_invlist_previous_index_addr(new_list) = 0;
8770
8771     return new_list;
8772 }
8773
8774 SV*
8775 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8776 {
8777     /* Return a pointer to a newly constructed inversion list, initialized to
8778      * point to <list>, which has to be in the exact correct inversion list
8779      * form, including internal fields.  Thus this is a dangerous routine that
8780      * should not be used in the wrong hands.  The passed in 'list' contains
8781      * several header fields at the beginning that are not part of the
8782      * inversion list body proper */
8783
8784     const STRLEN length = (STRLEN) list[0];
8785     const UV version_id =          list[1];
8786     const bool offset   =    cBOOL(list[2]);
8787 #define HEADER_LENGTH 3
8788     /* If any of the above changes in any way, you must change HEADER_LENGTH
8789      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8790      *      perl -E 'say int(rand 2**31-1)'
8791      */
8792 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8793                                         data structure type, so that one being
8794                                         passed in can be validated to be an
8795                                         inversion list of the correct vintage.
8796                                        */
8797
8798     SV* invlist = newSV_type(SVt_INVLIST);
8799
8800     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8801
8802     if (version_id != INVLIST_VERSION_ID) {
8803         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8804     }
8805
8806     /* The generated array passed in includes header elements that aren't part
8807      * of the list proper, so start it just after them */
8808     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8809
8810     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8811                                shouldn't touch it */
8812
8813     *(get_invlist_offset_addr(invlist)) = offset;
8814
8815     /* The 'length' passed to us is the physical number of elements in the
8816      * inversion list.  But if there is an offset the logical number is one
8817      * less than that */
8818     invlist_set_len(invlist, length  - offset, offset);
8819
8820     invlist_set_previous_index(invlist, 0);
8821
8822     /* Initialize the iteration pointer. */
8823     invlist_iterfinish(invlist);
8824
8825     SvREADONLY_on(invlist);
8826
8827     return invlist;
8828 }
8829
8830 STATIC void
8831 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8832 {
8833     /* Grow the maximum size of an inversion list */
8834
8835     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8836
8837     assert(SvTYPE(invlist) == SVt_INVLIST);
8838
8839     /* Add one to account for the zero element at the beginning which may not
8840      * be counted by the calling parameters */
8841     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8842 }
8843
8844 STATIC void
8845 S__append_range_to_invlist(pTHX_ SV* const invlist,
8846                                  const UV start, const UV end)
8847 {
8848    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8849     * the end of the inversion list.  The range must be above any existing
8850     * ones. */
8851
8852     UV* array;
8853     UV max = invlist_max(invlist);
8854     UV len = _invlist_len(invlist);
8855     bool offset;
8856
8857     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8858
8859     if (len == 0) { /* Empty lists must be initialized */
8860         offset = start != 0;
8861         array = _invlist_array_init(invlist, ! offset);
8862     }
8863     else {
8864         /* Here, the existing list is non-empty. The current max entry in the
8865          * list is generally the first value not in the set, except when the
8866          * set extends to the end of permissible values, in which case it is
8867          * the first entry in that final set, and so this call is an attempt to
8868          * append out-of-order */
8869
8870         UV final_element = len - 1;
8871         array = invlist_array(invlist);
8872         if (   array[final_element] > start
8873             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8874         {
8875             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c",
8876                      array[final_element], start,
8877                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8878         }
8879
8880         /* Here, it is a legal append.  If the new range begins 1 above the end
8881          * of the range below it, it is extending the range below it, so the
8882          * new first value not in the set is one greater than the newly
8883          * extended range.  */
8884         offset = *get_invlist_offset_addr(invlist);
8885         if (array[final_element] == start) {
8886             if (end != UV_MAX) {
8887                 array[final_element] = end + 1;
8888             }
8889             else {
8890                 /* But if the end is the maximum representable on the machine,
8891                  * assume that infinity was actually what was meant.  Just let
8892                  * the range that this would extend to have no end */
8893                 invlist_set_len(invlist, len - 1, offset);
8894             }
8895             return;
8896         }
8897     }
8898
8899     /* Here the new range doesn't extend any existing set.  Add it */
8900
8901     len += 2;   /* Includes an element each for the start and end of range */
8902
8903     /* If wll overflow the existing space, extend, which may cause the array to
8904      * be moved */
8905     if (max < len) {
8906         invlist_extend(invlist, len);
8907
8908         /* Have to set len here to avoid assert failure in invlist_array() */
8909         invlist_set_len(invlist, len, offset);
8910
8911         array = invlist_array(invlist);
8912     }
8913     else {
8914         invlist_set_len(invlist, len, offset);
8915     }
8916
8917     /* The next item on the list starts the range, the one after that is
8918      * one past the new range.  */
8919     array[len - 2] = start;
8920     if (end != UV_MAX) {
8921         array[len - 1] = end + 1;
8922     }
8923     else {
8924         /* But if the end is the maximum representable on the machine, just let
8925          * the range have no end */
8926         invlist_set_len(invlist, len - 1, offset);
8927     }
8928 }
8929
8930 SSize_t
8931 Perl__invlist_search(SV* const invlist, const UV cp)
8932 {
8933     /* Searches the inversion list for the entry that contains the input code
8934      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8935      * return value is the index into the list's array of the range that
8936      * contains <cp>, that is, 'i' such that
8937      *  array[i] <= cp < array[i+1]
8938      */
8939
8940     IV low = 0;
8941     IV mid;
8942     IV high = _invlist_len(invlist);
8943     const IV highest_element = high - 1;
8944     const UV* array;
8945
8946     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8947
8948     /* If list is empty, return failure. */
8949     if (high == 0) {
8950         return -1;
8951     }
8952
8953     /* (We can't get the array unless we know the list is non-empty) */
8954     array = invlist_array(invlist);
8955
8956     mid = invlist_previous_index(invlist);
8957     assert(mid >=0);
8958     if (mid > highest_element) {
8959         mid = highest_element;
8960     }
8961
8962     /* <mid> contains the cache of the result of the previous call to this
8963      * function (0 the first time).  See if this call is for the same result,
8964      * or if it is for mid-1.  This is under the theory that calls to this
8965      * function will often be for related code points that are near each other.
8966      * And benchmarks show that caching gives better results.  We also test
8967      * here if the code point is within the bounds of the list.  These tests
8968      * replace others that would have had to be made anyway to make sure that
8969      * the array bounds were not exceeded, and these give us extra information
8970      * at the same time */
8971     if (cp >= array[mid]) {
8972         if (cp >= array[highest_element]) {
8973             return highest_element;
8974         }
8975
8976         /* Here, array[mid] <= cp < array[highest_element].  This means that
8977          * the final element is not the answer, so can exclude it; it also
8978          * means that <mid> is not the final element, so can refer to 'mid + 1'
8979          * safely */
8980         if (cp < array[mid + 1]) {
8981             return mid;
8982         }
8983         high--;
8984         low = mid + 1;
8985     }
8986     else { /* cp < aray[mid] */
8987         if (cp < array[0]) { /* Fail if outside the array */
8988             return -1;
8989         }
8990         high = mid;
8991         if (cp >= array[mid - 1]) {
8992             goto found_entry;
8993         }
8994     }
8995
8996     /* Binary search.  What we are looking for is <i> such that
8997      *  array[i] <= cp < array[i+1]
8998      * The loop below converges on the i+1.  Note that there may not be an
8999      * (i+1)th element in the array, and things work nonetheless */
9000     while (low < high) {
9001         mid = (low + high) / 2;
9002         assert(mid <= highest_element);
9003         if (array[mid] <= cp) { /* cp >= array[mid] */
9004             low = mid + 1;
9005
9006             /* We could do this extra test to exit the loop early.
9007             if (cp < array[low]) {
9008                 return mid;
9009             }
9010             */
9011         }
9012         else { /* cp < array[mid] */
9013             high = mid;
9014         }
9015     }
9016
9017   found_entry:
9018     high--;
9019     invlist_set_previous_index(invlist, high);
9020     return high;
9021 }
9022
9023 void
9024 Perl__invlist_populate_swatch(SV* const invlist,
9025                               const UV start, const UV end, U8* swatch)
9026 {
9027     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
9028      * but is used when the swash has an inversion list.  This makes this much
9029      * faster, as it uses a binary search instead of a linear one.  This is
9030      * intimately tied to that function, and perhaps should be in utf8.c,
9031      * except it is intimately tied to inversion lists as well.  It assumes
9032      * that <swatch> is all 0's on input */
9033
9034     UV current = start;
9035     const IV len = _invlist_len(invlist);
9036     IV i;
9037     const UV * array;
9038
9039     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
9040
9041     if (len == 0) { /* Empty inversion list */
9042         return;
9043     }
9044
9045     array = invlist_array(invlist);
9046
9047     /* Find which element it is */
9048     i = _invlist_search(invlist, start);
9049
9050     /* We populate from <start> to <end> */
9051     while (current < end) {
9052         UV upper;
9053
9054         /* The inversion list gives the results for every possible code point
9055          * after the first one in the list.  Only those ranges whose index is
9056          * even are ones that the inversion list matches.  For the odd ones,
9057          * and if the initial code point is not in the list, we have to skip
9058          * forward to the next element */
9059         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
9060             i++;
9061             if (i >= len) { /* Finished if beyond the end of the array */
9062                 return;
9063             }
9064             current = array[i];
9065             if (current >= end) {   /* Finished if beyond the end of what we
9066                                        are populating */
9067                 if (LIKELY(end < UV_MAX)) {
9068                     return;
9069                 }
9070
9071                 /* We get here when the upper bound is the maximum
9072                  * representable on the machine, and we are looking for just
9073                  * that code point.  Have to special case it */
9074                 i = len;
9075                 goto join_end_of_list;
9076             }
9077         }
9078         assert(current >= start);
9079
9080         /* The current range ends one below the next one, except don't go past
9081          * <end> */
9082         i++;
9083         upper = (i < len && array[i] < end) ? array[i] : end;
9084
9085         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
9086          * for each code point in it */
9087         for (; current < upper; current++) {
9088             const STRLEN offset = (STRLEN)(current - start);
9089             swatch[offset >> 3] |= 1 << (offset & 7);
9090         }
9091
9092       join_end_of_list:
9093
9094         /* Quit if at the end of the list */
9095         if (i >= len) {
9096
9097             /* But first, have to deal with the highest possible code point on
9098              * the platform.  The previous code assumes that <end> is one
9099              * beyond where we want to populate, but that is impossible at the
9100              * platform's infinity, so have to handle it specially */
9101             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
9102             {
9103                 const STRLEN offset = (STRLEN)(end - start);
9104                 swatch[offset >> 3] |= 1 << (offset & 7);
9105             }
9106             return;
9107         }
9108
9109         /* Advance to the next range, which will be for code points not in the
9110          * inversion list */
9111         current = array[i];
9112     }
9113
9114     return;
9115 }
9116
9117 void
9118 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9119                                          const bool complement_b, SV** output)
9120 {
9121     /* Take the union of two inversion lists and point '*output' to it.  On
9122      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9123      * even 'a' or 'b').  If to an inversion list, the contents of the original
9124      * list will be replaced by the union.  The first list, 'a', may be
9125      * NULL, in which case a copy of the second list is placed in '*output'.
9126      * If 'complement_b' is TRUE, the union is taken of the complement
9127      * (inversion) of 'b' instead of b itself.
9128      *
9129      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9130      * Richard Gillam, published by Addison-Wesley, and explained at some
9131      * length there.  The preface says to incorporate its examples into your
9132      * code at your own risk.
9133      *
9134      * The algorithm is like a merge sort. */
9135
9136     const UV* array_a;    /* a's array */
9137     const UV* array_b;
9138     UV len_a;       /* length of a's array */
9139     UV len_b;
9140
9141     SV* u;                      /* the resulting union */
9142     UV* array_u;
9143     UV len_u = 0;
9144
9145     UV i_a = 0;             /* current index into a's array */
9146     UV i_b = 0;
9147     UV i_u = 0;
9148
9149     /* running count, as explained in the algorithm source book; items are
9150      * stopped accumulating and are output when the count changes to/from 0.
9151      * The count is incremented when we start a range that's in an input's set,
9152      * and decremented when we start a range that's not in a set.  So this
9153      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9154      * and hence nothing goes into the union; 1, just one of the inputs is in
9155      * its set (and its current range gets added to the union); and 2 when both
9156      * inputs are in their sets.  */
9157     UV count = 0;
9158
9159     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9160     assert(a != b);
9161     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9162
9163     len_b = _invlist_len(b);
9164     if (len_b == 0) {
9165
9166         /* Here, 'b' is empty, hence it's complement is all possible code
9167          * points.  So if the union includes the complement of 'b', it includes
9168          * everything, and we need not even look at 'a'.  It's easiest to
9169          * create a new inversion list that matches everything.  */
9170         if (complement_b) {
9171             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9172
9173             if (*output == NULL) { /* If the output didn't exist, just point it
9174                                       at the new list */
9175                 *output = everything;
9176             }
9177             else { /* Otherwise, replace its contents with the new list */
9178                 invlist_replace_list_destroys_src(*output, everything);
9179                 SvREFCNT_dec_NN(everything);
9180             }
9181
9182             return;
9183         }
9184
9185         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9186          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9187          * output will be empty */
9188
9189         if (a == NULL || _invlist_len(a) == 0) {
9190             if (*output == NULL) {
9191                 *output = _new_invlist(0);
9192             }
9193             else {
9194                 invlist_clear(*output);
9195             }
9196             return;
9197         }
9198
9199         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9200          * union.  We can just return a copy of 'a' if '*output' doesn't point
9201          * to an existing list */
9202         if (*output == NULL) {
9203             *output = invlist_clone(a);
9204             return;
9205         }
9206
9207         /* If the output is to overwrite 'a', we have a no-op, as it's
9208          * already in 'a' */
9209         if (*output == a) {
9210             return;
9211         }
9212
9213         /* Here, '*output' is to be overwritten by 'a' */
9214         u = invlist_clone(a);
9215         invlist_replace_list_destroys_src(*output, u);
9216         SvREFCNT_dec_NN(u);
9217
9218         return;
9219     }
9220
9221     /* Here 'b' is not empty.  See about 'a' */
9222
9223     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9224
9225         /* Here, 'a' is empty (and b is not).  That means the union will come
9226          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9227          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9228          * the clone */
9229
9230         SV ** dest = (*output == NULL) ? output : &u;
9231         *dest = invlist_clone(b);
9232         if (complement_b) {
9233             _invlist_invert(*dest);
9234         }
9235
9236         if (dest == &u) {
9237             invlist_replace_list_destroys_src(*output, u);
9238             SvREFCNT_dec_NN(u);
9239         }
9240
9241         return;
9242     }
9243
9244     /* Here both lists exist and are non-empty */
9245     array_a = invlist_array(a);
9246     array_b = invlist_array(b);
9247
9248     /* If are to take the union of 'a' with the complement of b, set it
9249      * up so are looking at b's complement. */
9250     if (complement_b) {
9251
9252         /* To complement, we invert: if the first element is 0, remove it.  To
9253          * do this, we just pretend the array starts one later */
9254         if (array_b[0] == 0) {
9255             array_b++;
9256             len_b--;
9257         }
9258         else {
9259
9260             /* But if the first element is not zero, we pretend the list starts
9261              * at the 0 that is always stored immediately before the array. */
9262             array_b--;
9263             len_b++;
9264         }
9265     }
9266
9267     /* Size the union for the worst case: that the sets are completely
9268      * disjoint */
9269     u = _new_invlist(len_a + len_b);
9270
9271     /* Will contain U+0000 if either component does */
9272     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9273                                       || (len_b > 0 && array_b[0] == 0));
9274
9275     /* Go through each input list item by item, stopping when have exhausted
9276      * one of them */
9277     while (i_a < len_a && i_b < len_b) {
9278         UV cp;      /* The element to potentially add to the union's array */
9279         bool cp_in_set;   /* is it in the the input list's set or not */
9280
9281         /* We need to take one or the other of the two inputs for the union.
9282          * Since we are merging two sorted lists, we take the smaller of the
9283          * next items.  In case of a tie, we take first the one that is in its
9284          * set.  If we first took the one not in its set, it would decrement
9285          * the count, possibly to 0 which would cause it to be output as ending
9286          * the range, and the next time through we would take the same number,
9287          * and output it again as beginning the next range.  By doing it the
9288          * opposite way, there is no possibility that the count will be
9289          * momentarily decremented to 0, and thus the two adjoining ranges will
9290          * be seamlessly merged.  (In a tie and both are in the set or both not
9291          * in the set, it doesn't matter which we take first.) */
9292         if (       array_a[i_a] < array_b[i_b]
9293             || (   array_a[i_a] == array_b[i_b]
9294                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9295         {
9296             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9297             cp = array_a[i_a++];
9298         }
9299         else {
9300             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9301             cp = array_b[i_b++];
9302         }
9303
9304         /* Here, have chosen which of the two inputs to look at.  Only output
9305          * if the running count changes to/from 0, which marks the
9306          * beginning/end of a range that's in the set */
9307         if (cp_in_set) {
9308             if (count == 0) {
9309                 array_u[i_u++] = cp;
9310             }
9311             count++;
9312         }
9313         else {
9314             count--;
9315             if (count == 0) {
9316                 array_u[i_u++] = cp;
9317             }
9318         }
9319     }
9320
9321
9322     /* The loop above increments the index into exactly one of the input lists
9323      * each iteration, and ends when either index gets to its list end.  That
9324      * means the other index is lower than its end, and so something is
9325      * remaining in that one.  We decrement 'count', as explained below, if
9326      * that list is in its set.  (i_a and i_b each currently index the element
9327      * beyond the one we care about.) */
9328     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9329         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9330     {
9331         count--;
9332     }
9333
9334     /* Above we decremented 'count' if the list that had unexamined elements in
9335      * it was in its set.  This has made it so that 'count' being non-zero
9336      * means there isn't anything left to output; and 'count' equal to 0 means
9337      * that what is left to output is precisely that which is left in the
9338      * non-exhausted input list.
9339      *
9340      * To see why, note first that the exhausted input obviously has nothing
9341      * left to add to the union.  If it was in its set at its end, that means
9342      * the set extends from here to the platform's infinity, and hence so does
9343      * the union and the non-exhausted set is irrelevant.  The exhausted set
9344      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9345      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9346      * 'count' remains at 1.  This is consistent with the decremented 'count'
9347      * != 0 meaning there's nothing left to add to the union.
9348      *
9349      * But if the exhausted input wasn't in its set, it contributed 0 to
9350      * 'count', and the rest of the union will be whatever the other input is.
9351      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9352      * otherwise it gets decremented to 0.  This is consistent with 'count'
9353      * == 0 meaning the remainder of the union is whatever is left in the
9354      * non-exhausted list. */
9355     if (count != 0) {
9356         len_u = i_u;
9357     }
9358     else {
9359         IV copy_count = len_a - i_a;
9360         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9361             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9362         }
9363         else { /* The non-exhausted input is b */
9364             copy_count = len_b - i_b;
9365             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9366         }
9367         len_u = i_u + copy_count;
9368     }
9369
9370     /* Set the result to the final length, which can change the pointer to
9371      * array_u, so re-find it.  (Note that it is unlikely that this will
9372      * change, as we are shrinking the space, not enlarging it) */
9373     if (len_u != _invlist_len(u)) {
9374         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9375         invlist_trim(u);
9376         array_u = invlist_array(u);
9377     }
9378
9379     if (*output == NULL) {  /* Simply return the new inversion list */
9380         *output = u;
9381     }
9382     else {
9383         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9384          * could instead free '*output', and then set it to 'u', but experience
9385          * has shown [perl #127392] that if the input is a mortal, we can get a
9386          * huge build-up of these during regex compilation before they get
9387          * freed. */
9388         invlist_replace_list_destroys_src(*output, u);
9389         SvREFCNT_dec_NN(u);
9390     }
9391
9392     return;
9393 }
9394
9395 void
9396 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9397                                                const bool complement_b, SV** i)
9398 {
9399     /* Take the intersection of two inversion lists and point '*i' to it.  On
9400      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9401      * even 'a' or 'b').  If to an inversion list, the contents of the original
9402      * list will be replaced by the intersection.  The first list, 'a', may be
9403      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9404      * TRUE, the result will be the intersection of 'a' and the complement (or
9405      * inversion) of 'b' instead of 'b' directly.
9406      *
9407      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9408      * Richard Gillam, published by Addison-Wesley, and explained at some
9409      * length there.  The preface says to incorporate its examples into your
9410      * code at your own risk.  In fact, it had bugs
9411      *
9412      * The algorithm is like a merge sort, and is essentially the same as the
9413      * union above
9414      */
9415
9416     const UV* array_a;          /* a's array */
9417     const UV* array_b;
9418     UV len_a;   /* length of a's array */
9419     UV len_b;
9420
9421     SV* r;                   /* the resulting intersection */
9422     UV* array_r;
9423     UV len_r = 0;
9424
9425     UV i_a = 0;             /* current index into a's array */
9426     UV i_b = 0;
9427     UV i_r = 0;
9428
9429     /* running count of how many of the two inputs are postitioned at ranges
9430      * that are in their sets.  As explained in the algorithm source book,
9431      * items are stopped accumulating and are output when the count changes
9432      * to/from 2.  The count is incremented when we start a range that's in an
9433      * input's set, and decremented when we start a range that's not in a set.
9434      * Only when it is 2 are we in the intersection. */
9435     UV count = 0;
9436
9437     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9438     assert(a != b);
9439     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9440
9441     /* Special case if either one is empty */
9442     len_a = (a == NULL) ? 0 : _invlist_len(a);
9443     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9444         if (len_a != 0 && complement_b) {
9445
9446             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9447              * must be empty.  Here, also we are using 'b's complement, which
9448              * hence must be every possible code point.  Thus the intersection
9449              * is simply 'a'. */
9450
9451             if (*i == a) {  /* No-op */
9452                 return;
9453             }
9454
9455             if (*i == NULL) {
9456                 *i = invlist_clone(a);
9457                 return;
9458             }
9459
9460             r = invlist_clone(a);
9461             invlist_replace_list_destroys_src(*i, r);
9462             SvREFCNT_dec_NN(r);
9463             return;
9464         }
9465
9466         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9467          * intersection must be empty */
9468         if (*i == NULL) {
9469             *i = _new_invlist(0);
9470             return;
9471         }
9472
9473         invlist_clear(*i);
9474         return;
9475     }
9476
9477     /* Here both lists exist and are non-empty */
9478     array_a = invlist_array(a);
9479     array_b = invlist_array(b);
9480
9481     /* If are to take the intersection of 'a' with the complement of b, set it
9482      * up so are looking at b's complement. */
9483     if (complement_b) {
9484
9485         /* To complement, we invert: if the first element is 0, remove it.  To
9486          * do this, we just pretend the array starts one later */
9487         if (array_b[0] == 0) {
9488             array_b++;
9489             len_b--;
9490         }
9491         else {
9492
9493             /* But if the first element is not zero, we pretend the list starts
9494              * at the 0 that is always stored immediately before the array. */
9495             array_b--;
9496             len_b++;
9497         }
9498     }
9499
9500     /* Size the intersection for the worst case: that the intersection ends up
9501      * fragmenting everything to be completely disjoint */
9502     r= _new_invlist(len_a + len_b);
9503
9504     /* Will contain U+0000 iff both components do */
9505     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9506                                      && len_b > 0 && array_b[0] == 0);
9507
9508     /* Go through each list item by item, stopping when have exhausted one of
9509      * them */
9510     while (i_a < len_a && i_b < len_b) {
9511         UV cp;      /* The element to potentially add to the intersection's
9512                        array */
9513         bool cp_in_set; /* Is it in the input list's set or not */
9514
9515         /* We need to take one or the other of the two inputs for the
9516          * intersection.  Since we are merging two sorted lists, we take the
9517          * smaller of the next items.  In case of a tie, we take first the one
9518          * that is not in its set (a difference from the union algorithm).  If
9519          * we first took the one in its set, it would increment the count,
9520          * possibly to 2 which would cause it to be output as starting a range
9521          * in the intersection, and the next time through we would take that
9522          * same number, and output it again as ending the set.  By doing the
9523          * opposite of this, there is no possibility that the count will be
9524          * momentarily incremented to 2.  (In a tie and both are in the set or
9525          * both not in the set, it doesn't matter which we take first.) */
9526         if (       array_a[i_a] < array_b[i_b]
9527             || (   array_a[i_a] == array_b[i_b]
9528                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9529         {
9530             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9531             cp = array_a[i_a++];
9532         }
9533         else {
9534             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9535             cp= array_b[i_b++];
9536         }
9537
9538         /* Here, have chosen which of the two inputs to look at.  Only output
9539          * if the running count changes to/from 2, which marks the
9540          * beginning/end of a range that's in the intersection */
9541         if (cp_in_set) {
9542             count++;
9543             if (count == 2) {
9544                 array_r[i_r++] = cp;
9545             }
9546         }
9547         else {
9548             if (count == 2) {
9549                 array_r[i_r++] = cp;
9550             }
9551             count--;
9552         }
9553
9554     }
9555
9556     /* The loop above increments the index into exactly one of the input lists
9557      * each iteration, and ends when either index gets to its list end.  That
9558      * means the other index is lower than its end, and so something is
9559      * remaining in that one.  We increment 'count', as explained below, if the
9560      * exhausted list was in its set.  (i_a and i_b each currently index the
9561      * element beyond the one we care about.) */
9562     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9563         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9564     {
9565         count++;
9566     }
9567
9568     /* Above we incremented 'count' if the exhausted list was in its set.  This
9569      * has made it so that 'count' being below 2 means there is nothing left to
9570      * output; otheriwse what's left to add to the intersection is precisely
9571      * that which is left in the non-exhausted input list.
9572      *
9573      * To see why, note first that the exhausted input obviously has nothing
9574      * left to affect the intersection.  If it was in its set at its end, that
9575      * means the set extends from here to the platform's infinity, and hence
9576      * anything in the non-exhausted's list will be in the intersection, and
9577      * anything not in it won't be.  Hence, the rest of the intersection is
9578      * precisely what's in the non-exhausted list  The exhausted set also
9579      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9580      * it means 'count' is now at least 2.  This is consistent with the
9581      * incremented 'count' being >= 2 means to add the non-exhausted list to
9582      * the intersection.
9583      *
9584      * But if the exhausted input wasn't in its set, it contributed 0 to
9585      * 'count', and the intersection can't include anything further; the
9586      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9587      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9588      * further to add to the intersection. */
9589     if (count < 2) { /* Nothing left to put in the intersection. */
9590         len_r = i_r;
9591     }
9592     else { /* copy the non-exhausted list, unchanged. */
9593         IV copy_count = len_a - i_a;
9594         if (copy_count > 0) {   /* a is the one with stuff left */
9595             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9596         }
9597         else {  /* b is the one with stuff left */
9598             copy_count = len_b - i_b;
9599             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9600         }
9601         len_r = i_r + copy_count;
9602     }
9603
9604     /* Set the result to the final length, which can change the pointer to
9605      * array_r, so re-find it.  (Note that it is unlikely that this will
9606      * change, as we are shrinking the space, not enlarging it) */
9607     if (len_r != _invlist_len(r)) {
9608         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9609         invlist_trim(r);
9610         array_r = invlist_array(r);
9611     }
9612
9613     if (*i == NULL) { /* Simply return the calculated intersection */
9614         *i = r;
9615     }
9616     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9617               instead free '*i', and then set it to 'r', but experience has
9618               shown [perl #127392] that if the input is a mortal, we can get a
9619               huge build-up of these during regex compilation before they get
9620               freed. */
9621         if (len_r) {
9622             invlist_replace_list_destroys_src(*i, r);
9623         }
9624         else {
9625             invlist_clear(*i);
9626         }
9627         SvREFCNT_dec_NN(r);
9628     }
9629
9630     return;
9631 }
9632
9633 SV*
9634 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9635 {
9636     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9637      * set.  A pointer to the inversion list is returned.  This may actually be
9638      * a new list, in which case the passed in one has been destroyed.  The
9639      * passed-in inversion list can be NULL, in which case a new one is created
9640      * with just the one range in it.  The new list is not necessarily
9641      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9642      * result of this function.  The gain would not be large, and in many
9643      * cases, this is called multiple times on a single inversion list, so
9644      * anything freed may almost immediately be needed again.
9645      *
9646      * This used to mostly call the 'union' routine, but that is much more
9647      * heavyweight than really needed for a single range addition */
9648
9649     UV* array;              /* The array implementing the inversion list */
9650     UV len;                 /* How many elements in 'array' */
9651     SSize_t i_s;            /* index into the invlist array where 'start'
9652                                should go */
9653     SSize_t i_e = 0;        /* And the index where 'end' should go */
9654     UV cur_highest;         /* The highest code point in the inversion list
9655                                upon entry to this function */
9656
9657     /* This range becomes the whole inversion list if none already existed */
9658     if (invlist == NULL) {
9659         invlist = _new_invlist(2);
9660         _append_range_to_invlist(invlist, start, end);
9661         return invlist;
9662     }
9663
9664     /* Likewise, if the inversion list is currently empty */
9665     len = _invlist_len(invlist);
9666     if (len == 0) {
9667         _append_range_to_invlist(invlist, start, end);
9668         return invlist;
9669     }
9670
9671     /* Starting here, we have to know the internals of the list */
9672     array = invlist_array(invlist);
9673
9674     /* If the new range ends higher than the current highest ... */
9675     cur_highest = invlist_highest(invlist);
9676     if (end > cur_highest) {
9677
9678         /* If the whole range is higher, we can just append it */
9679         if (start > cur_highest) {
9680             _append_range_to_invlist(invlist, start, end);
9681             return invlist;
9682         }
9683
9684         /* Otherwise, add the portion that is higher ... */
9685         _append_range_to_invlist(invlist, cur_highest + 1, end);
9686
9687         /* ... and continue on below to handle the rest.  As a result of the
9688          * above append, we know that the index of the end of the range is the
9689          * final even numbered one of the array.  Recall that the final element
9690          * always starts a range that extends to infinity.  If that range is in
9691          * the set (meaning the set goes from here to infinity), it will be an
9692          * even index, but if it isn't in the set, it's odd, and the final
9693          * range in the set is one less, which is even. */
9694         if (end == UV_MAX) {
9695             i_e = len;
9696         }
9697         else {
9698             i_e = len - 2;
9699         }
9700     }
9701
9702     /* We have dealt with appending, now see about prepending.  If the new
9703      * range starts lower than the current lowest ... */
9704     if (start < array[0]) {
9705
9706         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9707          * Let the union code handle it, rather than having to know the
9708          * trickiness in two code places.  */
9709         if (UNLIKELY(start == 0)) {
9710             SV* range_invlist;
9711
9712             range_invlist = _new_invlist(2);
9713             _append_range_to_invlist(range_invlist, start, end);
9714
9715             _invlist_union(invlist, range_invlist, &invlist);
9716
9717             SvREFCNT_dec_NN(range_invlist);
9718
9719             return invlist;
9720         }
9721
9722         /* If the whole new range comes before the first entry, and doesn't
9723          * extend it, we have to insert it as an additional range */
9724         if (end < array[0] - 1) {
9725             i_s = i_e = -1;
9726             goto splice_in_new_range;
9727         }
9728
9729         /* Here the new range adjoins the existing first range, extending it
9730          * downwards. */
9731         array[0] = start;
9732
9733         /* And continue on below to handle the rest.  We know that the index of
9734          * the beginning of the range is the first one of the array */
9735         i_s = 0;
9736     }
9737     else { /* Not prepending any part of the new range to the existing list.
9738             * Find where in the list it should go.  This finds i_s, such that:
9739             *     invlist[i_s] <= start < array[i_s+1]
9740             */
9741         i_s = _invlist_search(invlist, start);
9742     }
9743
9744     /* At this point, any extending before the beginning of the inversion list
9745      * and/or after the end has been done.  This has made it so that, in the
9746      * code below, each endpoint of the new range is either in a range that is
9747      * in the set, or is in a gap between two ranges that are.  This means we
9748      * don't have to worry about exceeding the array bounds.
9749      *
9750      * Find where in the list the new range ends (but we can skip this if we
9751      * have already determined what it is, or if it will be the same as i_s,
9752      * which we already have computed) */
9753     if (i_e == 0) {
9754         i_e = (start == end)
9755               ? i_s
9756               : _invlist_search(invlist, end);
9757     }
9758
9759     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9760      * is a range that goes to infinity there is no element at invlist[i_e+1],
9761      * so only the first relation holds. */
9762
9763     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9764
9765         /* Here, the ranges on either side of the beginning of the new range
9766          * are in the set, and this range starts in the gap between them.
9767          *
9768          * The new range extends the range above it downwards if the new range
9769          * ends at or above that range's start */
9770         const bool extends_the_range_above = (   end == UV_MAX
9771                                               || end + 1 >= array[i_s+1]);
9772
9773         /* The new range extends the range below it upwards if it begins just
9774          * after where that range ends */
9775         if (start == array[i_s]) {
9776
9777             /* If the new range fills the entire gap between the other ranges,
9778              * they will get merged together.  Other ranges may also get
9779              * merged, depending on how many of them the new range spans.  In
9780              * the general case, we do the merge later, just once, after we
9781              * figure out how many to merge.  But in the case where the new
9782              * range exactly spans just this one gap (possibly extending into
9783              * the one above), we do the merge here, and an early exit.  This
9784              * is done here to avoid having to special case later. */
9785             if (i_e - i_s <= 1) {
9786
9787                 /* If i_e - i_s == 1, it means that the new range terminates
9788                  * within the range above, and hence 'extends_the_range_above'
9789                  * must be true.  (If the range above it extends to infinity,
9790                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9791                  * will be 0, so no harm done.) */
9792                 if (extends_the_range_above) {
9793                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9794                     invlist_set_len(invlist,
9795                                     len - 2,
9796                                     *(get_invlist_offset_addr(invlist)));
9797                     return invlist;
9798                 }
9799
9800                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9801                  * to the same range, and below we are about to decrement i_s
9802                  * */
9803                 i_e--;
9804             }
9805
9806             /* Here, the new range is adjacent to the one below.  (It may also
9807              * span beyond the range above, but that will get resolved later.)
9808              * Extend the range below to include this one. */
9809             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9810             i_s--;
9811             start = array[i_s];
9812         }
9813         else if (extends_the_range_above) {
9814
9815             /* Here the new range only extends the range above it, but not the
9816              * one below.  It merges with the one above.  Again, we keep i_e
9817              * and i_s in sync if they point to the same range */
9818             if (i_e == i_s) {
9819                 i_e++;
9820             }
9821             i_s++;
9822             array[i_s] = start;
9823         }
9824     }
9825
9826     /* Here, we've dealt with the new range start extending any adjoining
9827      * existing ranges.
9828      *
9829      * If the new range extends to infinity, it is now the final one,
9830      * regardless of what was there before */
9831     if (UNLIKELY(end == UV_MAX)) {
9832         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9833         return invlist;
9834     }
9835
9836     /* If i_e started as == i_s, it has also been dealt with,
9837      * and been updated to the new i_s, which will fail the following if */
9838     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9839
9840         /* Here, the ranges on either side of the end of the new range are in
9841          * the set, and this range ends in the gap between them.
9842          *
9843          * If this range is adjacent to (hence extends) the range above it, it
9844          * becomes part of that range; likewise if it extends the range below,
9845          * it becomes part of that range */
9846         if (end + 1 == array[i_e+1]) {
9847             i_e++;
9848             array[i_e] = start;
9849         }
9850         else if (start <= array[i_e]) {
9851             array[i_e] = end + 1;
9852             i_e--;
9853         }
9854     }
9855
9856     if (i_s == i_e) {
9857
9858         /* If the range fits entirely in an existing range (as possibly already
9859          * extended above), it doesn't add anything new */
9860         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9861             return invlist;
9862         }
9863
9864         /* Here, no part of the range is in the list.  Must add it.  It will
9865          * occupy 2 more slots */
9866       splice_in_new_range:
9867
9868         invlist_extend(invlist, len + 2);
9869         array = invlist_array(invlist);
9870         /* Move the rest of the array down two slots. Don't include any
9871          * trailing NUL */
9872         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9873
9874         /* Do the actual splice */
9875         array[i_e+1] = start;
9876         array[i_e+2] = end + 1;
9877         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9878         return invlist;
9879     }
9880
9881     /* Here the new range crossed the boundaries of a pre-existing range.  The
9882      * code above has adjusted things so that both ends are in ranges that are
9883      * in the set.  This means everything in between must also be in the set.
9884      * Just squash things together */
9885     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9886     invlist_set_len(invlist,
9887                     len - i_e + i_s,
9888                     *(get_invlist_offset_addr(invlist)));
9889
9890     return invlist;
9891 }
9892
9893 SV*
9894 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9895                                  UV** other_elements_ptr)
9896 {
9897     /* Create and return an inversion list whose contents are to be populated
9898      * by the caller.  The caller gives the number of elements (in 'size') and
9899      * the very first element ('element0').  This function will set
9900      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9901      * are to be placed.
9902      *
9903      * Obviously there is some trust involved that the caller will properly
9904      * fill in the other elements of the array.
9905      *
9906      * (The first element needs to be passed in, as the underlying code does
9907      * things differently depending on whether it is zero or non-zero) */
9908
9909     SV* invlist = _new_invlist(size);
9910     bool offset;
9911
9912     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9913
9914     invlist = add_cp_to_invlist(invlist, element0);
9915     offset = *get_invlist_offset_addr(invlist);
9916
9917     invlist_set_len(invlist, size, offset);
9918     *other_elements_ptr = invlist_array(invlist) + 1;
9919     return invlist;
9920 }
9921
9922 #endif
9923
9924 PERL_STATIC_INLINE SV*
9925 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9926     return _add_range_to_invlist(invlist, cp, cp);
9927 }
9928
9929 #ifndef PERL_IN_XSUB_RE
9930 void
9931 Perl__invlist_invert(pTHX_ SV* const invlist)
9932 {
9933     /* Complement the input inversion list.  This adds a 0 if the list didn't
9934      * have a zero; removes it otherwise.  As described above, the data
9935      * structure is set up so that this is very efficient */
9936
9937     PERL_ARGS_ASSERT__INVLIST_INVERT;
9938
9939     assert(! invlist_is_iterating(invlist));
9940
9941     /* The inverse of matching nothing is matching everything */
9942     if (_invlist_len(invlist) == 0) {
9943         _append_range_to_invlist(invlist, 0, UV_MAX);
9944         return;
9945     }
9946
9947     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9948 }
9949
9950 #endif
9951
9952 PERL_STATIC_INLINE SV*
9953 S_invlist_clone(pTHX_ SV* const invlist)
9954 {
9955
9956     /* Return a new inversion list that is a copy of the input one, which is
9957      * unchanged.  The new list will not be mortal even if the old one was. */
9958
9959     /* Need to allocate extra space to accommodate Perl's addition of a
9960      * trailing NUL to SvPV's, since it thinks they are always strings */
9961     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9962     STRLEN physical_length = SvCUR(invlist);
9963     bool offset = *(get_invlist_offset_addr(invlist));
9964
9965     PERL_ARGS_ASSERT_INVLIST_CLONE;
9966
9967     *(get_invlist_offset_addr(new_invlist)) = offset;
9968     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9969     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9970
9971     return new_invlist;
9972 }
9973
9974 PERL_STATIC_INLINE STRLEN*
9975 S_get_invlist_iter_addr(SV* invlist)
9976 {
9977     /* Return the address of the UV that contains the current iteration
9978      * position */
9979
9980     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9981
9982     assert(SvTYPE(invlist) == SVt_INVLIST);
9983
9984     return &(((XINVLIST*) SvANY(invlist))->iterator);
9985 }
9986
9987 PERL_STATIC_INLINE void
9988 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9989 {
9990     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9991
9992     *get_invlist_iter_addr(invlist) = 0;
9993 }
9994
9995 PERL_STATIC_INLINE void
9996 S_invlist_iterfinish(SV* invlist)
9997 {
9998     /* Terminate iterator for invlist.  This is to catch development errors.
9999      * Any iteration that is interrupted before completed should call this
10000      * function.  Functions that add code points anywhere else but to the end
10001      * of an inversion list assert that they are not in the middle of an
10002      * iteration.  If they were, the addition would make the iteration
10003      * problematical: if the iteration hadn't reached the place where things
10004      * were being added, it would be ok */
10005
10006     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
10007
10008     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
10009 }
10010
10011 STATIC bool
10012 S_invlist_iternext(SV* invlist, UV* start, UV* end)
10013 {
10014     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
10015      * This call sets in <*start> and <*end>, the next range in <invlist>.
10016      * Returns <TRUE> if successful and the next call will return the next
10017      * range; <FALSE> if was already at the end of the list.  If the latter,
10018      * <*start> and <*end> are unchanged, and the next call to this function
10019      * will start over at the beginning of the list */
10020
10021     STRLEN* pos = get_invlist_iter_addr(invlist);
10022     UV len = _invlist_len(invlist);
10023     UV *array;
10024
10025     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
10026
10027     if (*pos >= len) {
10028         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
10029         return FALSE;
10030     }
10031
10032     array = invlist_array(invlist);
10033
10034     *start = array[(*pos)++];
10035
10036     if (*pos >= len) {
10037         *end = UV_MAX;
10038     }
10039     else {
10040         *end = array[(*pos)++] - 1;
10041     }
10042
10043     return TRUE;
10044 }
10045
10046 PERL_STATIC_INLINE UV
10047 S_invlist_highest(SV* const invlist)
10048 {
10049     /* Returns the highest code point that matches an inversion list.  This API
10050      * has an ambiguity, as it returns 0 under either the highest is actually
10051      * 0, or if the list is empty.  If this distinction matters to you, check
10052      * for emptiness before calling this function */
10053
10054     UV len = _invlist_len(invlist);
10055     UV *array;
10056
10057     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
10058
10059     if (len == 0) {
10060         return 0;
10061     }
10062
10063     array = invlist_array(invlist);
10064
10065     /* The last element in the array in the inversion list always starts a
10066      * range that goes to infinity.  That range may be for code points that are
10067      * matched in the inversion list, or it may be for ones that aren't
10068      * matched.  In the latter case, the highest code point in the set is one
10069      * less than the beginning of this range; otherwise it is the final element
10070      * of this range: infinity */
10071     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
10072            ? UV_MAX
10073            : array[len - 1] - 1;
10074 }
10075
10076 STATIC SV *
10077 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10078 {
10079     /* Get the contents of an inversion list into a string SV so that they can
10080      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10081      * traditionally done for debug tracing; otherwise it uses a format
10082      * suitable for just copying to the output, with blanks between ranges and
10083      * a dash between range components */
10084
10085     UV start, end;
10086     SV* output;
10087     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10088     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10089
10090     if (traditional_style) {
10091         output = newSVpvs("\n");
10092     }
10093     else {
10094         output = newSVpvs("");
10095     }
10096
10097     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10098
10099     assert(! invlist_is_iterating(invlist));
10100
10101     invlist_iterinit(invlist);
10102     while (invlist_iternext(invlist, &start, &end)) {
10103         if (end == UV_MAX) {
10104             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
10105                                           start, intra_range_delimiter,
10106                                                  inter_range_delimiter);
10107         }
10108         else if (end != start) {
10109             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10110                                           start,
10111                                                    intra_range_delimiter,
10112                                                   end, inter_range_delimiter);
10113         }
10114         else {
10115             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10116                                           start, inter_range_delimiter);
10117         }
10118     }
10119
10120     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10121         SvCUR_set(output, SvCUR(output) - 1);
10122     }
10123
10124     return output;
10125 }
10126
10127 #ifndef PERL_IN_XSUB_RE
10128 void
10129 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10130                          const char * const indent, SV* const invlist)
10131 {
10132     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10133      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10134      * the string 'indent'.  The output looks like this:
10135          [0] 0x000A .. 0x000D
10136          [2] 0x0085
10137          [4] 0x2028 .. 0x2029
10138          [6] 0x3104 .. INFINITY
10139      * This means that the first range of code points matched by the list are
10140      * 0xA through 0xD; the second range contains only the single code point
10141      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10142      * are used to define each range (except if the final range extends to
10143      * infinity, only a single element is needed).  The array index of the
10144      * first element for the corresponding range is given in brackets. */
10145
10146     UV start, end;
10147     STRLEN count = 0;
10148
10149     PERL_ARGS_ASSERT__INVLIST_DUMP;
10150
10151     if (invlist_is_iterating(invlist)) {
10152         Perl_dump_indent(aTHX_ level, file,
10153              "%sCan't dump inversion list because is in middle of iterating\n",
10154              indent);
10155         return;
10156     }
10157
10158     invlist_iterinit(invlist);
10159     while (invlist_iternext(invlist, &start, &end)) {
10160         if (end == UV_MAX) {
10161             Perl_dump_indent(aTHX_ level, file,
10162                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10163                                    indent, (UV)count, start);
10164         }
10165         else if (end != start) {
10166             Perl_dump_indent(aTHX_ level, file,
10167                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10168                                 indent, (UV)count, start,         end);
10169         }
10170         else {
10171             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10172                                             indent, (UV)count, start);
10173         }
10174         count += 2;
10175     }
10176 }
10177
10178 #endif
10179
10180 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10181 bool
10182 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10183 {
10184     /* Return a boolean as to if the two passed in inversion lists are
10185      * identical.  The final argument, if TRUE, says to take the complement of
10186      * the second inversion list before doing the comparison */
10187
10188     const UV* array_a = invlist_array(a);
10189     const UV* array_b = invlist_array(b);
10190     UV len_a = _invlist_len(a);
10191     UV len_b = _invlist_len(b);
10192
10193     PERL_ARGS_ASSERT__INVLISTEQ;
10194
10195     /* If are to compare 'a' with the complement of b, set it
10196      * up so are looking at b's complement. */
10197     if (complement_b) {
10198
10199         /* The complement of nothing is everything, so <a> would have to have
10200          * just one element, starting at zero (ending at infinity) */
10201         if (len_b == 0) {
10202             return (len_a == 1 && array_a[0] == 0);
10203         }
10204         else if (array_b[0] == 0) {
10205
10206             /* Otherwise, to complement, we invert.  Here, the first element is
10207              * 0, just remove it.  To do this, we just pretend the array starts
10208              * one later */
10209
10210             array_b++;
10211             len_b--;
10212         }
10213         else {
10214
10215             /* But if the first element is not zero, we pretend the list starts
10216              * at the 0 that is always stored immediately before the array. */
10217             array_b--;
10218             len_b++;
10219         }
10220     }
10221
10222     return    len_a == len_b
10223            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10224
10225 }
10226 #endif
10227
10228 /*
10229  * As best we can, determine the characters that can match the start of
10230  * the given EXACTF-ish node.
10231  *
10232  * Returns the invlist as a new SV*; it is the caller's responsibility to
10233  * call SvREFCNT_dec() when done with it.
10234  */
10235 STATIC SV*
10236 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10237 {
10238     const U8 * s = (U8*)STRING(node);
10239     SSize_t bytelen = STR_LEN(node);
10240     UV uc;
10241     /* Start out big enough for 2 separate code points */
10242     SV* invlist = _new_invlist(4);
10243
10244     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10245
10246     if (! UTF) {
10247         uc = *s;
10248
10249         /* We punt and assume can match anything if the node begins
10250          * with a multi-character fold.  Things are complicated.  For
10251          * example, /ffi/i could match any of:
10252          *  "\N{LATIN SMALL LIGATURE FFI}"
10253          *  "\N{LATIN SMALL LIGATURE FF}I"
10254          *  "F\N{LATIN SMALL LIGATURE FI}"
10255          *  plus several other things; and making sure we have all the
10256          *  possibilities is hard. */
10257         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10258             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10259         }
10260         else {
10261             /* Any Latin1 range character can potentially match any
10262              * other depending on the locale */
10263             if (OP(node) == EXACTFL) {
10264                 _invlist_union(invlist, PL_Latin1, &invlist);
10265             }
10266             else {
10267                 /* But otherwise, it matches at least itself.  We can
10268                  * quickly tell if it has a distinct fold, and if so,
10269                  * it matches that as well */
10270                 invlist = add_cp_to_invlist(invlist, uc);
10271                 if (IS_IN_SOME_FOLD_L1(uc))
10272                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10273             }
10274
10275             /* Some characters match above-Latin1 ones under /i.  This
10276              * is true of EXACTFL ones when the locale is UTF-8 */
10277             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10278                 && (! isASCII(uc) || (OP(node) != EXACTFAA
10279                                     && OP(node) != EXACTFAA_NO_TRIE)))
10280             {
10281                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10282             }
10283         }
10284     }
10285     else {  /* Pattern is UTF-8 */
10286         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10287         const U8* e = s + bytelen;
10288         IV fc;
10289
10290         fc = uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10291
10292         /* The only code points that aren't folded in a UTF EXACTFish
10293          * node are are the problematic ones in EXACTFL nodes */
10294         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10295             /* We need to check for the possibility that this EXACTFL
10296              * node begins with a multi-char fold.  Therefore we fold
10297              * the first few characters of it so that we can make that
10298              * check */
10299             U8 *d = folded;
10300             int i;
10301
10302             fc = -1;
10303             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10304                 if (isASCII(*s)) {
10305                     *(d++) = (U8) toFOLD(*s);
10306                     if (fc < 0) {       /* Save the first fold */
10307                         fc = *(d-1);
10308                     }
10309                     s++;
10310                 }
10311                 else {
10312                     STRLEN len;
10313                     UV fold = toFOLD_utf8_safe(s, e, d, &len);
10314                     if (fc < 0) {       /* Save the first fold */
10315                         fc = fold;
10316                     }
10317                     d += len;
10318                     s += UTF8SKIP(s);
10319                 }
10320             }
10321
10322             /* And set up so the code below that looks in this folded
10323              * buffer instead of the node's string */
10324             e = d;
10325             s = folded;
10326         }
10327
10328         /* When we reach here 's' points to the fold of the first
10329          * character(s) of the node; and 'e' points to far enough along
10330          * the folded string to be just past any possible multi-char
10331          * fold.
10332          *
10333          * Unlike the non-UTF-8 case, the macro for determining if a
10334          * string is a multi-char fold requires all the characters to
10335          * already be folded.  This is because of all the complications
10336          * if not.  Note that they are folded anyway, except in EXACTFL
10337          * nodes.  Like the non-UTF case above, we punt if the node
10338          * begins with a multi-char fold  */
10339
10340         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10341             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10342         }
10343         else {  /* Single char fold */
10344             unsigned int k;
10345             unsigned int first_folds_to;
10346             const unsigned int * remaining_folds_to_list;
10347             Size_t folds_to_count;
10348
10349             /* It matches itself */
10350             invlist = add_cp_to_invlist(invlist, fc);
10351
10352             /* ... plus all the things that fold to it, which are found in
10353              * PL_utf8_foldclosures */
10354             folds_to_count = _inverse_folds(fc, &first_folds_to,
10355                                                 &remaining_folds_to_list);
10356             for (k = 0; k < folds_to_count; k++) {
10357                 UV c = (k == 0) ? first_folds_to : remaining_folds_to_list[k-1];
10358
10359                 /* /aa doesn't allow folds between ASCII and non- */
10360                 if (   (OP(node) == EXACTFAA || OP(node) == EXACTFAA_NO_TRIE)
10361                     && isASCII(c) != isASCII(fc))
10362                 {
10363                     continue;
10364                 }
10365
10366                 invlist = add_cp_to_invlist(invlist, c);
10367             }
10368         }
10369     }
10370
10371     return invlist;
10372 }
10373
10374 #undef HEADER_LENGTH
10375 #undef TO_INTERNAL_SIZE
10376 #undef FROM_INTERNAL_SIZE
10377 #undef INVLIST_VERSION_ID
10378
10379 /* End of inversion list object */
10380
10381 STATIC void
10382 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10383 {
10384     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10385      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10386      * should point to the first flag; it is updated on output to point to the
10387      * final ')' or ':'.  There needs to be at least one flag, or this will
10388      * abort */
10389
10390     /* for (?g), (?gc), and (?o) warnings; warning
10391        about (?c) will warn about (?g) -- japhy    */
10392
10393 #define WASTED_O  0x01
10394 #define WASTED_G  0x02
10395 #define WASTED_C  0x04
10396 #define WASTED_GC (WASTED_G|WASTED_C)
10397     I32 wastedflags = 0x00;
10398     U32 posflags = 0, negflags = 0;
10399     U32 *flagsp = &posflags;
10400     char has_charset_modifier = '\0';
10401     regex_charset cs;
10402     bool has_use_defaults = FALSE;
10403     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10404     int x_mod_count = 0;
10405
10406     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10407
10408     /* '^' as an initial flag sets certain defaults */
10409     if (UCHARAT(RExC_parse) == '^') {
10410         RExC_parse++;
10411         has_use_defaults = TRUE;
10412         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10413         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10414                                         ? REGEX_UNICODE_CHARSET
10415                                         : REGEX_DEPENDS_CHARSET);
10416     }
10417
10418     cs = get_regex_charset(RExC_flags);
10419     if (cs == REGEX_DEPENDS_CHARSET
10420         && (RExC_utf8 || RExC_uni_semantics))
10421     {
10422         cs = REGEX_UNICODE_CHARSET;
10423     }
10424
10425     while (RExC_parse < RExC_end) {
10426         /* && strchr("iogcmsx", *RExC_parse) */
10427         /* (?g), (?gc) and (?o) are useless here
10428            and must be globally applied -- japhy */
10429         switch (*RExC_parse) {
10430
10431             /* Code for the imsxn flags */
10432             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10433
10434             case LOCALE_PAT_MOD:
10435                 if (has_charset_modifier) {
10436                     goto excess_modifier;
10437                 }
10438                 else if (flagsp == &negflags) {
10439                     goto neg_modifier;
10440                 }
10441                 cs = REGEX_LOCALE_CHARSET;
10442                 has_charset_modifier = LOCALE_PAT_MOD;
10443                 break;
10444             case UNICODE_PAT_MOD:
10445                 if (has_charset_modifier) {
10446                     goto excess_modifier;
10447                 }
10448                 else if (flagsp == &negflags) {
10449                     goto neg_modifier;
10450                 }
10451                 cs = REGEX_UNICODE_CHARSET;
10452                 has_charset_modifier = UNICODE_PAT_MOD;
10453                 break;
10454             case ASCII_RESTRICT_PAT_MOD:
10455                 if (flagsp == &negflags) {
10456                     goto neg_modifier;
10457                 }
10458                 if (has_charset_modifier) {
10459                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10460                         goto excess_modifier;
10461                     }
10462                     /* Doubled modifier implies more restricted */
10463                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10464                 }
10465                 else {
10466                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10467                 }
10468                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10469                 break;
10470             case DEPENDS_PAT_MOD:
10471                 if (has_use_defaults) {
10472                     goto fail_modifiers;
10473                 }
10474                 else if (flagsp == &negflags) {
10475                     goto neg_modifier;
10476                 }
10477                 else if (has_charset_modifier) {
10478                     goto excess_modifier;
10479                 }
10480
10481                 /* The dual charset means unicode semantics if the
10482                  * pattern (or target, not known until runtime) are
10483                  * utf8, or something in the pattern indicates unicode
10484                  * semantics */
10485                 cs = (RExC_utf8 || RExC_uni_semantics)
10486                      ? REGEX_UNICODE_CHARSET
10487                      : REGEX_DEPENDS_CHARSET;
10488                 has_charset_modifier = DEPENDS_PAT_MOD;
10489                 break;
10490               excess_modifier:
10491                 RExC_parse++;
10492                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10493                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10494                 }
10495                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10496                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10497                                         *(RExC_parse - 1));
10498                 }
10499                 else {
10500                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10501                 }
10502                 NOT_REACHED; /*NOTREACHED*/
10503               neg_modifier:
10504                 RExC_parse++;
10505                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10506                                     *(RExC_parse - 1));
10507                 NOT_REACHED; /*NOTREACHED*/
10508             case ONCE_PAT_MOD: /* 'o' */
10509             case GLOBAL_PAT_MOD: /* 'g' */
10510                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10511                     const I32 wflagbit = *RExC_parse == 'o'
10512                                          ? WASTED_O
10513                                          : WASTED_G;
10514                     if (! (wastedflags & wflagbit) ) {
10515                         wastedflags |= wflagbit;
10516                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10517                         vWARN5(
10518                             RExC_parse + 1,
10519                             "Useless (%s%c) - %suse /%c modifier",
10520                             flagsp == &negflags ? "?-" : "?",
10521                             *RExC_parse,
10522                             flagsp == &negflags ? "don't " : "",
10523                             *RExC_parse
10524                         );
10525                     }
10526                 }
10527                 break;
10528
10529             case CONTINUE_PAT_MOD: /* 'c' */
10530                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10531                     if (! (wastedflags & WASTED_C) ) {
10532                         wastedflags |= WASTED_GC;
10533                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10534                         vWARN3(
10535                             RExC_parse + 1,
10536                             "Useless (%sc) - %suse /gc modifier",
10537                             flagsp == &negflags ? "?-" : "?",
10538                             flagsp == &negflags ? "don't " : ""
10539                         );
10540                     }
10541                 }
10542                 break;
10543             case KEEPCOPY_PAT_MOD: /* 'p' */
10544                 if (flagsp == &negflags) {
10545                     if (PASS2)
10546                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10547                 } else {
10548                     *flagsp |= RXf_PMf_KEEPCOPY;
10549                 }
10550                 break;
10551             case '-':
10552                 /* A flag is a default iff it is following a minus, so
10553                  * if there is a minus, it means will be trying to
10554                  * re-specify a default which is an error */
10555                 if (has_use_defaults || flagsp == &negflags) {
10556                     goto fail_modifiers;
10557                 }
10558                 flagsp = &negflags;
10559                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10560                 x_mod_count = 0;
10561                 break;
10562             case ':':
10563             case ')':
10564
10565                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10566                     negflags |= RXf_PMf_EXTENDED_MORE;
10567                 }
10568                 RExC_flags |= posflags;
10569
10570                 if (negflags & RXf_PMf_EXTENDED) {
10571                     negflags |= RXf_PMf_EXTENDED_MORE;
10572                 }
10573                 RExC_flags &= ~negflags;
10574                 set_regex_charset(&RExC_flags, cs);
10575
10576                 return;
10577             default:
10578               fail_modifiers:
10579                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10580                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10581                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10582                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10583                 NOT_REACHED; /*NOTREACHED*/
10584         }
10585
10586         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10587     }
10588
10589     vFAIL("Sequence (?... not terminated");
10590 }
10591
10592 /*
10593  - reg - regular expression, i.e. main body or parenthesized thing
10594  *
10595  * Caller must absorb opening parenthesis.
10596  *
10597  * Combining parenthesis handling with the base level of regular expression
10598  * is a trifle forced, but the need to tie the tails of the branches to what
10599  * follows makes it hard to avoid.
10600  */
10601 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10602 #ifdef DEBUGGING
10603 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10604 #else
10605 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10606 #endif
10607
10608 PERL_STATIC_INLINE regnode *
10609 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10610                              I32 *flagp,
10611                              char * parse_start,
10612                              char ch
10613                       )
10614 {
10615     regnode *ret;
10616     char* name_start = RExC_parse;
10617     U32 num = 0;
10618     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10619                                             ? REG_RSN_RETURN_NULL
10620                                             : REG_RSN_RETURN_DATA);
10621     GET_RE_DEBUG_FLAGS_DECL;
10622
10623     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10624
10625     if (RExC_parse == name_start || *RExC_parse != ch) {
10626         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10627         vFAIL2("Sequence %.3s... not terminated",parse_start);
10628     }
10629
10630     if (!SIZE_ONLY) {
10631         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10632         RExC_rxi->data->data[num]=(void*)sv_dat;
10633         SvREFCNT_inc_simple_void(sv_dat);
10634     }
10635     RExC_sawback = 1;
10636     ret = reganode(pRExC_state,
10637                    ((! FOLD)
10638                      ? NREF
10639                      : (ASCII_FOLD_RESTRICTED)
10640                        ? NREFFA
10641                        : (AT_LEAST_UNI_SEMANTICS)
10642                          ? NREFFU
10643                          : (LOC)
10644                            ? NREFFL
10645                            : NREFF),
10646                     num);
10647     *flagp |= HASWIDTH;
10648
10649     Set_Node_Offset(ret, parse_start+1);
10650     Set_Node_Cur_Length(ret, parse_start);
10651
10652     nextchar(pRExC_state);
10653     return ret;
10654 }
10655
10656 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10657    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10658    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10659    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10660    NULL, which cannot happen.  */
10661 STATIC regnode *
10662 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10663     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10664      * 2 is like 1, but indicates that nextchar() has been called to advance
10665      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10666      * this flag alerts us to the need to check for that */
10667 {
10668     regnode *ret = NULL;    /* Will be the head of the group. */
10669     regnode *br;
10670     regnode *lastbr;
10671     regnode *ender = NULL;
10672     I32 parno = 0;
10673     I32 flags;
10674     U32 oregflags = RExC_flags;
10675     bool have_branch = 0;
10676     bool is_open = 0;
10677     I32 freeze_paren = 0;
10678     I32 after_freeze = 0;
10679     I32 num; /* numeric backreferences */
10680
10681     char * parse_start = RExC_parse; /* MJD */
10682     char * const oregcomp_parse = RExC_parse;
10683
10684     GET_RE_DEBUG_FLAGS_DECL;
10685
10686     PERL_ARGS_ASSERT_REG;
10687     DEBUG_PARSE("reg ");
10688
10689     *flagp = 0;                         /* Tentatively. */
10690
10691     /* Having this true makes it feasible to have a lot fewer tests for the
10692      * parse pointer being in scope.  For example, we can write
10693      *      while(isFOO(*RExC_parse)) RExC_parse++;
10694      * instead of
10695      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10696      */
10697     assert(*RExC_end == '\0');
10698
10699     /* Make an OPEN node, if parenthesized. */
10700     if (paren) {
10701
10702         /* Under /x, space and comments can be gobbled up between the '(' and
10703          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10704          * intervening space, as the sequence is a token, and a token should be
10705          * indivisible */
10706         bool has_intervening_patws = (paren == 2)
10707                                   && *(RExC_parse - 1) != '(';
10708
10709         if (RExC_parse >= RExC_end) {
10710             vFAIL("Unmatched (");
10711         }
10712
10713         if (paren == 'r') {     /* Atomic script run */
10714             paren = '>';
10715             goto parse_rest;
10716         }
10717         else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
10718             char *start_verb = RExC_parse + 1;
10719             STRLEN verb_len;
10720             char *start_arg = NULL;
10721             unsigned char op = 0;
10722             int arg_required = 0;
10723             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10724             bool has_upper = FALSE;
10725
10726             if (has_intervening_patws) {
10727                 RExC_parse++;   /* past the '*' */
10728
10729                 /* For strict backwards compatibility, don't change the message
10730                  * now that we also have lowercase operands */
10731                 if (isUPPER(*RExC_parse)) {
10732                     vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10733                 }
10734                 else {
10735                     vFAIL("In '(*...)', the '(' and '*' must be adjacent");
10736                 }
10737             }
10738             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10739                 if ( *RExC_parse == ':' ) {
10740                     start_arg = RExC_parse + 1;
10741                     break;
10742                 }
10743                 else if (! UTF) {
10744                     if (isUPPER(*RExC_parse)) {
10745                         has_upper = TRUE;
10746                     }
10747                     RExC_parse++;
10748                 }
10749                 else {
10750                     RExC_parse += UTF8SKIP(RExC_parse);
10751                 }
10752             }
10753             verb_len = RExC_parse - start_verb;
10754             if ( start_arg ) {
10755                 if (RExC_parse >= RExC_end) {
10756                     goto unterminated_verb_pattern;
10757                 }
10758
10759                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10760                 while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
10761                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10762                 }
10763                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
10764                   unterminated_verb_pattern:
10765                     if (has_upper) {
10766                         vFAIL("Unterminated verb pattern argument");
10767                     }
10768                     else {
10769                         vFAIL("Unterminated '(*...' argument");
10770                     }
10771                 }
10772             } else {
10773                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
10774                     if (has_upper) {
10775                         vFAIL("Unterminated verb pattern");
10776                     }
10777                     else {
10778                         vFAIL("Unterminated '(*...' construct");
10779                     }
10780                 }
10781             }
10782
10783             /* Here, we know that RExC_parse < RExC_end */
10784
10785             switch ( *start_verb ) {
10786             case 'A':  /* (*ACCEPT) */
10787                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10788                     op = ACCEPT;
10789                     internal_argval = RExC_nestroot;
10790                 }
10791                 break;
10792             case 'C':  /* (*COMMIT) */
10793                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10794                     op = COMMIT;
10795                 break;
10796             case 'F':  /* (*FAIL) */
10797                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10798                     op = OPFAIL;
10799                 }
10800                 break;
10801             case ':':  /* (*:NAME) */
10802             case 'M':  /* (*MARK:NAME) */
10803                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10804                     op = MARKPOINT;
10805                     arg_required = 1;
10806                 }
10807                 break;
10808             case 'P':  /* (*PRUNE) */
10809                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10810                     op = PRUNE;
10811                 break;
10812             case 'S':   /* (*SKIP) */
10813                 if ( memEQs(start_verb,verb_len,"SKIP") )
10814                     op = SKIP;
10815                 break;
10816             case 'T':  /* (*THEN) */
10817                 /* [19:06] <TimToady> :: is then */
10818                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10819                     op = CUTGROUP;
10820                     RExC_seen |= REG_CUTGROUP_SEEN;
10821                 }
10822                 break;
10823             case 'a':
10824                 if (   memEQs(start_verb, verb_len, "asr")
10825                     || memEQs(start_verb, verb_len, "atomic_script_run"))
10826                 {
10827                     paren = 'r';        /* Mnemonic: recursed run */
10828                     goto script_run;
10829                 }
10830                 else if (memEQs(start_verb, verb_len, "atomic")) {
10831                     paren = 't';    /* AtOMIC */
10832                     goto alpha_assertions;
10833                 }
10834                 break;
10835             case 'p':
10836                 if (   memEQs(start_verb, verb_len, "plb")
10837                     || memEQs(start_verb, verb_len, "positive_lookbehind"))
10838                 {
10839                     paren = 'b';
10840                     goto lookbehind_alpha_assertions;
10841                 }
10842                 else if (   memEQs(start_verb, verb_len, "pla")
10843                          || memEQs(start_verb, verb_len, "positive_lookahead"))
10844                 {
10845                     paren = 'a';
10846                     goto alpha_assertions;
10847                 }
10848                 break;
10849             case 'n':
10850                 if (   memEQs(start_verb, verb_len, "nlb")
10851                     || memEQs(start_verb, verb_len, "negative_lookbehind"))
10852                 {
10853                     paren = 'B';
10854                     goto lookbehind_alpha_assertions;
10855                 }
10856                 else if (   memEQs(start_verb, verb_len, "nla")
10857                          || memEQs(start_verb, verb_len, "negative_lookahead"))
10858                 {
10859                     paren = 'A';
10860                     goto alpha_assertions;
10861                 }
10862                 break;
10863             case 's':
10864                 if (   memEQs(start_verb, verb_len, "sr")
10865                     || memEQs(start_verb, verb_len, "script_run"))
10866                 {
10867                     regnode * atomic;
10868
10869                     paren = 's';
10870
10871                    script_run:
10872
10873                     /* This indicates Unicode rules. */
10874                     REQUIRE_UNI_RULES(flagp, NULL);
10875
10876                     if (! start_arg) {
10877                         goto no_colon;
10878                     }
10879
10880                     RExC_parse = start_arg;
10881
10882                     if (RExC_in_script_run) {
10883
10884                         /*  Nested script runs are treated as no-ops, because
10885                          *  if the nested one fails, the outer one must as
10886                          *  well.  It could fail sooner, and avoid (??{} with
10887                          *  side effects, but that is explicitly documented as
10888                          *  undefined behavior. */
10889
10890                         ret = NULL;
10891
10892                         if (paren == 's') {
10893                             paren = ':';
10894                             goto parse_rest;
10895                         }
10896
10897                         /* But, the atomic part of a nested atomic script run
10898                          * isn't a no-op, but can be treated just like a '(?>'
10899                          * */
10900                         paren = '>';
10901                         goto parse_rest;
10902                     }
10903
10904                     /* By doing this here, we avoid extra warnings for nested
10905                      * script runs */
10906                     if (PASS2) {
10907                         Perl_ck_warner_d(aTHX_
10908                             packWARN(WARN_EXPERIMENTAL__SCRIPT_RUN),
10909                             "The script_run feature is experimental"
10910                             REPORT_LOCATION, REPORT_LOCATION_ARGS(RExC_parse));
10911
10912                     }
10913
10914                     if (paren == 's') {
10915                         /* Here, we're starting a new regular script run */
10916                         ret = reg_node(pRExC_state, SROPEN);
10917                         RExC_in_script_run = 1;
10918                         is_open = 1;
10919                         goto parse_rest;
10920                     }
10921
10922                     /* Here, we are starting an atomic script run.  This is
10923                      * handled by recursing to deal with the atomic portion
10924                      * separately, enclosed in SROPEN ... SRCLOSE nodes */
10925
10926                     ret = reg_node(pRExC_state, SROPEN);
10927
10928                     RExC_in_script_run = 1;
10929
10930                     atomic = reg(pRExC_state, 'r', &flags, depth);
10931                     if (flags & (RESTART_PASS1|NEED_UTF8)) {
10932                         *flagp = flags & (RESTART_PASS1|NEED_UTF8);
10933                         return NULL;
10934                     }
10935
10936                     REGTAIL(pRExC_state, ret, atomic);
10937
10938                     REGTAIL(pRExC_state, atomic,
10939                            reg_node(pRExC_state, SRCLOSE));
10940
10941                     RExC_in_script_run = 0;
10942                     return ret;
10943                 }
10944
10945                 break;
10946
10947             lookbehind_alpha_assertions:
10948                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10949                 RExC_in_lookbehind++;
10950                 /*FALLTHROUGH*/
10951
10952             alpha_assertions:
10953
10954                 if (PASS2) {
10955                     Perl_ck_warner_d(aTHX_
10956                         packWARN(WARN_EXPERIMENTAL__ALPHA_ASSERTIONS),
10957                         "The alpha_assertions feature is experimental"
10958                         REPORT_LOCATION, REPORT_LOCATION_ARGS(RExC_parse));
10959                 }
10960
10961                 RExC_seen_zerolen++;
10962
10963                 if (! start_arg) {
10964                     goto no_colon;
10965                 }
10966
10967                 /* An empty negative lookahead assertion simply is failure */
10968                 if (paren == 'A' && RExC_parse == start_arg) {
10969                     ret=reganode(pRExC_state, OPFAIL, 0);
10970                     nextchar(pRExC_state);
10971                     return ret;
10972                 }
10973
10974                 RExC_parse = start_arg;
10975                 goto parse_rest;
10976
10977               no_colon:
10978                 vFAIL2utf8f(
10979                 "'(*%" UTF8f "' requires a terminating ':'",
10980                 UTF8fARG(UTF, verb_len, start_verb));
10981                 NOT_REACHED; /*NOTREACHED*/
10982
10983             } /* End of switch */
10984             if ( ! op ) {
10985                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10986                 if (has_upper || verb_len == 0) {
10987                     vFAIL2utf8f(
10988                     "Unknown verb pattern '%" UTF8f "'",
10989                     UTF8fARG(UTF, verb_len, start_verb));
10990                 }
10991                 else {
10992                     vFAIL2utf8f(
10993                     "Unknown '(*...)' construct '%" UTF8f "'",
10994                     UTF8fARG(UTF, verb_len, start_verb));
10995                 }
10996             }
10997             if ( RExC_parse == start_arg ) {
10998                 start_arg = NULL;
10999             }
11000             if ( arg_required && !start_arg ) {
11001                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
11002                     verb_len, start_verb);
11003             }
11004             if (internal_argval == -1) {
11005                 ret = reganode(pRExC_state, op, 0);
11006             } else {
11007                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
11008             }
11009             RExC_seen |= REG_VERBARG_SEEN;
11010             if ( ! SIZE_ONLY ) {
11011                 if (start_arg) {
11012                     SV *sv = newSVpvn( start_arg,
11013                                        RExC_parse - start_arg);
11014                     ARG(ret) = add_data( pRExC_state,
11015                                          STR_WITH_LEN("S"));
11016                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
11017                     ret->flags = 1;
11018                 } else {
11019                     ret->flags = 0;
11020                 }
11021                 if ( internal_argval != -1 )
11022                     ARG2L_SET(ret, internal_argval);
11023             }
11024             nextchar(pRExC_state);
11025             return ret;
11026         }
11027         else if (*RExC_parse == '?') { /* (?...) */
11028             bool is_logical = 0;
11029             const char * const seqstart = RExC_parse;
11030             const char * endptr;
11031             if (has_intervening_patws) {
11032                 RExC_parse++;
11033                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
11034             }
11035
11036             RExC_parse++;           /* past the '?' */
11037             paren = *RExC_parse;    /* might be a trailing NUL, if not
11038                                        well-formed */
11039             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11040             if (RExC_parse > RExC_end) {
11041                 paren = '\0';
11042             }
11043             ret = NULL;                 /* For look-ahead/behind. */
11044             switch (paren) {
11045
11046             case 'P':   /* (?P...) variants for those used to PCRE/Python */
11047                 paren = *RExC_parse;
11048                 if ( paren == '<') {    /* (?P<...>) named capture */
11049                     RExC_parse++;
11050                     if (RExC_parse >= RExC_end) {
11051                         vFAIL("Sequence (?P<... not terminated");
11052                     }
11053                     goto named_capture;
11054                 }
11055                 else if (paren == '>') {   /* (?P>name) named recursion */
11056                     RExC_parse++;
11057                     if (RExC_parse >= RExC_end) {
11058                         vFAIL("Sequence (?P>... not terminated");
11059                     }
11060                     goto named_recursion;
11061                 }
11062                 else if (paren == '=') {   /* (?P=...)  named backref */
11063                     RExC_parse++;
11064                     return handle_named_backref(pRExC_state, flagp,
11065                                                 parse_start, ')');
11066                 }
11067                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
11068                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11069                 vFAIL3("Sequence (%.*s...) not recognized",
11070                                 RExC_parse-seqstart, seqstart);
11071                 NOT_REACHED; /*NOTREACHED*/
11072             case '<':           /* (?<...) */
11073                 if (*RExC_parse == '!')
11074                     paren = ',';
11075                 else if (*RExC_parse != '=')
11076               named_capture:
11077                 {               /* (?<...>) */
11078                     char *name_start;
11079                     SV *svname;
11080                     paren= '>';
11081                 /* FALLTHROUGH */
11082             case '\'':          /* (?'...') */
11083                     name_start = RExC_parse;
11084                     svname = reg_scan_name(pRExC_state,
11085                         SIZE_ONLY    /* reverse test from the others */
11086                         ? REG_RSN_RETURN_NAME
11087                         : REG_RSN_RETURN_NULL);
11088                     if (   RExC_parse == name_start
11089                         || RExC_parse >= RExC_end
11090                         || *RExC_parse != paren)
11091                     {
11092                         vFAIL2("Sequence (?%c... not terminated",
11093                             paren=='>' ? '<' : paren);
11094                     }
11095                     if (SIZE_ONLY) {
11096                         HE *he_str;
11097                         SV *sv_dat = NULL;
11098                         if (!svname) /* shouldn't happen */
11099                             Perl_croak(aTHX_
11100                                 "panic: reg_scan_name returned NULL");
11101                         if (!RExC_paren_names) {
11102                             RExC_paren_names= newHV();
11103                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
11104 #ifdef DEBUGGING
11105                             RExC_paren_name_list= newAV();
11106                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
11107 #endif
11108                         }
11109                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
11110                         if ( he_str )
11111                             sv_dat = HeVAL(he_str);
11112                         if ( ! sv_dat ) {
11113                             /* croak baby croak */
11114                             Perl_croak(aTHX_
11115                                 "panic: paren_name hash element allocation failed");
11116                         } else if ( SvPOK(sv_dat) ) {
11117                             /* (?|...) can mean we have dupes so scan to check
11118                                its already been stored. Maybe a flag indicating
11119                                we are inside such a construct would be useful,
11120                                but the arrays are likely to be quite small, so
11121                                for now we punt -- dmq */
11122                             IV count = SvIV(sv_dat);
11123                             I32 *pv = (I32*)SvPVX(sv_dat);
11124                             IV i;
11125                             for ( i = 0 ; i < count ; i++ ) {
11126                                 if ( pv[i] == RExC_npar ) {
11127                                     count = 0;
11128                                     break;
11129                                 }
11130                             }
11131                             if ( count ) {
11132                                 pv = (I32*)SvGROW(sv_dat,
11133                                                 SvCUR(sv_dat) + sizeof(I32)+1);
11134                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
11135                                 pv[count] = RExC_npar;
11136                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
11137                             }
11138                         } else {
11139                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
11140                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
11141                                                                 sizeof(I32));
11142                             SvIOK_on(sv_dat);
11143                             SvIV_set(sv_dat, 1);
11144                         }
11145 #ifdef DEBUGGING
11146                         /* Yes this does cause a memory leak in debugging Perls
11147                          * */
11148                         if (!av_store(RExC_paren_name_list,
11149                                       RExC_npar, SvREFCNT_inc(svname)))
11150                             SvREFCNT_dec_NN(svname);
11151 #endif
11152
11153                         /*sv_dump(sv_dat);*/
11154                     }
11155                     nextchar(pRExC_state);
11156                     paren = 1;
11157                     goto capturing_parens;
11158                 }
11159
11160                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11161                 RExC_in_lookbehind++;
11162                 RExC_parse++;
11163                 if (RExC_parse >= RExC_end) {
11164                     vFAIL("Sequence (?... not terminated");
11165                 }
11166
11167                 /* FALLTHROUGH */
11168             case '=':           /* (?=...) */
11169                 RExC_seen_zerolen++;
11170                 break;
11171             case '!':           /* (?!...) */
11172                 RExC_seen_zerolen++;
11173                 /* check if we're really just a "FAIL" assertion */
11174                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11175                                         FALSE /* Don't force to /x */ );
11176                 if (*RExC_parse == ')') {
11177                     ret=reganode(pRExC_state, OPFAIL, 0);
11178                     nextchar(pRExC_state);
11179                     return ret;
11180                 }
11181                 break;
11182             case '|':           /* (?|...) */
11183                 /* branch reset, behave like a (?:...) except that
11184                    buffers in alternations share the same numbers */
11185                 paren = ':';
11186                 after_freeze = freeze_paren = RExC_npar;
11187                 break;
11188             case ':':           /* (?:...) */
11189             case '>':           /* (?>...) */
11190                 break;
11191             case '$':           /* (?$...) */
11192             case '@':           /* (?@...) */
11193                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
11194                 break;
11195             case '0' :           /* (?0) */
11196             case 'R' :           /* (?R) */
11197                 if (RExC_parse == RExC_end || *RExC_parse != ')')
11198                     FAIL("Sequence (?R) not terminated");
11199                 num = 0;
11200                 RExC_seen |= REG_RECURSE_SEEN;
11201                 *flagp |= POSTPONED;
11202                 goto gen_recurse_regop;
11203                 /*notreached*/
11204             /* named and numeric backreferences */
11205             case '&':            /* (?&NAME) */
11206                 parse_start = RExC_parse - 1;
11207               named_recursion:
11208                 {
11209                     SV *sv_dat = reg_scan_name(pRExC_state,
11210                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11211                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
11212                 }
11213                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
11214                     vFAIL("Sequence (?&... not terminated");
11215                 goto gen_recurse_regop;
11216                 /* NOTREACHED */
11217             case '+':
11218                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
11219                     RExC_parse++;
11220                     vFAIL("Illegal pattern");
11221                 }
11222                 goto parse_recursion;
11223                 /* NOTREACHED*/
11224             case '-': /* (?-1) */
11225                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
11226                     RExC_parse--; /* rewind to let it be handled later */
11227                     goto parse_flags;
11228                 }
11229                 /* FALLTHROUGH */
11230             case '1': case '2': case '3': case '4': /* (?1) */
11231             case '5': case '6': case '7': case '8': case '9':
11232                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
11233               parse_recursion:
11234                 {
11235                     bool is_neg = FALSE;
11236                     UV unum;
11237                     parse_start = RExC_parse - 1; /* MJD */
11238                     if (*RExC_parse == '-') {
11239                         RExC_parse++;
11240                         is_neg = TRUE;
11241                     }
11242                     if (grok_atoUV(RExC_parse, &unum, &endptr)
11243                         && unum <= I32_MAX
11244                     ) {
11245                         num = (I32)unum;
11246                         RExC_parse = (char*)endptr;
11247                     } else
11248                         num = I32_MAX;
11249                     if (is_neg) {
11250                         /* Some limit for num? */
11251                         num = -num;
11252                     }
11253                 }
11254                 if (*RExC_parse!=')')
11255                     vFAIL("Expecting close bracket");
11256
11257               gen_recurse_regop:
11258                 if ( paren == '-' ) {
11259                     /*
11260                     Diagram of capture buffer numbering.
11261                     Top line is the normal capture buffer numbers
11262                     Bottom line is the negative indexing as from
11263                     the X (the (?-2))
11264
11265                     +   1 2    3 4 5 X          6 7
11266                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11267                     -   5 4    3 2 1 X          x x
11268
11269                     */
11270                     num = RExC_npar + num;
11271                     if (num < 1)  {
11272                         RExC_parse++;
11273                         vFAIL("Reference to nonexistent group");
11274                     }
11275                 } else if ( paren == '+' ) {
11276                     num = RExC_npar + num - 1;
11277                 }
11278                 /* We keep track how many GOSUB items we have produced.
11279                    To start off the ARG2L() of the GOSUB holds its "id",
11280                    which is used later in conjunction with RExC_recurse
11281                    to calculate the offset we need to jump for the GOSUB,
11282                    which it will store in the final representation.
11283                    We have to defer the actual calculation until much later
11284                    as the regop may move.
11285                  */
11286
11287                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11288                 if (!SIZE_ONLY) {
11289                     if (num > (I32)RExC_rx->nparens) {
11290                         RExC_parse++;
11291                         vFAIL("Reference to nonexistent group");
11292                     }
11293                     RExC_recurse_count++;
11294                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11295                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11296                               22, "|    |", (int)(depth * 2 + 1), "",
11297                               (UV)ARG(ret), (IV)ARG2L(ret)));
11298                 }
11299                 RExC_seen |= REG_RECURSE_SEEN;
11300
11301                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
11302                 Set_Node_Offset(ret, parse_start); /* MJD */
11303
11304                 *flagp |= POSTPONED;
11305                 assert(*RExC_parse == ')');
11306                 nextchar(pRExC_state);
11307                 return ret;
11308
11309             /* NOTREACHED */
11310
11311             case '?':           /* (??...) */
11312                 is_logical = 1;
11313                 if (*RExC_parse != '{') {
11314                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
11315                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11316                     vFAIL2utf8f(
11317                         "Sequence (%" UTF8f "...) not recognized",
11318                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11319                     NOT_REACHED; /*NOTREACHED*/
11320                 }
11321                 *flagp |= POSTPONED;
11322                 paren = '{';
11323                 RExC_parse++;
11324                 /* FALLTHROUGH */
11325             case '{':           /* (?{...}) */
11326             {
11327                 U32 n = 0;
11328                 struct reg_code_block *cb;
11329
11330                 RExC_seen_zerolen++;
11331
11332                 if (   !pRExC_state->code_blocks
11333                     || pRExC_state->code_index
11334                                         >= pRExC_state->code_blocks->count
11335                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11336                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11337                             - RExC_start)
11338                 ) {
11339                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11340                         FAIL("panic: Sequence (?{...}): no code block found\n");
11341                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11342                 }
11343                 /* this is a pre-compiled code block (?{...}) */
11344                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11345                 RExC_parse = RExC_start + cb->end;
11346                 if (!SIZE_ONLY) {
11347                     OP *o = cb->block;
11348                     if (cb->src_regex) {
11349                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11350                         RExC_rxi->data->data[n] =
11351                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11352                         RExC_rxi->data->data[n+1] = (void*)o;
11353                     }
11354                     else {
11355                         n = add_data(pRExC_state,
11356                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11357                         RExC_rxi->data->data[n] = (void*)o;
11358                     }
11359                 }
11360                 pRExC_state->code_index++;
11361                 nextchar(pRExC_state);
11362
11363                 if (is_logical) {
11364                     regnode *eval;
11365                     ret = reg_node(pRExC_state, LOGICAL);
11366
11367                     eval = reg2Lanode(pRExC_state, EVAL,
11368                                        n,
11369
11370                                        /* for later propagation into (??{})
11371                                         * return value */
11372                                        RExC_flags & RXf_PMf_COMPILETIME
11373                                       );
11374                     if (!SIZE_ONLY) {
11375                         ret->flags = 2;
11376                     }
11377                     REGTAIL(pRExC_state, ret, eval);
11378                     /* deal with the length of this later - MJD */
11379                     return ret;
11380                 }
11381                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11382                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11383                 Set_Node_Offset(ret, parse_start);
11384                 return ret;
11385             }
11386             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11387             {
11388                 int is_define= 0;
11389                 const int DEFINE_len = sizeof("DEFINE") - 1;
11390                 if (    RExC_parse < RExC_end - 1
11391                     && (   (       RExC_parse[0] == '?'        /* (?(?...)) */
11392                             && (   RExC_parse[1] == '='
11393                                 || RExC_parse[1] == '!'
11394                                 || RExC_parse[1] == '<'
11395                                 || RExC_parse[1] == '{'))
11396                         || (       RExC_parse[0] == '*'        /* (?(*...)) */
11397                             && (   memBEGINs(RExC_parse + 1,
11398                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11399                                          "pla:")
11400                                 || memBEGINs(RExC_parse + 1,
11401                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11402                                          "plb:")
11403                                 || memBEGINs(RExC_parse + 1,
11404                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11405                                          "nla:")
11406                                 || memBEGINs(RExC_parse + 1,
11407                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11408                                          "nlb:")
11409                                 || memBEGINs(RExC_parse + 1,
11410                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11411                                          "positive_lookahead:")
11412                                 || memBEGINs(RExC_parse + 1,
11413                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11414                                          "positive_lookbehind:")
11415                                 || memBEGINs(RExC_parse + 1,
11416                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11417                                          "negative_lookahead:")
11418                                 || memBEGINs(RExC_parse + 1,
11419                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11420                                          "negative_lookbehind:"))))
11421                 ) { /* Lookahead or eval. */
11422                     I32 flag;
11423                     regnode *tail;
11424
11425                     ret = reg_node(pRExC_state, LOGICAL);
11426                     if (!SIZE_ONLY)
11427                         ret->flags = 1;
11428
11429                     tail = reg(pRExC_state, 1, &flag, depth+1);
11430                     RETURN_NULL_ON_RESTART(flag,flagp);
11431                     REGTAIL(pRExC_state, ret, tail);
11432                     goto insert_if;
11433                 }
11434                 else if (   RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11435                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11436                 {
11437                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11438                     char *name_start= RExC_parse++;
11439                     U32 num = 0;
11440                     SV *sv_dat=reg_scan_name(pRExC_state,
11441                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11442                     if (   RExC_parse == name_start
11443                         || RExC_parse >= RExC_end
11444                         || *RExC_parse != ch)
11445                     {
11446                         vFAIL2("Sequence (?(%c... not terminated",
11447                             (ch == '>' ? '<' : ch));
11448                     }
11449                     RExC_parse++;
11450                     if (!SIZE_ONLY) {
11451                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11452                         RExC_rxi->data->data[num]=(void*)sv_dat;
11453                         SvREFCNT_inc_simple_void(sv_dat);
11454                     }
11455                     ret = reganode(pRExC_state,NGROUPP,num);
11456                     goto insert_if_check_paren;
11457                 }
11458                 else if (memBEGINs(RExC_parse,
11459                                    (STRLEN) (RExC_end - RExC_parse),
11460                                    "DEFINE"))
11461                 {
11462                     ret = reganode(pRExC_state,DEFINEP,0);
11463                     RExC_parse += DEFINE_len;
11464                     is_define = 1;
11465                     goto insert_if_check_paren;
11466                 }
11467                 else if (RExC_parse[0] == 'R') {
11468                     RExC_parse++;
11469                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11470                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11471                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11472                      */
11473                     parno = 0;
11474                     if (RExC_parse[0] == '0') {
11475                         parno = 1;
11476                         RExC_parse++;
11477                     }
11478                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11479                         UV uv;
11480                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11481                             && uv <= I32_MAX
11482                         ) {
11483                             parno = (I32)uv + 1;
11484                             RExC_parse = (char*)endptr;
11485                         }
11486                         /* else "Switch condition not recognized" below */
11487                     } else if (RExC_parse[0] == '&') {
11488                         SV *sv_dat;
11489                         RExC_parse++;
11490                         sv_dat = reg_scan_name(pRExC_state,
11491                             SIZE_ONLY
11492                             ? REG_RSN_RETURN_NULL
11493                             : REG_RSN_RETURN_DATA);
11494
11495                         /* we should only have a false sv_dat when
11496                          * SIZE_ONLY is true, and we always have false
11497                          * sv_dat when SIZE_ONLY is true.
11498                          * reg_scan_name() will VFAIL() if the name is
11499                          * unknown when SIZE_ONLY is false, and otherwise
11500                          * will return something, and when SIZE_ONLY is
11501                          * true, reg_scan_name() just parses the string,
11502                          * and doesnt return anything. (in theory) */
11503                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11504
11505                         if (sv_dat)
11506                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11507                     }
11508                     ret = reganode(pRExC_state,INSUBP,parno);
11509                     goto insert_if_check_paren;
11510                 }
11511                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11512                     /* (?(1)...) */
11513                     char c;
11514                     UV uv;
11515                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11516                         && uv <= I32_MAX
11517                     ) {
11518                         parno = (I32)uv;
11519                         RExC_parse = (char*)endptr;
11520                     }
11521                     else {
11522                         vFAIL("panic: grok_atoUV returned FALSE");
11523                     }
11524                     ret = reganode(pRExC_state, GROUPP, parno);
11525
11526                  insert_if_check_paren:
11527                     if (UCHARAT(RExC_parse) != ')') {
11528                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11529                         vFAIL("Switch condition not recognized");
11530                     }
11531                     nextchar(pRExC_state);
11532                   insert_if:
11533                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11534                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11535                     if (br == NULL) {
11536                         RETURN_NULL_ON_RESTART(flags,flagp);
11537                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11538                               (UV) flags);
11539                     } else
11540                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11541                                                           LONGJMP, 0));
11542                     c = UCHARAT(RExC_parse);
11543                     nextchar(pRExC_state);
11544                     if (flags&HASWIDTH)
11545                         *flagp |= HASWIDTH;
11546                     if (c == '|') {
11547                         if (is_define)
11548                             vFAIL("(?(DEFINE)....) does not allow branches");
11549
11550                         /* Fake one for optimizer.  */
11551                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11552
11553                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11554                             RETURN_NULL_ON_RESTART(flags,flagp);
11555                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11556                                   (UV) flags);
11557                         }
11558                         REGTAIL(pRExC_state, ret, lastbr);
11559                         if (flags&HASWIDTH)
11560                             *flagp |= HASWIDTH;
11561                         c = UCHARAT(RExC_parse);
11562                         nextchar(pRExC_state);
11563                     }
11564                     else
11565                         lastbr = NULL;
11566                     if (c != ')') {
11567                         if (RExC_parse >= RExC_end)
11568                             vFAIL("Switch (?(condition)... not terminated");
11569                         else
11570                             vFAIL("Switch (?(condition)... contains too many branches");
11571                     }
11572                     ender = reg_node(pRExC_state, TAIL);
11573                     REGTAIL(pRExC_state, br, ender);
11574                     if (lastbr) {
11575                         REGTAIL(pRExC_state, lastbr, ender);
11576                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11577                     }
11578                     else
11579                         REGTAIL(pRExC_state, ret, ender);
11580                     RExC_size++; /* XXX WHY do we need this?!!
11581                                     For large programs it seems to be required
11582                                     but I can't figure out why. -- dmq*/
11583                     return ret;
11584                 }
11585                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11586                 vFAIL("Unknown switch condition (?(...))");
11587             }
11588             case '[':           /* (?[ ... ]) */
11589                 return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
11590                                          oregcomp_parse);
11591             case 0: /* A NUL */
11592                 RExC_parse--; /* for vFAIL to print correctly */
11593                 vFAIL("Sequence (? incomplete");
11594                 break;
11595             default: /* e.g., (?i) */
11596                 RExC_parse = (char *) seqstart + 1;
11597               parse_flags:
11598                 parse_lparen_question_flags(pRExC_state);
11599                 if (UCHARAT(RExC_parse) != ':') {
11600                     if (RExC_parse < RExC_end)
11601                         nextchar(pRExC_state);
11602                     *flagp = TRYAGAIN;
11603                     return NULL;
11604                 }
11605                 paren = ':';
11606                 nextchar(pRExC_state);
11607                 ret = NULL;
11608                 goto parse_rest;
11609             } /* end switch */
11610         }
11611         else {
11612             if (*RExC_parse == '{' && PASS2) {
11613                 ckWARNregdep(RExC_parse + 1,
11614                             "Unescaped left brace in regex is "
11615                             "deprecated here (and will be fatal "
11616                             "in Perl 5.32), passed through");
11617             }
11618             /* Not bothering to indent here, as the above 'else' is temporary
11619              * */
11620         if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11621           capturing_parens:
11622             parno = RExC_npar;
11623             RExC_npar++;
11624
11625             ret = reganode(pRExC_state, OPEN, parno);
11626             if (!SIZE_ONLY ){
11627                 if (!RExC_nestroot)
11628                     RExC_nestroot = parno;
11629                 if (RExC_open_parens && !RExC_open_parens[parno])
11630                 {
11631                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11632                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11633                         22, "|    |", (int)(depth * 2 + 1), "",
11634                         (IV)parno, REG_NODE_NUM(ret)));
11635                     RExC_open_parens[parno]= ret;
11636                 }
11637             }
11638             Set_Node_Length(ret, 1); /* MJD */
11639             Set_Node_Offset(ret, RExC_parse); /* MJD */
11640             is_open = 1;
11641         } else {
11642             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11643             paren = ':';
11644             ret = NULL;
11645         }
11646         }
11647     }
11648     else                        /* ! paren */
11649         ret = NULL;
11650
11651    parse_rest:
11652     /* Pick up the branches, linking them together. */
11653     parse_start = RExC_parse;   /* MJD */
11654     br = regbranch(pRExC_state, &flags, 1,depth+1);
11655
11656     /*     branch_len = (paren != 0); */
11657
11658     if (br == NULL) {
11659         RETURN_NULL_ON_RESTART(flags,flagp);
11660         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11661     }
11662     if (*RExC_parse == '|') {
11663         if (!SIZE_ONLY && RExC_extralen) {
11664             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11665         }
11666         else {                  /* MJD */
11667             reginsert(pRExC_state, BRANCH, br, depth+1);
11668             Set_Node_Length(br, paren != 0);
11669             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11670         }
11671         have_branch = 1;
11672         if (SIZE_ONLY)
11673             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11674     }
11675     else if (paren == ':') {
11676         *flagp |= flags&SIMPLE;
11677     }
11678     if (is_open) {                              /* Starts with OPEN. */
11679         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11680     }
11681     else if (paren != '?')              /* Not Conditional */
11682         ret = br;
11683     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11684     lastbr = br;
11685     while (*RExC_parse == '|') {
11686         if (!SIZE_ONLY && RExC_extralen) {
11687             ender = reganode(pRExC_state, LONGJMP,0);
11688
11689             /* Append to the previous. */
11690             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11691         }
11692         if (SIZE_ONLY)
11693             RExC_extralen += 2;         /* Account for LONGJMP. */
11694         nextchar(pRExC_state);
11695         if (freeze_paren) {
11696             if (RExC_npar > after_freeze)
11697                 after_freeze = RExC_npar;
11698             RExC_npar = freeze_paren;
11699         }
11700         br = regbranch(pRExC_state, &flags, 0, depth+1);
11701
11702         if (br == NULL) {
11703             RETURN_NULL_ON_RESTART(flags,flagp);
11704             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11705         }
11706         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11707         lastbr = br;
11708         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11709     }
11710
11711     if (have_branch || paren != ':') {
11712         /* Make a closing node, and hook it on the end. */
11713         switch (paren) {
11714         case ':':
11715             ender = reg_node(pRExC_state, TAIL);
11716             break;
11717         case 1: case 2:
11718             ender = reganode(pRExC_state, CLOSE, parno);
11719             if ( RExC_close_parens ) {
11720                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11721                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11722                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11723                 RExC_close_parens[parno]= ender;
11724                 if (RExC_nestroot == parno)
11725                     RExC_nestroot = 0;
11726             }
11727             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11728             Set_Node_Length(ender,1); /* MJD */
11729             break;
11730         case 's':
11731             ender = reg_node(pRExC_state, SRCLOSE);
11732             RExC_in_script_run = 0;
11733             break;
11734         case '<':
11735         case 'a':
11736         case 'A':
11737         case 'b':
11738         case 'B':
11739         case ',':
11740         case '=':
11741         case '!':
11742             *flagp &= ~HASWIDTH;
11743             /* FALLTHROUGH */
11744         case 't':   /* aTomic */
11745         case '>':
11746             ender = reg_node(pRExC_state, SUCCEED);
11747             break;
11748         case 0:
11749             ender = reg_node(pRExC_state, END);
11750             if (!SIZE_ONLY) {
11751                 assert(!RExC_end_op); /* there can only be one! */
11752                 RExC_end_op = ender;
11753                 if (RExC_close_parens) {
11754                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11755                         "%*s%*s Setting close paren #0 (END) to %d\n",
11756                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11757
11758                     RExC_close_parens[0]= ender;
11759                 }
11760             }
11761             break;
11762         }
11763         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11764             DEBUG_PARSE_MSG("lsbr");
11765             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11766             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11767             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11768                           SvPV_nolen_const(RExC_mysv1),
11769                           (IV)REG_NODE_NUM(lastbr),
11770                           SvPV_nolen_const(RExC_mysv2),
11771                           (IV)REG_NODE_NUM(ender),
11772                           (IV)(ender - lastbr)
11773             );
11774         });
11775         REGTAIL(pRExC_state, lastbr, ender);
11776
11777         if (have_branch && !SIZE_ONLY) {
11778             char is_nothing= 1;
11779             if (depth==1)
11780                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11781
11782             /* Hook the tails of the branches to the closing node. */
11783             for (br = ret; br; br = regnext(br)) {
11784                 const U8 op = PL_regkind[OP(br)];
11785                 if (op == BRANCH) {
11786                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11787                     if ( OP(NEXTOPER(br)) != NOTHING
11788                          || regnext(NEXTOPER(br)) != ender)
11789                         is_nothing= 0;
11790                 }
11791                 else if (op == BRANCHJ) {
11792                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11793                     /* for now we always disable this optimisation * /
11794                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11795                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11796                     */
11797                         is_nothing= 0;
11798                 }
11799             }
11800             if (is_nothing) {
11801                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11802                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11803                     DEBUG_PARSE_MSG("NADA");
11804                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11805                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11806                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11807                                   SvPV_nolen_const(RExC_mysv1),
11808                                   (IV)REG_NODE_NUM(ret),
11809                                   SvPV_nolen_const(RExC_mysv2),
11810                                   (IV)REG_NODE_NUM(ender),
11811                                   (IV)(ender - ret)
11812                     );
11813                 });
11814                 OP(br)= NOTHING;
11815                 if (OP(ender) == TAIL) {
11816                     NEXT_OFF(br)= 0;
11817                     RExC_emit= br + 1;
11818                 } else {
11819                     regnode *opt;
11820                     for ( opt= br + 1; opt < ender ; opt++ )
11821                         OP(opt)= OPTIMIZED;
11822                     NEXT_OFF(br)= ender - br;
11823                 }
11824             }
11825         }
11826     }
11827
11828     {
11829         const char *p;
11830          /* Even/odd or x=don't care: 010101x10x */
11831         static const char parens[] = "=!aA<,>Bbt";
11832          /* flag below is set to 0 up through 'A'; 1 for larger */
11833
11834         if (paren && (p = strchr(parens, paren))) {
11835             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11836             int flag = (p - parens) > 3;
11837
11838             if (paren == '>' || paren == 't') {
11839                 node = SUSPEND, flag = 0;
11840             }
11841
11842             reginsert(pRExC_state, node,ret, depth+1);
11843             Set_Node_Cur_Length(ret, parse_start);
11844             Set_Node_Offset(ret, parse_start + 1);
11845             ret->flags = flag;
11846             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11847         }
11848     }
11849
11850     /* Check for proper termination. */
11851     if (paren) {
11852         /* restore original flags, but keep (?p) and, if we've changed from /d
11853          * rules to /u, keep the /u */
11854         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11855         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11856             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11857         }
11858         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11859             RExC_parse = oregcomp_parse;
11860             vFAIL("Unmatched (");
11861         }
11862         nextchar(pRExC_state);
11863     }
11864     else if (!paren && RExC_parse < RExC_end) {
11865         if (*RExC_parse == ')') {
11866             RExC_parse++;
11867             vFAIL("Unmatched )");
11868         }
11869         else
11870             FAIL("Junk on end of regexp");      /* "Can't happen". */
11871         NOT_REACHED; /* NOTREACHED */
11872     }
11873
11874     if (RExC_in_lookbehind) {
11875         RExC_in_lookbehind--;
11876     }
11877     if (after_freeze > RExC_npar)
11878         RExC_npar = after_freeze;
11879     return(ret);
11880 }
11881
11882 /*
11883  - regbranch - one alternative of an | operator
11884  *
11885  * Implements the concatenation operator.
11886  *
11887  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11888  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11889  */
11890 STATIC regnode *
11891 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11892 {
11893     regnode *ret;
11894     regnode *chain = NULL;
11895     regnode *latest;
11896     I32 flags = 0, c = 0;
11897     GET_RE_DEBUG_FLAGS_DECL;
11898
11899     PERL_ARGS_ASSERT_REGBRANCH;
11900
11901     DEBUG_PARSE("brnc");
11902
11903     if (first)
11904         ret = NULL;
11905     else {
11906         if (!SIZE_ONLY && RExC_extralen)
11907             ret = reganode(pRExC_state, BRANCHJ,0);
11908         else {
11909             ret = reg_node(pRExC_state, BRANCH);
11910             Set_Node_Length(ret, 1);
11911         }
11912     }
11913
11914     if (!first && SIZE_ONLY)
11915         RExC_extralen += 1;                     /* BRANCHJ */
11916
11917     *flagp = WORST;                     /* Tentatively. */
11918
11919     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11920                             FALSE /* Don't force to /x */ );
11921     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11922         flags &= ~TRYAGAIN;
11923         latest = regpiece(pRExC_state, &flags,depth+1);
11924         if (latest == NULL) {
11925             if (flags & TRYAGAIN)
11926                 continue;
11927             RETURN_NULL_ON_RESTART(flags,flagp);
11928             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11929         }
11930         else if (ret == NULL)
11931             ret = latest;
11932         *flagp |= flags&(HASWIDTH|POSTPONED);
11933         if (chain == NULL)      /* First piece. */
11934             *flagp |= flags&SPSTART;
11935         else {
11936             /* FIXME adding one for every branch after the first is probably
11937              * excessive now we have TRIE support. (hv) */
11938             MARK_NAUGHTY(1);
11939             REGTAIL(pRExC_state, chain, latest);
11940         }
11941         chain = latest;
11942         c++;
11943     }
11944     if (chain == NULL) {        /* Loop ran zero times. */
11945         chain = reg_node(pRExC_state, NOTHING);
11946         if (ret == NULL)
11947             ret = chain;
11948     }
11949     if (c == 1) {
11950         *flagp |= flags&SIMPLE;
11951     }
11952
11953     return ret;
11954 }
11955
11956 /*
11957  - regpiece - something followed by possible quantifier * + ? {n,m}
11958  *
11959  * Note that the branching code sequences used for ? and the general cases
11960  * of * and + are somewhat optimized:  they use the same NOTHING node as
11961  * both the endmarker for their branch list and the body of the last branch.
11962  * It might seem that this node could be dispensed with entirely, but the
11963  * endmarker role is not redundant.
11964  *
11965  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11966  * TRYAGAIN.
11967  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11968  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11969  */
11970 STATIC regnode *
11971 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11972 {
11973     regnode *ret;
11974     char op;
11975     char *next;
11976     I32 flags;
11977     const char * const origparse = RExC_parse;
11978     I32 min;
11979     I32 max = REG_INFTY;
11980 #ifdef RE_TRACK_PATTERN_OFFSETS
11981     char *parse_start;
11982 #endif
11983     const char *maxpos = NULL;
11984     UV uv;
11985
11986     /* Save the original in case we change the emitted regop to a FAIL. */
11987     regnode * const orig_emit = RExC_emit;
11988
11989     GET_RE_DEBUG_FLAGS_DECL;
11990
11991     PERL_ARGS_ASSERT_REGPIECE;
11992
11993     DEBUG_PARSE("piec");
11994
11995     ret = regatom(pRExC_state, &flags,depth+1);
11996     if (ret == NULL) {
11997         RETURN_NULL_ON_RESTART_OR_FLAGS(flags,flagp,TRYAGAIN);
11998         FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11999     }
12000
12001     op = *RExC_parse;
12002
12003     if (op == '{' && regcurly(RExC_parse)) {
12004         maxpos = NULL;
12005 #ifdef RE_TRACK_PATTERN_OFFSETS
12006         parse_start = RExC_parse; /* MJD */
12007 #endif
12008         next = RExC_parse + 1;
12009         while (isDIGIT(*next) || *next == ',') {
12010             if (*next == ',') {
12011                 if (maxpos)
12012                     break;
12013                 else
12014                     maxpos = next;
12015             }
12016             next++;
12017         }
12018         if (*next == '}') {             /* got one */
12019             const char* endptr;
12020             if (!maxpos)
12021                 maxpos = next;
12022             RExC_parse++;
12023             if (isDIGIT(*RExC_parse)) {
12024                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
12025                     vFAIL("Invalid quantifier in {,}");
12026                 if (uv >= REG_INFTY)
12027                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12028                 min = (I32)uv;
12029             } else {
12030                 min = 0;
12031             }
12032             if (*maxpos == ',')
12033                 maxpos++;
12034             else
12035                 maxpos = RExC_parse;
12036             if (isDIGIT(*maxpos)) {
12037                 if (!grok_atoUV(maxpos, &uv, &endptr))
12038                     vFAIL("Invalid quantifier in {,}");
12039                 if (uv >= REG_INFTY)
12040                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12041                 max = (I32)uv;
12042             } else {
12043                 max = REG_INFTY;                /* meaning "infinity" */
12044             }
12045             RExC_parse = next;
12046             nextchar(pRExC_state);
12047             if (max < min) {    /* If can't match, warn and optimize to fail
12048                                    unconditionally */
12049                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
12050                 if (PASS2) {
12051                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
12052                     NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE;
12053                 }
12054                 return ret;
12055             }
12056             else if (min == max && *RExC_parse == '?')
12057             {
12058                 if (PASS2) {
12059                     ckWARN2reg(RExC_parse + 1,
12060                                "Useless use of greediness modifier '%c'",
12061                                *RExC_parse);
12062                 }
12063             }
12064
12065           do_curly:
12066             if ((flags&SIMPLE)) {
12067                 if (min == 0 && max == REG_INFTY) {
12068                     reginsert(pRExC_state, STAR, ret, depth+1);
12069                     MARK_NAUGHTY(4);
12070                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12071                     goto nest_check;
12072                 }
12073                 if (min == 1 && max == REG_INFTY) {
12074                     reginsert(pRExC_state, PLUS, ret, depth+1);
12075                     MARK_NAUGHTY(3);
12076                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12077                     goto nest_check;
12078                 }
12079                 MARK_NAUGHTY_EXP(2, 2);
12080                 reginsert(pRExC_state, CURLY, ret, depth+1);
12081                 Set_Node_Offset(ret, parse_start+1); /* MJD */
12082                 Set_Node_Cur_Length(ret, parse_start);
12083             }
12084             else {
12085                 regnode * const w = reg_node(pRExC_state, WHILEM);
12086
12087                 w->flags = 0;
12088                 REGTAIL(pRExC_state, ret, w);
12089                 if (!SIZE_ONLY && RExC_extralen) {
12090                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
12091                     reginsert(pRExC_state, NOTHING,ret, depth+1);
12092                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
12093                 }
12094                 reginsert(pRExC_state, CURLYX,ret, depth+1);
12095                                 /* MJD hk */
12096                 Set_Node_Offset(ret, parse_start+1);
12097                 Set_Node_Length(ret,
12098                                 op == '{' ? (RExC_parse - parse_start) : 1);
12099
12100                 if (!SIZE_ONLY && RExC_extralen)
12101                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
12102                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
12103                 if (SIZE_ONLY)
12104                     RExC_whilem_seen++, RExC_extralen += 3;
12105                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
12106             }
12107             ret->flags = 0;
12108
12109             if (min > 0)
12110                 *flagp = WORST;
12111             if (max > 0)
12112                 *flagp |= HASWIDTH;
12113             if (!SIZE_ONLY) {
12114                 ARG1_SET(ret, (U16)min);
12115                 ARG2_SET(ret, (U16)max);
12116             }
12117             if (max == REG_INFTY)
12118                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12119
12120             goto nest_check;
12121         }
12122     }
12123
12124     if (!ISMULT1(op)) {
12125         *flagp = flags;
12126         return(ret);
12127     }
12128
12129 #if 0                           /* Now runtime fix should be reliable. */
12130
12131     /* if this is reinstated, don't forget to put this back into perldiag:
12132
12133             =item Regexp *+ operand could be empty at {#} in regex m/%s/
12134
12135            (F) The part of the regexp subject to either the * or + quantifier
12136            could match an empty string. The {#} shows in the regular
12137            expression about where the problem was discovered.
12138
12139     */
12140
12141     if (!(flags&HASWIDTH) && op != '?')
12142       vFAIL("Regexp *+ operand could be empty");
12143 #endif
12144
12145 #ifdef RE_TRACK_PATTERN_OFFSETS
12146     parse_start = RExC_parse;
12147 #endif
12148     nextchar(pRExC_state);
12149
12150     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
12151
12152     if (op == '*') {
12153         min = 0;
12154         goto do_curly;
12155     }
12156     else if (op == '+') {
12157         min = 1;
12158         goto do_curly;
12159     }
12160     else if (op == '?') {
12161         min = 0; max = 1;
12162         goto do_curly;
12163     }
12164   nest_check:
12165     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
12166         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
12167         ckWARN2reg(RExC_parse,
12168                    "%" UTF8f " matches null string many times",
12169                    UTF8fARG(UTF, (RExC_parse >= origparse
12170                                  ? RExC_parse - origparse
12171                                  : 0),
12172                    origparse));
12173         (void)ReREFCNT_inc(RExC_rx_sv);
12174     }
12175
12176     if (*RExC_parse == '?') {
12177         nextchar(pRExC_state);
12178         reginsert(pRExC_state, MINMOD, ret, depth+1);
12179         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
12180     }
12181     else if (*RExC_parse == '+') {
12182         regnode *ender;
12183         nextchar(pRExC_state);
12184         ender = reg_node(pRExC_state, SUCCEED);
12185         REGTAIL(pRExC_state, ret, ender);
12186         reginsert(pRExC_state, SUSPEND, ret, depth+1);
12187         ender = reg_node(pRExC_state, TAIL);
12188         REGTAIL(pRExC_state, ret, ender);
12189     }
12190
12191     if (ISMULT2(RExC_parse)) {
12192         RExC_parse++;
12193         vFAIL("Nested quantifiers");
12194     }
12195
12196     return(ret);
12197 }
12198
12199 STATIC bool
12200 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
12201                 regnode ** node_p,
12202                 UV * code_point_p,
12203                 int * cp_count,
12204                 I32 * flagp,
12205                 const bool strict,
12206                 const U32 depth
12207     )
12208 {
12209  /* This routine teases apart the various meanings of \N and returns
12210   * accordingly.  The input parameters constrain which meaning(s) is/are valid
12211   * in the current context.
12212   *
12213   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
12214   *
12215   * If <code_point_p> is not NULL, the context is expecting the result to be a
12216   * single code point.  If this \N instance turns out to a single code point,
12217   * the function returns TRUE and sets *code_point_p to that code point.
12218   *
12219   * If <node_p> is not NULL, the context is expecting the result to be one of
12220   * the things representable by a regnode.  If this \N instance turns out to be
12221   * one such, the function generates the regnode, returns TRUE and sets *node_p
12222   * to point to that regnode.
12223   *
12224   * If this instance of \N isn't legal in any context, this function will
12225   * generate a fatal error and not return.
12226   *
12227   * On input, RExC_parse should point to the first char following the \N at the
12228   * time of the call.  On successful return, RExC_parse will have been updated
12229   * to point to just after the sequence identified by this routine.  Also
12230   * *flagp has been updated as needed.
12231   *
12232   * When there is some problem with the current context and this \N instance,
12233   * the function returns FALSE, without advancing RExC_parse, nor setting
12234   * *node_p, nor *code_point_p, nor *flagp.
12235   *
12236   * If <cp_count> is not NULL, the caller wants to know the length (in code
12237   * points) that this \N sequence matches.  This is set even if the function
12238   * returns FALSE, as detailed below.
12239   *
12240   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
12241   *
12242   * Probably the most common case is for the \N to specify a single code point.
12243   * *cp_count will be set to 1, and *code_point_p will be set to that code
12244   * point.
12245   *
12246   * Another possibility is for the input to be an empty \N{}, which for
12247   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
12248   * will be set to a generated NOTHING node.
12249   *
12250   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
12251   * set to 0. *node_p will be set to a generated REG_ANY node.
12252   *
12253   * The fourth possibility is that \N resolves to a sequence of more than one
12254   * code points.  *cp_count will be set to the number of code points in the
12255   * sequence. *node_p * will be set to a generated node returned by this
12256   * function calling S_reg().
12257   *
12258   * The final possibility is that it is premature to be calling this function;
12259   * that pass1 needs to be restarted.  This can happen when this changes from
12260   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
12261   * latter occurs only when the fourth possibility would otherwise be in
12262   * effect, and is because one of those code points requires the pattern to be
12263   * recompiled as UTF-8.  The function returns FALSE, and sets the
12264   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
12265   * happens, the caller needs to desist from continuing parsing, and return
12266   * this information to its caller.  This is not set for when there is only one
12267   * code point, as this can be called as part of an ANYOF node, and they can
12268   * store above-Latin1 code points without the pattern having to be in UTF-8.
12269   *
12270   * For non-single-quoted regexes, the tokenizer has resolved character and
12271   * sequence names inside \N{...} into their Unicode values, normalizing the
12272   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
12273   * hex-represented code points in the sequence.  This is done there because
12274   * the names can vary based on what charnames pragma is in scope at the time,
12275   * so we need a way to take a snapshot of what they resolve to at the time of
12276   * the original parse. [perl #56444].
12277   *
12278   * That parsing is skipped for single-quoted regexes, so we may here get
12279   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
12280   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
12281   * is legal and handled here.  The code point is Unicode, and has to be
12282   * translated into the native character set for non-ASCII platforms.
12283   */
12284
12285     char * endbrace;    /* points to '}' following the name */
12286     char* p = RExC_parse; /* Temporary */
12287
12288     SV * substitute_parse = NULL;
12289     char *orig_end;
12290     char *save_start;
12291     I32 flags;
12292     Size_t count = 0;   /* code point count kept internally by this function */
12293
12294     GET_RE_DEBUG_FLAGS_DECL;
12295
12296     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12297
12298     GET_RE_DEBUG_FLAGS;
12299
12300     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12301     assert(! (node_p && cp_count));               /* At most 1 should be set */
12302
12303     if (cp_count) {     /* Initialize return for the most common case */
12304         *cp_count = 1;
12305     }
12306
12307     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12308      * modifier.  The other meanings do not, so use a temporary until we find
12309      * out which we are being called with */
12310     skip_to_be_ignored_text(pRExC_state, &p,
12311                             FALSE /* Don't force to /x */ );
12312
12313     /* Disambiguate between \N meaning a named character versus \N meaning
12314      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12315      * quantifier, or there is no '{' at all */
12316     if (*p != '{' || regcurly(p)) {
12317         RExC_parse = p;
12318         if (cp_count) {
12319             *cp_count = -1;
12320         }
12321
12322         if (! node_p) {
12323             return FALSE;
12324         }
12325
12326         *node_p = reg_node(pRExC_state, REG_ANY);
12327         *flagp |= HASWIDTH|SIMPLE;
12328         MARK_NAUGHTY(1);
12329         Set_Node_Length(*node_p, 1); /* MJD */
12330         return TRUE;
12331     }
12332
12333     /* The test above made sure that the next real character is a '{', but
12334      * under the /x modifier, it could be separated by space (or a comment and
12335      * \n) and this is not allowed (for consistency with \x{...} and the
12336      * tokenizer handling of \N{NAME}). */
12337     if (*RExC_parse != '{') {
12338         vFAIL("Missing braces on \\N{}");
12339     }
12340
12341     RExC_parse++;       /* Skip past the '{' */
12342
12343     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
12344     if (! endbrace) { /* no trailing brace */
12345         vFAIL2("Missing right brace on \\%c{}", 'N');
12346     }
12347
12348     /* Here, we have decided it should be a named character or sequence */
12349     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12350                                         semantics */
12351
12352     if (endbrace == RExC_parse) {   /* empty: \N{} */
12353         if (strict) {
12354             RExC_parse++;   /* Position after the "}" */
12355             vFAIL("Zero length \\N{}");
12356         }
12357         if (cp_count) {
12358             *cp_count = 0;
12359         }
12360         nextchar(pRExC_state);
12361         if (! node_p) {
12362             return FALSE;
12363         }
12364
12365         *node_p = reg_node(pRExC_state,NOTHING);
12366         return TRUE;
12367     }
12368
12369     /* If we haven't got something that begins with 'U+', then it didn't get lexed. */
12370     if (   endbrace - RExC_parse < 2
12371         || strnNE(RExC_parse, "U+", 2))
12372     {
12373         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12374         vFAIL("\\N{NAME} must be resolved by the lexer");
12375     }
12376
12377         /* This code purposely indented below because of future changes coming */
12378
12379         /* We can get to here when the input is \N{U+...} or when toke.c has
12380          * converted a name to the \N{U+...} form.  This include changing a
12381          * name that evaluates to multiple code points to \N{U+c1.c2.c3 ...} */
12382
12383         RExC_parse += 2;    /* Skip past the 'U+' */
12384
12385         /* Code points are separated by dots.  The '}' terminates the whole
12386          * thing. */
12387
12388         do {    /* Loop until the ending brace */
12389             UV cp = 0;
12390             char * start_digit;     /* The first of the current code point */
12391             if (! isXDIGIT(*RExC_parse)) {
12392                 RExC_parse++;
12393                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
12394             }
12395
12396             start_digit = RExC_parse;
12397             count++;
12398
12399             /* Loop through the hex digits of the current code point */
12400             do {
12401                 /* Adding this digit will shift the result 4 bits.  If that
12402                  * result would be above IV_MAX, it's overflow */
12403                 if (cp > IV_MAX >> 4) {
12404
12405                     /* Find the end of the code point */
12406                     do {
12407                         RExC_parse ++;
12408                     } while (isXDIGIT(*RExC_parse) || *RExC_parse == '_');
12409
12410                     /* Be sure to synchronize this message with the similar one
12411                      * in utf8.c */
12412                     vFAIL4("Use of code point 0x%.*s is not allowed; the"
12413                         " permissible max is 0x%" UVxf,
12414                         (int) (RExC_parse - start_digit), start_digit, IV_MAX);
12415                 }
12416
12417                 /* Accumulate this (valid) digit into the running total */
12418                 cp  = (cp << 4) + READ_XDIGIT(RExC_parse);
12419
12420                 /* READ_XDIGIT advanced the input pointer.  Ignore a single
12421                  * underscore separator */
12422                 if (*RExC_parse == '_' && isXDIGIT(RExC_parse[1])) {
12423                     RExC_parse++;
12424                 }
12425             } while (isXDIGIT(*RExC_parse));
12426
12427             /* Here, have accumulated the next code point */
12428             if (RExC_parse >= endbrace) {   /* If done ... */
12429                 if (count != 1) {
12430                     goto do_concat;
12431                 }
12432
12433                 /* Here, is a single code point; fail if doesn't want that */
12434                 if (! code_point_p) {
12435                     RExC_parse = p;
12436                     return FALSE;
12437                 }
12438
12439                 /* A single code point is easy to handle; just return it */
12440                 *code_point_p = UNI_TO_NATIVE(cp);
12441                 RExC_parse = endbrace;
12442                 nextchar(pRExC_state);
12443                 return TRUE;
12444             }
12445
12446             /* Here, the only legal thing would be a multiple character
12447              * sequence (of the form "\N{U+c1.c2. ... }".   So the next
12448              * character must be a dot (and the one after that can't be the
12449              * endbrace, or we'd have something like \N{U+100.} ) */
12450             if (*RExC_parse != '.' || RExC_parse + 1 >= endbrace) {
12451                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
12452                                 ? UTF8SKIP(RExC_parse)
12453                                 : 1;
12454                 if (RExC_parse >= endbrace) { /* Guard against malformed utf8 */
12455                     RExC_parse = endbrace;
12456                 }
12457                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
12458             }
12459
12460             /* Here, looks like its really a multiple character sequence.  Fail
12461              * if that's not what the caller wants. */
12462             if (! node_p) {
12463
12464                 /* But even if failing, we count the code points if requested, and
12465                  * don't back up up the pointer as the caller is expected to
12466                  * handle this situation */
12467                 if (cp_count) {
12468                     char * dot = RExC_parse + 1;
12469                     do {
12470                         dot = (char *) memchr(dot, '.', endbrace - dot);
12471                         if (! dot) {
12472                             break;
12473                         }
12474                         count++;
12475                         dot++;
12476                     } while (dot < endbrace);
12477                     count++;
12478
12479                     *cp_count = count;
12480                     RExC_parse = endbrace;
12481                     nextchar(pRExC_state);
12482                 }
12483                 else {  /* Back up the pointer. */
12484                     RExC_parse = p;
12485                 }
12486                 return FALSE;
12487             }
12488
12489             /* What is done here is to convert this to a sub-pattern of the
12490              * form \x{char1}\x{char2}...  and then call reg recursively to
12491              * parse it (enclosing in "(?: ... )" ).  That way, it retains its
12492              * atomicness, while not having to worry about special handling
12493              * that some code points may have. */
12494
12495             if (count == 1) {
12496                 substitute_parse = newSVpvs("?:");
12497             }
12498
12499           do_concat:
12500
12501             /* Convert to notation the rest of the code understands */
12502             sv_catpv(substitute_parse, "\\x{");
12503             sv_catpvn(substitute_parse, start_digit, RExC_parse - start_digit);
12504             sv_catpv(substitute_parse, "}");
12505
12506             /* Move to after the dot (or ending brace the final time through.)
12507              * */
12508             RExC_parse++;
12509
12510         } while (RExC_parse < endbrace);
12511
12512         sv_catpv(substitute_parse, ")");
12513
12514 #ifdef EBCDIC
12515         /* The values are Unicode, and therefore have to be converted to native
12516          * on a non-Unicode (meaning non-ASCII) platform. */
12517         RExC_recode_x_to_native = 1;
12518 #endif
12519
12520     /* Here, we have the string the name evaluates to, ready to be parsed,
12521      * stored in 'substitute_parse' as a series of valid "\x{...}\x{...}"
12522      * constructs.  This can be called from within a substitute parse already.
12523      * The error reporting mechanism doesn't work for 2 levels of this, but the
12524      * code above has validated this new construct, so there should be no
12525      * errors generated by the below.*/
12526     save_start = RExC_start;
12527     orig_end = RExC_end;
12528
12529     RExC_parse = RExC_start = SvPVX(substitute_parse);
12530     RExC_end = RExC_parse + SvCUR(substitute_parse);
12531
12532     *node_p = reg(pRExC_state, 1, &flags, depth+1);
12533
12534     /* Restore the saved values */
12535     RExC_start = save_start;
12536     RExC_parse = endbrace;
12537     RExC_end = orig_end;
12538 #ifdef EBCDIC
12539     RExC_recode_x_to_native = 0;
12540 #endif
12541
12542     SvREFCNT_dec_NN(substitute_parse);
12543
12544     if (! *node_p) {
12545         RETURN_X_ON_RESTART(FALSE, flags,flagp);
12546         FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12547             (UV) flags);
12548     }
12549     *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12550
12551     nextchar(pRExC_state);
12552
12553     return TRUE;
12554 }
12555
12556
12557 PERL_STATIC_INLINE U8
12558 S_compute_EXACTish(RExC_state_t *pRExC_state)
12559 {
12560     U8 op;
12561
12562     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12563
12564     if (! FOLD) {
12565         return (LOC)
12566                 ? EXACTL
12567                 : EXACT;
12568     }
12569
12570     op = get_regex_charset(RExC_flags);
12571     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12572         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12573                  been, so there is no hole */
12574     }
12575
12576     return op + EXACTF;
12577 }
12578
12579 PERL_STATIC_INLINE void
12580 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12581                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12582                          bool downgradable)
12583 {
12584     /* This knows the details about sizing an EXACTish node, setting flags for
12585      * it (by setting <*flagp>, and potentially populating it with a single
12586      * character.
12587      *
12588      * If <len> (the length in bytes) is non-zero, this function assumes that
12589      * the node has already been populated, and just does the sizing.  In this
12590      * case <code_point> should be the final code point that has already been
12591      * placed into the node.  This value will be ignored except that under some
12592      * circumstances <*flagp> is set based on it.
12593      *
12594      * If <len> is zero, the function assumes that the node is to contain only
12595      * the single character given by <code_point> and calculates what <len>
12596      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12597      * additionally will populate the node's STRING with <code_point> or its
12598      * fold if folding.
12599      *
12600      * In both cases <*flagp> is appropriately set
12601      *
12602      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12603      * 255, must be folded (the former only when the rules indicate it can
12604      * match 'ss')
12605      *
12606      * When it does the populating, it looks at the flag 'downgradable'.  If
12607      * true with a node that folds, it checks if the single code point
12608      * participates in a fold, and if not downgrades the node to an EXACT.
12609      * This helps the optimizer */
12610
12611     bool len_passed_in = cBOOL(len != 0);
12612     U8 character[UTF8_MAXBYTES_CASE+1];
12613
12614     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12615
12616     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12617      * sizing difference, and is extra work that is thrown away */
12618     if (downgradable && ! PASS2) {
12619         downgradable = FALSE;
12620     }
12621
12622     if (! len_passed_in) {
12623         if (UTF) {
12624             if (UVCHR_IS_INVARIANT(code_point)) {
12625                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12626                     *character = (U8) code_point;
12627                 }
12628                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12629                           ASCII, which isn't the same thing as INVARIANT on
12630                           EBCDIC, but it works there, as the extra invariants
12631                           fold to themselves) */
12632                     *character = toFOLD((U8) code_point);
12633
12634                     /* We can downgrade to an EXACT node if this character
12635                      * isn't a folding one.  Note that this assumes that
12636                      * nothing above Latin1 folds to some other invariant than
12637                      * one of these alphabetics; otherwise we would also have
12638                      * to check:
12639                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12640                      *      || ASCII_FOLD_RESTRICTED))
12641                      */
12642                     if (downgradable && PL_fold[code_point] == code_point) {
12643                         OP(node) = EXACT;
12644                     }
12645                 }
12646                 len = 1;
12647             }
12648             else if (FOLD && (! LOC
12649                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12650             {   /* Folding, and ok to do so now */
12651                 UV folded = _to_uni_fold_flags(
12652                                    code_point,
12653                                    character,
12654                                    &len,
12655                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12656                                                       ? FOLD_FLAGS_NOMIX_ASCII
12657                                                       : 0));
12658                 if (downgradable
12659                     && folded == code_point /* This quickly rules out many
12660                                                cases, avoiding the
12661                                                _invlist_contains_cp() overhead
12662                                                for those.  */
12663                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12664                 {
12665                     OP(node) = (LOC)
12666                                ? EXACTL
12667                                : EXACT;
12668                 }
12669             }
12670             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12671
12672                 /* Not folding this cp, and can output it directly */
12673                 *character = UTF8_TWO_BYTE_HI(code_point);
12674                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12675                 len = 2;
12676             }
12677             else {
12678                 uvchr_to_utf8( character, code_point);
12679                 len = UTF8SKIP(character);
12680             }
12681         } /* Else pattern isn't UTF8.  */
12682         else if (! FOLD) {
12683             *character = (U8) code_point;
12684             len = 1;
12685         } /* Else is folded non-UTF8 */
12686 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12687    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12688                                       || UNICODE_DOT_DOT_VERSION > 0)
12689         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12690 #else
12691         else if (1) {
12692 #endif
12693             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12694              * comments at join_exact()); */
12695             *character = (U8) code_point;
12696             len = 1;
12697
12698             /* Can turn into an EXACT node if we know the fold at compile time,
12699              * and it folds to itself and doesn't particpate in other folds */
12700             if (downgradable
12701                 && ! LOC
12702                 && PL_fold_latin1[code_point] == code_point
12703                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12704                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12705             {
12706                 OP(node) = EXACT;
12707             }
12708         } /* else is Sharp s.  May need to fold it */
12709         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12710             *character = 's';
12711             *(character + 1) = 's';
12712             len = 2;
12713         }
12714         else {
12715             *character = LATIN_SMALL_LETTER_SHARP_S;
12716             len = 1;
12717         }
12718     }
12719
12720     if (SIZE_ONLY) {
12721         RExC_size += STR_SZ(len);
12722     }
12723     else {
12724         RExC_emit += STR_SZ(len);
12725         STR_LEN(node) = len;
12726         if (! len_passed_in) {
12727             Copy((char *) character, STRING(node), len, char);
12728         }
12729     }
12730
12731     *flagp |= HASWIDTH;
12732
12733     /* A single character node is SIMPLE, except for the special-cased SHARP S
12734      * under /di. */
12735     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12736 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12737    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12738                                       || UNICODE_DOT_DOT_VERSION > 0)
12739         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12740             || ! FOLD || ! DEPENDS_SEMANTICS)
12741 #endif
12742     ) {
12743         *flagp |= SIMPLE;
12744     }
12745
12746     /* The OP may not be well defined in PASS1 */
12747     if (PASS2 && OP(node) == EXACTFL) {
12748         RExC_contains_locale = 1;
12749     }
12750 }
12751
12752 STATIC bool
12753 S_new_regcurly(const char *s, const char *e)
12754 {
12755     /* This is a temporary function designed to match the most lenient form of
12756      * a {m,n} quantifier we ever envision, with either number omitted, and
12757      * spaces anywhere between/before/after them.
12758      *
12759      * If this function fails, then the string it matches is very unlikely to
12760      * ever be considered a valid quantifier, so we can allow the '{' that
12761      * begins it to be considered as a literal */
12762
12763     bool has_min = FALSE;
12764     bool has_max = FALSE;
12765
12766     PERL_ARGS_ASSERT_NEW_REGCURLY;
12767
12768     if (s >= e || *s++ != '{')
12769         return FALSE;
12770
12771     while (s < e && isSPACE(*s)) {
12772         s++;
12773     }
12774     while (s < e && isDIGIT(*s)) {
12775         has_min = TRUE;
12776         s++;
12777     }
12778     while (s < e && isSPACE(*s)) {
12779         s++;
12780     }
12781
12782     if (*s == ',') {
12783         s++;
12784         while (s < e && isSPACE(*s)) {
12785             s++;
12786         }
12787         while (s < e && isDIGIT(*s)) {
12788             has_max = TRUE;
12789             s++;
12790         }
12791         while (s < e && isSPACE(*s)) {
12792             s++;
12793         }
12794     }
12795
12796     return s < e && *s == '}' && (has_min || has_max);
12797 }
12798
12799 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12800  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12801
12802 static I32
12803 S_backref_value(char *p)
12804 {
12805     const char* endptr;
12806     UV val;
12807     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12808         return (I32)val;
12809     return I32_MAX;
12810 }
12811
12812
12813 /*
12814  - regatom - the lowest level
12815
12816    Try to identify anything special at the start of the current parse position.
12817    If there is, then handle it as required. This may involve generating a
12818    single regop, such as for an assertion; or it may involve recursing, such as
12819    to handle a () structure.
12820
12821    If the string doesn't start with something special then we gobble up
12822    as much literal text as we can.  If we encounter a quantifier, we have to
12823    back off the final literal character, as that quantifier applies to just it
12824    and not to the whole string of literals.
12825
12826    Once we have been able to handle whatever type of thing started the
12827    sequence, we return.
12828
12829    Note: we have to be careful with escapes, as they can be both literal
12830    and special, and in the case of \10 and friends, context determines which.
12831
12832    A summary of the code structure is:
12833
12834    switch (first_byte) {
12835         cases for each special:
12836             handle this special;
12837             break;
12838         case '\\':
12839             switch (2nd byte) {
12840                 cases for each unambiguous special:
12841                     handle this special;
12842                     break;
12843                 cases for each ambigous special/literal:
12844                     disambiguate;
12845                     if (special)  handle here
12846                     else goto defchar;
12847                 default: // unambiguously literal:
12848                     goto defchar;
12849             }
12850         default:  // is a literal char
12851             // FALL THROUGH
12852         defchar:
12853             create EXACTish node for literal;
12854             while (more input and node isn't full) {
12855                 switch (input_byte) {
12856                    cases for each special;
12857                        make sure parse pointer is set so that the next call to
12858                            regatom will see this special first
12859                        goto loopdone; // EXACTish node terminated by prev. char
12860                    default:
12861                        append char to EXACTISH node;
12862                 }
12863                 get next input byte;
12864             }
12865         loopdone:
12866    }
12867    return the generated node;
12868
12869    Specifically there are two separate switches for handling
12870    escape sequences, with the one for handling literal escapes requiring
12871    a dummy entry for all of the special escapes that are actually handled
12872    by the other.
12873
12874    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12875    TRYAGAIN.
12876    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12877    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12878    Otherwise does not return NULL.
12879 */
12880
12881 STATIC regnode *
12882 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12883 {
12884     regnode *ret = NULL;
12885     I32 flags = 0;
12886     char *parse_start;
12887     U8 op;
12888     int invert = 0;
12889     U8 arg;
12890
12891     GET_RE_DEBUG_FLAGS_DECL;
12892
12893     *flagp = WORST;             /* Tentatively. */
12894
12895     DEBUG_PARSE("atom");
12896
12897     PERL_ARGS_ASSERT_REGATOM;
12898
12899   tryagain:
12900     parse_start = RExC_parse;
12901     assert(RExC_parse < RExC_end);
12902     switch ((U8)*RExC_parse) {
12903     case '^':
12904         RExC_seen_zerolen++;
12905         nextchar(pRExC_state);
12906         if (RExC_flags & RXf_PMf_MULTILINE)
12907             ret = reg_node(pRExC_state, MBOL);
12908         else
12909             ret = reg_node(pRExC_state, SBOL);
12910         Set_Node_Length(ret, 1); /* MJD */
12911         break;
12912     case '$':
12913         nextchar(pRExC_state);
12914         if (*RExC_parse)
12915             RExC_seen_zerolen++;
12916         if (RExC_flags & RXf_PMf_MULTILINE)
12917             ret = reg_node(pRExC_state, MEOL);
12918         else
12919             ret = reg_node(pRExC_state, SEOL);
12920         Set_Node_Length(ret, 1); /* MJD */
12921         break;
12922     case '.':
12923         nextchar(pRExC_state);
12924         if (RExC_flags & RXf_PMf_SINGLELINE)
12925             ret = reg_node(pRExC_state, SANY);
12926         else
12927             ret = reg_node(pRExC_state, REG_ANY);
12928         *flagp |= HASWIDTH|SIMPLE;
12929         MARK_NAUGHTY(1);
12930         Set_Node_Length(ret, 1); /* MJD */
12931         break;
12932     case '[':
12933     {
12934         char * const oregcomp_parse = ++RExC_parse;
12935         ret = regclass(pRExC_state, flagp,depth+1,
12936                        FALSE, /* means parse the whole char class */
12937                        TRUE, /* allow multi-char folds */
12938                        FALSE, /* don't silence non-portable warnings. */
12939                        (bool) RExC_strict,
12940                        TRUE, /* Allow an optimized regnode result */
12941                        NULL,
12942                        NULL);
12943         if (ret == NULL) {
12944             RETURN_NULL_ON_RESTART_FLAGP_OR_FLAGS(flagp,NEED_UTF8);
12945             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12946                   (UV) *flagp);
12947         }
12948         if (*RExC_parse != ']') {
12949             RExC_parse = oregcomp_parse;
12950             vFAIL("Unmatched [");
12951         }
12952         nextchar(pRExC_state);
12953         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12954         break;
12955     }
12956     case '(':
12957         nextchar(pRExC_state);
12958         ret = reg(pRExC_state, 2, &flags,depth+1);
12959         if (ret == NULL) {
12960                 if (flags & TRYAGAIN) {
12961                     if (RExC_parse >= RExC_end) {
12962                          /* Make parent create an empty node if needed. */
12963                         *flagp |= TRYAGAIN;
12964                         return(NULL);
12965                     }
12966                     goto tryagain;
12967                 }
12968                 RETURN_NULL_ON_RESTART(flags,flagp);
12969                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12970                                                                  (UV) flags);
12971         }
12972         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12973         break;
12974     case '|':
12975     case ')':
12976         if (flags & TRYAGAIN) {
12977             *flagp |= TRYAGAIN;
12978             return NULL;
12979         }
12980         vFAIL("Internal urp");
12981                                 /* Supposed to be caught earlier. */
12982         break;
12983     case '?':
12984     case '+':
12985     case '*':
12986         RExC_parse++;
12987         vFAIL("Quantifier follows nothing");
12988         break;
12989     case '\\':
12990         /* Special Escapes
12991
12992            This switch handles escape sequences that resolve to some kind
12993            of special regop and not to literal text. Escape sequnces that
12994            resolve to literal text are handled below in the switch marked
12995            "Literal Escapes".
12996
12997            Every entry in this switch *must* have a corresponding entry
12998            in the literal escape switch. However, the opposite is not
12999            required, as the default for this switch is to jump to the
13000            literal text handling code.
13001         */
13002         RExC_parse++;
13003         switch ((U8)*RExC_parse) {
13004         /* Special Escapes */
13005         case 'A':
13006             RExC_seen_zerolen++;
13007             ret = reg_node(pRExC_state, SBOL);
13008             /* SBOL is shared with /^/ so we set the flags so we can tell
13009              * /\A/ from /^/ in split. We check ret because first pass we
13010              * have no regop struct to set the flags on. */
13011             if (PASS2)
13012                 ret->flags = 1;
13013             *flagp |= SIMPLE;
13014             goto finish_meta_pat;
13015         case 'G':
13016             ret = reg_node(pRExC_state, GPOS);
13017             RExC_seen |= REG_GPOS_SEEN;
13018             *flagp |= SIMPLE;
13019             goto finish_meta_pat;
13020         case 'K':
13021             RExC_seen_zerolen++;
13022             ret = reg_node(pRExC_state, KEEPS);
13023             *flagp |= SIMPLE;
13024             /* XXX:dmq : disabling in-place substitution seems to
13025              * be necessary here to avoid cases of memory corruption, as
13026              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
13027              */
13028             RExC_seen |= REG_LOOKBEHIND_SEEN;
13029             goto finish_meta_pat;
13030         case 'Z':
13031             ret = reg_node(pRExC_state, SEOL);
13032             *flagp |= SIMPLE;
13033             RExC_seen_zerolen++;                /* Do not optimize RE away */
13034             goto finish_meta_pat;
13035         case 'z':
13036             ret = reg_node(pRExC_state, EOS);
13037             *flagp |= SIMPLE;
13038             RExC_seen_zerolen++;                /* Do not optimize RE away */
13039             goto finish_meta_pat;
13040         case 'C':
13041             vFAIL("\\C no longer supported");
13042         case 'X':
13043             ret = reg_node(pRExC_state, CLUMP);
13044             *flagp |= HASWIDTH;
13045             goto finish_meta_pat;
13046
13047         case 'W':
13048             invert = 1;
13049             /* FALLTHROUGH */
13050         case 'w':
13051             arg = ANYOF_WORDCHAR;
13052             goto join_posix;
13053
13054         case 'B':
13055             invert = 1;
13056             /* FALLTHROUGH */
13057         case 'b':
13058           {
13059             regex_charset charset = get_regex_charset(RExC_flags);
13060
13061             RExC_seen_zerolen++;
13062             RExC_seen |= REG_LOOKBEHIND_SEEN;
13063             op = BOUND + charset;
13064
13065             if (op == BOUNDL) {
13066                 RExC_contains_locale = 1;
13067             }
13068
13069             ret = reg_node(pRExC_state, op);
13070             *flagp |= SIMPLE;
13071             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
13072                 FLAGS(ret) = TRADITIONAL_BOUND;
13073                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
13074                     OP(ret) = BOUNDA;
13075                 }
13076             }
13077             else {
13078                 STRLEN length;
13079                 char name = *RExC_parse;
13080                 char * endbrace = NULL;
13081                 RExC_parse += 2;
13082                 if (RExC_parse < RExC_end) {
13083                     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13084                 }
13085
13086                 if (! endbrace) {
13087                     vFAIL2("Missing right brace on \\%c{}", name);
13088                 }
13089                 /* XXX Need to decide whether to take spaces or not.  Should be
13090                  * consistent with \p{}, but that currently is SPACE, which
13091                  * means vertical too, which seems wrong
13092                  * while (isBLANK(*RExC_parse)) {
13093                     RExC_parse++;
13094                 }*/
13095                 if (endbrace == RExC_parse) {
13096                     RExC_parse++;  /* After the '}' */
13097                     vFAIL2("Empty \\%c{}", name);
13098                 }
13099                 length = endbrace - RExC_parse;
13100                 /*while (isBLANK(*(RExC_parse + length - 1))) {
13101                     length--;
13102                 }*/
13103                 switch (*RExC_parse) {
13104                     case 'g':
13105                         if (    length != 1
13106                             && (memNEs(RExC_parse + 1, length - 1, "cb")))
13107                         {
13108                             goto bad_bound_type;
13109                         }
13110                         FLAGS(ret) = GCB_BOUND;
13111                         break;
13112                     case 'l':
13113                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13114                             goto bad_bound_type;
13115                         }
13116                         FLAGS(ret) = LB_BOUND;
13117                         break;
13118                     case 's':
13119                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13120                             goto bad_bound_type;
13121                         }
13122                         FLAGS(ret) = SB_BOUND;
13123                         break;
13124                     case 'w':
13125                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13126                             goto bad_bound_type;
13127                         }
13128                         FLAGS(ret) = WB_BOUND;
13129                         break;
13130                     default:
13131                       bad_bound_type:
13132                         RExC_parse = endbrace;
13133                         vFAIL2utf8f(
13134                             "'%" UTF8f "' is an unknown bound type",
13135                             UTF8fARG(UTF, length, endbrace - length));
13136                         NOT_REACHED; /*NOTREACHED*/
13137                 }
13138                 RExC_parse = endbrace;
13139                 REQUIRE_UNI_RULES(flagp, NULL);
13140
13141                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
13142                     OP(ret) = BOUNDU;
13143                     length += 4;
13144
13145                     /* Don't have to worry about UTF-8, in this message because
13146                      * to get here the contents of the \b must be ASCII */
13147                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
13148                               "Using /u for '%.*s' instead of /%s",
13149                               (unsigned) length,
13150                               endbrace - length + 1,
13151                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
13152                               ? ASCII_RESTRICT_PAT_MODS
13153                               : ASCII_MORE_RESTRICT_PAT_MODS);
13154                 }
13155             }
13156
13157             if (PASS2 && invert) {
13158                 OP(ret) += NBOUND - BOUND;
13159             }
13160             goto finish_meta_pat;
13161           }
13162
13163         case 'D':
13164             invert = 1;
13165             /* FALLTHROUGH */
13166         case 'd':
13167             arg = ANYOF_DIGIT;
13168             if (! DEPENDS_SEMANTICS) {
13169                 goto join_posix;
13170             }
13171
13172             /* \d doesn't have any matches in the upper Latin1 range, hence /d
13173              * is equivalent to /u.  Changing to /u saves some branches at
13174              * runtime */
13175             op = POSIXU;
13176             goto join_posix_op_known;
13177
13178         case 'R':
13179             ret = reg_node(pRExC_state, LNBREAK);
13180             *flagp |= HASWIDTH|SIMPLE;
13181             goto finish_meta_pat;
13182
13183         case 'H':
13184             invert = 1;
13185             /* FALLTHROUGH */
13186         case 'h':
13187             arg = ANYOF_BLANK;
13188             op = POSIXU;
13189             goto join_posix_op_known;
13190
13191         case 'V':
13192             invert = 1;
13193             /* FALLTHROUGH */
13194         case 'v':
13195             arg = ANYOF_VERTWS;
13196             op = POSIXU;
13197             goto join_posix_op_known;
13198
13199         case 'S':
13200             invert = 1;
13201             /* FALLTHROUGH */
13202         case 's':
13203             arg = ANYOF_SPACE;
13204
13205           join_posix:
13206
13207             op = POSIXD + get_regex_charset(RExC_flags);
13208             if (op > POSIXA) {  /* /aa is same as /a */
13209                 op = POSIXA;
13210             }
13211             else if (op == POSIXL) {
13212                 RExC_contains_locale = 1;
13213             }
13214
13215           join_posix_op_known:
13216
13217             if (invert) {
13218                 op += NPOSIXD - POSIXD;
13219             }
13220
13221             ret = reg_node(pRExC_state, op);
13222             if (! SIZE_ONLY) {
13223                 FLAGS(ret) = namedclass_to_classnum(arg);
13224             }
13225
13226             *flagp |= HASWIDTH|SIMPLE;
13227             /* FALLTHROUGH */
13228
13229           finish_meta_pat:
13230             if (   UCHARAT(RExC_parse + 1) == '{'
13231                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
13232             {
13233                 RExC_parse += 2;
13234                 vFAIL("Unescaped left brace in regex is illegal here");
13235             }
13236             nextchar(pRExC_state);
13237             Set_Node_Length(ret, 2); /* MJD */
13238             break;
13239         case 'p':
13240         case 'P':
13241             RExC_parse--;
13242
13243             ret = regclass(pRExC_state, flagp,depth+1,
13244                            TRUE, /* means just parse this element */
13245                            FALSE, /* don't allow multi-char folds */
13246                            FALSE, /* don't silence non-portable warnings.  It
13247                                      would be a bug if these returned
13248                                      non-portables */
13249                            (bool) RExC_strict,
13250                            TRUE, /* Allow an optimized regnode result */
13251                            NULL,
13252                            NULL);
13253             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13254             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
13255              * multi-char folds are allowed.  */
13256             if (!ret)
13257                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
13258                       (UV) *flagp);
13259
13260             RExC_parse--;
13261
13262             Set_Node_Offset(ret, parse_start);
13263             Set_Node_Cur_Length(ret, parse_start - 2);
13264             nextchar(pRExC_state);
13265             break;
13266         case 'N':
13267             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
13268              * \N{...} evaluates to a sequence of more than one code points).
13269              * The function call below returns a regnode, which is our result.
13270              * The parameters cause it to fail if the \N{} evaluates to a
13271              * single code point; we handle those like any other literal.  The
13272              * reason that the multicharacter case is handled here and not as
13273              * part of the EXACtish code is because of quantifiers.  In
13274              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
13275              * this way makes that Just Happen. dmq.
13276              * join_exact() will join this up with adjacent EXACTish nodes
13277              * later on, if appropriate. */
13278             ++RExC_parse;
13279             if (grok_bslash_N(pRExC_state,
13280                               &ret,     /* Want a regnode returned */
13281                               NULL,     /* Fail if evaluates to a single code
13282                                            point */
13283                               NULL,     /* Don't need a count of how many code
13284                                            points */
13285                               flagp,
13286                               RExC_strict,
13287                               depth)
13288             ) {
13289                 break;
13290             }
13291
13292             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13293
13294             /* Here, evaluates to a single code point.  Go get that */
13295             RExC_parse = parse_start;
13296             goto defchar;
13297
13298         case 'k':    /* Handle \k<NAME> and \k'NAME' */
13299       parse_named_seq:
13300         {
13301             char ch;
13302             if (   RExC_parse >= RExC_end - 1
13303                 || ((   ch = RExC_parse[1]) != '<'
13304                                       && ch != '\''
13305                                       && ch != '{'))
13306             {
13307                 RExC_parse++;
13308                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13309                 vFAIL2("Sequence %.2s... not terminated",parse_start);
13310             } else {
13311                 RExC_parse += 2;
13312                 ret = handle_named_backref(pRExC_state,
13313                                            flagp,
13314                                            parse_start,
13315                                            (ch == '<')
13316                                            ? '>'
13317                                            : (ch == '{')
13318                                              ? '}'
13319                                              : '\'');
13320             }
13321             break;
13322         }
13323         case 'g':
13324         case '1': case '2': case '3': case '4':
13325         case '5': case '6': case '7': case '8': case '9':
13326             {
13327                 I32 num;
13328                 bool hasbrace = 0;
13329
13330                 if (*RExC_parse == 'g') {
13331                     bool isrel = 0;
13332
13333                     RExC_parse++;
13334                     if (*RExC_parse == '{') {
13335                         RExC_parse++;
13336                         hasbrace = 1;
13337                     }
13338                     if (*RExC_parse == '-') {
13339                         RExC_parse++;
13340                         isrel = 1;
13341                     }
13342                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13343                         if (isrel) RExC_parse--;
13344                         RExC_parse -= 2;
13345                         goto parse_named_seq;
13346                     }
13347
13348                     if (RExC_parse >= RExC_end) {
13349                         goto unterminated_g;
13350                     }
13351                     num = S_backref_value(RExC_parse);
13352                     if (num == 0)
13353                         vFAIL("Reference to invalid group 0");
13354                     else if (num == I32_MAX) {
13355                          if (isDIGIT(*RExC_parse))
13356                             vFAIL("Reference to nonexistent group");
13357                         else
13358                           unterminated_g:
13359                             vFAIL("Unterminated \\g... pattern");
13360                     }
13361
13362                     if (isrel) {
13363                         num = RExC_npar - num;
13364                         if (num < 1)
13365                             vFAIL("Reference to nonexistent or unclosed group");
13366                     }
13367                 }
13368                 else {
13369                     num = S_backref_value(RExC_parse);
13370                     /* bare \NNN might be backref or octal - if it is larger
13371                      * than or equal RExC_npar then it is assumed to be an
13372                      * octal escape. Note RExC_npar is +1 from the actual
13373                      * number of parens. */
13374                     /* Note we do NOT check if num == I32_MAX here, as that is
13375                      * handled by the RExC_npar check */
13376
13377                     if (
13378                         /* any numeric escape < 10 is always a backref */
13379                         num > 9
13380                         /* any numeric escape < RExC_npar is a backref */
13381                         && num >= RExC_npar
13382                         /* cannot be an octal escape if it starts with 8 */
13383                         && *RExC_parse != '8'
13384                         /* cannot be an octal escape it it starts with 9 */
13385                         && *RExC_parse != '9'
13386                     )
13387                     {
13388                         /* Probably not a backref, instead likely to be an
13389                          * octal character escape, e.g. \35 or \777.
13390                          * The above logic should make it obvious why using
13391                          * octal escapes in patterns is problematic. - Yves */
13392                         RExC_parse = parse_start;
13393                         goto defchar;
13394                     }
13395                 }
13396
13397                 /* At this point RExC_parse points at a numeric escape like
13398                  * \12 or \88 or something similar, which we should NOT treat
13399                  * as an octal escape. It may or may not be a valid backref
13400                  * escape. For instance \88888888 is unlikely to be a valid
13401                  * backref. */
13402                 while (isDIGIT(*RExC_parse))
13403                     RExC_parse++;
13404                 if (hasbrace) {
13405                     if (*RExC_parse != '}')
13406                         vFAIL("Unterminated \\g{...} pattern");
13407                     RExC_parse++;
13408                 }
13409                 if (!SIZE_ONLY) {
13410                     if (num > (I32)RExC_rx->nparens)
13411                         vFAIL("Reference to nonexistent group");
13412                 }
13413                 RExC_sawback = 1;
13414                 ret = reganode(pRExC_state,
13415                                ((! FOLD)
13416                                  ? REF
13417                                  : (ASCII_FOLD_RESTRICTED)
13418                                    ? REFFA
13419                                    : (AT_LEAST_UNI_SEMANTICS)
13420                                      ? REFFU
13421                                      : (LOC)
13422                                        ? REFFL
13423                                        : REFF),
13424                                 num);
13425                 *flagp |= HASWIDTH;
13426
13427                 /* override incorrect value set in reganode MJD */
13428                 Set_Node_Offset(ret, parse_start);
13429                 Set_Node_Cur_Length(ret, parse_start-1);
13430                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13431                                         FALSE /* Don't force to /x */ );
13432             }
13433             break;
13434         case '\0':
13435             if (RExC_parse >= RExC_end)
13436                 FAIL("Trailing \\");
13437             /* FALLTHROUGH */
13438         default:
13439             /* Do not generate "unrecognized" warnings here, we fall
13440                back into the quick-grab loop below */
13441             RExC_parse = parse_start;
13442             goto defchar;
13443         } /* end of switch on a \foo sequence */
13444         break;
13445
13446     case '#':
13447
13448         /* '#' comments should have been spaced over before this function was
13449          * called */
13450         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13451         /*
13452         if (RExC_flags & RXf_PMf_EXTENDED) {
13453             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13454             if (RExC_parse < RExC_end)
13455                 goto tryagain;
13456         }
13457         */
13458
13459         /* FALLTHROUGH */
13460
13461     default:
13462           defchar: {
13463
13464             /* Here, we have determined that the next thing is probably a
13465              * literal character.  RExC_parse points to the first byte of its
13466              * definition.  (It still may be an escape sequence that evaluates
13467              * to a single character) */
13468
13469             STRLEN len = 0;
13470             UV ender = 0;
13471             char *p;
13472             char *s;
13473
13474 /* This allows us to fill a node with just enough spare so that if the final
13475  * character folds, its expansion is guaranteed to fit */
13476 #define MAX_NODE_STRING_SIZE (255-UTF8_MAXBYTES_CASE)
13477             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE+1];
13478
13479             char *s0;
13480             U8 upper_parse = MAX_NODE_STRING_SIZE;
13481
13482             /* We start out as an EXACT node, even if under /i, until we find a
13483              * character which is in a fold.  The algorithm now segregates into
13484              * separate nodes, characters that fold from those that don't under
13485              * /i.  (This hopefull will create nodes that are fixed strings
13486              * even under /i, giving the optimizer something to grab onto to.)
13487              * So, if a node has something in it and the next character is in
13488              * the opposite category, that node is closed up, and the function
13489              * returns.  Then regatom is called again, and a new node is
13490              * created for the new category. */
13491             U8 node_type = EXACT;
13492
13493             bool next_is_quantifier;
13494             char * oldp = NULL;
13495
13496             /* We can convert EXACTF nodes to EXACTFU if they contain only
13497              * characters that match identically regardless of the target
13498              * string's UTF8ness.  The reason to do this is that EXACTF is not
13499              * trie-able, EXACTFU is.
13500              *
13501              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13502              * contain only above-Latin1 characters (hence must be in UTF8),
13503              * which don't participate in folds with Latin1-range characters,
13504              * as the latter's folds aren't known until runtime.  (We don't
13505              * need to figure this out until pass 2) */
13506             bool maybe_exactfu = PASS2;
13507
13508             /* The node_type may change below, but since the size of the node
13509              * doesn't change, it works */
13510             ret = reg_node(pRExC_state, node_type);
13511
13512             /* In pass1, folded, we use a temporary buffer instead of the
13513              * actual node, as the node doesn't exist yet */
13514             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13515
13516             s0 = s;
13517
13518           reparse:
13519
13520             /* This breaks under rare circumstances.  If folding, we do not
13521              * want to split a node at a character that is a non-final in a
13522              * multi-char fold, as an input string could just happen to want to
13523              * match across the node boundary.  The code at the end of the loop
13524              * looks for this, and backs off until it finds not such a
13525              * character, but it is possible (though extremely, extremely
13526              * unlikely) for all characters in the node to be non-final fold
13527              * ones, in which case we just leave the node fully filled, and
13528              * hope that it doesn't match the string in just the wrong place */
13529
13530             assert( ! UTF     /* Is at the beginning of a character */
13531                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13532                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13533
13534             /* Here, we have a literal character.  Find the maximal string of
13535              * them in the input that we can fit into a single EXACTish node.
13536              * We quit at the first non-literal or when the node gets full, or
13537              * under /i the categorization of folding/non-folding character
13538              * changes */
13539             for (p = RExC_parse; len < upper_parse && p < RExC_end; ) {
13540
13541                 /* In most cases each iteration adds one byte to the output.
13542                  * The exceptions override this */
13543                 Size_t added_len = 1;
13544
13545                 oldp = p;
13546
13547                 /* White space has already been ignored */
13548                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13549                        || ! is_PATWS_safe((p), RExC_end, UTF));
13550
13551                 switch ((U8)*p) {
13552                 case '^':
13553                 case '$':
13554                 case '.':
13555                 case '[':
13556                 case '(':
13557                 case ')':
13558                 case '|':
13559                     goto loopdone;
13560                 case '\\':
13561                     /* Literal Escapes Switch
13562
13563                        This switch is meant to handle escape sequences that
13564                        resolve to a literal character.
13565
13566                        Every escape sequence that represents something
13567                        else, like an assertion or a char class, is handled
13568                        in the switch marked 'Special Escapes' above in this
13569                        routine, but also has an entry here as anything that
13570                        isn't explicitly mentioned here will be treated as
13571                        an unescaped equivalent literal.
13572                     */
13573
13574                     switch ((U8)*++p) {
13575                     /* These are all the special escapes. */
13576                     case 'A':             /* Start assertion */
13577                     case 'b': case 'B':   /* Word-boundary assertion*/
13578                     case 'C':             /* Single char !DANGEROUS! */
13579                     case 'd': case 'D':   /* digit class */
13580                     case 'g': case 'G':   /* generic-backref, pos assertion */
13581                     case 'h': case 'H':   /* HORIZWS */
13582                     case 'k': case 'K':   /* named backref, keep marker */
13583                     case 'p': case 'P':   /* Unicode property */
13584                               case 'R':   /* LNBREAK */
13585                     case 's': case 'S':   /* space class */
13586                     case 'v': case 'V':   /* VERTWS */
13587                     case 'w': case 'W':   /* word class */
13588                     case 'X':             /* eXtended Unicode "combining
13589                                              character sequence" */
13590                     case 'z': case 'Z':   /* End of line/string assertion */
13591                         --p;
13592                         goto loopdone;
13593
13594                     /* Anything after here is an escape that resolves to a
13595                        literal. (Except digits, which may or may not)
13596                      */
13597                     case 'n':
13598                         ender = '\n';
13599                         p++;
13600                         break;
13601                     case 'N': /* Handle a single-code point named character. */
13602                         RExC_parse = p + 1;
13603                         if (! grok_bslash_N(pRExC_state,
13604                                             NULL,   /* Fail if evaluates to
13605                                                        anything other than a
13606                                                        single code point */
13607                                             &ender, /* The returned single code
13608                                                        point */
13609                                             NULL,   /* Don't need a count of
13610                                                        how many code points */
13611                                             flagp,
13612                                             RExC_strict,
13613                                             depth)
13614                         ) {
13615                             if (*flagp & NEED_UTF8)
13616                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13617                             RETURN_NULL_ON_RESTART_FLAGP(flagp);
13618
13619                             /* Here, it wasn't a single code point.  Go close
13620                              * up this EXACTish node.  The switch() prior to
13621                              * this switch handles the other cases */
13622                             RExC_parse = p = oldp;
13623                             goto loopdone;
13624                         }
13625                         p = RExC_parse;
13626                         RExC_parse = parse_start;
13627                         if (ender > 0xff) {
13628                             REQUIRE_UTF8(flagp);
13629                         }
13630                         break;
13631                     case 'r':
13632                         ender = '\r';
13633                         p++;
13634                         break;
13635                     case 't':
13636                         ender = '\t';
13637                         p++;
13638                         break;
13639                     case 'f':
13640                         ender = '\f';
13641                         p++;
13642                         break;
13643                     case 'e':
13644                         ender = ESC_NATIVE;
13645                         p++;
13646                         break;
13647                     case 'a':
13648                         ender = '\a';
13649                         p++;
13650                         break;
13651                     case 'o':
13652                         {
13653                             UV result;
13654                             const char* error_msg;
13655
13656                             bool valid = grok_bslash_o(&p,
13657                                                        RExC_end,
13658                                                        &result,
13659                                                        &error_msg,
13660                                                        PASS2, /* out warnings */
13661                                                        (bool) RExC_strict,
13662                                                        TRUE, /* Output warnings
13663                                                                 for non-
13664                                                                 portables */
13665                                                        UTF);
13666                             if (! valid) {
13667                                 RExC_parse = p; /* going to die anyway; point
13668                                                    to exact spot of failure */
13669                                 vFAIL(error_msg);
13670                             }
13671                             ender = result;
13672                             if (ender > 0xff) {
13673                                 REQUIRE_UTF8(flagp);
13674                             }
13675                             break;
13676                         }
13677                     case 'x':
13678                         {
13679                             UV result = UV_MAX; /* initialize to erroneous
13680                                                    value */
13681                             const char* error_msg;
13682
13683                             bool valid = grok_bslash_x(&p,
13684                                                        RExC_end,
13685                                                        &result,
13686                                                        &error_msg,
13687                                                        PASS2, /* out warnings */
13688                                                        (bool) RExC_strict,
13689                                                        TRUE, /* Silence warnings
13690                                                                 for non-
13691                                                                 portables */
13692                                                        UTF);
13693                             if (! valid) {
13694                                 RExC_parse = p; /* going to die anyway; point
13695                                                    to exact spot of failure */
13696                                 vFAIL(error_msg);
13697                             }
13698                             ender = result;
13699
13700                             if (ender < 0x100) {
13701 #ifdef EBCDIC
13702                                 if (RExC_recode_x_to_native) {
13703                                     ender = LATIN1_TO_NATIVE(ender);
13704                                 }
13705 #endif
13706                             }
13707                             else {
13708                                 REQUIRE_UTF8(flagp);
13709                             }
13710                             break;
13711                         }
13712                     case 'c':
13713                         p++;
13714                         ender = grok_bslash_c(*p++, PASS2);
13715                         break;
13716                     case '8': case '9': /* must be a backreference */
13717                         --p;
13718                         /* we have an escape like \8 which cannot be an octal escape
13719                          * so we exit the loop, and let the outer loop handle this
13720                          * escape which may or may not be a legitimate backref. */
13721                         goto loopdone;
13722                     case '1': case '2': case '3':case '4':
13723                     case '5': case '6': case '7':
13724                         /* When we parse backslash escapes there is ambiguity
13725                          * between backreferences and octal escapes. Any escape
13726                          * from \1 - \9 is a backreference, any multi-digit
13727                          * escape which does not start with 0 and which when
13728                          * evaluated as decimal could refer to an already
13729                          * parsed capture buffer is a back reference. Anything
13730                          * else is octal.
13731                          *
13732                          * Note this implies that \118 could be interpreted as
13733                          * 118 OR as "\11" . "8" depending on whether there
13734                          * were 118 capture buffers defined already in the
13735                          * pattern.  */
13736
13737                         /* NOTE, RExC_npar is 1 more than the actual number of
13738                          * parens we have seen so far, hence the < RExC_npar below. */
13739
13740                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13741                         {  /* Not to be treated as an octal constant, go
13742                                    find backref */
13743                             --p;
13744                             goto loopdone;
13745                         }
13746                         /* FALLTHROUGH */
13747                     case '0':
13748                         {
13749                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13750                             STRLEN numlen = 3;
13751                             ender = grok_oct(p, &numlen, &flags, NULL);
13752                             if (ender > 0xff) {
13753                                 REQUIRE_UTF8(flagp);
13754                             }
13755                             p += numlen;
13756                             if (PASS2   /* like \08, \178 */
13757                                 && numlen < 3
13758                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13759                             {
13760                                 reg_warn_non_literal_string(
13761                                          p + 1,
13762                                          form_short_octal_warning(p, numlen));
13763                             }
13764                         }
13765                         break;
13766                     case '\0':
13767                         if (p >= RExC_end)
13768                             FAIL("Trailing \\");
13769                         /* FALLTHROUGH */
13770                     default:
13771                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13772                             /* Include any left brace following the alpha to emphasize
13773                              * that it could be part of an escape at some point
13774                              * in the future */
13775                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13776                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13777                         }
13778                         goto normal_default;
13779                     } /* End of switch on '\' */
13780                     break;
13781                 case '{':
13782                     /* Currently we allow an lbrace at the start of a construct
13783                      * without raising a warning.  This is because we think we
13784                      * will never want such a brace to be meant to be other
13785                      * than taken literally. */
13786                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
13787
13788                         /* But, we raise a fatal warning otherwise, as the
13789                          * deprecation cycle has come and gone.  Except that it
13790                          * turns out that some heavily-relied on upstream
13791                          * software, notably GNU Autoconf, have failed to fix
13792                          * their uses.  For these, don't make it fatal unless
13793                          * we anticipate using the '{' for something else.
13794                          * This happens after any alpha, and for a looser {m,n}
13795                          * quantifier specification */
13796                         if (      RExC_strict
13797                             || (  p > parse_start + 1
13798                                 && isALPHA_A(*(p - 1))
13799                                 && *(p - 2) == '\\')
13800                             || new_regcurly(p, RExC_end))
13801                         {
13802                             RExC_parse = p + 1;
13803                             vFAIL("Unescaped left brace in regex is "
13804                                   "illegal here");
13805                         }
13806                         if (PASS2) {
13807                             ckWARNregdep(p + 1,
13808                                         "Unescaped left brace in regex is "
13809                                         "deprecated here (and will be fatal "
13810                                         "in Perl 5.30), passed through");
13811                         }
13812                     }
13813                     goto normal_default;
13814                 case '}':
13815                 case ']':
13816                     if (PASS2 && p > RExC_parse && RExC_strict) {
13817                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
13818                     }
13819                     /*FALLTHROUGH*/
13820                 default:    /* A literal character */
13821                   normal_default:
13822                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13823                         STRLEN numlen;
13824                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13825                                                &numlen, UTF8_ALLOW_DEFAULT);
13826                         p += numlen;
13827                     }
13828                     else
13829                         ender = (U8) *p++;
13830                     break;
13831                 } /* End of switch on the literal */
13832
13833                 /* Here, have looked at the literal character, and <ender>
13834                  * contains its ordinal; <p> points to the character after it.
13835                  * We need to check if the next non-ignored thing is a
13836                  * quantifier.  Move <p> to after anything that should be
13837                  * ignored, which, as a side effect, positions <p> for the next
13838                  * loop iteration */
13839                 skip_to_be_ignored_text(pRExC_state, &p,
13840                                         FALSE /* Don't force to /x */ );
13841
13842                 /* If the next thing is a quantifier, it applies to this
13843                  * character only, which means that this character has to be in
13844                  * its own node and can't just be appended to the string in an
13845                  * existing node, so if there are already other characters in
13846                  * the node, close the node with just them, and set up to do
13847                  * this character again next time through, when it will be the
13848                  * only thing in its new node */
13849
13850                 next_is_quantifier =    LIKELY(p < RExC_end)
13851                                      && UNLIKELY(ISMULT2(p));
13852
13853                 if (next_is_quantifier && LIKELY(len)) {
13854                     p = oldp;
13855                     goto loopdone;
13856                 }
13857
13858                 /* Ready to add 'ender' to the node */
13859
13860                 if (! FOLD) {  /* The simple case, just append the literal */
13861
13862                     /* In the sizing pass, we need only the size of the
13863                      * character we are appending, hence we can delay getting
13864                      * its representation until PASS2. */
13865                     if (SIZE_ONLY) {
13866                         if (UTF && ! UVCHR_IS_INVARIANT(ender)) {
13867                             const STRLEN unilen = UVCHR_SKIP(ender);
13868                             s += unilen;
13869                             added_len = unilen;
13870                         }
13871                         else {
13872                             s++;
13873                         }
13874                     } else { /* PASS2 */
13875                       not_fold_common:
13876                         if (UTF && ! UVCHR_IS_INVARIANT(ender)) {
13877                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13878                             added_len = (char *) new_s - s;
13879                             s = (char *) new_s;
13880                         }
13881                         else {
13882                             *(s++) = (char) ender;
13883                         }
13884                     }
13885                 }
13886                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13887
13888                     /* Here are folding under /l, and the code point is
13889                      * problematic.  If this is the first character in the
13890                      * node, change the node type to folding.   Otherwise, if
13891                      * this is the first problematic character, close up the
13892                      * existing node, so can start a new node with this one */
13893                     if (! len) {
13894                         node_type = EXACTFL;
13895                     }
13896                     else if (node_type == EXACT) {
13897                         p = oldp;
13898                         goto loopdone;
13899                     }
13900
13901                     /* This code point means we can't simplify things */
13902                     maybe_exactfu = FALSE;
13903
13904                     /* A problematic code point in this context means that its
13905                      * fold isn't known until runtime, so we can't fold it now.
13906                      * (The non-problematic code points are the above-Latin1
13907                      * ones that fold to also all above-Latin1.  Their folds
13908                      * don't vary no matter what the locale is.) But here we
13909                      * have characters whose fold depends on the locale.
13910                      * Unlike the non-folding case above, we have to keep track
13911                      * of these in the sizing pass, so that we can make sure we
13912                      * don't split too-long nodes in the middle of a potential
13913                      * multi-char fold.  And unlike the regular fold case
13914                      * handled in the else clauses below, we don't actually
13915                      * fold and don't have special cases to consider.  What we
13916                      * do for both passes is the PASS2 code for non-folding */
13917                     goto not_fold_common;
13918                 }
13919                 else                /* A regular FOLD code point */
13920                      if (! UTF)
13921                 {
13922                     /* Here, are folding and are not UTF-8 encoded; therefore
13923                      * the character must be in the range 0-255, and is not /l.
13924                      * (Not /l because we already handled these under /l in
13925                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13926                     if (! IS_IN_SOME_FOLD_L1(ender)) {
13927
13928                         /* Start a new node for this non-folding character if
13929                          * previous ones in the node were folded */
13930                         if (len && node_type != EXACT) {
13931                             p = oldp;
13932                             goto loopdone;
13933                         }
13934
13935                         *(s++) = (char) ender;
13936                     }
13937                     else {  /* Here, does participate in some fold */
13938
13939                         /* if this is the first character in the node, change
13940                          * its type to folding.  Otherwise, if this is the
13941                          * first folding character in the node, close up the
13942                          * existing node, so can start a new node with this
13943                          * one.  */
13944                         if (! len) {
13945                             node_type = compute_EXACTish(pRExC_state);
13946                         }
13947                         else if (node_type == EXACT) {
13948                             p = oldp;
13949                             goto loopdone;
13950                         }
13951
13952                         /* See if the character's fold differs between /d and
13953                          * /u.  On non-ancient Unicode versions, this includes
13954                          * the multi-char fold SHARP S to 'ss' */
13955
13956 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13957    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13958                                       || UNICODE_DOT_DOT_VERSION > 0)
13959
13960                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13961
13962                             /* See comments for join_exact() as to why we fold
13963                              * this non-UTF at compile time */
13964                             if (node_type == EXACTFU) {
13965                                 *(s++) = 's';
13966
13967                                 /* Let the code below add in the extra 's' */
13968                                 ender = 's';
13969                                 added_len = 2;
13970                             }
13971                             else {
13972                                 RExC_seen_unfolded_sharp_s = 1;
13973                                 maybe_exactfu = FALSE;
13974                             }
13975                         }
13976                         else if (   len
13977                                  && isALPHA_FOLD_EQ(ender, 's')
13978                                  && isALPHA_FOLD_EQ(*(s-1), 's'))
13979                         {
13980                             maybe_exactfu = FALSE;
13981                         }
13982                         else
13983 #endif
13984
13985                         if (PL_fold[ender] != PL_fold_latin1[ender]) {
13986                             maybe_exactfu = FALSE;
13987                         }
13988
13989                         /* Even when folding, we store just the input
13990                          * character, as we have an array that finds its fold
13991                          * quickly */
13992                         *(s++) = (char) ender;
13993                     }
13994                 }
13995                 else {  /* FOLD, and UTF */
13996                     /* Unlike the non-fold case, we do actually have to
13997                      * calculate the fold in pass 1.  This is for two reasons,
13998                      * the folded length may be longer than the unfolded, and
13999                      * we have to calculate how many EXACTish nodes it will
14000                      * take; and we may run out of room in a node in the middle
14001                      * of a potential multi-char fold, and have to back off
14002                      * accordingly.  */
14003
14004                     if (isASCII_uni(ender)) {
14005
14006                         /* As above, we close up and start a new node if the
14007                          * previous characters don't match the fold/non-fold
14008                          * state of this one.  And if this is the first
14009                          * character in the node, and it folds, we change the
14010                          * node away from being EXACT */
14011                         if (! IS_IN_SOME_FOLD_L1(ender)) {
14012                             if (len && node_type != EXACT) {
14013                                 p = oldp;
14014                                 goto loopdone;
14015                             }
14016
14017                             *(s)++ = (U8) ender;
14018                         }
14019                         else {  /* Is in a fold */
14020
14021                             if (! len) {
14022                                 node_type = compute_EXACTish(pRExC_state);
14023                             }
14024                             else if (node_type == EXACT) {
14025                                 p = oldp;
14026                                 goto loopdone;
14027                             }
14028
14029                             *(s)++ = (U8) toFOLD(ender);
14030                         }
14031                     }
14032                     else {  /* Not ASCII */
14033                         STRLEN foldlen;
14034
14035                         /* As above, we close up and start a new node if the
14036                          * previous characters don't match the fold/non-fold
14037                          * state of this one.  And if this is the first
14038                          * character in the node, and it folds, we change the
14039                          * node away from being EXACT */
14040                         if (! _invlist_contains_cp(PL_utf8_foldable, ender)) {
14041                             if (len && node_type != EXACT) {
14042                                 p = oldp;
14043                                 goto loopdone;
14044                             }
14045
14046                             s = (char *) uvchr_to_utf8((U8 *) s, ender);
14047                             added_len = UVCHR_SKIP(ender);
14048                         }
14049                         else {
14050
14051                             if (! len) {
14052                                 node_type = compute_EXACTish(pRExC_state);
14053                             }
14054                             else if (node_type == EXACT) {
14055                                 p = oldp;
14056                                 goto loopdone;
14057                             }
14058
14059                             ender = _to_uni_fold_flags(
14060                                      ender,
14061                                      (U8 *) s,
14062                                      &foldlen,
14063                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
14064                                                         ? FOLD_FLAGS_NOMIX_ASCII
14065                                                         : 0));
14066                             s += foldlen;
14067                             added_len = foldlen;
14068                         }
14069                     }
14070                 }
14071
14072                 len += added_len;
14073
14074                 if (next_is_quantifier) {
14075
14076                     /* Here, the next input is a quantifier, and to get here,
14077                      * the current character is the only one in the node. */
14078                     goto loopdone;
14079                 }
14080
14081             } /* End of loop through literal characters */
14082
14083             /* Here we have either exhausted the input or ran out of room in
14084              * the node.  (If we encountered a character that can't be in the
14085              * node, transfer is made directly to <loopdone>, and so we
14086              * wouldn't have fallen off the end of the loop.)  In the latter
14087              * case, we artificially have to split the node into two, because
14088              * we just don't have enough space to hold everything.  This
14089              * creates a problem if the final character participates in a
14090              * multi-character fold in the non-final position, as a match that
14091              * should have occurred won't, due to the way nodes are matched,
14092              * and our artificial boundary.  So back off until we find a non-
14093              * problematic character -- one that isn't at the beginning or
14094              * middle of such a fold.  (Either it doesn't participate in any
14095              * folds, or appears only in the final position of all the folds it
14096              * does participate in.)  A better solution with far fewer false
14097              * positives, and that would fill the nodes more completely, would
14098              * be to actually have available all the multi-character folds to
14099              * test against, and to back-off only far enough to be sure that
14100              * this node isn't ending with a partial one.  <upper_parse> is set
14101              * further below (if we need to reparse the node) to include just
14102              * up through that final non-problematic character that this code
14103              * identifies, so when it is set to less than the full node, we can
14104              * skip the rest of this */
14105             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
14106
14107                 const STRLEN full_len = len;
14108
14109                 assert(len >= MAX_NODE_STRING_SIZE);
14110
14111                 /* Here, <s> points to the final byte of the final character.
14112                  * Look backwards through the string until find a non-
14113                  * problematic character */
14114
14115                 if (! UTF) {
14116
14117                     /* This has no multi-char folds to non-UTF characters */
14118                     if (ASCII_FOLD_RESTRICTED) {
14119                         goto loopdone;
14120                     }
14121
14122                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
14123                     len = s - s0 + 1;
14124                 }
14125                 else {
14126
14127                     /* Point to the first byte of the final character */
14128                     s = (char *) utf8_hop((U8 *) s, -1);
14129
14130                     while (s >= s0) {   /* Search backwards until find
14131                                            a non-problematic char */
14132                         if (UTF8_IS_INVARIANT(*s)) {
14133
14134                             /* There are no ascii characters that participate
14135                              * in multi-char folds under /aa.  In EBCDIC, the
14136                              * non-ascii invariants are all control characters,
14137                              * so don't ever participate in any folds. */
14138                             if (ASCII_FOLD_RESTRICTED
14139                                 || ! IS_NON_FINAL_FOLD(*s))
14140                             {
14141                                 break;
14142                             }
14143                         }
14144                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
14145                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
14146                                                                   *s, *(s+1))))
14147                             {
14148                                 break;
14149                             }
14150                         }
14151                         else if (! _invlist_contains_cp(
14152                                         PL_NonL1NonFinalFold,
14153                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
14154                         {
14155                             break;
14156                         }
14157
14158                         /* Here, the current character is problematic in that
14159                          * it does occur in the non-final position of some
14160                          * fold, so try the character before it, but have to
14161                          * special case the very first byte in the string, so
14162                          * we don't read outside the string */
14163                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
14164                     } /* End of loop backwards through the string */
14165
14166                     /* If there were only problematic characters in the string,
14167                      * <s> will point to before s0, in which case the length
14168                      * should be 0, otherwise include the length of the
14169                      * non-problematic character just found */
14170                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
14171                 }
14172
14173                 /* Here, have found the final character, if any, that is
14174                  * non-problematic as far as ending the node without splitting
14175                  * it across a potential multi-char fold.  <len> contains the
14176                  * number of bytes in the node up-to and including that
14177                  * character, or is 0 if there is no such character, meaning
14178                  * the whole node contains only problematic characters.  In
14179                  * this case, give up and just take the node as-is.  We can't
14180                  * do any better */
14181                 if (len == 0) {
14182                     len = full_len;
14183
14184                     /* If the node ends in an 's' we make sure it stays EXACTF,
14185                      * as if it turns into an EXACTFU, it could later get
14186                      * joined with another 's' that would then wrongly match
14187                      * the sharp s */
14188                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
14189                     {
14190                         maybe_exactfu = FALSE;
14191                     }
14192                 } else {
14193
14194                     /* Here, the node does contain some characters that aren't
14195                      * problematic.  If one such is the final character in the
14196                      * node, we are done */
14197                     if (len == full_len) {
14198                         goto loopdone;
14199                     }
14200                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
14201
14202                         /* If the final character is problematic, but the
14203                          * penultimate is not, back-off that last character to
14204                          * later start a new node with it */
14205                         p = oldp;
14206                         goto loopdone;
14207                     }
14208
14209                     /* Here, the final non-problematic character is earlier
14210                      * in the input than the penultimate character.  What we do
14211                      * is reparse from the beginning, going up only as far as
14212                      * this final ok one, thus guaranteeing that the node ends
14213                      * in an acceptable character.  The reason we reparse is
14214                      * that we know how far in the character is, but we don't
14215                      * know how to correlate its position with the input parse.
14216                      * An alternate implementation would be to build that
14217                      * correlation as we go along during the original parse,
14218                      * but that would entail extra work for every node, whereas
14219                      * this code gets executed only when the string is too
14220                      * large for the node, and the final two characters are
14221                      * problematic, an infrequent occurrence.  Yet another
14222                      * possible strategy would be to save the tail of the
14223                      * string, and the next time regatom is called, initialize
14224                      * with that.  The problem with this is that unless you
14225                      * back off one more character, you won't be guaranteed
14226                      * regatom will get called again, unless regbranch,
14227                      * regpiece ... are also changed.  If you do back off that
14228                      * extra character, so that there is input guaranteed to
14229                      * force calling regatom, you can't handle the case where
14230                      * just the first character in the node is acceptable.  I
14231                      * (khw) decided to try this method which doesn't have that
14232                      * pitfall; if performance issues are found, we can do a
14233                      * combination of the current approach plus that one */
14234                     upper_parse = len;
14235                     len = 0;
14236                     s = s0;
14237                     goto reparse;
14238                 }
14239             }   /* End of verifying node ends with an appropriate char */
14240
14241           loopdone:   /* Jumped to when encounters something that shouldn't be
14242                          in the node */
14243
14244             /* I (khw) don't know if you can get here with zero length, but the
14245              * old code handled this situation by creating a zero-length EXACT
14246              * node.  Might as well be NOTHING instead */
14247             if (len == 0) {
14248                 OP(ret) = NOTHING;
14249             }
14250             else {
14251                 OP(ret) = node_type;
14252
14253                 /* If the node type is EXACT here, check to see if it
14254                  * should be EXACTL. */
14255                 if (node_type == EXACT) {
14256                     if (LOC) {
14257                         OP(ret) = EXACTL;
14258                     }
14259                 }
14260
14261                 if (FOLD) {
14262                     /* If 'maybe_exactfu' is set, then there are no code points
14263                      * that match differently depending on UTF8ness of the
14264                      * target string (for /u), or depending on locale for /l */
14265                     if (maybe_exactfu) {
14266                         if (node_type == EXACTF) {
14267                             OP(ret) = EXACTFU;
14268                         }
14269                         else if (node_type == EXACTFL) {
14270                             OP(ret) = EXACTFLU8;
14271                         }
14272                     }
14273                 }
14274
14275                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
14276                                            FALSE /* Don't look to see if could
14277                                                     be turned into an EXACT
14278                                                     node, as we have already
14279                                                     computed that */
14280                                           );
14281             }
14282
14283             RExC_parse = p - 1;
14284             Set_Node_Cur_Length(ret, parse_start);
14285             RExC_parse = p;
14286             {
14287                 /* len is STRLEN which is unsigned, need to copy to signed */
14288                 IV iv = len;
14289                 if (iv < 0)
14290                     vFAIL("Internal disaster");
14291             }
14292
14293         } /* End of label 'defchar:' */
14294         break;
14295     } /* End of giant switch on input character */
14296
14297     /* Position parse to next real character */
14298     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14299                                             FALSE /* Don't force to /x */ );
14300     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
14301         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here (and will be fatal in Perl 5.30), passed through");
14302     }
14303
14304     return(ret);
14305 }
14306
14307
14308 STATIC void
14309 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
14310 {
14311     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
14312      * sets up the bitmap and any flags, removing those code points from the
14313      * inversion list, setting it to NULL should it become completely empty */
14314
14315     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
14316     assert(PL_regkind[OP(node)] == ANYOF);
14317
14318     ANYOF_BITMAP_ZERO(node);
14319     if (*invlist_ptr) {
14320
14321         /* This gets set if we actually need to modify things */
14322         bool change_invlist = FALSE;
14323
14324         UV start, end;
14325
14326         /* Start looking through *invlist_ptr */
14327         invlist_iterinit(*invlist_ptr);
14328         while (invlist_iternext(*invlist_ptr, &start, &end)) {
14329             UV high;
14330             int i;
14331
14332             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
14333                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
14334             }
14335
14336             /* Quit if are above what we should change */
14337             if (start >= NUM_ANYOF_CODE_POINTS) {
14338                 break;
14339             }
14340
14341             change_invlist = TRUE;
14342
14343             /* Set all the bits in the range, up to the max that we are doing */
14344             high = (end < NUM_ANYOF_CODE_POINTS - 1)
14345                    ? end
14346                    : NUM_ANYOF_CODE_POINTS - 1;
14347             for (i = start; i <= (int) high; i++) {
14348                 if (! ANYOF_BITMAP_TEST(node, i)) {
14349                     ANYOF_BITMAP_SET(node, i);
14350                 }
14351             }
14352         }
14353         invlist_iterfinish(*invlist_ptr);
14354
14355         /* Done with loop; remove any code points that are in the bitmap from
14356          * *invlist_ptr; similarly for code points above the bitmap if we have
14357          * a flag to match all of them anyways */
14358         if (change_invlist) {
14359             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
14360         }
14361         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
14362             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
14363         }
14364
14365         /* If have completely emptied it, remove it completely */
14366         if (_invlist_len(*invlist_ptr) == 0) {
14367             SvREFCNT_dec_NN(*invlist_ptr);
14368             *invlist_ptr = NULL;
14369         }
14370     }
14371 }
14372
14373 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
14374    Character classes ([:foo:]) can also be negated ([:^foo:]).
14375    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
14376    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
14377    but trigger failures because they are currently unimplemented. */
14378
14379 #define POSIXCC_DONE(c)   ((c) == ':')
14380 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
14381 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
14382 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
14383
14384 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
14385 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
14386 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
14387
14388 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
14389
14390 /* 'posix_warnings' and 'warn_text' are names of variables in the following
14391  * routine. q.v. */
14392 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
14393         if (posix_warnings) {                                               \
14394             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
14395             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
14396                                              WARNING_PREFIX                 \
14397                                              text                           \
14398                                              REPORT_LOCATION,               \
14399                                              REPORT_LOCATION_ARGS(p)));     \
14400         }                                                                   \
14401     } STMT_END
14402 #define CLEAR_POSIX_WARNINGS()                                              \
14403     STMT_START {                                                            \
14404         if (posix_warnings && RExC_warn_text)                               \
14405             av_clear(RExC_warn_text);                                       \
14406     } STMT_END
14407
14408 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
14409     STMT_START {                                                            \
14410         CLEAR_POSIX_WARNINGS();                                             \
14411         return ret;                                                         \
14412     } STMT_END
14413
14414 STATIC int
14415 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
14416
14417     const char * const s,      /* Where the putative posix class begins.
14418                                   Normally, this is one past the '['.  This
14419                                   parameter exists so it can be somewhere
14420                                   besides RExC_parse. */
14421     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
14422                                   NULL */
14423     AV ** posix_warnings,      /* Where to place any generated warnings, or
14424                                   NULL */
14425     const bool check_only      /* Don't die if error */
14426 )
14427 {
14428     /* This parses what the caller thinks may be one of the three POSIX
14429      * constructs:
14430      *  1) a character class, like [:blank:]
14431      *  2) a collating symbol, like [. .]
14432      *  3) an equivalence class, like [= =]
14433      * In the latter two cases, it croaks if it finds a syntactically legal
14434      * one, as these are not handled by Perl.
14435      *
14436      * The main purpose is to look for a POSIX character class.  It returns:
14437      *  a) the class number
14438      *      if it is a completely syntactically and semantically legal class.
14439      *      'updated_parse_ptr', if not NULL, is set to point to just after the
14440      *      closing ']' of the class
14441      *  b) OOB_NAMEDCLASS
14442      *      if it appears that one of the three POSIX constructs was meant, but
14443      *      its specification was somehow defective.  'updated_parse_ptr', if
14444      *      not NULL, is set to point to the character just after the end
14445      *      character of the class.  See below for handling of warnings.
14446      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
14447      *      if it  doesn't appear that a POSIX construct was intended.
14448      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
14449      *      raised.
14450      *
14451      * In b) there may be errors or warnings generated.  If 'check_only' is
14452      * TRUE, then any errors are discarded.  Warnings are returned to the
14453      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
14454      * instead it is NULL, warnings are suppressed.  This is done in all
14455      * passes.  The reason for this is that the rest of the parsing is heavily
14456      * dependent on whether this routine found a valid posix class or not.  If
14457      * it did, the closing ']' is absorbed as part of the class.  If no class,
14458      * or an invalid one is found, any ']' will be considered the terminator of
14459      * the outer bracketed character class, leading to very different results.
14460      * In particular, a '(?[ ])' construct will likely have a syntax error if
14461      * the class is parsed other than intended, and this will happen in pass1,
14462      * before the warnings would normally be output.  This mechanism allows the
14463      * caller to output those warnings in pass1 just before dieing, giving a
14464      * much better clue as to what is wrong.
14465      *
14466      * The reason for this function, and its complexity is that a bracketed
14467      * character class can contain just about anything.  But it's easy to
14468      * mistype the very specific posix class syntax but yielding a valid
14469      * regular bracketed class, so it silently gets compiled into something
14470      * quite unintended.
14471      *
14472      * The solution adopted here maintains backward compatibility except that
14473      * it adds a warning if it looks like a posix class was intended but
14474      * improperly specified.  The warning is not raised unless what is input
14475      * very closely resembles one of the 14 legal posix classes.  To do this,
14476      * it uses fuzzy parsing.  It calculates how many single-character edits it
14477      * would take to transform what was input into a legal posix class.  Only
14478      * if that number is quite small does it think that the intention was a
14479      * posix class.  Obviously these are heuristics, and there will be cases
14480      * where it errs on one side or another, and they can be tweaked as
14481      * experience informs.
14482      *
14483      * The syntax for a legal posix class is:
14484      *
14485      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
14486      *
14487      * What this routine considers syntactically to be an intended posix class
14488      * is this (the comments indicate some restrictions that the pattern
14489      * doesn't show):
14490      *
14491      *  qr/(?x: \[?                         # The left bracket, possibly
14492      *                                      # omitted
14493      *          \h*                         # possibly followed by blanks
14494      *          (?: \^ \h* )?               # possibly a misplaced caret
14495      *          [:;]?                       # The opening class character,
14496      *                                      # possibly omitted.  A typo
14497      *                                      # semi-colon can also be used.
14498      *          \h*
14499      *          \^?                         # possibly a correctly placed
14500      *                                      # caret, but not if there was also
14501      *                                      # a misplaced one
14502      *          \h*
14503      *          .{3,15}                     # The class name.  If there are
14504      *                                      # deviations from the legal syntax,
14505      *                                      # its edit distance must be close
14506      *                                      # to a real class name in order
14507      *                                      # for it to be considered to be
14508      *                                      # an intended posix class.
14509      *          \h*
14510      *          [[:punct:]]?                # The closing class character,
14511      *                                      # possibly omitted.  If not a colon
14512      *                                      # nor semi colon, the class name
14513      *                                      # must be even closer to a valid
14514      *                                      # one
14515      *          \h*
14516      *          \]?                         # The right bracket, possibly
14517      *                                      # omitted.
14518      *     )/
14519      *
14520      * In the above, \h must be ASCII-only.
14521      *
14522      * These are heuristics, and can be tweaked as field experience dictates.
14523      * There will be cases when someone didn't intend to specify a posix class
14524      * that this warns as being so.  The goal is to minimize these, while
14525      * maximizing the catching of things intended to be a posix class that
14526      * aren't parsed as such.
14527      */
14528
14529     const char* p             = s;
14530     const char * const e      = RExC_end;
14531     unsigned complement       = 0;      /* If to complement the class */
14532     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14533     bool has_opening_bracket  = FALSE;
14534     bool has_opening_colon    = FALSE;
14535     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14536                                                    valid class */
14537     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14538     const char* name_start;             /* ptr to class name first char */
14539
14540     /* If the number of single-character typos the input name is away from a
14541      * legal name is no more than this number, it is considered to have meant
14542      * the legal name */
14543     int max_distance          = 2;
14544
14545     /* to store the name.  The size determines the maximum length before we
14546      * decide that no posix class was intended.  Should be at least
14547      * sizeof("alphanumeric") */
14548     UV input_text[15];
14549     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
14550
14551     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14552
14553     CLEAR_POSIX_WARNINGS();
14554
14555     if (p >= e) {
14556         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14557     }
14558
14559     if (*(p - 1) != '[') {
14560         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14561         found_problem = TRUE;
14562     }
14563     else {
14564         has_opening_bracket = TRUE;
14565     }
14566
14567     /* They could be confused and think you can put spaces between the
14568      * components */
14569     if (isBLANK(*p)) {
14570         found_problem = TRUE;
14571
14572         do {
14573             p++;
14574         } while (p < e && isBLANK(*p));
14575
14576         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14577     }
14578
14579     /* For [. .] and [= =].  These are quite different internally from [: :],
14580      * so they are handled separately.  */
14581     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14582                                             and 1 for at least one char in it
14583                                           */
14584     {
14585         const char open_char  = *p;
14586         const char * temp_ptr = p + 1;
14587
14588         /* These two constructs are not handled by perl, and if we find a
14589          * syntactically valid one, we croak.  khw, who wrote this code, finds
14590          * this explanation of them very unclear:
14591          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14592          * And searching the rest of the internet wasn't very helpful either.
14593          * It looks like just about any byte can be in these constructs,
14594          * depending on the locale.  But unless the pattern is being compiled
14595          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14596          * In that case, it looks like [= =] isn't allowed at all, and that
14597          * [. .] could be any single code point, but for longer strings the
14598          * constituent characters would have to be the ASCII alphabetics plus
14599          * the minus-hyphen.  Any sensible locale definition would limit itself
14600          * to these.  And any portable one definitely should.  Trying to parse
14601          * the general case is a nightmare (see [perl #127604]).  So, this code
14602          * looks only for interiors of these constructs that match:
14603          *      qr/.|[-\w]{2,}/
14604          * Using \w relaxes the apparent rules a little, without adding much
14605          * danger of mistaking something else for one of these constructs.
14606          *
14607          * [. .] in some implementations described on the internet is usable to
14608          * escape a character that otherwise is special in bracketed character
14609          * classes.  For example [.].] means a literal right bracket instead of
14610          * the ending of the class
14611          *
14612          * [= =] can legitimately contain a [. .] construct, but we don't
14613          * handle this case, as that [. .] construct will later get parsed
14614          * itself and croak then.  And [= =] is checked for even when not under
14615          * /l, as Perl has long done so.
14616          *
14617          * The code below relies on there being a trailing NUL, so it doesn't
14618          * have to keep checking if the parse ptr < e.
14619          */
14620         if (temp_ptr[1] == open_char) {
14621             temp_ptr++;
14622         }
14623         else while (    temp_ptr < e
14624                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14625         {
14626             temp_ptr++;
14627         }
14628
14629         if (*temp_ptr == open_char) {
14630             temp_ptr++;
14631             if (*temp_ptr == ']') {
14632                 temp_ptr++;
14633                 if (! found_problem && ! check_only) {
14634                     RExC_parse = (char *) temp_ptr;
14635                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14636                             "extensions", open_char, open_char);
14637                 }
14638
14639                 /* Here, the syntax wasn't completely valid, or else the call
14640                  * is to check-only */
14641                 if (updated_parse_ptr) {
14642                     *updated_parse_ptr = (char *) temp_ptr;
14643                 }
14644
14645                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
14646             }
14647         }
14648
14649         /* If we find something that started out to look like one of these
14650          * constructs, but isn't, we continue below so that it can be checked
14651          * for being a class name with a typo of '.' or '=' instead of a colon.
14652          * */
14653     }
14654
14655     /* Here, we think there is a possibility that a [: :] class was meant, and
14656      * we have the first real character.  It could be they think the '^' comes
14657      * first */
14658     if (*p == '^') {
14659         found_problem = TRUE;
14660         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14661         complement = 1;
14662         p++;
14663
14664         if (isBLANK(*p)) {
14665             found_problem = TRUE;
14666
14667             do {
14668                 p++;
14669             } while (p < e && isBLANK(*p));
14670
14671             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14672         }
14673     }
14674
14675     /* But the first character should be a colon, which they could have easily
14676      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14677      * distinguish from a colon, so treat that as a colon).  */
14678     if (*p == ':') {
14679         p++;
14680         has_opening_colon = TRUE;
14681     }
14682     else if (*p == ';') {
14683         found_problem = TRUE;
14684         p++;
14685         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14686         has_opening_colon = TRUE;
14687     }
14688     else {
14689         found_problem = TRUE;
14690         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14691
14692         /* Consider an initial punctuation (not one of the recognized ones) to
14693          * be a left terminator */
14694         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14695             p++;
14696         }
14697     }
14698
14699     /* They may think that you can put spaces between the components */
14700     if (isBLANK(*p)) {
14701         found_problem = TRUE;
14702
14703         do {
14704             p++;
14705         } while (p < e && isBLANK(*p));
14706
14707         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14708     }
14709
14710     if (*p == '^') {
14711
14712         /* We consider something like [^:^alnum:]] to not have been intended to
14713          * be a posix class, but XXX maybe we should */
14714         if (complement) {
14715             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14716         }
14717
14718         complement = 1;
14719         p++;
14720     }
14721
14722     /* Again, they may think that you can put spaces between the components */
14723     if (isBLANK(*p)) {
14724         found_problem = TRUE;
14725
14726         do {
14727             p++;
14728         } while (p < e && isBLANK(*p));
14729
14730         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14731     }
14732
14733     if (*p == ']') {
14734
14735         /* XXX This ']' may be a typo, and something else was meant.  But
14736          * treating it as such creates enough complications, that that
14737          * possibility isn't currently considered here.  So we assume that the
14738          * ']' is what is intended, and if we've already found an initial '[',
14739          * this leaves this construct looking like [:] or [:^], which almost
14740          * certainly weren't intended to be posix classes */
14741         if (has_opening_bracket) {
14742             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14743         }
14744
14745         /* But this function can be called when we parse the colon for
14746          * something like qr/[alpha:]]/, so we back up to look for the
14747          * beginning */
14748         p--;
14749
14750         if (*p == ';') {
14751             found_problem = TRUE;
14752             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14753         }
14754         else if (*p != ':') {
14755
14756             /* XXX We are currently very restrictive here, so this code doesn't
14757              * consider the possibility that, say, /[alpha.]]/ was intended to
14758              * be a posix class. */
14759             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14760         }
14761
14762         /* Here we have something like 'foo:]'.  There was no initial colon,
14763          * and we back up over 'foo.  XXX Unlike the going forward case, we
14764          * don't handle typos of non-word chars in the middle */
14765         has_opening_colon = FALSE;
14766         p--;
14767
14768         while (p > RExC_start && isWORDCHAR(*p)) {
14769             p--;
14770         }
14771         p++;
14772
14773         /* Here, we have positioned ourselves to where we think the first
14774          * character in the potential class is */
14775     }
14776
14777     /* Now the interior really starts.  There are certain key characters that
14778      * can end the interior, or these could just be typos.  To catch both
14779      * cases, we may have to do two passes.  In the first pass, we keep on
14780      * going unless we come to a sequence that matches
14781      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14782      * This means it takes a sequence to end the pass, so two typos in a row if
14783      * that wasn't what was intended.  If the class is perfectly formed, just
14784      * this one pass is needed.  We also stop if there are too many characters
14785      * being accumulated, but this number is deliberately set higher than any
14786      * real class.  It is set high enough so that someone who thinks that
14787      * 'alphanumeric' is a correct name would get warned that it wasn't.
14788      * While doing the pass, we keep track of where the key characters were in
14789      * it.  If we don't find an end to the class, and one of the key characters
14790      * was found, we redo the pass, but stop when we get to that character.
14791      * Thus the key character was considered a typo in the first pass, but a
14792      * terminator in the second.  If two key characters are found, we stop at
14793      * the second one in the first pass.  Again this can miss two typos, but
14794      * catches a single one
14795      *
14796      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14797      * point to the first key character.  For the second pass, it starts as -1.
14798      * */
14799
14800     name_start = p;
14801   parse_name:
14802     {
14803         bool has_blank               = FALSE;
14804         bool has_upper               = FALSE;
14805         bool has_terminating_colon   = FALSE;
14806         bool has_terminating_bracket = FALSE;
14807         bool has_semi_colon          = FALSE;
14808         unsigned int name_len        = 0;
14809         int punct_count              = 0;
14810
14811         while (p < e) {
14812
14813             /* Squeeze out blanks when looking up the class name below */
14814             if (isBLANK(*p) ) {
14815                 has_blank = TRUE;
14816                 found_problem = TRUE;
14817                 p++;
14818                 continue;
14819             }
14820
14821             /* The name will end with a punctuation */
14822             if (isPUNCT(*p)) {
14823                 const char * peek = p + 1;
14824
14825                 /* Treat any non-']' punctuation followed by a ']' (possibly
14826                  * with intervening blanks) as trying to terminate the class.
14827                  * ']]' is very likely to mean a class was intended (but
14828                  * missing the colon), but the warning message that gets
14829                  * generated shows the error position better if we exit the
14830                  * loop at the bottom (eventually), so skip it here. */
14831                 if (*p != ']') {
14832                     if (peek < e && isBLANK(*peek)) {
14833                         has_blank = TRUE;
14834                         found_problem = TRUE;
14835                         do {
14836                             peek++;
14837                         } while (peek < e && isBLANK(*peek));
14838                     }
14839
14840                     if (peek < e && *peek == ']') {
14841                         has_terminating_bracket = TRUE;
14842                         if (*p == ':') {
14843                             has_terminating_colon = TRUE;
14844                         }
14845                         else if (*p == ';') {
14846                             has_semi_colon = TRUE;
14847                             has_terminating_colon = TRUE;
14848                         }
14849                         else {
14850                             found_problem = TRUE;
14851                         }
14852                         p = peek + 1;
14853                         goto try_posix;
14854                     }
14855                 }
14856
14857                 /* Here we have punctuation we thought didn't end the class.
14858                  * Keep track of the position of the key characters that are
14859                  * more likely to have been class-enders */
14860                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14861
14862                     /* Allow just one such possible class-ender not actually
14863                      * ending the class. */
14864                     if (possible_end) {
14865                         break;
14866                     }
14867                     possible_end = p;
14868                 }
14869
14870                 /* If we have too many punctuation characters, no use in
14871                  * keeping going */
14872                 if (++punct_count > max_distance) {
14873                     break;
14874                 }
14875
14876                 /* Treat the punctuation as a typo. */
14877                 input_text[name_len++] = *p;
14878                 p++;
14879             }
14880             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14881                 input_text[name_len++] = toLOWER(*p);
14882                 has_upper = TRUE;
14883                 found_problem = TRUE;
14884                 p++;
14885             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14886                 input_text[name_len++] = *p;
14887                 p++;
14888             }
14889             else {
14890                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14891                 p+= UTF8SKIP(p);
14892             }
14893
14894             /* The declaration of 'input_text' is how long we allow a potential
14895              * class name to be, before saying they didn't mean a class name at
14896              * all */
14897             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14898                 break;
14899             }
14900         }
14901
14902         /* We get to here when the possible class name hasn't been properly
14903          * terminated before:
14904          *   1) we ran off the end of the pattern; or
14905          *   2) found two characters, each of which might have been intended to
14906          *      be the name's terminator
14907          *   3) found so many punctuation characters in the purported name,
14908          *      that the edit distance to a valid one is exceeded
14909          *   4) we decided it was more characters than anyone could have
14910          *      intended to be one. */
14911
14912         found_problem = TRUE;
14913
14914         /* In the final two cases, we know that looking up what we've
14915          * accumulated won't lead to a match, even a fuzzy one. */
14916         if (   name_len >= C_ARRAY_LENGTH(input_text)
14917             || punct_count > max_distance)
14918         {
14919             /* If there was an intermediate key character that could have been
14920              * an intended end, redo the parse, but stop there */
14921             if (possible_end && possible_end != (char *) -1) {
14922                 possible_end = (char *) -1; /* Special signal value to say
14923                                                we've done a first pass */
14924                 p = name_start;
14925                 goto parse_name;
14926             }
14927
14928             /* Otherwise, it can't have meant to have been a class */
14929             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14930         }
14931
14932         /* If we ran off the end, and the final character was a punctuation
14933          * one, back up one, to look at that final one just below.  Later, we
14934          * will restore the parse pointer if appropriate */
14935         if (name_len && p == e && isPUNCT(*(p-1))) {
14936             p--;
14937             name_len--;
14938         }
14939
14940         if (p < e && isPUNCT(*p)) {
14941             if (*p == ']') {
14942                 has_terminating_bracket = TRUE;
14943
14944                 /* If this is a 2nd ']', and the first one is just below this
14945                  * one, consider that to be the real terminator.  This gives a
14946                  * uniform and better positioning for the warning message  */
14947                 if (   possible_end
14948                     && possible_end != (char *) -1
14949                     && *possible_end == ']'
14950                     && name_len && input_text[name_len - 1] == ']')
14951                 {
14952                     name_len--;
14953                     p = possible_end;
14954
14955                     /* And this is actually equivalent to having done the 2nd
14956                      * pass now, so set it to not try again */
14957                     possible_end = (char *) -1;
14958                 }
14959             }
14960             else {
14961                 if (*p == ':') {
14962                     has_terminating_colon = TRUE;
14963                 }
14964                 else if (*p == ';') {
14965                     has_semi_colon = TRUE;
14966                     has_terminating_colon = TRUE;
14967                 }
14968                 p++;
14969             }
14970         }
14971
14972     try_posix:
14973
14974         /* Here, we have a class name to look up.  We can short circuit the
14975          * stuff below for short names that can't possibly be meant to be a
14976          * class name.  (We can do this on the first pass, as any second pass
14977          * will yield an even shorter name) */
14978         if (name_len < 3) {
14979             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
14980         }
14981
14982         /* Find which class it is.  Initially switch on the length of the name.
14983          * */
14984         switch (name_len) {
14985             case 4:
14986                 if (memEQs(name_start, 4, "word")) {
14987                     /* this is not POSIX, this is the Perl \w */
14988                     class_number = ANYOF_WORDCHAR;
14989                 }
14990                 break;
14991             case 5:
14992                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14993                  *                        graph lower print punct space upper
14994                  * Offset 4 gives the best switch position.  */
14995                 switch (name_start[4]) {
14996                     case 'a':
14997                         if (memBEGINs(name_start, 5, "alph")) /* alpha */
14998                             class_number = ANYOF_ALPHA;
14999                         break;
15000                     case 'e':
15001                         if (memBEGINs(name_start, 5, "spac")) /* space */
15002                             class_number = ANYOF_SPACE;
15003                         break;
15004                     case 'h':
15005                         if (memBEGINs(name_start, 5, "grap")) /* graph */
15006                             class_number = ANYOF_GRAPH;
15007                         break;
15008                     case 'i':
15009                         if (memBEGINs(name_start, 5, "asci")) /* ascii */
15010                             class_number = ANYOF_ASCII;
15011                         break;
15012                     case 'k':
15013                         if (memBEGINs(name_start, 5, "blan")) /* blank */
15014                             class_number = ANYOF_BLANK;
15015                         break;
15016                     case 'l':
15017                         if (memBEGINs(name_start, 5, "cntr")) /* cntrl */
15018                             class_number = ANYOF_CNTRL;
15019                         break;
15020                     case 'm':
15021                         if (memBEGINs(name_start, 5, "alnu")) /* alnum */
15022                             class_number = ANYOF_ALPHANUMERIC;
15023                         break;
15024                     case 'r':
15025                         if (memBEGINs(name_start, 5, "lowe")) /* lower */
15026                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
15027                         else if (memBEGINs(name_start, 5, "uppe")) /* upper */
15028                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
15029                         break;
15030                     case 't':
15031                         if (memBEGINs(name_start, 5, "digi")) /* digit */
15032                             class_number = ANYOF_DIGIT;
15033                         else if (memBEGINs(name_start, 5, "prin")) /* print */
15034                             class_number = ANYOF_PRINT;
15035                         else if (memBEGINs(name_start, 5, "punc")) /* punct */
15036                             class_number = ANYOF_PUNCT;
15037                         break;
15038                 }
15039                 break;
15040             case 6:
15041                 if (memEQs(name_start, 6, "xdigit"))
15042                     class_number = ANYOF_XDIGIT;
15043                 break;
15044         }
15045
15046         /* If the name exactly matches a posix class name the class number will
15047          * here be set to it, and the input almost certainly was meant to be a
15048          * posix class, so we can skip further checking.  If instead the syntax
15049          * is exactly correct, but the name isn't one of the legal ones, we
15050          * will return that as an error below.  But if neither of these apply,
15051          * it could be that no posix class was intended at all, or that one
15052          * was, but there was a typo.  We tease these apart by doing fuzzy
15053          * matching on the name */
15054         if (class_number == OOB_NAMEDCLASS && found_problem) {
15055             const UV posix_names[][6] = {
15056                                                 { 'a', 'l', 'n', 'u', 'm' },
15057                                                 { 'a', 'l', 'p', 'h', 'a' },
15058                                                 { 'a', 's', 'c', 'i', 'i' },
15059                                                 { 'b', 'l', 'a', 'n', 'k' },
15060                                                 { 'c', 'n', 't', 'r', 'l' },
15061                                                 { 'd', 'i', 'g', 'i', 't' },
15062                                                 { 'g', 'r', 'a', 'p', 'h' },
15063                                                 { 'l', 'o', 'w', 'e', 'r' },
15064                                                 { 'p', 'r', 'i', 'n', 't' },
15065                                                 { 'p', 'u', 'n', 'c', 't' },
15066                                                 { 's', 'p', 'a', 'c', 'e' },
15067                                                 { 'u', 'p', 'p', 'e', 'r' },
15068                                                 { 'w', 'o', 'r', 'd' },
15069                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
15070                                             };
15071             /* The names of the above all have added NULs to make them the same
15072              * size, so we need to also have the real lengths */
15073             const UV posix_name_lengths[] = {
15074                                                 sizeof("alnum") - 1,
15075                                                 sizeof("alpha") - 1,
15076                                                 sizeof("ascii") - 1,
15077                                                 sizeof("blank") - 1,
15078                                                 sizeof("cntrl") - 1,
15079                                                 sizeof("digit") - 1,
15080                                                 sizeof("graph") - 1,
15081                                                 sizeof("lower") - 1,
15082                                                 sizeof("print") - 1,
15083                                                 sizeof("punct") - 1,
15084                                                 sizeof("space") - 1,
15085                                                 sizeof("upper") - 1,
15086                                                 sizeof("word")  - 1,
15087                                                 sizeof("xdigit")- 1
15088                                             };
15089             unsigned int i;
15090             int temp_max = max_distance;    /* Use a temporary, so if we
15091                                                reparse, we haven't changed the
15092                                                outer one */
15093
15094             /* Use a smaller max edit distance if we are missing one of the
15095              * delimiters */
15096             if (   has_opening_bracket + has_opening_colon < 2
15097                 || has_terminating_bracket + has_terminating_colon < 2)
15098             {
15099                 temp_max--;
15100             }
15101
15102             /* See if the input name is close to a legal one */
15103             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
15104
15105                 /* Short circuit call if the lengths are too far apart to be
15106                  * able to match */
15107                 if (abs( (int) (name_len - posix_name_lengths[i]))
15108                     > temp_max)
15109                 {
15110                     continue;
15111                 }
15112
15113                 if (edit_distance(input_text,
15114                                   posix_names[i],
15115                                   name_len,
15116                                   posix_name_lengths[i],
15117                                   temp_max
15118                                  )
15119                     > -1)
15120                 { /* If it is close, it probably was intended to be a class */
15121                     goto probably_meant_to_be;
15122                 }
15123             }
15124
15125             /* Here the input name is not close enough to a valid class name
15126              * for us to consider it to be intended to be a posix class.  If
15127              * we haven't already done so, and the parse found a character that
15128              * could have been terminators for the name, but which we absorbed
15129              * as typos during the first pass, repeat the parse, signalling it
15130              * to stop at that character */
15131             if (possible_end && possible_end != (char *) -1) {
15132                 possible_end = (char *) -1;
15133                 p = name_start;
15134                 goto parse_name;
15135             }
15136
15137             /* Here neither pass found a close-enough class name */
15138             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15139         }
15140
15141     probably_meant_to_be:
15142
15143         /* Here we think that a posix specification was intended.  Update any
15144          * parse pointer */
15145         if (updated_parse_ptr) {
15146             *updated_parse_ptr = (char *) p;
15147         }
15148
15149         /* If a posix class name was intended but incorrectly specified, we
15150          * output or return the warnings */
15151         if (found_problem) {
15152
15153             /* We set flags for these issues in the parse loop above instead of
15154              * adding them to the list of warnings, because we can parse it
15155              * twice, and we only want one warning instance */
15156             if (has_upper) {
15157                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
15158             }
15159             if (has_blank) {
15160                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15161             }
15162             if (has_semi_colon) {
15163                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15164             }
15165             else if (! has_terminating_colon) {
15166                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
15167             }
15168             if (! has_terminating_bracket) {
15169                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
15170             }
15171
15172             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
15173                 *posix_warnings = RExC_warn_text;
15174             }
15175         }
15176         else if (class_number != OOB_NAMEDCLASS) {
15177             /* If it is a known class, return the class.  The class number
15178              * #defines are structured so each complement is +1 to the normal
15179              * one */
15180             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
15181         }
15182         else if (! check_only) {
15183
15184             /* Here, it is an unrecognized class.  This is an error (unless the
15185             * call is to check only, which we've already handled above) */
15186             const char * const complement_string = (complement)
15187                                                    ? "^"
15188                                                    : "";
15189             RExC_parse = (char *) p;
15190             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
15191                         complement_string,
15192                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
15193         }
15194     }
15195
15196     return OOB_NAMEDCLASS;
15197 }
15198 #undef ADD_POSIX_WARNING
15199
15200 STATIC unsigned  int
15201 S_regex_set_precedence(const U8 my_operator) {
15202
15203     /* Returns the precedence in the (?[...]) construct of the input operator,
15204      * specified by its character representation.  The precedence follows
15205      * general Perl rules, but it extends this so that ')' and ']' have (low)
15206      * precedence even though they aren't really operators */
15207
15208     switch (my_operator) {
15209         case '!':
15210             return 5;
15211         case '&':
15212             return 4;
15213         case '^':
15214         case '|':
15215         case '+':
15216         case '-':
15217             return 3;
15218         case ')':
15219             return 2;
15220         case ']':
15221             return 1;
15222     }
15223
15224     NOT_REACHED; /* NOTREACHED */
15225     return 0;   /* Silence compiler warning */
15226 }
15227
15228 STATIC regnode *
15229 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
15230                     I32 *flagp, U32 depth,
15231                     char * const oregcomp_parse)
15232 {
15233     /* Handle the (?[...]) construct to do set operations */
15234
15235     U8 curchar;                     /* Current character being parsed */
15236     UV start, end;                  /* End points of code point ranges */
15237     SV* final = NULL;               /* The end result inversion list */
15238     SV* result_string;              /* 'final' stringified */
15239     AV* stack;                      /* stack of operators and operands not yet
15240                                        resolved */
15241     AV* fence_stack = NULL;         /* A stack containing the positions in
15242                                        'stack' of where the undealt-with left
15243                                        parens would be if they were actually
15244                                        put there */
15245     /* The 'volatile' is a workaround for an optimiser bug
15246      * in Solaris Studio 12.3. See RT #127455 */
15247     volatile IV fence = 0;          /* Position of where most recent undealt-
15248                                        with left paren in stack is; -1 if none.
15249                                      */
15250     STRLEN len;                     /* Temporary */
15251     regnode* node;                  /* Temporary, and final regnode returned by
15252                                        this function */
15253     const bool save_fold = FOLD;    /* Temporary */
15254     char *save_end, *save_parse;    /* Temporaries */
15255     const bool in_locale = LOC;     /* we turn off /l during processing */
15256     AV* posix_warnings = NULL;
15257
15258     GET_RE_DEBUG_FLAGS_DECL;
15259
15260     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
15261
15262     DEBUG_PARSE("xcls");
15263
15264     if (in_locale) {
15265         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
15266     }
15267
15268     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
15269                                          This is required so that the compile
15270                                          time values are valid in all runtime
15271                                          cases */
15272
15273     /* This will return only an ANYOF regnode, or (unlikely) something smaller
15274      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
15275      * call regclass to handle '[]' so as to not have to reinvent its parsing
15276      * rules here (throwing away the size it computes each time).  And, we exit
15277      * upon an unescaped ']' that isn't one ending a regclass.  To do both
15278      * these things, we need to realize that something preceded by a backslash
15279      * is escaped, so we have to keep track of backslashes */
15280     if (SIZE_ONLY) {
15281         UV nest_depth = 0; /* how many nested (?[...]) constructs */
15282
15283         while (RExC_parse < RExC_end) {
15284             SV* current = NULL;
15285
15286             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15287                                     TRUE /* Force /x */ );
15288
15289             switch (*RExC_parse) {
15290                 case '(':
15291                     if (RExC_parse[1] == '?' && RExC_parse[2] == '[')
15292                         nest_depth++, RExC_parse+=2;
15293                     /* FALLTHROUGH */
15294                 default:
15295                     break;
15296                 case '\\':
15297                     /* Skip past this, so the next character gets skipped, after
15298                      * the switch */
15299                     RExC_parse++;
15300                     if (*RExC_parse == 'c') {
15301                             /* Skip the \cX notation for control characters */
15302                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
15303                     }
15304                     break;
15305
15306                 case '[':
15307                 {
15308                     /* See if this is a [:posix:] class. */
15309                     bool is_posix_class = (OOB_NAMEDCLASS
15310                             < handle_possible_posix(pRExC_state,
15311                                                 RExC_parse + 1,
15312                                                 NULL,
15313                                                 NULL,
15314                                                 TRUE /* checking only */));
15315                     /* If it is a posix class, leave the parse pointer at the
15316                      * '[' to fool regclass() into thinking it is part of a
15317                      * '[[:posix:]]'. */
15318                     if (! is_posix_class) {
15319                         RExC_parse++;
15320                     }
15321
15322                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
15323                      * if multi-char folds are allowed.  */
15324                     if (!regclass(pRExC_state, flagp,depth+1,
15325                                   is_posix_class, /* parse the whole char
15326                                                      class only if not a
15327                                                      posix class */
15328                                   FALSE, /* don't allow multi-char folds */
15329                                   TRUE, /* silence non-portable warnings. */
15330                                   TRUE, /* strict */
15331                                   FALSE, /* Require return to be an ANYOF */
15332                                   &current,
15333                                   &posix_warnings
15334                                  ))
15335                         FAIL2("panic: regclass returned NULL to handle_sets, "
15336                               "flags=%#" UVxf, (UV) *flagp);
15337
15338                     /* function call leaves parse pointing to the ']', except
15339                      * if we faked it */
15340                     if (is_posix_class) {
15341                         RExC_parse--;
15342                     }
15343
15344                     SvREFCNT_dec(current);   /* In case it returned something */
15345                     break;
15346                 }
15347
15348                 case ']':
15349                     if (RExC_parse[1] == ')') {
15350                         RExC_parse++;
15351                         if (nest_depth--) break;
15352                         node = reganode(pRExC_state, ANYOF, 0);
15353                         RExC_size += ANYOF_SKIP;
15354                         nextchar(pRExC_state);
15355                         Set_Node_Length(node,
15356                                 RExC_parse - oregcomp_parse + 1); /* MJD */
15357                         if (in_locale) {
15358                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15359                         }
15360
15361                         return node;
15362                     }
15363                     /* We output the messages even if warnings are off, because we'll fail
15364                      * the very next thing, and these give a likely diagnosis for that */
15365                     if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
15366                         output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
15367                     }
15368                     RExC_parse++;
15369                     vFAIL("Unexpected ']' with no following ')' in (?[...");
15370             }
15371
15372             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
15373         }
15374
15375         /* We output the messages even if warnings are off, because we'll fail
15376          * the very next thing, and these give a likely diagnosis for that */
15377         if (posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
15378             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
15379         }
15380
15381         vFAIL("Syntax error in (?[...])");
15382     }
15383
15384     /* Pass 2 only after this. */
15385     Perl_ck_warner_d(aTHX_
15386         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
15387         "The regex_sets feature is experimental" REPORT_LOCATION,
15388         REPORT_LOCATION_ARGS(RExC_parse));
15389
15390     /* Everything in this construct is a metacharacter.  Operands begin with
15391      * either a '\' (for an escape sequence), or a '[' for a bracketed
15392      * character class.  Any other character should be an operator, or
15393      * parenthesis for grouping.  Both types of operands are handled by calling
15394      * regclass() to parse them.  It is called with a parameter to indicate to
15395      * return the computed inversion list.  The parsing here is implemented via
15396      * a stack.  Each entry on the stack is a single character representing one
15397      * of the operators; or else a pointer to an operand inversion list. */
15398
15399 #define IS_OPERATOR(a) SvIOK(a)
15400 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
15401
15402     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
15403      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
15404      * with pronouncing it called it Reverse Polish instead, but now that YOU
15405      * know how to pronounce it you can use the correct term, thus giving due
15406      * credit to the person who invented it, and impressing your geek friends.
15407      * Wikipedia says that the pronounciation of "Ł" has been changing so that
15408      * it is now more like an English initial W (as in wonk) than an L.)
15409      *
15410      * This means that, for example, 'a | b & c' is stored on the stack as
15411      *
15412      * c  [4]
15413      * b  [3]
15414      * &  [2]
15415      * a  [1]
15416      * |  [0]
15417      *
15418      * where the numbers in brackets give the stack [array] element number.
15419      * In this implementation, parentheses are not stored on the stack.
15420      * Instead a '(' creates a "fence" so that the part of the stack below the
15421      * fence is invisible except to the corresponding ')' (this allows us to
15422      * replace testing for parens, by using instead subtraction of the fence
15423      * position).  As new operands are processed they are pushed onto the stack
15424      * (except as noted in the next paragraph).  New operators of higher
15425      * precedence than the current final one are inserted on the stack before
15426      * the lhs operand (so that when the rhs is pushed next, everything will be
15427      * in the correct positions shown above.  When an operator of equal or
15428      * lower precedence is encountered in parsing, all the stacked operations
15429      * of equal or higher precedence are evaluated, leaving the result as the
15430      * top entry on the stack.  This makes higher precedence operations
15431      * evaluate before lower precedence ones, and causes operations of equal
15432      * precedence to left associate.
15433      *
15434      * The only unary operator '!' is immediately pushed onto the stack when
15435      * encountered.  When an operand is encountered, if the top of the stack is
15436      * a '!", the complement is immediately performed, and the '!' popped.  The
15437      * resulting value is treated as a new operand, and the logic in the
15438      * previous paragraph is executed.  Thus in the expression
15439      *      [a] + ! [b]
15440      * the stack looks like
15441      *
15442      * !
15443      * a
15444      * +
15445      *
15446      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
15447      * becomes
15448      *
15449      * !b
15450      * a
15451      * +
15452      *
15453      * A ')' is treated as an operator with lower precedence than all the
15454      * aforementioned ones, which causes all operations on the stack above the
15455      * corresponding '(' to be evaluated down to a single resultant operand.
15456      * Then the fence for the '(' is removed, and the operand goes through the
15457      * algorithm above, without the fence.
15458      *
15459      * A separate stack is kept of the fence positions, so that the position of
15460      * the latest so-far unbalanced '(' is at the top of it.
15461      *
15462      * The ']' ending the construct is treated as the lowest operator of all,
15463      * so that everything gets evaluated down to a single operand, which is the
15464      * result */
15465
15466     sv_2mortal((SV *)(stack = newAV()));
15467     sv_2mortal((SV *)(fence_stack = newAV()));
15468
15469     while (RExC_parse < RExC_end) {
15470         I32 top_index;              /* Index of top-most element in 'stack' */
15471         SV** top_ptr;               /* Pointer to top 'stack' element */
15472         SV* current = NULL;         /* To contain the current inversion list
15473                                        operand */
15474         SV* only_to_avoid_leaks;
15475
15476         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15477                                 TRUE /* Force /x */ );
15478         if (RExC_parse >= RExC_end) {
15479             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
15480         }
15481
15482         curchar = UCHARAT(RExC_parse);
15483
15484 redo_curchar:
15485
15486 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15487                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
15488         DEBUG_U(dump_regex_sets_structures(pRExC_state,
15489                                            stack, fence, fence_stack));
15490 #endif
15491
15492         top_index = av_tindex_skip_len_mg(stack);
15493
15494         switch (curchar) {
15495             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
15496             char stacked_operator;  /* The topmost operator on the 'stack'. */
15497             SV* lhs;                /* Operand to the left of the operator */
15498             SV* rhs;                /* Operand to the right of the operator */
15499             SV* fence_ptr;          /* Pointer to top element of the fence
15500                                        stack */
15501
15502             case '(':
15503
15504                 if (   RExC_parse < RExC_end - 1
15505                     && (UCHARAT(RExC_parse + 1) == '?'))
15506                 {
15507                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
15508                      * This happens when we have some thing like
15509                      *
15510                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15511                      *   ...
15512                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15513                      *
15514                      * Here we would be handling the interpolated
15515                      * '$thai_or_lao'.  We handle this by a recursive call to
15516                      * ourselves which returns the inversion list the
15517                      * interpolated expression evaluates to.  We use the flags
15518                      * from the interpolated pattern. */
15519                     U32 save_flags = RExC_flags;
15520                     const char * save_parse;
15521
15522                     RExC_parse += 2;        /* Skip past the '(?' */
15523                     save_parse = RExC_parse;
15524
15525                     /* Parse any flags for the '(?' */
15526                     parse_lparen_question_flags(pRExC_state);
15527
15528                     if (RExC_parse == save_parse  /* Makes sure there was at
15529                                                      least one flag (or else
15530                                                      this embedding wasn't
15531                                                      compiled) */
15532                         || RExC_parse >= RExC_end - 4
15533                         || UCHARAT(RExC_parse) != ':'
15534                         || UCHARAT(++RExC_parse) != '('
15535                         || UCHARAT(++RExC_parse) != '?'
15536                         || UCHARAT(++RExC_parse) != '[')
15537                     {
15538
15539                         /* In combination with the above, this moves the
15540                          * pointer to the point just after the first erroneous
15541                          * character (or if there are no flags, to where they
15542                          * should have been) */
15543                         if (RExC_parse >= RExC_end - 4) {
15544                             RExC_parse = RExC_end;
15545                         }
15546                         else if (RExC_parse != save_parse) {
15547                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15548                         }
15549                         vFAIL("Expecting '(?flags:(?[...'");
15550                     }
15551
15552                     /* Recurse, with the meat of the embedded expression */
15553                     RExC_parse++;
15554                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15555                                                     depth+1, oregcomp_parse);
15556
15557                     /* Here, 'current' contains the embedded expression's
15558                      * inversion list, and RExC_parse points to the trailing
15559                      * ']'; the next character should be the ')' */
15560                     RExC_parse++;
15561                     if (UCHARAT(RExC_parse) != ')')
15562                         vFAIL("Expecting close paren for nested extended charclass");
15563
15564                     /* Then the ')' matching the original '(' handled by this
15565                      * case: statement */
15566                     RExC_parse++;
15567                     if (UCHARAT(RExC_parse) != ')')
15568                         vFAIL("Expecting close paren for wrapper for nested extended charclass");
15569
15570                     RExC_parse++;
15571                     RExC_flags = save_flags;
15572                     goto handle_operand;
15573                 }
15574
15575                 /* A regular '('.  Look behind for illegal syntax */
15576                 if (top_index - fence >= 0) {
15577                     /* If the top entry on the stack is an operator, it had
15578                      * better be a '!', otherwise the entry below the top
15579                      * operand should be an operator */
15580                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15581                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15582                         || (   IS_OPERAND(*top_ptr)
15583                             && (   top_index - fence < 1
15584                                 || ! (stacked_ptr = av_fetch(stack,
15585                                                              top_index - 1,
15586                                                              FALSE))
15587                                 || ! IS_OPERATOR(*stacked_ptr))))
15588                     {
15589                         RExC_parse++;
15590                         vFAIL("Unexpected '(' with no preceding operator");
15591                     }
15592                 }
15593
15594                 /* Stack the position of this undealt-with left paren */
15595                 av_push(fence_stack, newSViv(fence));
15596                 fence = top_index + 1;
15597                 break;
15598
15599             case '\\':
15600                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15601                  * multi-char folds are allowed.  */
15602                 if (!regclass(pRExC_state, flagp,depth+1,
15603                               TRUE, /* means parse just the next thing */
15604                               FALSE, /* don't allow multi-char folds */
15605                               FALSE, /* don't silence non-portable warnings.  */
15606                               TRUE,  /* strict */
15607                               FALSE, /* Require return to be an ANYOF */
15608                               &current,
15609                               NULL))
15610                 {
15611                     FAIL2("panic: regclass returned NULL to handle_sets, "
15612                           "flags=%#" UVxf, (UV) *flagp);
15613                 }
15614
15615                 /* regclass() will return with parsing just the \ sequence,
15616                  * leaving the parse pointer at the next thing to parse */
15617                 RExC_parse--;
15618                 goto handle_operand;
15619
15620             case '[':   /* Is a bracketed character class */
15621             {
15622                 /* See if this is a [:posix:] class. */
15623                 bool is_posix_class = (OOB_NAMEDCLASS
15624                             < handle_possible_posix(pRExC_state,
15625                                                 RExC_parse + 1,
15626                                                 NULL,
15627                                                 NULL,
15628                                                 TRUE /* checking only */));
15629                 /* If it is a posix class, leave the parse pointer at the '['
15630                  * to fool regclass() into thinking it is part of a
15631                  * '[[:posix:]]'. */
15632                 if (! is_posix_class) {
15633                     RExC_parse++;
15634                 }
15635
15636                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15637                  * multi-char folds are allowed.  */
15638                 if (!regclass(pRExC_state, flagp,depth+1,
15639                                 is_posix_class, /* parse the whole char
15640                                                     class only if not a
15641                                                     posix class */
15642                                 FALSE, /* don't allow multi-char folds */
15643                                 TRUE, /* silence non-portable warnings. */
15644                                 TRUE, /* strict */
15645                                 FALSE, /* Require return to be an ANYOF */
15646                                 &current,
15647                                 NULL
15648                                 ))
15649                 {
15650                     FAIL2("panic: regclass returned NULL to handle_sets, "
15651                           "flags=%#" UVxf, (UV) *flagp);
15652                 }
15653
15654                 /* function call leaves parse pointing to the ']', except if we
15655                  * faked it */
15656                 if (is_posix_class) {
15657                     RExC_parse--;
15658                 }
15659
15660                 goto handle_operand;
15661             }
15662
15663             case ']':
15664                 if (top_index >= 1) {
15665                     goto join_operators;
15666                 }
15667
15668                 /* Only a single operand on the stack: are done */
15669                 goto done;
15670
15671             case ')':
15672                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
15673                     RExC_parse++;
15674                     vFAIL("Unexpected ')'");
15675                 }
15676
15677                 /* If nothing after the fence, is missing an operand */
15678                 if (top_index - fence < 0) {
15679                     RExC_parse++;
15680                     goto bad_syntax;
15681                 }
15682                 /* If at least two things on the stack, treat this as an
15683                   * operator */
15684                 if (top_index - fence >= 1) {
15685                     goto join_operators;
15686                 }
15687
15688                 /* Here only a single thing on the fenced stack, and there is a
15689                  * fence.  Get rid of it */
15690                 fence_ptr = av_pop(fence_stack);
15691                 assert(fence_ptr);
15692                 fence = SvIV(fence_ptr);
15693                 SvREFCNT_dec_NN(fence_ptr);
15694                 fence_ptr = NULL;
15695
15696                 if (fence < 0) {
15697                     fence = 0;
15698                 }
15699
15700                 /* Having gotten rid of the fence, we pop the operand at the
15701                  * stack top and process it as a newly encountered operand */
15702                 current = av_pop(stack);
15703                 if (IS_OPERAND(current)) {
15704                     goto handle_operand;
15705                 }
15706
15707                 RExC_parse++;
15708                 goto bad_syntax;
15709
15710             case '&':
15711             case '|':
15712             case '+':
15713             case '-':
15714             case '^':
15715
15716                 /* These binary operators should have a left operand already
15717                  * parsed */
15718                 if (   top_index - fence < 0
15719                     || top_index - fence == 1
15720                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15721                     || ! IS_OPERAND(*top_ptr))
15722                 {
15723                     goto unexpected_binary;
15724                 }
15725
15726                 /* If only the one operand is on the part of the stack visible
15727                  * to us, we just place this operator in the proper position */
15728                 if (top_index - fence < 2) {
15729
15730                     /* Place the operator before the operand */
15731
15732                     SV* lhs = av_pop(stack);
15733                     av_push(stack, newSVuv(curchar));
15734                     av_push(stack, lhs);
15735                     break;
15736                 }
15737
15738                 /* But if there is something else on the stack, we need to
15739                  * process it before this new operator if and only if the
15740                  * stacked operation has equal or higher precedence than the
15741                  * new one */
15742
15743              join_operators:
15744
15745                 /* The operator on the stack is supposed to be below both its
15746                  * operands */
15747                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15748                     || IS_OPERAND(*stacked_ptr))
15749                 {
15750                     /* But if not, it's legal and indicates we are completely
15751                      * done if and only if we're currently processing a ']',
15752                      * which should be the final thing in the expression */
15753                     if (curchar == ']') {
15754                         goto done;
15755                     }
15756
15757                   unexpected_binary:
15758                     RExC_parse++;
15759                     vFAIL2("Unexpected binary operator '%c' with no "
15760                            "preceding operand", curchar);
15761                 }
15762                 stacked_operator = (char) SvUV(*stacked_ptr);
15763
15764                 if (regex_set_precedence(curchar)
15765                     > regex_set_precedence(stacked_operator))
15766                 {
15767                     /* Here, the new operator has higher precedence than the
15768                      * stacked one.  This means we need to add the new one to
15769                      * the stack to await its rhs operand (and maybe more
15770                      * stuff).  We put it before the lhs operand, leaving
15771                      * untouched the stacked operator and everything below it
15772                      * */
15773                     lhs = av_pop(stack);
15774                     assert(IS_OPERAND(lhs));
15775
15776                     av_push(stack, newSVuv(curchar));
15777                     av_push(stack, lhs);
15778                     break;
15779                 }
15780
15781                 /* Here, the new operator has equal or lower precedence than
15782                  * what's already there.  This means the operation already
15783                  * there should be performed now, before the new one. */
15784
15785                 rhs = av_pop(stack);
15786                 if (! IS_OPERAND(rhs)) {
15787
15788                     /* This can happen when a ! is not followed by an operand,
15789                      * like in /(?[\t &!])/ */
15790                     goto bad_syntax;
15791                 }
15792
15793                 lhs = av_pop(stack);
15794
15795                 if (! IS_OPERAND(lhs)) {
15796
15797                     /* This can happen when there is an empty (), like in
15798                      * /(?[[0]+()+])/ */
15799                     goto bad_syntax;
15800                 }
15801
15802                 switch (stacked_operator) {
15803                     case '&':
15804                         _invlist_intersection(lhs, rhs, &rhs);
15805                         break;
15806
15807                     case '|':
15808                     case '+':
15809                         _invlist_union(lhs, rhs, &rhs);
15810                         break;
15811
15812                     case '-':
15813                         _invlist_subtract(lhs, rhs, &rhs);
15814                         break;
15815
15816                     case '^':   /* The union minus the intersection */
15817                     {
15818                         SV* i = NULL;
15819                         SV* u = NULL;
15820
15821                         _invlist_union(lhs, rhs, &u);
15822                         _invlist_intersection(lhs, rhs, &i);
15823                         _invlist_subtract(u, i, &rhs);
15824                         SvREFCNT_dec_NN(i);
15825                         SvREFCNT_dec_NN(u);
15826                         break;
15827                     }
15828                 }
15829                 SvREFCNT_dec(lhs);
15830
15831                 /* Here, the higher precedence operation has been done, and the
15832                  * result is in 'rhs'.  We overwrite the stacked operator with
15833                  * the result.  Then we redo this code to either push the new
15834                  * operator onto the stack or perform any higher precedence
15835                  * stacked operation */
15836                 only_to_avoid_leaks = av_pop(stack);
15837                 SvREFCNT_dec(only_to_avoid_leaks);
15838                 av_push(stack, rhs);
15839                 goto redo_curchar;
15840
15841             case '!':   /* Highest priority, right associative */
15842
15843                 /* If what's already at the top of the stack is another '!",
15844                  * they just cancel each other out */
15845                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15846                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15847                 {
15848                     only_to_avoid_leaks = av_pop(stack);
15849                     SvREFCNT_dec(only_to_avoid_leaks);
15850                 }
15851                 else { /* Otherwise, since it's right associative, just push
15852                           onto the stack */
15853                     av_push(stack, newSVuv(curchar));
15854                 }
15855                 break;
15856
15857             default:
15858                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15859                 vFAIL("Unexpected character");
15860
15861           handle_operand:
15862
15863             /* Here 'current' is the operand.  If something is already on the
15864              * stack, we have to check if it is a !.  But first, the code above
15865              * may have altered the stack in the time since we earlier set
15866              * 'top_index'.  */
15867
15868             top_index = av_tindex_skip_len_mg(stack);
15869             if (top_index - fence >= 0) {
15870                 /* If the top entry on the stack is an operator, it had better
15871                  * be a '!', otherwise the entry below the top operand should
15872                  * be an operator */
15873                 top_ptr = av_fetch(stack, top_index, FALSE);
15874                 assert(top_ptr);
15875                 if (IS_OPERATOR(*top_ptr)) {
15876
15877                     /* The only permissible operator at the top of the stack is
15878                      * '!', which is applied immediately to this operand. */
15879                     curchar = (char) SvUV(*top_ptr);
15880                     if (curchar != '!') {
15881                         SvREFCNT_dec(current);
15882                         vFAIL2("Unexpected binary operator '%c' with no "
15883                                 "preceding operand", curchar);
15884                     }
15885
15886                     _invlist_invert(current);
15887
15888                     only_to_avoid_leaks = av_pop(stack);
15889                     SvREFCNT_dec(only_to_avoid_leaks);
15890
15891                     /* And we redo with the inverted operand.  This allows
15892                      * handling multiple ! in a row */
15893                     goto handle_operand;
15894                 }
15895                           /* Single operand is ok only for the non-binary ')'
15896                            * operator */
15897                 else if ((top_index - fence == 0 && curchar != ')')
15898                          || (top_index - fence > 0
15899                              && (! (stacked_ptr = av_fetch(stack,
15900                                                            top_index - 1,
15901                                                            FALSE))
15902                                  || IS_OPERAND(*stacked_ptr))))
15903                 {
15904                     SvREFCNT_dec(current);
15905                     vFAIL("Operand with no preceding operator");
15906                 }
15907             }
15908
15909             /* Here there was nothing on the stack or the top element was
15910              * another operand.  Just add this new one */
15911             av_push(stack, current);
15912
15913         } /* End of switch on next parse token */
15914
15915         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15916     } /* End of loop parsing through the construct */
15917
15918   done:
15919     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
15920         vFAIL("Unmatched (");
15921     }
15922
15923     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
15924         || ((final = av_pop(stack)) == NULL)
15925         || ! IS_OPERAND(final)
15926         || SvTYPE(final) != SVt_INVLIST
15927         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
15928     {
15929       bad_syntax:
15930         SvREFCNT_dec(final);
15931         vFAIL("Incomplete expression within '(?[ ])'");
15932     }
15933
15934     /* Here, 'final' is the resultant inversion list from evaluating the
15935      * expression.  Return it if so requested */
15936     if (return_invlist) {
15937         *return_invlist = final;
15938         return END;
15939     }
15940
15941     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15942      * expecting a string of ranges and individual code points */
15943     invlist_iterinit(final);
15944     result_string = newSVpvs("");
15945     while (invlist_iternext(final, &start, &end)) {
15946         if (start == end) {
15947             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15948         }
15949         else {
15950             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15951                                                      start,          end);
15952         }
15953     }
15954
15955     /* About to generate an ANYOF (or similar) node from the inversion list we
15956      * have calculated */
15957     save_parse = RExC_parse;
15958     RExC_parse = SvPV(result_string, len);
15959     save_end = RExC_end;
15960     RExC_end = RExC_parse + len;
15961
15962     /* We turn off folding around the call, as the class we have constructed
15963      * already has all folding taken into consideration, and we don't want
15964      * regclass() to add to that */
15965     RExC_flags &= ~RXf_PMf_FOLD;
15966     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15967      * folds are allowed.  */
15968     node = regclass(pRExC_state, flagp,depth+1,
15969                     FALSE, /* means parse the whole char class */
15970                     FALSE, /* don't allow multi-char folds */
15971                     TRUE, /* silence non-portable warnings.  The above may very
15972                              well have generated non-portable code points, but
15973                              they're valid on this machine */
15974                     FALSE, /* similarly, no need for strict */
15975                     FALSE, /* Require return to be an ANYOF */
15976                     NULL,
15977                     NULL
15978                 );
15979     if (!node)
15980         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15981                     PTR2UV(flagp));
15982
15983     /* Fix up the node type if we are in locale.  (We have pretended we are
15984      * under /u for the purposes of regclass(), as this construct will only
15985      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15986      * as to cause any warnings about bad locales to be output in regexec.c),
15987      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15988      * reason we above forbid optimization into something other than an ANYOF
15989      * node is simply to minimize the number of code changes in regexec.c.
15990      * Otherwise we would have to create new EXACTish node types and deal with
15991      * them.  This decision could be revisited should this construct become
15992      * popular.
15993      *
15994      * (One might think we could look at the resulting ANYOF node and suppress
15995      * the flag if everything is above 255, as those would be UTF-8 only,
15996      * but this isn't true, as the components that led to that result could
15997      * have been locale-affected, and just happen to cancel each other out
15998      * under UTF-8 locales.) */
15999     if (in_locale) {
16000         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
16001
16002         assert(OP(node) == ANYOF);
16003
16004         OP(node) = ANYOFL;
16005         ANYOF_FLAGS(node)
16006                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
16007     }
16008
16009     if (save_fold) {
16010         RExC_flags |= RXf_PMf_FOLD;
16011     }
16012
16013     RExC_parse = save_parse + 1;
16014     RExC_end = save_end;
16015     SvREFCNT_dec_NN(final);
16016     SvREFCNT_dec_NN(result_string);
16017
16018     nextchar(pRExC_state);
16019     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
16020     return node;
16021 }
16022
16023 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16024
16025 STATIC void
16026 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
16027                              AV * stack, const IV fence, AV * fence_stack)
16028 {   /* Dumps the stacks in handle_regex_sets() */
16029
16030     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
16031     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
16032     SSize_t i;
16033
16034     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
16035
16036     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
16037
16038     if (stack_top < 0) {
16039         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
16040     }
16041     else {
16042         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
16043         for (i = stack_top; i >= 0; i--) {
16044             SV ** element_ptr = av_fetch(stack, i, FALSE);
16045             if (! element_ptr) {
16046             }
16047
16048             if (IS_OPERATOR(*element_ptr)) {
16049                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
16050                                             (int) i, (int) SvIV(*element_ptr));
16051             }
16052             else {
16053                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
16054                 sv_dump(*element_ptr);
16055             }
16056         }
16057     }
16058
16059     if (fence_stack_top < 0) {
16060         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
16061     }
16062     else {
16063         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
16064         for (i = fence_stack_top; i >= 0; i--) {
16065             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
16066             if (! element_ptr) {
16067             }
16068
16069             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
16070                                             (int) i, (int) SvIV(*element_ptr));
16071         }
16072     }
16073 }
16074
16075 #endif
16076
16077 #undef IS_OPERATOR
16078 #undef IS_OPERAND
16079
16080 STATIC void
16081 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
16082 {
16083     /* This adds the Latin1/above-Latin1 folding rules.
16084      *
16085      * This should be called only for a Latin1-range code points, cp, which is
16086      * known to be involved in a simple fold with other code points above
16087      * Latin1.  It would give false results if /aa has been specified.
16088      * Multi-char folds are outside the scope of this, and must be handled
16089      * specially. */
16090
16091     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
16092
16093     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
16094
16095     /* The rules that are valid for all Unicode versions are hard-coded in */
16096     switch (cp) {
16097         case 'k':
16098         case 'K':
16099           *invlist =
16100              add_cp_to_invlist(*invlist, KELVIN_SIGN);
16101             break;
16102         case 's':
16103         case 'S':
16104           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
16105             break;
16106         case MICRO_SIGN:
16107           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
16108           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
16109             break;
16110         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
16111         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
16112           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
16113             break;
16114         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
16115           *invlist = add_cp_to_invlist(*invlist,
16116                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
16117             break;
16118
16119         default:    /* Other code points are checked against the data for the
16120                        current Unicode version */
16121           {
16122             Size_t folds_to_count;
16123             unsigned int first_folds_to;
16124             const unsigned int * remaining_folds_to_list;
16125             UV folded_cp;
16126
16127             if (isASCII(cp)) {
16128                 folded_cp = toFOLD(cp);
16129             }
16130             else {
16131                 U8 dummy_fold[UTF8_MAXBYTES_CASE+1];
16132                 Size_t dummy_len;
16133                 folded_cp = _to_fold_latin1(cp, dummy_fold, &dummy_len, 0);
16134             }
16135
16136             if (folded_cp > 255) {
16137                 *invlist = add_cp_to_invlist(*invlist, folded_cp);
16138             }
16139
16140             folds_to_count = _inverse_folds(folded_cp, &first_folds_to,
16141                                                     &remaining_folds_to_list);
16142             if (folds_to_count == 0) {
16143
16144                 /* Use deprecated warning to increase the chances of this being
16145                  * output */
16146                 if (PASS2) {
16147                     ckWARN2reg_d(RExC_parse,
16148                         "Perl folding rules are not up-to-date for 0x%02X;"
16149                         " please use the perlbug utility to report;", cp);
16150                 }
16151             }
16152             else {
16153                 unsigned int i;
16154
16155                 if (first_folds_to > 255) {
16156                     *invlist = add_cp_to_invlist(*invlist, first_folds_to);
16157                 }
16158                 for (i = 0; i < folds_to_count - 1; i++) {
16159                     if (remaining_folds_to_list[i] > 255) {
16160                         *invlist = add_cp_to_invlist(*invlist,
16161                                                     remaining_folds_to_list[i]);
16162                     }
16163                 }
16164             }
16165             break;
16166          }
16167     }
16168 }
16169
16170 STATIC void
16171 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
16172 {
16173     /* If the final parameter is NULL, output the elements of the array given
16174      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
16175      * pushed onto it, (creating if necessary) */
16176
16177     SV * msg;
16178     const bool first_is_fatal =  ! return_posix_warnings
16179                                 && ckDEAD(packWARN(WARN_REGEXP));
16180
16181     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
16182
16183     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
16184         if (return_posix_warnings) {
16185             if (! *return_posix_warnings) { /* mortalize to not leak if
16186                                                warnings are fatal */
16187                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
16188             }
16189             av_push(*return_posix_warnings, msg);
16190         }
16191         else {
16192             if (first_is_fatal) {           /* Avoid leaking this */
16193                 av_undef(posix_warnings);   /* This isn't necessary if the
16194                                                array is mortal, but is a
16195                                                fail-safe */
16196                 (void) sv_2mortal(msg);
16197                 if (PASS2) {
16198                     SAVEFREESV(RExC_rx_sv);
16199                 }
16200             }
16201             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
16202             SvREFCNT_dec_NN(msg);
16203         }
16204     }
16205 }
16206
16207 STATIC AV *
16208 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
16209 {
16210     /* This adds the string scalar <multi_string> to the array
16211      * <multi_char_matches>.  <multi_string> is known to have exactly
16212      * <cp_count> code points in it.  This is used when constructing a
16213      * bracketed character class and we find something that needs to match more
16214      * than a single character.
16215      *
16216      * <multi_char_matches> is actually an array of arrays.  Each top-level
16217      * element is an array that contains all the strings known so far that are
16218      * the same length.  And that length (in number of code points) is the same
16219      * as the index of the top-level array.  Hence, the [2] element is an
16220      * array, each element thereof is a string containing TWO code points;
16221      * while element [3] is for strings of THREE characters, and so on.  Since
16222      * this is for multi-char strings there can never be a [0] nor [1] element.
16223      *
16224      * When we rewrite the character class below, we will do so such that the
16225      * longest strings are written first, so that it prefers the longest
16226      * matching strings first.  This is done even if it turns out that any
16227      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
16228      * Christiansen has agreed that this is ok.  This makes the test for the
16229      * ligature 'ffi' come before the test for 'ff', for example */
16230
16231     AV* this_array;
16232     AV** this_array_ptr;
16233
16234     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
16235
16236     if (! multi_char_matches) {
16237         multi_char_matches = newAV();
16238     }
16239
16240     if (av_exists(multi_char_matches, cp_count)) {
16241         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
16242         this_array = *this_array_ptr;
16243     }
16244     else {
16245         this_array = newAV();
16246         av_store(multi_char_matches, cp_count,
16247                  (SV*) this_array);
16248     }
16249     av_push(this_array, multi_string);
16250
16251     return multi_char_matches;
16252 }
16253
16254 /* The names of properties whose definitions are not known at compile time are
16255  * stored in this SV, after a constant heading.  So if the length has been
16256  * changed since initialization, then there is a run-time definition. */
16257 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
16258                                         (SvCUR(listsv) != initial_listsv_len)
16259
16260 /* There is a restricted set of white space characters that are legal when
16261  * ignoring white space in a bracketed character class.  This generates the
16262  * code to skip them.
16263  *
16264  * There is a line below that uses the same white space criteria but is outside
16265  * this macro.  Both here and there must use the same definition */
16266 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
16267     STMT_START {                                                        \
16268         if (do_skip) {                                                  \
16269             while (isBLANK_A(UCHARAT(p)))                               \
16270             {                                                           \
16271                 p++;                                                    \
16272             }                                                           \
16273         }                                                               \
16274     } STMT_END
16275
16276 STATIC regnode *
16277 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
16278                  const bool stop_at_1,  /* Just parse the next thing, don't
16279                                            look for a full character class */
16280                  bool allow_multi_folds,
16281                  const bool silence_non_portable,   /* Don't output warnings
16282                                                        about too large
16283                                                        characters */
16284                  const bool strict,
16285                  bool optimizable,                  /* ? Allow a non-ANYOF return
16286                                                        node */
16287                  SV** ret_invlist, /* Return an inversion list, not a node */
16288                  AV** return_posix_warnings
16289           )
16290 {
16291     /* parse a bracketed class specification.  Most of these will produce an
16292      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
16293      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
16294      * under /i with multi-character folds: it will be rewritten following the
16295      * paradigm of this example, where the <multi-fold>s are characters which
16296      * fold to multiple character sequences:
16297      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
16298      * gets effectively rewritten as:
16299      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
16300      * reg() gets called (recursively) on the rewritten version, and this
16301      * function will return what it constructs.  (Actually the <multi-fold>s
16302      * aren't physically removed from the [abcdefghi], it's just that they are
16303      * ignored in the recursion by means of a flag:
16304      * <RExC_in_multi_char_class>.)
16305      *
16306      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
16307      * characters, with the corresponding bit set if that character is in the
16308      * list.  For characters above this, a range list or swash is used.  There
16309      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
16310      * determinable at compile time
16311      *
16312      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
16313      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
16314      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
16315      */
16316
16317     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
16318     IV range = 0;
16319     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
16320     regnode *ret;
16321     STRLEN numlen;
16322     int namedclass = OOB_NAMEDCLASS;
16323     char *rangebegin = NULL;
16324     bool need_class = 0;
16325     SV *listsv = NULL;
16326     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
16327                                       than just initialized.  */
16328     SV* properties = NULL;    /* Code points that match \p{} \P{} */
16329     SV* posixes = NULL;     /* Code points that match classes like [:word:],
16330                                extended beyond the Latin1 range.  These have to
16331                                be kept separate from other code points for much
16332                                of this function because their handling  is
16333                                different under /i, and for most classes under
16334                                /d as well */
16335     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
16336                                separate for a while from the non-complemented
16337                                versions because of complications with /d
16338                                matching */
16339     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
16340                                   treated more simply than the general case,
16341                                   leading to less compilation and execution
16342                                   work */
16343     UV element_count = 0;   /* Number of distinct elements in the class.
16344                                Optimizations may be possible if this is tiny */
16345     AV * multi_char_matches = NULL; /* Code points that fold to more than one
16346                                        character; used under /i */
16347     UV n;
16348     char * stop_ptr = RExC_end;    /* where to stop parsing */
16349
16350     /* ignore unescaped whitespace? */
16351     const bool skip_white = cBOOL(   ret_invlist
16352                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
16353
16354     /* Unicode properties are stored in a swash; this holds the current one
16355      * being parsed.  If this swash is the only above-latin1 component of the
16356      * character class, an optimization is to pass it directly on to the
16357      * execution engine.  Otherwise, it is set to NULL to indicate that there
16358      * are other things in the class that have to be dealt with at execution
16359      * time */
16360     SV* swash = NULL;           /* Code points that match \p{} \P{} */
16361
16362     /* Set if a component of this character class is user-defined; just passed
16363      * on to the engine */
16364     bool has_user_defined_property = FALSE;
16365
16366     /* inversion list of code points this node matches only when the target
16367      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
16368      * /d) */
16369     SV* has_upper_latin1_only_utf8_matches = NULL;
16370
16371     /* Inversion list of code points this node matches regardless of things
16372      * like locale, folding, utf8ness of the target string */
16373     SV* cp_list = NULL;
16374
16375     /* Like cp_list, but code points on this list need to be checked for things
16376      * that fold to/from them under /i */
16377     SV* cp_foldable_list = NULL;
16378
16379     /* Like cp_list, but code points on this list are valid only when the
16380      * runtime locale is UTF-8 */
16381     SV* only_utf8_locale_list = NULL;
16382
16383     /* In a range, if one of the endpoints is non-character-set portable,
16384      * meaning that it hard-codes a code point that may mean a different
16385      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
16386      * mnemonic '\t' which each mean the same character no matter which
16387      * character set the platform is on. */
16388     unsigned int non_portable_endpoint = 0;
16389
16390     /* Is the range unicode? which means on a platform that isn't 1-1 native
16391      * to Unicode (i.e. non-ASCII), each code point in it should be considered
16392      * to be a Unicode value.  */
16393     bool unicode_range = FALSE;
16394     bool invert = FALSE;    /* Is this class to be complemented */
16395
16396     bool warn_super = ALWAYS_WARN_SUPER;
16397
16398     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
16399         case we need to change the emitted regop to an EXACT. */
16400     const char * orig_parse = RExC_parse;
16401     const SSize_t orig_size = RExC_size;
16402     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
16403
16404     /* This variable is used to mark where the end in the input is of something
16405      * that looks like a POSIX construct but isn't.  During the parse, when
16406      * something looks like it could be such a construct is encountered, it is
16407      * checked for being one, but not if we've already checked this area of the
16408      * input.  Only after this position is reached do we check again */
16409     char *not_posix_region_end = RExC_parse - 1;
16410
16411     AV* posix_warnings = NULL;
16412     const bool do_posix_warnings =     return_posix_warnings
16413                                    || (PASS2 && ckWARN(WARN_REGEXP));
16414
16415     GET_RE_DEBUG_FLAGS_DECL;
16416
16417     PERL_ARGS_ASSERT_REGCLASS;
16418 #ifndef DEBUGGING
16419     PERL_UNUSED_ARG(depth);
16420 #endif
16421
16422     DEBUG_PARSE("clas");
16423
16424 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
16425     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
16426                                    && UNICODE_DOT_DOT_VERSION == 0)
16427     allow_multi_folds = FALSE;
16428 #endif
16429
16430     /* Assume we are going to generate an ANYOF node. */
16431     ret = reganode(pRExC_state,
16432                    (LOC)
16433                     ? ANYOFL
16434                     : ANYOF,
16435                    0);
16436
16437     if (SIZE_ONLY) {
16438         RExC_size += ANYOF_SKIP;
16439         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
16440     }
16441     else {
16442         ANYOF_FLAGS(ret) = 0;
16443
16444         RExC_emit += ANYOF_SKIP;
16445         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
16446         initial_listsv_len = SvCUR(listsv);
16447         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
16448     }
16449
16450     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16451
16452     assert(RExC_parse <= RExC_end);
16453
16454     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
16455         RExC_parse++;
16456         invert = TRUE;
16457         allow_multi_folds = FALSE;
16458         MARK_NAUGHTY(1);
16459         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16460     }
16461
16462     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
16463     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
16464         int maybe_class = handle_possible_posix(pRExC_state,
16465                                                 RExC_parse,
16466                                                 &not_posix_region_end,
16467                                                 NULL,
16468                                                 TRUE /* checking only */);
16469         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
16470             SAVEFREESV(RExC_rx_sv);
16471             ckWARN4reg(not_posix_region_end,
16472                     "POSIX syntax [%c %c] belongs inside character classes%s",
16473                     *RExC_parse, *RExC_parse,
16474                     (maybe_class == OOB_NAMEDCLASS)
16475                     ? ((POSIXCC_NOTYET(*RExC_parse))
16476                         ? " (but this one isn't implemented)"
16477                         : " (but this one isn't fully valid)")
16478                     : ""
16479                     );
16480             (void)ReREFCNT_inc(RExC_rx_sv);
16481         }
16482     }
16483
16484     /* If the caller wants us to just parse a single element, accomplish this
16485      * by faking the loop ending condition */
16486     if (stop_at_1 && RExC_end > RExC_parse) {
16487         stop_ptr = RExC_parse + 1;
16488     }
16489
16490     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
16491     if (UCHARAT(RExC_parse) == ']')
16492         goto charclassloop;
16493
16494     while (1) {
16495
16496         if (   posix_warnings
16497             && av_tindex_skip_len_mg(posix_warnings) >= 0
16498             && RExC_parse > not_posix_region_end)
16499         {
16500             /* Warnings about posix class issues are considered tentative until
16501              * we are far enough along in the parse that we can no longer
16502              * change our mind, at which point we either output them or add
16503              * them, if it has so specified, to what gets returned to the
16504              * caller.  This is done each time through the loop so that a later
16505              * class won't zap them before they have been dealt with. */
16506             output_or_return_posix_warnings(pRExC_state, posix_warnings,
16507                                             return_posix_warnings);
16508         }
16509
16510         if  (RExC_parse >= stop_ptr) {
16511             break;
16512         }
16513
16514         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16515
16516         if  (UCHARAT(RExC_parse) == ']') {
16517             break;
16518         }
16519
16520       charclassloop:
16521
16522         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16523         save_value = value;
16524         save_prevvalue = prevvalue;
16525
16526         if (!range) {
16527             rangebegin = RExC_parse;
16528             element_count++;
16529             non_portable_endpoint = 0;
16530         }
16531         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16532             value = utf8n_to_uvchr((U8*)RExC_parse,
16533                                    RExC_end - RExC_parse,
16534                                    &numlen, UTF8_ALLOW_DEFAULT);
16535             RExC_parse += numlen;
16536         }
16537         else
16538             value = UCHARAT(RExC_parse++);
16539
16540         if (value == '[') {
16541             char * posix_class_end;
16542             namedclass = handle_possible_posix(pRExC_state,
16543                                                RExC_parse,
16544                                                &posix_class_end,
16545                                                do_posix_warnings ? &posix_warnings : NULL,
16546                                                FALSE    /* die if error */);
16547             if (namedclass > OOB_NAMEDCLASS) {
16548
16549                 /* If there was an earlier attempt to parse this particular
16550                  * posix class, and it failed, it was a false alarm, as this
16551                  * successful one proves */
16552                 if (   posix_warnings
16553                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16554                     && not_posix_region_end >= RExC_parse
16555                     && not_posix_region_end <= posix_class_end)
16556                 {
16557                     av_undef(posix_warnings);
16558                 }
16559
16560                 RExC_parse = posix_class_end;
16561             }
16562             else if (namedclass == OOB_NAMEDCLASS) {
16563                 not_posix_region_end = posix_class_end;
16564             }
16565             else {
16566                 namedclass = OOB_NAMEDCLASS;
16567             }
16568         }
16569         else if (   RExC_parse - 1 > not_posix_region_end
16570                  && MAYBE_POSIXCC(value))
16571         {
16572             (void) handle_possible_posix(
16573                         pRExC_state,
16574                         RExC_parse - 1,  /* -1 because parse has already been
16575                                             advanced */
16576                         &not_posix_region_end,
16577                         do_posix_warnings ? &posix_warnings : NULL,
16578                         TRUE /* checking only */);
16579         }
16580         else if (  strict && ! skip_white
16581                  && (   _generic_isCC(value, _CC_VERTSPACE)
16582                      || is_VERTWS_cp_high(value)))
16583         {
16584             vFAIL("Literal vertical space in [] is illegal except under /x");
16585         }
16586         else if (value == '\\') {
16587             /* Is a backslash; get the code point of the char after it */
16588
16589             if (RExC_parse >= RExC_end) {
16590                 vFAIL("Unmatched [");
16591             }
16592
16593             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16594                 value = utf8n_to_uvchr((U8*)RExC_parse,
16595                                    RExC_end - RExC_parse,
16596                                    &numlen, UTF8_ALLOW_DEFAULT);
16597                 RExC_parse += numlen;
16598             }
16599             else
16600                 value = UCHARAT(RExC_parse++);
16601
16602             /* Some compilers cannot handle switching on 64-bit integer
16603              * values, therefore value cannot be an UV.  Yes, this will
16604              * be a problem later if we want switch on Unicode.
16605              * A similar issue a little bit later when switching on
16606              * namedclass. --jhi */
16607
16608             /* If the \ is escaping white space when white space is being
16609              * skipped, it means that that white space is wanted literally, and
16610              * is already in 'value'.  Otherwise, need to translate the escape
16611              * into what it signifies. */
16612             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16613
16614             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16615             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16616             case 's':   namedclass = ANYOF_SPACE;       break;
16617             case 'S':   namedclass = ANYOF_NSPACE;      break;
16618             case 'd':   namedclass = ANYOF_DIGIT;       break;
16619             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16620             case 'v':   namedclass = ANYOF_VERTWS;      break;
16621             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16622             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16623             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16624             case 'N':  /* Handle \N{NAME} in class */
16625                 {
16626                     const char * const backslash_N_beg = RExC_parse - 2;
16627                     int cp_count;
16628
16629                     if (! grok_bslash_N(pRExC_state,
16630                                         NULL,      /* No regnode */
16631                                         &value,    /* Yes single value */
16632                                         &cp_count, /* Multiple code pt count */
16633                                         flagp,
16634                                         strict,
16635                                         depth)
16636                     ) {
16637
16638                         if (*flagp & NEED_UTF8)
16639                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16640
16641                         RETURN_NULL_ON_RESTART_FLAGP(flagp);
16642
16643                         if (cp_count < 0) {
16644                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16645                         }
16646                         else if (cp_count == 0) {
16647                             if (PASS2) {
16648                                 ckWARNreg(RExC_parse,
16649                                         "Ignoring zero length \\N{} in character class");
16650                             }
16651                         }
16652                         else { /* cp_count > 1 */
16653                             if (! RExC_in_multi_char_class) {
16654                                 if (invert || range || *RExC_parse == '-') {
16655                                     if (strict) {
16656                                         RExC_parse--;
16657                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16658                                     }
16659                                     else if (PASS2) {
16660                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16661                                     }
16662                                     break; /* <value> contains the first code
16663                                               point. Drop out of the switch to
16664                                               process it */
16665                                 }
16666                                 else {
16667                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16668                                                  RExC_parse - backslash_N_beg);
16669                                     multi_char_matches
16670                                         = add_multi_match(multi_char_matches,
16671                                                           multi_char_N,
16672                                                           cp_count);
16673                                 }
16674                             }
16675                         } /* End of cp_count != 1 */
16676
16677                         /* This element should not be processed further in this
16678                          * class */
16679                         element_count--;
16680                         value = save_value;
16681                         prevvalue = save_prevvalue;
16682                         continue;   /* Back to top of loop to get next char */
16683                     }
16684
16685                     /* Here, is a single code point, and <value> contains it */
16686                     unicode_range = TRUE;   /* \N{} are Unicode */
16687                 }
16688                 break;
16689             case 'p':
16690             case 'P':
16691                 {
16692                 char *e;
16693
16694                 /* We will handle any undefined properties ourselves */
16695                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16696                                        /* And we actually would prefer to get
16697                                         * the straight inversion list of the
16698                                         * swash, since we will be accessing it
16699                                         * anyway, to save a little time */
16700                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16701
16702                 if (RExC_parse >= RExC_end)
16703                     vFAIL2("Empty \\%c", (U8)value);
16704                 if (*RExC_parse == '{') {
16705                     const U8 c = (U8)value;
16706                     e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
16707                     if (!e) {
16708                         RExC_parse++;
16709                         vFAIL2("Missing right brace on \\%c{}", c);
16710                     }
16711
16712                     RExC_parse++;
16713                     while (isSPACE(*RExC_parse)) {
16714                          RExC_parse++;
16715                     }
16716
16717                     if (UCHARAT(RExC_parse) == '^') {
16718
16719                         /* toggle.  (The rhs xor gets the single bit that
16720                          * differs between P and p; the other xor inverts just
16721                          * that bit) */
16722                         value ^= 'P' ^ 'p';
16723
16724                         RExC_parse++;
16725                         while (isSPACE(*RExC_parse)) {
16726                             RExC_parse++;
16727                         }
16728                     }
16729
16730                     if (e == RExC_parse)
16731                         vFAIL2("Empty \\%c{}", c);
16732
16733                     n = e - RExC_parse;
16734                     while (isSPACE(*(RExC_parse + n - 1)))
16735                         n--;
16736                 }   /* The \p isn't immediately followed by a '{' */
16737                 else if (! isALPHA(*RExC_parse)) {
16738                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16739                     vFAIL2("Character following \\%c must be '{' or a "
16740                            "single-character Unicode property name",
16741                            (U8) value);
16742                 }
16743                 else {
16744                     e = RExC_parse;
16745                     n = 1;
16746                 }
16747                 if (!SIZE_ONLY) {
16748                     SV* invlist;
16749                     char* name;
16750                     char* base_name;    /* name after any packages are stripped */
16751                     char* lookup_name = NULL;
16752                     const char * const colon_colon = "::";
16753
16754                     /* Try to get the definition of the property into
16755                      * <invlist>.  If /i is in effect, the effective property
16756                      * will have its name be <__NAME_i>.  The design is
16757                      * discussed in commit
16758                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16759                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16760                     SAVEFREEPV(name);
16761                     if (FOLD) {
16762                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16763
16764                         /* The function call just below that uses this can fail
16765                          * to return, leaking memory if we don't do this */
16766                         SAVEFREEPV(lookup_name);
16767                     }
16768
16769                     /* Look up the property name, and get its swash and
16770                      * inversion list, if the property is found  */
16771                     SvREFCNT_dec(swash); /* Free any left-overs */
16772                     swash = _core_swash_init("utf8",
16773                                              (lookup_name)
16774                                               ? lookup_name
16775                                               : name,
16776                                              &PL_sv_undef,
16777                                              1, /* binary */
16778                                              0, /* not tr/// */
16779                                              NULL, /* No inversion list */
16780                                              &swash_init_flags
16781                                             );
16782                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16783                         HV* curpkg = (IN_PERL_COMPILETIME)
16784                                       ? PL_curstash
16785                                       : CopSTASH(PL_curcop);
16786                         UV final_n = n;
16787                         bool has_pkg;
16788
16789                         if (swash) {    /* Got a swash but no inversion list.
16790                                            Something is likely wrong that will
16791                                            be sorted-out later */
16792                             SvREFCNT_dec_NN(swash);
16793                             swash = NULL;
16794                         }
16795
16796                         /* Here didn't find it.  It could be a an error (like a
16797                          * typo) in specifying a Unicode property, or it could
16798                          * be a user-defined property that will be available at
16799                          * run-time.  The names of these must begin with 'In'
16800                          * or 'Is' (after any packages are stripped off).  So
16801                          * if not one of those, or if we accept only
16802                          * compile-time properties, is an error; otherwise add
16803                          * it to the list for run-time look up. */
16804                         if ((base_name = rninstr(name, name + n,
16805                                                  colon_colon, colon_colon + 2)))
16806                         { /* Has ::.  We know this must be a user-defined
16807                              property */
16808                             base_name += 2;
16809                             final_n -= base_name - name;
16810                             has_pkg = TRUE;
16811                         }
16812                         else {
16813                             base_name = name;
16814                             has_pkg = FALSE;
16815                         }
16816
16817                         if (   final_n < 3
16818                             || base_name[0] != 'I'
16819                             || (base_name[1] != 's' && base_name[1] != 'n')
16820                             || ret_invlist)
16821                         {
16822                             const char * const msg
16823                                 = (has_pkg)
16824                                   ? "Illegal user-defined property name"
16825                                   : "Can't find Unicode property definition";
16826                             RExC_parse = e + 1;
16827
16828                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16829                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16830                                 msg, UTF8fARG(UTF, n, name));
16831                         }
16832
16833                         /* If the property name doesn't already have a package
16834                          * name, add the current one to it so that it can be
16835                          * referred to outside it. [perl #121777] */
16836                         if (! has_pkg && curpkg) {
16837                             char* pkgname = HvNAME(curpkg);
16838                             if (memNEs(pkgname, HvNAMELEN(curpkg), "main")) {
16839                                 char* full_name = Perl_form(aTHX_
16840                                                             "%s::%s",
16841                                                             pkgname,
16842                                                             name);
16843                                 n = strlen(full_name);
16844                                 name = savepvn(full_name, n);
16845                                 SAVEFREEPV(name);
16846                             }
16847                         }
16848                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16849                                         (value == 'p' ? '+' : '!'),
16850                                         (FOLD) ? "__" : "",
16851                                         UTF8fARG(UTF, n, name),
16852                                         (FOLD) ? "_i" : "");
16853                         has_user_defined_property = TRUE;
16854                         optimizable = FALSE;    /* Will have to leave this an
16855                                                    ANYOF node */
16856
16857                         /* We don't know yet what this matches, so have to flag
16858                          * it */
16859                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16860                     }
16861                     else {
16862
16863                         /* Here, did get the swash and its inversion list.  If
16864                          * the swash is from a user-defined property, then this
16865                          * whole character class should be regarded as such */
16866                         if (swash_init_flags
16867                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16868                         {
16869                             has_user_defined_property = TRUE;
16870                         }
16871                         else if
16872                             /* We warn on matching an above-Unicode code point
16873                              * if the match would return true, except don't
16874                              * warn for \p{All}, which has exactly one element
16875                              * = 0 */
16876                             (_invlist_contains_cp(invlist, 0x110000)
16877                                 && (! (_invlist_len(invlist) == 1
16878                                        && *invlist_array(invlist) == 0)))
16879                         {
16880                             warn_super = TRUE;
16881                         }
16882
16883
16884                         /* Invert if asking for the complement */
16885                         if (value == 'P') {
16886                             _invlist_union_complement_2nd(properties,
16887                                                           invlist,
16888                                                           &properties);
16889
16890                             /* The swash can't be used as-is, because we've
16891                              * inverted things; delay removing it to here after
16892                              * have copied its invlist above */
16893                             SvREFCNT_dec_NN(swash);
16894                             swash = NULL;
16895                         }
16896                         else {
16897                             _invlist_union(properties, invlist, &properties);
16898                         }
16899                     }
16900                 }
16901                 RExC_parse = e + 1;
16902                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16903                                                 named */
16904
16905                 /* \p means they want Unicode semantics */
16906                 REQUIRE_UNI_RULES(flagp, NULL);
16907                 }
16908                 break;
16909             case 'n':   value = '\n';                   break;
16910             case 'r':   value = '\r';                   break;
16911             case 't':   value = '\t';                   break;
16912             case 'f':   value = '\f';                   break;
16913             case 'b':   value = '\b';                   break;
16914             case 'e':   value = ESC_NATIVE;             break;
16915             case 'a':   value = '\a';                   break;
16916             case 'o':
16917                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16918                 {
16919                     const char* error_msg;
16920                     bool valid = grok_bslash_o(&RExC_parse,
16921                                                RExC_end,
16922                                                &value,
16923                                                &error_msg,
16924                                                PASS2,   /* warnings only in
16925                                                            pass 2 */
16926                                                strict,
16927                                                silence_non_portable,
16928                                                UTF);
16929                     if (! valid) {
16930                         vFAIL(error_msg);
16931                     }
16932                 }
16933                 non_portable_endpoint++;
16934                 break;
16935             case 'x':
16936                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16937                 {
16938                     const char* error_msg;
16939                     bool valid = grok_bslash_x(&RExC_parse,
16940                                                RExC_end,
16941                                                &value,
16942                                                &error_msg,
16943                                                PASS2, /* Output warnings */
16944                                                strict,
16945                                                silence_non_portable,
16946                                                UTF);
16947                     if (! valid) {
16948                         vFAIL(error_msg);
16949                     }
16950                 }
16951                 non_portable_endpoint++;
16952                 break;
16953             case 'c':
16954                 value = grok_bslash_c(*RExC_parse++, PASS2);
16955                 non_portable_endpoint++;
16956                 break;
16957             case '0': case '1': case '2': case '3': case '4':
16958             case '5': case '6': case '7':
16959                 {
16960                     /* Take 1-3 octal digits */
16961                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16962                     numlen = (strict) ? 4 : 3;
16963                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16964                     RExC_parse += numlen;
16965                     if (numlen != 3) {
16966                         if (strict) {
16967                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16968                             vFAIL("Need exactly 3 octal digits");
16969                         }
16970                         else if (! SIZE_ONLY /* like \08, \178 */
16971                                  && numlen < 3
16972                                  && RExC_parse < RExC_end
16973                                  && isDIGIT(*RExC_parse)
16974                                  && ckWARN(WARN_REGEXP))
16975                         {
16976                             SAVEFREESV(RExC_rx_sv);
16977                             reg_warn_non_literal_string(
16978                                  RExC_parse + 1,
16979                                  form_short_octal_warning(RExC_parse, numlen));
16980                             (void)ReREFCNT_inc(RExC_rx_sv);
16981                         }
16982                     }
16983                     non_portable_endpoint++;
16984                     break;
16985                 }
16986             default:
16987                 /* Allow \_ to not give an error */
16988                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16989                     if (strict) {
16990                         vFAIL2("Unrecognized escape \\%c in character class",
16991                                (int)value);
16992                     }
16993                     else {
16994                         SAVEFREESV(RExC_rx_sv);
16995                         ckWARN2reg(RExC_parse,
16996                             "Unrecognized escape \\%c in character class passed through",
16997                             (int)value);
16998                         (void)ReREFCNT_inc(RExC_rx_sv);
16999                     }
17000                 }
17001                 break;
17002             }   /* End of switch on char following backslash */
17003         } /* end of handling backslash escape sequences */
17004
17005         /* Here, we have the current token in 'value' */
17006
17007         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
17008             U8 classnum;
17009
17010             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
17011              * literal, as is the character that began the false range, i.e.
17012              * the 'a' in the examples */
17013             if (range) {
17014                 if (!SIZE_ONLY) {
17015                     const int w = (RExC_parse >= rangebegin)
17016                                   ? RExC_parse - rangebegin
17017                                   : 0;
17018                     if (strict) {
17019                         vFAIL2utf8f(
17020                             "False [] range \"%" UTF8f "\"",
17021                             UTF8fARG(UTF, w, rangebegin));
17022                     }
17023                     else {
17024                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
17025                         ckWARN2reg(RExC_parse,
17026                             "False [] range \"%" UTF8f "\"",
17027                             UTF8fARG(UTF, w, rangebegin));
17028                         (void)ReREFCNT_inc(RExC_rx_sv);
17029                         cp_list = add_cp_to_invlist(cp_list, '-');
17030                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
17031                                                              prevvalue);
17032                     }
17033                 }
17034
17035                 range = 0; /* this was not a true range */
17036                 element_count += 2; /* So counts for three values */
17037             }
17038
17039             classnum = namedclass_to_classnum(namedclass);
17040
17041             if (LOC && namedclass < ANYOF_POSIXL_MAX
17042 #ifndef HAS_ISASCII
17043                 && classnum != _CC_ASCII
17044 #endif
17045             ) {
17046                 /* What the Posix classes (like \w, [:space:]) match in locale
17047                  * isn't knowable under locale until actual match time.  Room
17048                  * must be reserved (one time per outer bracketed class) to
17049                  * store such classes.  The space will contain a bit for each
17050                  * named class that is to be matched against.  This isn't
17051                  * needed for \p{} and pseudo-classes, as they are not affected
17052                  * by locale, and hence are dealt with separately */
17053                 if (! need_class) {
17054                     need_class = 1;
17055                     if (SIZE_ONLY) {
17056                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
17057                     }
17058                     else {
17059                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
17060                     }
17061                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
17062                     ANYOF_POSIXL_ZERO(ret);
17063
17064                     /* We can't change this into some other type of node
17065                      * (unless this is the only element, in which case there
17066                      * are nodes that mean exactly this) as has runtime
17067                      * dependencies */
17068                     optimizable = FALSE;
17069                 }
17070
17071                 /* Coverity thinks it is possible for this to be negative; both
17072                  * jhi and khw think it's not, but be safer */
17073                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
17074                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
17075
17076                 /* See if it already matches the complement of this POSIX
17077                  * class */
17078                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
17079                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
17080                                                             ? -1
17081                                                             : 1)))
17082                 {
17083                     posixl_matches_all = TRUE;
17084                     break;  /* No need to continue.  Since it matches both
17085                                e.g., \w and \W, it matches everything, and the
17086                                bracketed class can be optimized into qr/./s */
17087                 }
17088
17089                 /* Add this class to those that should be checked at runtime */
17090                 ANYOF_POSIXL_SET(ret, namedclass);
17091
17092                 /* The above-Latin1 characters are not subject to locale rules.
17093                  * Just add them, in the second pass, to the
17094                  * unconditionally-matched list */
17095                 if (! SIZE_ONLY) {
17096                     SV* scratch_list = NULL;
17097
17098                     /* Get the list of the above-Latin1 code points this
17099                      * matches */
17100                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
17101                                           PL_XPosix_ptrs[classnum],
17102
17103                                           /* Odd numbers are complements, like
17104                                            * NDIGIT, NASCII, ... */
17105                                           namedclass % 2 != 0,
17106                                           &scratch_list);
17107                     /* Checking if 'cp_list' is NULL first saves an extra
17108                      * clone.  Its reference count will be decremented at the
17109                      * next union, etc, or if this is the only instance, at the
17110                      * end of the routine */
17111                     if (! cp_list) {
17112                         cp_list = scratch_list;
17113                     }
17114                     else {
17115                         _invlist_union(cp_list, scratch_list, &cp_list);
17116                         SvREFCNT_dec_NN(scratch_list);
17117                     }
17118                     continue;   /* Go get next character */
17119                 }
17120             }
17121             else if (! SIZE_ONLY) {
17122
17123                 /* Here, not in pass1 (in that pass we skip calculating the
17124                  * contents of this class), and is not /l, or is a POSIX class
17125                  * for which /l doesn't matter (or is a Unicode property, which
17126                  * is skipped here). */
17127                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
17128                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
17129
17130                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
17131                          * nor /l make a difference in what these match,
17132                          * therefore we just add what they match to cp_list. */
17133                         if (classnum != _CC_VERTSPACE) {
17134                             assert(   namedclass == ANYOF_HORIZWS
17135                                    || namedclass == ANYOF_NHORIZWS);
17136
17137                             /* It turns out that \h is just a synonym for
17138                              * XPosixBlank */
17139                             classnum = _CC_BLANK;
17140                         }
17141
17142                         _invlist_union_maybe_complement_2nd(
17143                                 cp_list,
17144                                 PL_XPosix_ptrs[classnum],
17145                                 namedclass % 2 != 0,    /* Complement if odd
17146                                                           (NHORIZWS, NVERTWS)
17147                                                         */
17148                                 &cp_list);
17149                     }
17150                 }
17151                 else if (  UNI_SEMANTICS
17152                         || classnum == _CC_ASCII
17153                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
17154                                                   || classnum == _CC_XDIGIT)))
17155                 {
17156                     /* We usually have to worry about /d and /a affecting what
17157                      * POSIX classes match, with special code needed for /d
17158                      * because we won't know until runtime what all matches.
17159                      * But there is no extra work needed under /u, and
17160                      * [:ascii:] is unaffected by /a and /d; and :digit: and
17161                      * :xdigit: don't have runtime differences under /d.  So we
17162                      * can special case these, and avoid some extra work below,
17163                      * and at runtime. */
17164                     _invlist_union_maybe_complement_2nd(
17165                                                      simple_posixes,
17166                                                      PL_XPosix_ptrs[classnum],
17167                                                      namedclass % 2 != 0,
17168                                                      &simple_posixes);
17169                 }
17170                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
17171                            complement and use nposixes */
17172                     SV** posixes_ptr = namedclass % 2 == 0
17173                                        ? &posixes
17174                                        : &nposixes;
17175                     _invlist_union_maybe_complement_2nd(
17176                                                      *posixes_ptr,
17177                                                      PL_XPosix_ptrs[classnum],
17178                                                      namedclass % 2 != 0,
17179                                                      posixes_ptr);
17180                 }
17181             }
17182         } /* end of namedclass \blah */
17183
17184         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
17185
17186         /* If 'range' is set, 'value' is the ending of a range--check its
17187          * validity.  (If value isn't a single code point in the case of a
17188          * range, we should have figured that out above in the code that
17189          * catches false ranges).  Later, we will handle each individual code
17190          * point in the range.  If 'range' isn't set, this could be the
17191          * beginning of a range, so check for that by looking ahead to see if
17192          * the next real character to be processed is the range indicator--the
17193          * minus sign */
17194
17195         if (range) {
17196 #ifdef EBCDIC
17197             /* For unicode ranges, we have to test that the Unicode as opposed
17198              * to the native values are not decreasing.  (Above 255, there is
17199              * no difference between native and Unicode) */
17200             if (unicode_range && prevvalue < 255 && value < 255) {
17201                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
17202                     goto backwards_range;
17203                 }
17204             }
17205             else
17206 #endif
17207             if (prevvalue > value) /* b-a */ {
17208                 int w;
17209 #ifdef EBCDIC
17210               backwards_range:
17211 #endif
17212                 w = RExC_parse - rangebegin;
17213                 vFAIL2utf8f(
17214                     "Invalid [] range \"%" UTF8f "\"",
17215                     UTF8fARG(UTF, w, rangebegin));
17216                 NOT_REACHED; /* NOTREACHED */
17217             }
17218         }
17219         else {
17220             prevvalue = value; /* save the beginning of the potential range */
17221             if (! stop_at_1     /* Can't be a range if parsing just one thing */
17222                 && *RExC_parse == '-')
17223             {
17224                 char* next_char_ptr = RExC_parse + 1;
17225
17226                 /* Get the next real char after the '-' */
17227                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
17228
17229                 /* If the '-' is at the end of the class (just before the ']',
17230                  * it is a literal minus; otherwise it is a range */
17231                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
17232                     RExC_parse = next_char_ptr;
17233
17234                     /* a bad range like \w-, [:word:]- ? */
17235                     if (namedclass > OOB_NAMEDCLASS) {
17236                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
17237                             const int w = RExC_parse >= rangebegin
17238                                           ?  RExC_parse - rangebegin
17239                                           : 0;
17240                             if (strict) {
17241                                 vFAIL4("False [] range \"%*.*s\"",
17242                                     w, w, rangebegin);
17243                             }
17244                             else if (PASS2) {
17245                                 vWARN4(RExC_parse,
17246                                     "False [] range \"%*.*s\"",
17247                                     w, w, rangebegin);
17248                             }
17249                         }
17250                         if (!SIZE_ONLY) {
17251                             cp_list = add_cp_to_invlist(cp_list, '-');
17252                         }
17253                         element_count++;
17254                     } else
17255                         range = 1;      /* yeah, it's a range! */
17256                     continue;   /* but do it the next time */
17257                 }
17258             }
17259         }
17260
17261         if (namedclass > OOB_NAMEDCLASS) {
17262             continue;
17263         }
17264
17265         /* Here, we have a single value this time through the loop, and
17266          * <prevvalue> is the beginning of the range, if any; or <value> if
17267          * not. */
17268
17269         /* non-Latin1 code point implies unicode semantics.  Must be set in
17270          * pass1 so is there for the whole of pass 2 */
17271         if (value > 255) {
17272             REQUIRE_UNI_RULES(flagp, NULL);
17273         }
17274
17275         /* Ready to process either the single value, or the completed range.
17276          * For single-valued non-inverted ranges, we consider the possibility
17277          * of multi-char folds.  (We made a conscious decision to not do this
17278          * for the other cases because it can often lead to non-intuitive
17279          * results.  For example, you have the peculiar case that:
17280          *  "s s" =~ /^[^\xDF]+$/i => Y
17281          *  "ss"  =~ /^[^\xDF]+$/i => N
17282          *
17283          * See [perl #89750] */
17284         if (FOLD && allow_multi_folds && value == prevvalue) {
17285             if (value == LATIN_SMALL_LETTER_SHARP_S
17286                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
17287                                                         value)))
17288             {
17289                 /* Here <value> is indeed a multi-char fold.  Get what it is */
17290
17291                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17292                 STRLEN foldlen;
17293
17294                 UV folded = _to_uni_fold_flags(
17295                                 value,
17296                                 foldbuf,
17297                                 &foldlen,
17298                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
17299                                                    ? FOLD_FLAGS_NOMIX_ASCII
17300                                                    : 0)
17301                                 );
17302
17303                 /* Here, <folded> should be the first character of the
17304                  * multi-char fold of <value>, with <foldbuf> containing the
17305                  * whole thing.  But, if this fold is not allowed (because of
17306                  * the flags), <fold> will be the same as <value>, and should
17307                  * be processed like any other character, so skip the special
17308                  * handling */
17309                 if (folded != value) {
17310
17311                     /* Skip if we are recursed, currently parsing the class
17312                      * again.  Otherwise add this character to the list of
17313                      * multi-char folds. */
17314                     if (! RExC_in_multi_char_class) {
17315                         STRLEN cp_count = utf8_length(foldbuf,
17316                                                       foldbuf + foldlen);
17317                         SV* multi_fold = sv_2mortal(newSVpvs(""));
17318
17319                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
17320
17321                         multi_char_matches
17322                                         = add_multi_match(multi_char_matches,
17323                                                           multi_fold,
17324                                                           cp_count);
17325
17326                     }
17327
17328                     /* This element should not be processed further in this
17329                      * class */
17330                     element_count--;
17331                     value = save_value;
17332                     prevvalue = save_prevvalue;
17333                     continue;
17334                 }
17335             }
17336         }
17337
17338         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
17339             if (range) {
17340
17341                 /* If the range starts above 255, everything is portable and
17342                  * likely to be so for any forseeable character set, so don't
17343                  * warn. */
17344                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
17345                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
17346                 }
17347                 else if (prevvalue != value) {
17348
17349                     /* Under strict, ranges that stop and/or end in an ASCII
17350                      * printable should have each end point be a portable value
17351                      * for it (preferably like 'A', but we don't warn if it is
17352                      * a (portable) Unicode name or code point), and the range
17353                      * must be be all digits or all letters of the same case.
17354                      * Otherwise, the range is non-portable and unclear as to
17355                      * what it contains */
17356                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
17357                         && (          non_portable_endpoint
17358                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
17359                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
17360                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
17361                     ))) {
17362                         vWARN(RExC_parse, "Ranges of ASCII printables should"
17363                                           " be some subset of \"0-9\","
17364                                           " \"A-Z\", or \"a-z\"");
17365                     }
17366                     else if (prevvalue >= FIRST_NON_ASCII_DECIMAL_DIGIT) {
17367                         SSize_t index_start;
17368                         SSize_t index_final;
17369
17370                         /* But the nature of Unicode and languages mean we
17371                          * can't do the same checks for above-ASCII ranges,
17372                          * except in the case of digit ones.  These should
17373                          * contain only digits from the same group of 10.  The
17374                          * ASCII case is handled just above.  Hence here, the
17375                          * range could be a range of digits.  First some
17376                          * unlikely special cases.  Grandfather in that a range
17377                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
17378                          * if its starting value is one of the 10 digits prior
17379                          * to it.  This is because it is an alternate way of
17380                          * writing 19D1, and some people may expect it to be in
17381                          * that group.  But it is bad, because it won't give
17382                          * the expected results.  In Unicode 5.2 it was
17383                          * considered to be in that group (of 11, hence), but
17384                          * this was fixed in the next version */
17385
17386                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
17387                             goto warn_bad_digit_range;
17388                         }
17389                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
17390                                           &&     value <= 0x1D7FF))
17391                         {
17392                             /* This is the only other case currently in Unicode
17393                              * where the algorithm below fails.  The code
17394                              * points just above are the end points of a single
17395                              * range containing only decimal digits.  It is 5
17396                              * different series of 0-9.  All other ranges of
17397                              * digits currently in Unicode are just a single
17398                              * series.  (And mktables will notify us if a later
17399                              * Unicode version breaks this.)
17400                              *
17401                              * If the range being checked is at most 9 long,
17402                              * and the digit values represented are in
17403                              * numerical order, they are from the same series.
17404                              * */
17405                             if (         value - prevvalue > 9
17406                                 ||    (((    value - 0x1D7CE) % 10)
17407                                      <= (prevvalue - 0x1D7CE) % 10))
17408                             {
17409                                 goto warn_bad_digit_range;
17410                             }
17411                         }
17412                         else {
17413
17414                             /* For all other ranges of digits in Unicode, the
17415                              * algorithm is just to check if both end points
17416                              * are in the same series, which is the same range.
17417                              * */
17418                             index_start = _invlist_search(
17419                                                     PL_XPosix_ptrs[_CC_DIGIT],
17420                                                     prevvalue);
17421
17422                             /* Warn if the range starts and ends with a digit,
17423                              * and they are not in the same group of 10. */
17424                             if (   index_start >= 0
17425                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
17426                                 && (index_final =
17427                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
17428                                                     value)) != index_start
17429                                 && index_final >= 0
17430                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
17431                             {
17432                               warn_bad_digit_range:
17433                                 vWARN(RExC_parse, "Ranges of digits should be"
17434                                                   " from the same group of"
17435                                                   " 10");
17436                             }
17437                         }
17438                     }
17439                 }
17440             }
17441             if ((! range || prevvalue == value) && non_portable_endpoint) {
17442                 if (isPRINT_A(value)) {
17443                     char literal[3];
17444                     unsigned d = 0;
17445                     if (isBACKSLASHED_PUNCT(value)) {
17446                         literal[d++] = '\\';
17447                     }
17448                     literal[d++] = (char) value;
17449                     literal[d++] = '\0';
17450
17451                     vWARN4(RExC_parse,
17452                            "\"%.*s\" is more clearly written simply as \"%s\"",
17453                            (int) (RExC_parse - rangebegin),
17454                            rangebegin,
17455                            literal
17456                         );
17457                 }
17458                 else if isMNEMONIC_CNTRL(value) {
17459                     vWARN4(RExC_parse,
17460                            "\"%.*s\" is more clearly written simply as \"%s\"",
17461                            (int) (RExC_parse - rangebegin),
17462                            rangebegin,
17463                            cntrl_to_mnemonic((U8) value)
17464                         );
17465                 }
17466             }
17467         }
17468
17469         /* Deal with this element of the class */
17470         if (! SIZE_ONLY) {
17471
17472 #ifndef EBCDIC
17473             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17474                                                      prevvalue, value);
17475 #else
17476             /* On non-ASCII platforms, for ranges that span all of 0..255, and
17477              * ones that don't require special handling, we can just add the
17478              * range like we do for ASCII platforms */
17479             if ((UNLIKELY(prevvalue == 0) && value >= 255)
17480                 || ! (prevvalue < 256
17481                       && (unicode_range
17482                           || (! non_portable_endpoint
17483                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
17484                                   || (isUPPER_A(prevvalue)
17485                                       && isUPPER_A(value)))))))
17486             {
17487                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17488                                                          prevvalue, value);
17489             }
17490             else {
17491                 /* Here, requires special handling.  This can be because it is
17492                  * a range whose code points are considered to be Unicode, and
17493                  * so must be individually translated into native, or because
17494                  * its a subrange of 'A-Z' or 'a-z' which each aren't
17495                  * contiguous in EBCDIC, but we have defined them to include
17496                  * only the "expected" upper or lower case ASCII alphabetics.
17497                  * Subranges above 255 are the same in native and Unicode, so
17498                  * can be added as a range */
17499                 U8 start = NATIVE_TO_LATIN1(prevvalue);
17500                 unsigned j;
17501                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
17502                 for (j = start; j <= end; j++) {
17503                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
17504                 }
17505                 if (value > 255) {
17506                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17507                                                              256, value);
17508                 }
17509             }
17510 #endif
17511         }
17512
17513         range = 0; /* this range (if it was one) is done now */
17514     } /* End of loop through all the text within the brackets */
17515
17516
17517     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
17518         output_or_return_posix_warnings(pRExC_state, posix_warnings,
17519                                         return_posix_warnings);
17520     }
17521
17522     /* If anything in the class expands to more than one character, we have to
17523      * deal with them by building up a substitute parse string, and recursively
17524      * calling reg() on it, instead of proceeding */
17525     if (multi_char_matches) {
17526         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17527         I32 cp_count;
17528         STRLEN len;
17529         char *save_end = RExC_end;
17530         char *save_parse = RExC_parse;
17531         char *save_start = RExC_start;
17532         STRLEN prefix_end = 0;      /* We copy the character class after a
17533                                        prefix supplied here.  This is the size
17534                                        + 1 of that prefix */
17535         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17536                                        a "|" */
17537         I32 reg_flags;
17538
17539         assert(! invert);
17540         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
17541
17542 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17543            because too confusing */
17544         if (invert) {
17545             sv_catpv(substitute_parse, "(?:");
17546         }
17547 #endif
17548
17549         /* Look at the longest folds first */
17550         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17551                         cp_count > 0;
17552                         cp_count--)
17553         {
17554
17555             if (av_exists(multi_char_matches, cp_count)) {
17556                 AV** this_array_ptr;
17557                 SV* this_sequence;
17558
17559                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17560                                                  cp_count, FALSE);
17561                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17562                                                                 &PL_sv_undef)
17563                 {
17564                     if (! first_time) {
17565                         sv_catpv(substitute_parse, "|");
17566                     }
17567                     first_time = FALSE;
17568
17569                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17570                 }
17571             }
17572         }
17573
17574         /* If the character class contains anything else besides these
17575          * multi-character folds, have to include it in recursive parsing */
17576         if (element_count) {
17577             sv_catpv(substitute_parse, "|[");
17578             prefix_end = SvCUR(substitute_parse);
17579             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17580
17581             /* Put in a closing ']' only if not going off the end, as otherwise
17582              * we are adding something that really isn't there */
17583             if (RExC_parse < RExC_end) {
17584                 sv_catpv(substitute_parse, "]");
17585             }
17586         }
17587
17588         sv_catpv(substitute_parse, ")");
17589 #if 0
17590         if (invert) {
17591             /* This is a way to get the parse to skip forward a whole named
17592              * sequence instead of matching the 2nd character when it fails the
17593              * first */
17594             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17595         }
17596 #endif
17597
17598         /* Set up the data structure so that any errors will be properly
17599          * reported.  See the comments at the definition of
17600          * REPORT_LOCATION_ARGS for details */
17601         RExC_precomp_adj = orig_parse - RExC_precomp;
17602         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17603         RExC_adjusted_start = RExC_start + prefix_end;
17604         RExC_end = RExC_parse + len;
17605         RExC_in_multi_char_class = 1;
17606         RExC_emit = (regnode *)orig_emit;
17607
17608         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17609
17610         *flagp |= reg_flags & (HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17611
17612         /* And restore so can parse the rest of the pattern */
17613         RExC_parse = save_parse;
17614         RExC_start = RExC_adjusted_start = save_start;
17615         RExC_precomp_adj = 0;
17616         RExC_end = save_end;
17617         RExC_in_multi_char_class = 0;
17618         SvREFCNT_dec_NN(multi_char_matches);
17619         return ret;
17620     }
17621
17622     /* Here, we've gone through the entire class and dealt with multi-char
17623      * folds.  We are now in a position that we can do some checks to see if we
17624      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17625      * Currently we only do two checks:
17626      * 1) is in the unlikely event that the user has specified both, eg. \w and
17627      *    \W under /l, then the class matches everything.  (This optimization
17628      *    is done only to make the optimizer code run later work.)
17629      * 2) if the character class contains only a single element (including a
17630      *    single range), we see if there is an equivalent node for it.
17631      * Other checks are possible */
17632     if (   optimizable
17633         && ! ret_invlist   /* Can't optimize if returning the constructed
17634                               inversion list */
17635         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17636     {
17637         U8 op = END;
17638         U8 arg = 0;
17639
17640         if (UNLIKELY(posixl_matches_all)) {
17641             op = SANY;
17642         }
17643         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17644                                                    class, like \w or [:digit:]
17645                                                    or \p{foo} */
17646
17647             /* All named classes are mapped into POSIXish nodes, with its FLAG
17648              * argument giving which class it is */
17649             switch ((I32)namedclass) {
17650                 case ANYOF_UNIPROP:
17651                     break;
17652
17653                 /* These don't depend on the charset modifiers.  They always
17654                  * match under /u rules */
17655                 case ANYOF_NHORIZWS:
17656                 case ANYOF_HORIZWS:
17657                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17658                     /* FALLTHROUGH */
17659
17660                 case ANYOF_NVERTWS:
17661                 case ANYOF_VERTWS:
17662                     op = POSIXU;
17663                     goto join_posix;
17664
17665                 /* The actual POSIXish node for all the rest depends on the
17666                  * charset modifier.  The ones in the first set depend only on
17667                  * ASCII or, if available on this platform, also locale */
17668
17669                 case ANYOF_ASCII:
17670                 case ANYOF_NASCII:
17671
17672 #ifdef HAS_ISASCII
17673                     if (LOC) {
17674                         op = POSIXL;
17675                         goto join_posix;
17676                     }
17677 #endif
17678                     /* (named_class - ANYOF_ASCII) is 0 or 1. xor'ing with
17679                      * invert converts that to 1 or 0 */
17680                     op = ASCII + ((namedclass - ANYOF_ASCII) ^ invert);
17681                     break;
17682
17683                 /* The following don't have any matches in the upper Latin1
17684                  * range, hence /d is equivalent to /u for them.  Making it /u
17685                  * saves some branches at runtime */
17686                 case ANYOF_DIGIT:
17687                 case ANYOF_NDIGIT:
17688                 case ANYOF_XDIGIT:
17689                 case ANYOF_NXDIGIT:
17690                     if (! DEPENDS_SEMANTICS) {
17691                         goto treat_as_default;
17692                     }
17693
17694                     op = POSIXU;
17695                     goto join_posix;
17696
17697                 /* The following change to CASED under /i */
17698                 case ANYOF_LOWER:
17699                 case ANYOF_NLOWER:
17700                 case ANYOF_UPPER:
17701                 case ANYOF_NUPPER:
17702                     if (FOLD) {
17703                         namedclass = ANYOF_CASED + (namedclass % 2);
17704                     }
17705                     /* FALLTHROUGH */
17706
17707                 /* The rest have more possibilities depending on the charset.
17708                  * We take advantage of the enum ordering of the charset
17709                  * modifiers to get the exact node type, */
17710                 default:
17711                   treat_as_default:
17712                     op = POSIXD + get_regex_charset(RExC_flags);
17713                     if (op > POSIXA) { /* /aa is same as /a */
17714                         op = POSIXA;
17715                     }
17716
17717                   join_posix:
17718                     /* The odd numbered ones are the complements of the
17719                      * next-lower even number one */
17720                     if (namedclass % 2 == 1) {
17721                         invert = ! invert;
17722                         namedclass--;
17723                     }
17724                     arg = namedclass_to_classnum(namedclass);
17725                     break;
17726             }
17727         }
17728         else if (value == prevvalue) {
17729
17730             /* Here, the class consists of just a single code point */
17731
17732             if (invert) {
17733                 if (! LOC && value == '\n') {
17734                     op = REG_ANY; /* Optimize [^\n] */
17735                     *flagp |= HASWIDTH|SIMPLE;
17736                     MARK_NAUGHTY(1);
17737                 }
17738             }
17739             else if (value < 256 || UTF) {
17740
17741                 /* Optimize a single value into an EXACTish node, but not if it
17742                  * would require converting the pattern to UTF-8. */
17743                 op = compute_EXACTish(pRExC_state);
17744             }
17745         } /* Otherwise is a range */
17746         else if (! LOC) {   /* locale could vary these */
17747             if (prevvalue == '0') {
17748                 if (value == '9') {
17749                     arg = _CC_DIGIT;
17750                     op = POSIXA;
17751                 }
17752             }
17753             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17754                 /* We can optimize A-Z or a-z, but not if they could match
17755                  * something like the KELVIN SIGN under /i. */
17756                 if (prevvalue == 'A') {
17757                     if (value == 'Z'
17758 #ifdef EBCDIC
17759                         && ! non_portable_endpoint
17760 #endif
17761                     ) {
17762                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17763                         op = POSIXA;
17764                     }
17765                 }
17766                 else if (prevvalue == 'a') {
17767                     if (value == 'z'
17768 #ifdef EBCDIC
17769                         && ! non_portable_endpoint
17770 #endif
17771                     ) {
17772                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17773                         op = POSIXA;
17774                     }
17775                 }
17776             }
17777         }
17778
17779         /* Here, we have changed <op> away from its initial value iff we found
17780          * an optimization */
17781         if (op != END) {
17782
17783             /* Throw away this ANYOF regnode, and emit the calculated one,
17784              * which should correspond to the beginning, not current, state of
17785              * the parse */
17786             const char * cur_parse = RExC_parse;
17787             RExC_parse = (char *)orig_parse;
17788             if ( SIZE_ONLY) {
17789                 if (! LOC) {
17790
17791                     /* To get locale nodes to not use the full ANYOF size would
17792                      * require moving the code above that writes the portions
17793                      * of it that aren't in other nodes to after this point.
17794                      * e.g.  ANYOF_POSIXL_SET */
17795                     RExC_size = orig_size;
17796                 }
17797             }
17798             else {
17799                 RExC_emit = (regnode *)orig_emit;
17800                 if (PL_regkind[op] == POSIXD) {
17801                     if (op == POSIXL) {
17802                         RExC_contains_locale = 1;
17803                     }
17804                     if (invert) {
17805                         op += NPOSIXD - POSIXD;
17806                     }
17807                 }
17808             }
17809
17810             ret = reg_node(pRExC_state, op);
17811
17812             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17813                 if (! SIZE_ONLY) {
17814                     FLAGS(ret) = arg;
17815                 }
17816                 *flagp |= HASWIDTH|SIMPLE;
17817             }
17818             else if (PL_regkind[op] == EXACT) {
17819                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17820                                            TRUE /* downgradable to EXACT */
17821                                            );
17822             }
17823             else {
17824                 *flagp |= HASWIDTH|SIMPLE;
17825             }
17826
17827             RExC_parse = (char *) cur_parse;
17828
17829             SvREFCNT_dec(posixes);
17830             SvREFCNT_dec(nposixes);
17831             SvREFCNT_dec(simple_posixes);
17832             SvREFCNT_dec(cp_list);
17833             SvREFCNT_dec(cp_foldable_list);
17834             return ret;
17835         }
17836     }
17837
17838     if (SIZE_ONLY)
17839         return ret;
17840     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17841
17842     /* If folding, we calculate all characters that could fold to or from the
17843      * ones already on the list */
17844     if (cp_foldable_list) {
17845         if (FOLD) {
17846             UV start, end;      /* End points of code point ranges */
17847
17848             SV* fold_intersection = NULL;
17849             SV** use_list;
17850
17851             /* Our calculated list will be for Unicode rules.  For locale
17852              * matching, we have to keep a separate list that is consulted at
17853              * runtime only when the locale indicates Unicode rules.  For
17854              * non-locale, we just use the general list */
17855             if (LOC) {
17856                 use_list = &only_utf8_locale_list;
17857             }
17858             else {
17859                 use_list = &cp_list;
17860             }
17861
17862             /* Only the characters in this class that participate in folds need
17863              * be checked.  Get the intersection of this class and all the
17864              * possible characters that are foldable.  This can quickly narrow
17865              * down a large class */
17866             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17867                                   &fold_intersection);
17868
17869             /* Now look at the foldable characters in this class individually */
17870             invlist_iterinit(fold_intersection);
17871             while (invlist_iternext(fold_intersection, &start, &end)) {
17872                 UV j;
17873                 UV folded;
17874
17875                 /* Look at every character in the range */
17876                 for (j = start; j <= end; j++) {
17877                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17878                     STRLEN foldlen;
17879                     unsigned int k;
17880                     Size_t folds_to_count;
17881                     unsigned int first_folds_to;
17882                     const unsigned int * remaining_folds_to_list;
17883
17884                     if (j < 256) {
17885
17886                         if (IS_IN_SOME_FOLD_L1(j)) {
17887
17888                             /* ASCII is always matched; non-ASCII is matched
17889                              * only under Unicode rules (which could happen
17890                              * under /l if the locale is a UTF-8 one */
17891                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17892                                 *use_list = add_cp_to_invlist(*use_list,
17893                                                             PL_fold_latin1[j]);
17894                             }
17895                             else {
17896                                 has_upper_latin1_only_utf8_matches
17897                                     = add_cp_to_invlist(
17898                                             has_upper_latin1_only_utf8_matches,
17899                                             PL_fold_latin1[j]);
17900                             }
17901                         }
17902
17903                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17904                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17905                         {
17906                             add_above_Latin1_folds(pRExC_state,
17907                                                    (U8) j,
17908                                                    use_list);
17909                         }
17910                         continue;
17911                     }
17912
17913                     /* Here is an above Latin1 character.  We don't have the
17914                      * rules hard-coded for it.  First, get its fold.  This is
17915                      * the simple fold, as the multi-character folds have been
17916                      * handled earlier and separated out */
17917                     folded = _to_uni_fold_flags(j, foldbuf, &foldlen,
17918                                                         (ASCII_FOLD_RESTRICTED)
17919                                                         ? FOLD_FLAGS_NOMIX_ASCII
17920                                                         : 0);
17921
17922                     /* Single character fold of above Latin1.  Add everything
17923                      * in its fold closure to the list that this node should
17924                      * match. */
17925                     folds_to_count = _inverse_folds(folded, &first_folds_to,
17926                                                     &remaining_folds_to_list);
17927                     for (k = 0; k <= folds_to_count; k++) {
17928                         UV c = (k == 0)     /* First time through use itself */
17929                                 ? folded
17930                                 : (k == 1)  /* 2nd time use, the first fold */
17931                                    ? first_folds_to
17932
17933                                      /* Then the remaining ones */
17934                                    : remaining_folds_to_list[k-2];
17935
17936                         /* /aa doesn't allow folds between ASCII and non- */
17937                         if ((   ASCII_FOLD_RESTRICTED
17938                             && (isASCII(c) != isASCII(j))))
17939                         {
17940                             continue;
17941                         }
17942
17943                         /* Folds under /l which cross the 255/256 boundary are
17944                          * added to a separate list.  (These are valid only
17945                          * when the locale is UTF-8.) */
17946                         if (c < 256 && LOC) {
17947                             *use_list = add_cp_to_invlist(*use_list, c);
17948                             continue;
17949                         }
17950
17951                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17952                         {
17953                             cp_list = add_cp_to_invlist(cp_list, c);
17954                         }
17955                         else {
17956                             /* Similarly folds involving non-ascii Latin1
17957                              * characters under /d are added to their list */
17958                             has_upper_latin1_only_utf8_matches
17959                                 = add_cp_to_invlist(
17960                                             has_upper_latin1_only_utf8_matches,
17961                                             c);
17962                         }
17963                     }
17964                 }
17965             }
17966             SvREFCNT_dec_NN(fold_intersection);
17967         }
17968
17969         /* Now that we have finished adding all the folds, there is no reason
17970          * to keep the foldable list separate */
17971         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17972         SvREFCNT_dec_NN(cp_foldable_list);
17973     }
17974
17975     /* And combine the result (if any) with any inversion lists from posix
17976      * classes.  The lists are kept separate up to now because we don't want to
17977      * fold the classes (folding of those is automatically handled by the swash
17978      * fetching code) */
17979     if (simple_posixes) {   /* These are the classes known to be unaffected by
17980                                /a, /aa, and /d */
17981         if (cp_list) {
17982             _invlist_union(cp_list, simple_posixes, &cp_list);
17983             SvREFCNT_dec_NN(simple_posixes);
17984         }
17985         else {
17986             cp_list = simple_posixes;
17987         }
17988     }
17989     if (posixes || nposixes) {
17990
17991         /* We have to adjust /a and /aa */
17992         if (AT_LEAST_ASCII_RESTRICTED) {
17993
17994             /* Under /a and /aa, nothing above ASCII matches these */
17995             if (posixes) {
17996                 _invlist_intersection(posixes,
17997                                     PL_XPosix_ptrs[_CC_ASCII],
17998                                     &posixes);
17999             }
18000
18001             /* Under /a and /aa, everything above ASCII matches these
18002              * complements */
18003             if (nposixes) {
18004                 _invlist_union_complement_2nd(nposixes,
18005                                               PL_XPosix_ptrs[_CC_ASCII],
18006                                               &nposixes);
18007             }
18008         }
18009
18010         if (! DEPENDS_SEMANTICS) {
18011
18012             /* For everything but /d, we can just add the current 'posixes' and
18013              * 'nposixes' to the main list */
18014             if (posixes) {
18015                 if (cp_list) {
18016                     _invlist_union(cp_list, posixes, &cp_list);
18017                     SvREFCNT_dec_NN(posixes);
18018                 }
18019                 else {
18020                     cp_list = posixes;
18021                 }
18022             }
18023             if (nposixes) {
18024                 if (cp_list) {
18025                     _invlist_union(cp_list, nposixes, &cp_list);
18026                     SvREFCNT_dec_NN(nposixes);
18027                 }
18028                 else {
18029                     cp_list = nposixes;
18030                 }
18031             }
18032         }
18033         else {
18034             /* Under /d, things like \w match upper Latin1 characters only if
18035              * the target string is in UTF-8.  But things like \W match all the
18036              * upper Latin1 characters if the target string is not in UTF-8.
18037              *
18038              * Handle the case where there something like \W separately */
18039             if (nposixes) {
18040                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
18041
18042                 /* A complemented posix class matches all upper Latin1
18043                  * characters if not in UTF-8.  And it matches just certain
18044                  * ones when in UTF-8.  That means those certain ones are
18045                  * matched regardless, so can just be added to the
18046                  * unconditional list */
18047                 if (cp_list) {
18048                     _invlist_union(cp_list, nposixes, &cp_list);
18049                     SvREFCNT_dec_NN(nposixes);
18050                     nposixes = NULL;
18051                 }
18052                 else {
18053                     cp_list = nposixes;
18054                 }
18055
18056                 /* Likewise for 'posixes' */
18057                 _invlist_union(posixes, cp_list, &cp_list);
18058
18059                 /* Likewise for anything else in the range that matched only
18060                  * under UTF-8 */
18061                 if (has_upper_latin1_only_utf8_matches) {
18062                     _invlist_union(cp_list,
18063                                    has_upper_latin1_only_utf8_matches,
18064                                    &cp_list);
18065                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18066                     has_upper_latin1_only_utf8_matches = NULL;
18067                 }
18068
18069                 /* If we don't match all the upper Latin1 characters regardless
18070                  * of UTF-8ness, we have to set a flag to match the rest when
18071                  * not in UTF-8 */
18072                 _invlist_subtract(only_non_utf8_list, cp_list,
18073                                   &only_non_utf8_list);
18074                 if (_invlist_len(only_non_utf8_list) != 0) {
18075                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18076                 }
18077                 SvREFCNT_dec_NN(only_non_utf8_list);
18078             }
18079             else {
18080                 /* Here there were no complemented posix classes.  That means
18081                  * the upper Latin1 characters in 'posixes' match only when the
18082                  * target string is in UTF-8.  So we have to add them to the
18083                  * list of those types of code points, while adding the
18084                  * remainder to the unconditional list.
18085                  *
18086                  * First calculate what they are */
18087                 SV* nonascii_but_latin1_properties = NULL;
18088                 _invlist_intersection(posixes, PL_UpperLatin1,
18089                                       &nonascii_but_latin1_properties);
18090
18091                 /* And add them to the final list of such characters. */
18092                 _invlist_union(has_upper_latin1_only_utf8_matches,
18093                                nonascii_but_latin1_properties,
18094                                &has_upper_latin1_only_utf8_matches);
18095
18096                 /* Remove them from what now becomes the unconditional list */
18097                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
18098                                   &posixes);
18099
18100                 /* And add those unconditional ones to the final list */
18101                 if (cp_list) {
18102                     _invlist_union(cp_list, posixes, &cp_list);
18103                     SvREFCNT_dec_NN(posixes);
18104                     posixes = NULL;
18105                 }
18106                 else {
18107                     cp_list = posixes;
18108                 }
18109
18110                 SvREFCNT_dec(nonascii_but_latin1_properties);
18111
18112                 /* Get rid of any characters that we now know are matched
18113                  * unconditionally from the conditional list, which may make
18114                  * that list empty */
18115                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
18116                                   cp_list,
18117                                   &has_upper_latin1_only_utf8_matches);
18118                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
18119                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18120                     has_upper_latin1_only_utf8_matches = NULL;
18121                 }
18122             }
18123         }
18124     }
18125
18126     /* And combine the result (if any) with any inversion list from properties.
18127      * The lists are kept separate up to now so that we can distinguish the two
18128      * in regards to matching above-Unicode.  A run-time warning is generated
18129      * if a Unicode property is matched against a non-Unicode code point. But,
18130      * we allow user-defined properties to match anything, without any warning,
18131      * and we also suppress the warning if there is a portion of the character
18132      * class that isn't a Unicode property, and which matches above Unicode, \W
18133      * or [\x{110000}] for example.
18134      * (Note that in this case, unlike the Posix one above, there is no
18135      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
18136      * forces Unicode semantics */
18137     if (properties) {
18138         if (cp_list) {
18139
18140             /* If it matters to the final outcome, see if a non-property
18141              * component of the class matches above Unicode.  If so, the
18142              * warning gets suppressed.  This is true even if just a single
18143              * such code point is specified, as, though not strictly correct if
18144              * another such code point is matched against, the fact that they
18145              * are using above-Unicode code points indicates they should know
18146              * the issues involved */
18147             if (warn_super) {
18148                 warn_super = ! (invert
18149                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
18150             }
18151
18152             _invlist_union(properties, cp_list, &cp_list);
18153             SvREFCNT_dec_NN(properties);
18154         }
18155         else {
18156             cp_list = properties;
18157         }
18158
18159         if (warn_super) {
18160             ANYOF_FLAGS(ret)
18161              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18162
18163             /* Because an ANYOF node is the only one that warns, this node
18164              * can't be optimized into something else */
18165             optimizable = FALSE;
18166         }
18167     }
18168
18169     /* Here, we have calculated what code points should be in the character
18170      * class.
18171      *
18172      * Now we can see about various optimizations.  Fold calculation (which we
18173      * did above) needs to take place before inversion.  Otherwise /[^k]/i
18174      * would invert to include K, which under /i would match k, which it
18175      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
18176      * folded until runtime */
18177
18178     /* If we didn't do folding, it's because some information isn't available
18179      * until runtime; set the run-time fold flag for these.  (We don't have to
18180      * worry about properties folding, as that is taken care of by the swash
18181      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
18182      * locales, or the class matches at least one 0-255 range code point */
18183     if (LOC && FOLD) {
18184
18185         /* Some things on the list might be unconditionally included because of
18186          * other components.  Remove them, and clean up the list if it goes to
18187          * 0 elements */
18188         if (only_utf8_locale_list && cp_list) {
18189             _invlist_subtract(only_utf8_locale_list, cp_list,
18190                               &only_utf8_locale_list);
18191
18192             if (_invlist_len(only_utf8_locale_list) == 0) {
18193                 SvREFCNT_dec_NN(only_utf8_locale_list);
18194                 only_utf8_locale_list = NULL;
18195             }
18196         }
18197         if (only_utf8_locale_list) {
18198             ANYOF_FLAGS(ret)
18199                  |=  ANYOFL_FOLD
18200                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
18201         }
18202         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
18203             UV start, end;
18204             invlist_iterinit(cp_list);
18205             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
18206                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
18207             }
18208             invlist_iterfinish(cp_list);
18209         }
18210     }
18211     else if (   DEPENDS_SEMANTICS
18212              && (    has_upper_latin1_only_utf8_matches
18213                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
18214     {
18215         OP(ret) = ANYOFD;
18216         optimizable = FALSE;
18217     }
18218
18219
18220     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
18221      * at compile time.  Besides not inverting folded locale now, we can't
18222      * invert if there are things such as \w, which aren't known until runtime
18223      * */
18224     if (cp_list
18225         && invert
18226         && OP(ret) != ANYOFD
18227         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
18228         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
18229     {
18230         _invlist_invert(cp_list);
18231
18232         /* Any swash can't be used as-is, because we've inverted things */
18233         if (swash) {
18234             SvREFCNT_dec_NN(swash);
18235             swash = NULL;
18236         }
18237
18238         /* Clear the invert flag since have just done it here */
18239         invert = FALSE;
18240     }
18241
18242     if (ret_invlist) {
18243         assert(cp_list);
18244
18245         *ret_invlist = cp_list;
18246         SvREFCNT_dec(swash);
18247
18248         /* Discard the generated node */
18249         if (SIZE_ONLY) {
18250             RExC_size = orig_size;
18251         }
18252         else {
18253             RExC_emit = orig_emit;
18254         }
18255         return orig_emit;
18256     }
18257
18258     /* Some character classes are equivalent to other nodes.  Such nodes take
18259      * up less room and generally fewer operations to execute than ANYOF nodes.
18260      * Above, we checked for and optimized into some such equivalents for
18261      * certain common classes that are easy to test.  Getting to this point in
18262      * the code means that the class didn't get optimized there.  Since this
18263      * code is only executed in Pass 2, it is too late to save space--it has
18264      * been allocated in Pass 1, and currently isn't given back.  XXX Why not?
18265      * But turning things into an EXACTish node can allow the optimizer to join
18266      * it to any adjacent such nodes.  And if the class is equivalent to things
18267      * like /./, expensive run-time swashes can be avoided.  Now that we have
18268      * more complete information, we can find things necessarily missed by the
18269      * earlier code. */
18270
18271     if (optimizable && cp_list && ! invert) {
18272         UV start, end;
18273         U8 op = END;  /* The optimzation node-type */
18274         int posix_class = -1;   /* Illegal value */
18275         const char * cur_parse= RExC_parse;
18276         U8 ANYOFM_mask = 0xFF;
18277         U32 anode_arg = 0;
18278
18279         invlist_iterinit(cp_list);
18280         if (! invlist_iternext(cp_list, &start, &end)) {
18281
18282             /* Here, the list is empty.  This happens, for example, when a
18283              * Unicode property that doesn't match anything is the only element
18284              * in the character class (perluniprops.pod notes such properties).
18285              * */
18286             op = OPFAIL;
18287             *flagp |= HASWIDTH|SIMPLE;
18288         }
18289         else if (start == end) {    /* The range is a single code point */
18290             if (! invlist_iternext(cp_list, &start, &end)
18291
18292                     /* Don't do this optimization if it would require changing
18293                      * the pattern to UTF-8 */
18294                 && (start < 256 || UTF))
18295             {
18296                 /* Here, the list contains a single code point.  Can optimize
18297                  * into an EXACTish node */
18298
18299                 value = start;
18300
18301                 if (! FOLD) {
18302                     op = (LOC)
18303                          ? EXACTL
18304                          : EXACT;
18305                 }
18306                 else if (LOC) {
18307
18308                     /* A locale node under folding with one code point can be
18309                      * an EXACTFL, as its fold won't be calculated until
18310                      * runtime */
18311                     op = EXACTFL;
18312                 }
18313                 else {
18314
18315                     /* Here, we are generally folding, but there is only one
18316                      * code point to match.  If we have to, we use an EXACT
18317                      * node, but it would be better for joining with adjacent
18318                      * nodes in the optimization pass if we used the same
18319                      * EXACTFish node that any such are likely to be.  We can
18320                      * do this iff the code point doesn't participate in any
18321                      * folds.  For example, an EXACTF of a colon is the same as
18322                      * an EXACT one, since nothing folds to or from a colon. */
18323                     if (value < 256) {
18324                         if (IS_IN_SOME_FOLD_L1(value)) {
18325                             op = EXACT;
18326                         }
18327                     }
18328                     else {
18329                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
18330                             op = EXACT;
18331                         }
18332                     }
18333
18334                     /* If we haven't found the node type, above, it means we
18335                      * can use the prevailing one */
18336                     if (op == END) {
18337                         op = compute_EXACTish(pRExC_state);
18338                     }
18339                 }
18340             }
18341         }   /* End of first range contains just a single code point */
18342         else if (start == 0) {
18343             if (end == UV_MAX) {
18344                 op = SANY;
18345                 *flagp |= HASWIDTH|SIMPLE;
18346                 MARK_NAUGHTY(1);
18347             }
18348             else if (end == '\n' - 1
18349                     && invlist_iternext(cp_list, &start, &end)
18350                     && start == '\n' + 1 && end == UV_MAX)
18351             {
18352                 op = REG_ANY;
18353                 *flagp |= HASWIDTH|SIMPLE;
18354                 MARK_NAUGHTY(1);
18355             }
18356         }
18357         invlist_iterfinish(cp_list);
18358
18359         if (op == END) {
18360
18361             /* Here, didn't find an optimization.  See if this matches any of
18362              * the POSIX classes.  First try ASCII */
18363
18364             if (_invlistEQ(cp_list, PL_XPosix_ptrs[_CC_ASCII], 0)) {
18365                 op = ASCII;
18366                 *flagp |= HASWIDTH|SIMPLE;
18367             }
18368             else if (_invlistEQ(cp_list, PL_XPosix_ptrs[_CC_ASCII], 1)) {
18369                 op = NASCII;
18370                 *flagp |= HASWIDTH|SIMPLE;
18371             }
18372             else if (invlist_highest(cp_list) >= 0x2029) {
18373
18374                 /* Then try the other POSIX classes.  The POSIXA ones are about
18375                  * the same speed as ANYOF ops, but the ones that have
18376                  * above-Latin1 code point matches are somewhat faster than
18377                  * ANYOF.  So optimize those, but don't bother with the POSIXA
18378                  * ones nor [:cntrl:] which has no above-Latin1 matches.  If
18379                  * this ANYOF node has a lower highest possible matching code
18380                  * point than any of the XPosix ones, we know that it can't
18381                  * possibly be the same as any of them, so we can avoid
18382                  * executing this code.  The 0x2029 above for the lowest max
18383                  * was determined by manual inspection of the classes, and
18384                  * comes from \v.  Suppose Unicode in a later version adds a
18385                  * higher code point to \v.  All that means is that this code
18386                  * can be executed unnecessarily.  It will still give the
18387                  * correct answer. */
18388
18389                 for (posix_class = 0;
18390                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
18391                      posix_class++)
18392                 {
18393                     int try_inverted;
18394
18395                     if (posix_class == _CC_CNTRL) {
18396                         continue;
18397                     }
18398
18399                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
18400
18401                         /* Check if matches normal or inverted */
18402                         if (_invlistEQ(cp_list,
18403                                        PL_XPosix_ptrs[posix_class],
18404                                        try_inverted))
18405                         {
18406                             op = (try_inverted)
18407                                  ? NPOSIXU
18408                                  : POSIXU;
18409                             *flagp |= HASWIDTH|SIMPLE;
18410                             goto found_posix;
18411                         }
18412                     }
18413                 }
18414               found_posix: ;
18415             }
18416
18417             /* If it didn't match a POSIX class, it might be able to be turned
18418              * into an ANYOFM node.  Compare two different bytes, bit-by-bit.
18419              * In some positions, the bits in each will be 1; and in other
18420              * positions both will be 0; and in some positions the bit will be
18421              * 1 in one byte, and 0 in the other.  Let 'n' be the number of
18422              * positions where the bits differ.  We create a mask which has
18423              * exactly 'n' 0 bits, each in a position where the two bytes
18424              * differ.  Now take the set of all bytes that when ANDed with the
18425              * mask yield the same result.  That set has 2**n elements, and is
18426              * representable by just two 8 bit numbers: the result and the
18427              * mask.  Importantly, matching the set can be vectorized by
18428              * creating a word full of the result bytes, and a word full of the
18429              * mask bytes, yielding a significant speed up.  Here, see if this
18430              * node matches such a set.  As a concrete example consider [01],
18431              * and the byte representing '0' which is 0x30 on ASCII machines.
18432              * It has the bits 0011 0000.  Take the mask 1111 1110.  If we AND
18433              * 0x31 and 0x30 with that mask we get 0x30.  Any other bytes ANDed
18434              * yield something else.  So [01], which is a common usage, is
18435              * optimizable into ANYOFM, and can benefit from the speed up.  We
18436              * can only do this on UTF-8 invariant bytes, because the variance
18437              * would throw this off.  */
18438             if (   op == END
18439                 && invlist_highest(cp_list) <=
18440 #ifdef EBCDIC
18441                                                0xFF
18442 #else
18443                                                0x7F
18444 #endif
18445             ) {
18446                 Size_t cp_count = 0;
18447                 bool first_time = TRUE;
18448                 unsigned int lowest_cp = 0xFF;
18449                 U8 bits_differing = 0;
18450
18451                 /* Only needed on EBCDIC, as there, variants and non- are mixed
18452                  * together.  Could #ifdef it out on ASCII, but probably the
18453                  * compiler will optimize it out */
18454                 bool has_variant = FALSE;
18455
18456                 /* Go through the bytes and find the bit positions that differ */
18457                 invlist_iterinit(cp_list);
18458                 while (invlist_iternext(cp_list, &start, &end)) {
18459                     unsigned int i = start;
18460
18461                     cp_count += end - start + 1;
18462
18463                     if (first_time) {
18464                         if (! UVCHR_IS_INVARIANT(i)) {
18465                             has_variant = TRUE;
18466                             continue;
18467                         }
18468
18469                         first_time = FALSE;
18470                         lowest_cp = start;
18471
18472                         i++;
18473                     }
18474
18475                     /* Find the bit positions that differ from the lowest code
18476                      * point in the node.  Keep track of all such positions by
18477                      * OR'ing */
18478                     for (; i <= end; i++) {
18479                         if (! UVCHR_IS_INVARIANT(i)) {
18480                             has_variant = TRUE;
18481                             continue;
18482                         }
18483
18484                         bits_differing  |= i ^ lowest_cp;
18485                     }
18486                 }
18487                 invlist_iterfinish(cp_list);
18488
18489                 /* At the end of the loop, we count how many bits differ from
18490                  * the bits in lowest code point, call the count 'd'.  If the
18491                  * set we found contains 2**d elements, it is the closure of
18492                  * all code points that differ only in those bit positions.  To
18493                  * convince yourself of that, first note that the number in the
18494                  * closure must be a power of 2, which we test for.  The only
18495                  * way we could have that count and it be some differing set,
18496                  * is if we got some code points that don't differ from the
18497                  * lowest code point in any position, but do differ from each
18498                  * other in some other position.  That means one code point has
18499                  * a 1 in that position, and another has a 0.  But that would
18500                  * mean that one of them differs from the lowest code point in
18501                  * that position, which possibility we've already excluded. */
18502                 if ( ! has_variant
18503                     && cp_count == 1U << PL_bitcount[bits_differing])
18504                 {
18505                     assert(cp_count > 1);
18506                     op = ANYOFM;
18507
18508                     /* We need to make the bits that differ be 0's */
18509                     ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
18510
18511                     /* The argument is the lowest code point */
18512                     anode_arg = lowest_cp;
18513                     *flagp |= HASWIDTH|SIMPLE;
18514                 }
18515             }
18516         }
18517
18518         if (op != END) {
18519             RExC_parse = (char *)orig_parse;
18520             RExC_emit = (regnode *)orig_emit;
18521
18522             if (regarglen[op]) {
18523                 ret = reganode(pRExC_state, op, anode_arg);
18524             } else {
18525                 ret = reg_node(pRExC_state, op);
18526             }
18527
18528             RExC_parse = (char *)cur_parse;
18529
18530             if (PL_regkind[op] == EXACT) {
18531                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
18532                                            TRUE /* downgradable to EXACT */
18533                                           );
18534             }
18535             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
18536                 FLAGS(ret) = posix_class;
18537             }
18538             else if (PL_regkind[op] == ANYOFM) {
18539                 FLAGS(ret) = ANYOFM_mask;
18540             }
18541
18542             SvREFCNT_dec_NN(cp_list);
18543             return ret;
18544         }
18545     }
18546
18547     /* Here, <cp_list> contains all the code points we can determine at
18548      * compile time that match under all conditions.  Go through it, and
18549      * for things that belong in the bitmap, put them there, and delete from
18550      * <cp_list>.  While we are at it, see if everything above 255 is in the
18551      * list, and if so, set a flag to speed up execution */
18552
18553     populate_ANYOF_from_invlist(ret, &cp_list);
18554
18555     if (invert) {
18556         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
18557     }
18558
18559     /* Here, the bitmap has been populated with all the Latin1 code points that
18560      * always match.  Can now add to the overall list those that match only
18561      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
18562      * */
18563     if (has_upper_latin1_only_utf8_matches) {
18564         if (cp_list) {
18565             _invlist_union(cp_list,
18566                            has_upper_latin1_only_utf8_matches,
18567                            &cp_list);
18568             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
18569         }
18570         else {
18571             cp_list = has_upper_latin1_only_utf8_matches;
18572         }
18573         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
18574     }
18575
18576     /* If there is a swash and more than one element, we can't use the swash in
18577      * the optimization below. */
18578     if (swash && element_count > 1) {
18579         SvREFCNT_dec_NN(swash);
18580         swash = NULL;
18581     }
18582
18583     /* Note that the optimization of using 'swash' if it is the only thing in
18584      * the class doesn't have us change swash at all, so it can include things
18585      * that are also in the bitmap; otherwise we have purposely deleted that
18586      * duplicate information */
18587     set_ANYOF_arg(pRExC_state, ret, cp_list,
18588                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
18589                    ? listsv : NULL,
18590                   only_utf8_locale_list,
18591                   swash, has_user_defined_property);
18592
18593     *flagp |= HASWIDTH|SIMPLE;
18594
18595     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
18596         RExC_contains_locale = 1;
18597     }
18598
18599     return ret;
18600 }
18601
18602 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
18603
18604 STATIC void
18605 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
18606                 regnode* const node,
18607                 SV* const cp_list,
18608                 SV* const runtime_defns,
18609                 SV* const only_utf8_locale_list,
18610                 SV* const swash,
18611                 const bool has_user_defined_property)
18612 {
18613     /* Sets the arg field of an ANYOF-type node 'node', using information about
18614      * the node passed-in.  If there is nothing outside the node's bitmap, the
18615      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
18616      * the count returned by add_data(), having allocated and stored an array,
18617      * av, that that count references, as follows:
18618      *  av[0] stores the character class description in its textual form.
18619      *        This is used later (regexec.c:Perl_regclass_swash()) to
18620      *        initialize the appropriate swash, and is also useful for dumping
18621      *        the regnode.  This is set to &PL_sv_undef if the textual
18622      *        description is not needed at run-time (as happens if the other
18623      *        elements completely define the class)
18624      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
18625      *        computed from av[0].  But if no further computation need be done,
18626      *        the swash is stored here now (and av[0] is &PL_sv_undef).
18627      *  av[2] stores the inversion list of code points that match only if the
18628      *        current locale is UTF-8
18629      *  av[3] stores the cp_list inversion list for use in addition or instead
18630      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
18631      *        (Otherwise everything needed is already in av[0] and av[1])
18632      *  av[4] is set if any component of the class is from a user-defined
18633      *        property; used only if av[3] exists */
18634
18635     UV n;
18636
18637     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
18638
18639     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
18640         assert(! (ANYOF_FLAGS(node)
18641                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
18642         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
18643     }
18644     else {
18645         AV * const av = newAV();
18646         SV *rv;
18647
18648         av_store(av, 0, (runtime_defns)
18649                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
18650         if (swash) {
18651             assert(cp_list);
18652             av_store(av, 1, swash);
18653             SvREFCNT_dec_NN(cp_list);
18654         }
18655         else {
18656             av_store(av, 1, &PL_sv_undef);
18657             if (cp_list) {
18658                 av_store(av, 3, cp_list);
18659                 av_store(av, 4, newSVuv(has_user_defined_property));
18660             }
18661         }
18662
18663         if (only_utf8_locale_list) {
18664             av_store(av, 2, only_utf8_locale_list);
18665         }
18666         else {
18667             av_store(av, 2, &PL_sv_undef);
18668         }
18669
18670         rv = newRV_noinc(MUTABLE_SV(av));
18671         n = add_data(pRExC_state, STR_WITH_LEN("s"));
18672         RExC_rxi->data->data[n] = (void*)rv;
18673         ARG_SET(node, n);
18674     }
18675 }
18676
18677 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
18678 SV *
18679 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
18680                                         const regnode* node,
18681                                         bool doinit,
18682                                         SV** listsvp,
18683                                         SV** only_utf8_locale_ptr,
18684                                         SV** output_invlist)
18685
18686 {
18687     /* For internal core use only.
18688      * Returns the swash for the input 'node' in the regex 'prog'.
18689      * If <doinit> is 'true', will attempt to create the swash if not already
18690      *    done.
18691      * If <listsvp> is non-null, will return the printable contents of the
18692      *    swash.  This can be used to get debugging information even before the
18693      *    swash exists, by calling this function with 'doinit' set to false, in
18694      *    which case the components that will be used to eventually create the
18695      *    swash are returned  (in a printable form).
18696      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18697      *    store an inversion list of code points that should match only if the
18698      *    execution-time locale is a UTF-8 one.
18699      * If <output_invlist> is not NULL, it is where this routine is to store an
18700      *    inversion list of the code points that would be instead returned in
18701      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18702      *    when this parameter is used, is just the non-code point data that
18703      *    will go into creating the swash.  This currently should be just
18704      *    user-defined properties whose definitions were not known at compile
18705      *    time.  Using this parameter allows for easier manipulation of the
18706      *    swash's data by the caller.  It is illegal to call this function with
18707      *    this parameter set, but not <listsvp>
18708      *
18709      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18710      * that, in spite of this function's name, the swash it returns may include
18711      * the bitmap data as well */
18712
18713     SV *sw  = NULL;
18714     SV *si  = NULL;         /* Input swash initialization string */
18715     SV* invlist = NULL;
18716
18717     RXi_GET_DECL(prog,progi);
18718     const struct reg_data * const data = prog ? progi->data : NULL;
18719
18720     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18721     assert(! output_invlist || listsvp);
18722
18723     if (data && data->count) {
18724         const U32 n = ARG(node);
18725
18726         if (data->what[n] == 's') {
18727             SV * const rv = MUTABLE_SV(data->data[n]);
18728             AV * const av = MUTABLE_AV(SvRV(rv));
18729             SV **const ary = AvARRAY(av);
18730             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18731
18732             si = *ary;  /* ary[0] = the string to initialize the swash with */
18733
18734             if (av_tindex_skip_len_mg(av) >= 2) {
18735                 if (only_utf8_locale_ptr
18736                     && ary[2]
18737                     && ary[2] != &PL_sv_undef)
18738                 {
18739                     *only_utf8_locale_ptr = ary[2];
18740                 }
18741                 else {
18742                     assert(only_utf8_locale_ptr);
18743                     *only_utf8_locale_ptr = NULL;
18744                 }
18745
18746                 /* Elements 3 and 4 are either both present or both absent. [3]
18747                  * is any inversion list generated at compile time; [4]
18748                  * indicates if that inversion list has any user-defined
18749                  * properties in it. */
18750                 if (av_tindex_skip_len_mg(av) >= 3) {
18751                     invlist = ary[3];
18752                     if (SvUV(ary[4])) {
18753                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18754                     }
18755                 }
18756                 else {
18757                     invlist = NULL;
18758                 }
18759             }
18760
18761             /* Element [1] is reserved for the set-up swash.  If already there,
18762              * return it; if not, create it and store it there */
18763             if (ary[1] && SvROK(ary[1])) {
18764                 sw = ary[1];
18765             }
18766             else if (doinit && ((si && si != &PL_sv_undef)
18767                                  || (invlist && invlist != &PL_sv_undef))) {
18768                 assert(si);
18769                 sw = _core_swash_init("utf8", /* the utf8 package */
18770                                       "", /* nameless */
18771                                       si,
18772                                       1, /* binary */
18773                                       0, /* not from tr/// */
18774                                       invlist,
18775                                       &swash_init_flags);
18776                 (void)av_store(av, 1, sw);
18777             }
18778         }
18779     }
18780
18781     /* If requested, return a printable version of what this swash matches */
18782     if (listsvp) {
18783         SV* matches_string = NULL;
18784
18785         /* The swash should be used, if possible, to get the data, as it
18786          * contains the resolved data.  But this function can be called at
18787          * compile-time, before everything gets resolved, in which case we
18788          * return the currently best available information, which is the string
18789          * that will eventually be used to do that resolving, 'si' */
18790         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18791             && (si && si != &PL_sv_undef))
18792         {
18793             /* Here, we only have 'si' (and possibly some passed-in data in
18794              * 'invlist', which is handled below)  If the caller only wants
18795              * 'si', use that.  */
18796             if (! output_invlist) {
18797                 matches_string = newSVsv(si);
18798             }
18799             else {
18800                 /* But if the caller wants an inversion list of the node, we
18801                  * need to parse 'si' and place as much as possible in the
18802                  * desired output inversion list, making 'matches_string' only
18803                  * contain the currently unresolvable things */
18804                 const char *si_string = SvPVX(si);
18805                 STRLEN remaining = SvCUR(si);
18806                 UV prev_cp = 0;
18807                 U8 count = 0;
18808
18809                 /* Ignore everything before the first new-line */
18810                 while (*si_string != '\n' && remaining > 0) {
18811                     si_string++;
18812                     remaining--;
18813                 }
18814                 assert(remaining > 0);
18815
18816                 si_string++;
18817                 remaining--;
18818
18819                 while (remaining > 0) {
18820
18821                     /* The data consists of just strings defining user-defined
18822                      * property names, but in prior incarnations, and perhaps
18823                      * somehow from pluggable regex engines, it could still
18824                      * hold hex code point definitions.  Each component of a
18825                      * range would be separated by a tab, and each range by a
18826                      * new-line.  If these are found, instead add them to the
18827                      * inversion list */
18828                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18829                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18830                     STRLEN len = remaining;
18831                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18832
18833                     /* If the hex decode routine found something, it should go
18834                      * up to the next \n */
18835                     if (   *(si_string + len) == '\n') {
18836                         if (count) {    /* 2nd code point on line */
18837                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18838                         }
18839                         else {
18840                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18841                         }
18842                         count = 0;
18843                         goto prepare_for_next_iteration;
18844                     }
18845
18846                     /* If the hex decode was instead for the lower range limit,
18847                      * save it, and go parse the upper range limit */
18848                     if (*(si_string + len) == '\t') {
18849                         assert(count == 0);
18850
18851                         prev_cp = cp;
18852                         count = 1;
18853                       prepare_for_next_iteration:
18854                         si_string += len + 1;
18855                         remaining -= len + 1;
18856                         continue;
18857                     }
18858
18859                     /* Here, didn't find a legal hex number.  Just add it from
18860                      * here to the next \n */
18861
18862                     remaining -= len;
18863                     while (*(si_string + len) != '\n' && remaining > 0) {
18864                         remaining--;
18865                         len++;
18866                     }
18867                     if (*(si_string + len) == '\n') {
18868                         len++;
18869                         remaining--;
18870                     }
18871                     if (matches_string) {
18872                         sv_catpvn(matches_string, si_string, len - 1);
18873                     }
18874                     else {
18875                         matches_string = newSVpvn(si_string, len - 1);
18876                     }
18877                     si_string += len;
18878                     sv_catpvs(matches_string, " ");
18879                 } /* end of loop through the text */
18880
18881                 assert(matches_string);
18882                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18883                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18884                 }
18885             } /* end of has an 'si' but no swash */
18886         }
18887
18888         /* If we have a swash in place, its equivalent inversion list was above
18889          * placed into 'invlist'.  If not, this variable may contain a stored
18890          * inversion list which is information beyond what is in 'si' */
18891         if (invlist) {
18892
18893             /* Again, if the caller doesn't want the output inversion list, put
18894              * everything in 'matches-string' */
18895             if (! output_invlist) {
18896                 if ( ! matches_string) {
18897                     matches_string = newSVpvs("\n");
18898                 }
18899                 sv_catsv(matches_string, invlist_contents(invlist,
18900                                                   TRUE /* traditional style */
18901                                                   ));
18902             }
18903             else if (! *output_invlist) {
18904                 *output_invlist = invlist_clone(invlist);
18905             }
18906             else {
18907                 _invlist_union(*output_invlist, invlist, output_invlist);
18908             }
18909         }
18910
18911         *listsvp = matches_string;
18912     }
18913
18914     return sw;
18915 }
18916 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18917
18918 /* reg_skipcomment()
18919
18920    Absorbs an /x style # comment from the input stream,
18921    returning a pointer to the first character beyond the comment, or if the
18922    comment terminates the pattern without anything following it, this returns
18923    one past the final character of the pattern (in other words, RExC_end) and
18924    sets the REG_RUN_ON_COMMENT_SEEN flag.
18925
18926    Note it's the callers responsibility to ensure that we are
18927    actually in /x mode
18928
18929 */
18930
18931 PERL_STATIC_INLINE char*
18932 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18933 {
18934     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18935
18936     assert(*p == '#');
18937
18938     while (p < RExC_end) {
18939         if (*(++p) == '\n') {
18940             return p+1;
18941         }
18942     }
18943
18944     /* we ran off the end of the pattern without ending the comment, so we have
18945      * to add an \n when wrapping */
18946     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18947     return p;
18948 }
18949
18950 STATIC void
18951 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18952                                 char ** p,
18953                                 const bool force_to_xmod
18954                          )
18955 {
18956     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18957      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18958      * is /x whitespace, advance '*p' so that on exit it points to the first
18959      * byte past all such white space and comments */
18960
18961     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18962
18963     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18964
18965     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18966
18967     for (;;) {
18968         if (RExC_end - (*p) >= 3
18969             && *(*p)     == '('
18970             && *(*p + 1) == '?'
18971             && *(*p + 2) == '#')
18972         {
18973             while (*(*p) != ')') {
18974                 if ((*p) == RExC_end)
18975                     FAIL("Sequence (?#... not terminated");
18976                 (*p)++;
18977             }
18978             (*p)++;
18979             continue;
18980         }
18981
18982         if (use_xmod) {
18983             const char * save_p = *p;
18984             while ((*p) < RExC_end) {
18985                 STRLEN len;
18986                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18987                     (*p) += len;
18988                 }
18989                 else if (*(*p) == '#') {
18990                     (*p) = reg_skipcomment(pRExC_state, (*p));
18991                 }
18992                 else {
18993                     break;
18994                 }
18995             }
18996             if (*p != save_p) {
18997                 continue;
18998             }
18999         }
19000
19001         break;
19002     }
19003
19004     return;
19005 }
19006
19007 /* nextchar()
19008
19009    Advances the parse position by one byte, unless that byte is the beginning
19010    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
19011    those two cases, the parse position is advanced beyond all such comments and
19012    white space.
19013
19014    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
19015 */
19016
19017 STATIC void
19018 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
19019 {
19020     PERL_ARGS_ASSERT_NEXTCHAR;
19021
19022     if (RExC_parse < RExC_end) {
19023         assert(   ! UTF
19024                || UTF8_IS_INVARIANT(*RExC_parse)
19025                || UTF8_IS_START(*RExC_parse));
19026
19027         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
19028
19029         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
19030                                 FALSE /* Don't force /x */ );
19031     }
19032 }
19033
19034 STATIC regnode *
19035 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
19036 {
19037     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
19038      * space.  In pass1, it aligns and increments RExC_size; in pass2,
19039      * RExC_emit */
19040
19041     regnode * const ret = RExC_emit;
19042     GET_RE_DEBUG_FLAGS_DECL;
19043
19044     PERL_ARGS_ASSERT_REGNODE_GUTS;
19045
19046     assert(extra_size >= regarglen[op]);
19047
19048     if (SIZE_ONLY) {
19049         SIZE_ALIGN(RExC_size);
19050         RExC_size += 1 + extra_size;
19051         return(ret);
19052     }
19053     if (RExC_emit >= RExC_emit_bound)
19054         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
19055                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
19056
19057     NODE_ALIGN_FILL(ret);
19058 #ifndef RE_TRACK_PATTERN_OFFSETS
19059     PERL_UNUSED_ARG(name);
19060 #else
19061     if (RExC_offsets) {         /* MJD */
19062         MJD_OFFSET_DEBUG(
19063               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
19064               name, __LINE__,
19065               PL_reg_name[op],
19066               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
19067                 ? "Overwriting end of array!\n" : "OK",
19068               (UV)(RExC_emit - RExC_emit_start),
19069               (UV)(RExC_parse - RExC_start),
19070               (UV)RExC_offsets[0]));
19071         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
19072     }
19073 #endif
19074     return(ret);
19075 }
19076
19077 /*
19078 - reg_node - emit a node
19079 */
19080 STATIC regnode *                        /* Location. */
19081 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
19082 {
19083     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
19084
19085     PERL_ARGS_ASSERT_REG_NODE;
19086
19087     assert(regarglen[op] == 0);
19088
19089     if (PASS2) {
19090         regnode *ptr = ret;
19091         FILL_ADVANCE_NODE(ptr, op);
19092         RExC_emit = ptr;
19093     }
19094     return(ret);
19095 }
19096
19097 /*
19098 - reganode - emit a node with an argument
19099 */
19100 STATIC regnode *                        /* Location. */
19101 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
19102 {
19103     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
19104
19105     PERL_ARGS_ASSERT_REGANODE;
19106
19107     assert(regarglen[op] == 1);
19108
19109     if (PASS2) {
19110         regnode *ptr = ret;
19111         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
19112         RExC_emit = ptr;
19113     }
19114     return(ret);
19115 }
19116
19117 STATIC regnode *
19118 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
19119 {
19120     /* emit a node with U32 and I32 arguments */
19121
19122     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
19123
19124     PERL_ARGS_ASSERT_REG2LANODE;
19125
19126     assert(regarglen[op] == 2);
19127
19128     if (PASS2) {
19129         regnode *ptr = ret;
19130         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
19131         RExC_emit = ptr;
19132     }
19133     return(ret);
19134 }
19135
19136 /*
19137 - reginsert - insert an operator in front of already-emitted operand
19138 *
19139 * Means relocating the operand.
19140 *
19141 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
19142 * set up NEXT_OFF() of the inserted node if needed. Something like this:
19143 *
19144 * reginsert(pRExC, OPFAIL, orig_emit, depth+1);
19145 * if (PASS2)
19146 *     NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
19147 *
19148 * ALSO NOTE - operand->flags will be set to 0 as well.
19149 */
19150 STATIC void
19151 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth)
19152 {
19153     regnode *src;
19154     regnode *dst;
19155     regnode *place;
19156     const int offset = regarglen[(U8)op];
19157     const int size = NODE_STEP_REGNODE + offset;
19158     GET_RE_DEBUG_FLAGS_DECL;
19159
19160     PERL_ARGS_ASSERT_REGINSERT;
19161     PERL_UNUSED_CONTEXT;
19162     PERL_UNUSED_ARG(depth);
19163 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
19164     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
19165     if (SIZE_ONLY) {
19166         RExC_size += size;
19167         return;
19168     }
19169     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
19170                                     studying. If this is wrong then we need to adjust RExC_recurse
19171                                     below like we do with RExC_open_parens/RExC_close_parens. */
19172     src = RExC_emit;
19173     RExC_emit += size;
19174     dst = RExC_emit;
19175     if (RExC_open_parens) {
19176         int paren;
19177         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
19178         /* remember that RExC_npar is rex->nparens + 1,
19179          * iow it is 1 more than the number of parens seen in
19180          * the pattern so far. */
19181         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
19182             /* note, RExC_open_parens[0] is the start of the
19183              * regex, it can't move. RExC_close_parens[0] is the end
19184              * of the regex, it *can* move. */
19185             if ( paren && RExC_open_parens[paren] >= operand ) {
19186                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
19187                 RExC_open_parens[paren] += size;
19188             } else {
19189                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
19190             }
19191             if ( RExC_close_parens[paren] >= operand ) {
19192                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
19193                 RExC_close_parens[paren] += size;
19194             } else {
19195                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
19196             }
19197         }
19198     }
19199     if (RExC_end_op)
19200         RExC_end_op += size;
19201
19202     while (src > operand) {
19203         StructCopy(--src, --dst, regnode);
19204 #ifdef RE_TRACK_PATTERN_OFFSETS
19205         if (RExC_offsets) {     /* MJD 20010112 */
19206             MJD_OFFSET_DEBUG(
19207                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
19208                   "reg_insert",
19209                   __LINE__,
19210                   PL_reg_name[op],
19211                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
19212                     ? "Overwriting end of array!\n" : "OK",
19213                   (UV)(src - RExC_emit_start),
19214                   (UV)(dst - RExC_emit_start),
19215                   (UV)RExC_offsets[0]));
19216             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
19217             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
19218         }
19219 #endif
19220     }
19221
19222     place = operand;            /* Op node, where operand used to be. */
19223 #ifdef RE_TRACK_PATTERN_OFFSETS
19224     if (RExC_offsets) {         /* MJD */
19225         MJD_OFFSET_DEBUG(
19226               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
19227               "reginsert",
19228               __LINE__,
19229               PL_reg_name[op],
19230               (UV)(place - RExC_emit_start) > RExC_offsets[0]
19231               ? "Overwriting end of array!\n" : "OK",
19232               (UV)(place - RExC_emit_start),
19233               (UV)(RExC_parse - RExC_start),
19234               (UV)RExC_offsets[0]));
19235         Set_Node_Offset(place, RExC_parse);
19236         Set_Node_Length(place, 1);
19237     }
19238 #endif
19239     src = NEXTOPER(place);
19240     place->flags = 0;
19241     FILL_ADVANCE_NODE(place, op);
19242     Zero(src, offset, regnode);
19243 }
19244
19245 /*
19246 - regtail - set the next-pointer at the end of a node chain of p to val.
19247 - SEE ALSO: regtail_study
19248 */
19249 STATIC void
19250 S_regtail(pTHX_ RExC_state_t * pRExC_state,
19251                 const regnode * const p,
19252                 const regnode * const val,
19253                 const U32 depth)
19254 {
19255     regnode *scan;
19256     GET_RE_DEBUG_FLAGS_DECL;
19257
19258     PERL_ARGS_ASSERT_REGTAIL;
19259 #ifndef DEBUGGING
19260     PERL_UNUSED_ARG(depth);
19261 #endif
19262
19263     if (SIZE_ONLY)
19264         return;
19265
19266     /* Find last node. */
19267     scan = (regnode *) p;
19268     for (;;) {
19269         regnode * const temp = regnext(scan);
19270         DEBUG_PARSE_r({
19271             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
19272             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
19273             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
19274                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
19275                     (temp == NULL ? "->" : ""),
19276                     (temp == NULL ? PL_reg_name[OP(val)] : "")
19277             );
19278         });
19279         if (temp == NULL)
19280             break;
19281         scan = temp;
19282     }
19283
19284     if (reg_off_by_arg[OP(scan)]) {
19285         ARG_SET(scan, val - scan);
19286     }
19287     else {
19288         NEXT_OFF(scan) = val - scan;
19289     }
19290 }
19291
19292 #ifdef DEBUGGING
19293 /*
19294 - regtail_study - set the next-pointer at the end of a node chain of p to val.
19295 - Look for optimizable sequences at the same time.
19296 - currently only looks for EXACT chains.
19297
19298 This is experimental code. The idea is to use this routine to perform
19299 in place optimizations on branches and groups as they are constructed,
19300 with the long term intention of removing optimization from study_chunk so
19301 that it is purely analytical.
19302
19303 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
19304 to control which is which.
19305
19306 */
19307 /* TODO: All four parms should be const */
19308
19309 STATIC U8
19310 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
19311                       const regnode *val,U32 depth)
19312 {
19313     regnode *scan;
19314     U8 exact = PSEUDO;
19315 #ifdef EXPERIMENTAL_INPLACESCAN
19316     I32 min = 0;
19317 #endif
19318     GET_RE_DEBUG_FLAGS_DECL;
19319
19320     PERL_ARGS_ASSERT_REGTAIL_STUDY;
19321
19322
19323     if (SIZE_ONLY)
19324         return exact;
19325
19326     /* Find last node. */
19327
19328     scan = p;
19329     for (;;) {
19330         regnode * const temp = regnext(scan);
19331 #ifdef EXPERIMENTAL_INPLACESCAN
19332         if (PL_regkind[OP(scan)] == EXACT) {
19333             bool unfolded_multi_char;   /* Unexamined in this routine */
19334             if (join_exact(pRExC_state, scan, &min,
19335                            &unfolded_multi_char, 1, val, depth+1))
19336                 return EXACT;
19337         }
19338 #endif
19339         if ( exact ) {
19340             switch (OP(scan)) {
19341                 case EXACT:
19342                 case EXACTL:
19343                 case EXACTF:
19344                 case EXACTFAA_NO_TRIE:
19345                 case EXACTFAA:
19346                 case EXACTFU:
19347                 case EXACTFLU8:
19348                 case EXACTFU_SS:
19349                 case EXACTFL:
19350                         if( exact == PSEUDO )
19351                             exact= OP(scan);
19352                         else if ( exact != OP(scan) )
19353                             exact= 0;
19354                 case NOTHING:
19355                     break;
19356                 default:
19357                     exact= 0;
19358             }
19359         }
19360         DEBUG_PARSE_r({
19361             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
19362             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
19363             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
19364                 SvPV_nolen_const(RExC_mysv),
19365                 REG_NODE_NUM(scan),
19366                 PL_reg_name[exact]);
19367         });
19368         if (temp == NULL)
19369             break;
19370         scan = temp;
19371     }
19372     DEBUG_PARSE_r({
19373         DEBUG_PARSE_MSG("");
19374         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
19375         Perl_re_printf( aTHX_
19376                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
19377                       SvPV_nolen_const(RExC_mysv),
19378                       (IV)REG_NODE_NUM(val),
19379                       (IV)(val - scan)
19380         );
19381     });
19382     if (reg_off_by_arg[OP(scan)]) {
19383         ARG_SET(scan, val - scan);
19384     }
19385     else {
19386         NEXT_OFF(scan) = val - scan;
19387     }
19388
19389     return exact;
19390 }
19391 #endif
19392
19393 STATIC SV*
19394 S_get_ANYOFM_contents(pTHX_ const regnode * n) {
19395
19396     /* Returns an inversion list of all the code points matched by the ANYOFM
19397      * node 'n' */
19398
19399     SV * cp_list = _new_invlist(-1);
19400     const U8 lowest = (U8) ARG(n);
19401     unsigned int i;
19402     U8 count = 0;
19403     U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
19404
19405     PERL_ARGS_ASSERT_GET_ANYOFM_CONTENTS;
19406
19407     /* Starting with the lowest code point, any code point that ANDed with the
19408      * mask yields the lowest code point is in the set */
19409     for (i = lowest; i <= 0xFF; i++) {
19410         if ((i & FLAGS(n)) == ARG(n)) {
19411             cp_list = add_cp_to_invlist(cp_list, i);
19412             count++;
19413
19414             /* We know how many code points (a power of two) that are in the
19415              * set.  No use looking once we've got that number */
19416             if (count >= needed) break;
19417         }
19418     }
19419
19420     return cp_list;
19421 }
19422
19423 /*
19424  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
19425  */
19426 #ifdef DEBUGGING
19427
19428 static void
19429 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
19430 {
19431     int bit;
19432     int set=0;
19433
19434     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19435
19436     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
19437         if (flags & (1<<bit)) {
19438             if (!set++ && lead)
19439                 Perl_re_printf( aTHX_  "%s",lead);
19440             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
19441         }
19442     }
19443     if (lead)  {
19444         if (set)
19445             Perl_re_printf( aTHX_  "\n");
19446         else
19447             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
19448     }
19449 }
19450
19451 static void
19452 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
19453 {
19454     int bit;
19455     int set=0;
19456     regex_charset cs;
19457
19458     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19459
19460     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
19461         if (flags & (1<<bit)) {
19462             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
19463                 continue;
19464             }
19465             if (!set++ && lead)
19466                 Perl_re_printf( aTHX_  "%s",lead);
19467             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
19468         }
19469     }
19470     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
19471             if (!set++ && lead) {
19472                 Perl_re_printf( aTHX_  "%s",lead);
19473             }
19474             switch (cs) {
19475                 case REGEX_UNICODE_CHARSET:
19476                     Perl_re_printf( aTHX_  "UNICODE");
19477                     break;
19478                 case REGEX_LOCALE_CHARSET:
19479                     Perl_re_printf( aTHX_  "LOCALE");
19480                     break;
19481                 case REGEX_ASCII_RESTRICTED_CHARSET:
19482                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
19483                     break;
19484                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
19485                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
19486                     break;
19487                 default:
19488                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
19489                     break;
19490             }
19491     }
19492     if (lead)  {
19493         if (set)
19494             Perl_re_printf( aTHX_  "\n");
19495         else
19496             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
19497     }
19498 }
19499 #endif
19500
19501 void
19502 Perl_regdump(pTHX_ const regexp *r)
19503 {
19504 #ifdef DEBUGGING
19505     int i;
19506     SV * const sv = sv_newmortal();
19507     SV *dsv= sv_newmortal();
19508     RXi_GET_DECL(r,ri);
19509     GET_RE_DEBUG_FLAGS_DECL;
19510
19511     PERL_ARGS_ASSERT_REGDUMP;
19512
19513     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
19514
19515     /* Header fields of interest. */
19516     for (i = 0; i < 2; i++) {
19517         if (r->substrs->data[i].substr) {
19518             RE_PV_QUOTED_DECL(s, 0, dsv,
19519                             SvPVX_const(r->substrs->data[i].substr),
19520                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
19521                             PL_dump_re_max_len);
19522             Perl_re_printf( aTHX_
19523                           "%s %s%s at %" IVdf "..%" UVuf " ",
19524                           i ? "floating" : "anchored",
19525                           s,
19526                           RE_SV_TAIL(r->substrs->data[i].substr),
19527                           (IV)r->substrs->data[i].min_offset,
19528                           (UV)r->substrs->data[i].max_offset);
19529         }
19530         else if (r->substrs->data[i].utf8_substr) {
19531             RE_PV_QUOTED_DECL(s, 1, dsv,
19532                             SvPVX_const(r->substrs->data[i].utf8_substr),
19533                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
19534                             30);
19535             Perl_re_printf( aTHX_
19536                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
19537                           i ? "floating" : "anchored",
19538                           s,
19539                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
19540                           (IV)r->substrs->data[i].min_offset,
19541                           (UV)r->substrs->data[i].max_offset);
19542         }
19543     }
19544
19545     if (r->check_substr || r->check_utf8)
19546         Perl_re_printf( aTHX_
19547                       (const char *)
19548                       (   r->check_substr == r->substrs->data[1].substr
19549                        && r->check_utf8   == r->substrs->data[1].utf8_substr
19550                        ? "(checking floating" : "(checking anchored"));
19551     if (r->intflags & PREGf_NOSCAN)
19552         Perl_re_printf( aTHX_  " noscan");
19553     if (r->extflags & RXf_CHECK_ALL)
19554         Perl_re_printf( aTHX_  " isall");
19555     if (r->check_substr || r->check_utf8)
19556         Perl_re_printf( aTHX_  ") ");
19557
19558     if (ri->regstclass) {
19559         regprop(r, sv, ri->regstclass, NULL, NULL);
19560         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
19561     }
19562     if (r->intflags & PREGf_ANCH) {
19563         Perl_re_printf( aTHX_  "anchored");
19564         if (r->intflags & PREGf_ANCH_MBOL)
19565             Perl_re_printf( aTHX_  "(MBOL)");
19566         if (r->intflags & PREGf_ANCH_SBOL)
19567             Perl_re_printf( aTHX_  "(SBOL)");
19568         if (r->intflags & PREGf_ANCH_GPOS)
19569             Perl_re_printf( aTHX_  "(GPOS)");
19570         Perl_re_printf( aTHX_ " ");
19571     }
19572     if (r->intflags & PREGf_GPOS_SEEN)
19573         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
19574     if (r->intflags & PREGf_SKIP)
19575         Perl_re_printf( aTHX_  "plus ");
19576     if (r->intflags & PREGf_IMPLICIT)
19577         Perl_re_printf( aTHX_  "implicit ");
19578     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
19579     if (r->extflags & RXf_EVAL_SEEN)
19580         Perl_re_printf( aTHX_  "with eval ");
19581     Perl_re_printf( aTHX_  "\n");
19582     DEBUG_FLAGS_r({
19583         regdump_extflags("r->extflags: ",r->extflags);
19584         regdump_intflags("r->intflags: ",r->intflags);
19585     });
19586 #else
19587     PERL_ARGS_ASSERT_REGDUMP;
19588     PERL_UNUSED_CONTEXT;
19589     PERL_UNUSED_ARG(r);
19590 #endif  /* DEBUGGING */
19591 }
19592
19593 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
19594 #ifdef DEBUGGING
19595
19596 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
19597      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
19598      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
19599      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
19600      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
19601      || _CC_VERTSPACE != 15
19602 #   error Need to adjust order of anyofs[]
19603 #  endif
19604 static const char * const anyofs[] = {
19605     "\\w",
19606     "\\W",
19607     "\\d",
19608     "\\D",
19609     "[:alpha:]",
19610     "[:^alpha:]",
19611     "[:lower:]",
19612     "[:^lower:]",
19613     "[:upper:]",
19614     "[:^upper:]",
19615     "[:punct:]",
19616     "[:^punct:]",
19617     "[:print:]",
19618     "[:^print:]",
19619     "[:alnum:]",
19620     "[:^alnum:]",
19621     "[:graph:]",
19622     "[:^graph:]",
19623     "[:cased:]",
19624     "[:^cased:]",
19625     "\\s",
19626     "\\S",
19627     "[:blank:]",
19628     "[:^blank:]",
19629     "[:xdigit:]",
19630     "[:^xdigit:]",
19631     "[:cntrl:]",
19632     "[:^cntrl:]",
19633     "[:ascii:]",
19634     "[:^ascii:]",
19635     "\\v",
19636     "\\V"
19637 };
19638 #endif
19639
19640 /*
19641 - regprop - printable representation of opcode, with run time support
19642 */
19643
19644 void
19645 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
19646 {
19647 #ifdef DEBUGGING
19648     int k;
19649     RXi_GET_DECL(prog,progi);
19650     GET_RE_DEBUG_FLAGS_DECL;
19651
19652     PERL_ARGS_ASSERT_REGPROP;
19653
19654     SvPVCLEAR(sv);
19655
19656     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
19657         /* It would be nice to FAIL() here, but this may be called from
19658            regexec.c, and it would be hard to supply pRExC_state. */
19659         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19660                                               (int)OP(o), (int)REGNODE_MAX);
19661     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
19662
19663     k = PL_regkind[OP(o)];
19664
19665     if (k == EXACT) {
19666         sv_catpvs(sv, " ");
19667         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
19668          * is a crude hack but it may be the best for now since
19669          * we have no flag "this EXACTish node was UTF-8"
19670          * --jhi */
19671         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
19672                   PL_colors[0], PL_colors[1],
19673                   PERL_PV_ESCAPE_UNI_DETECT |
19674                   PERL_PV_ESCAPE_NONASCII   |
19675                   PERL_PV_PRETTY_ELLIPSES   |
19676                   PERL_PV_PRETTY_LTGT       |
19677                   PERL_PV_PRETTY_NOCLEAR
19678                   );
19679     } else if (k == TRIE) {
19680         /* print the details of the trie in dumpuntil instead, as
19681          * progi->data isn't available here */
19682         const char op = OP(o);
19683         const U32 n = ARG(o);
19684         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
19685                (reg_ac_data *)progi->data->data[n] :
19686                NULL;
19687         const reg_trie_data * const trie
19688             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
19689
19690         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
19691         DEBUG_TRIE_COMPILE_r({
19692           if (trie->jump)
19693             sv_catpvs(sv, "(JUMP)");
19694           Perl_sv_catpvf(aTHX_ sv,
19695             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
19696             (UV)trie->startstate,
19697             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
19698             (UV)trie->wordcount,
19699             (UV)trie->minlen,
19700             (UV)trie->maxlen,
19701             (UV)TRIE_CHARCOUNT(trie),
19702             (UV)trie->uniquecharcount
19703           );
19704         });
19705         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
19706             sv_catpvs(sv, "[");
19707             (void) put_charclass_bitmap_innards(sv,
19708                                                 ((IS_ANYOF_TRIE(op))
19709                                                  ? ANYOF_BITMAP(o)
19710                                                  : TRIE_BITMAP(trie)),
19711                                                 NULL,
19712                                                 NULL,
19713                                                 NULL,
19714                                                 FALSE
19715                                                );
19716             sv_catpvs(sv, "]");
19717         }
19718     } else if (k == CURLY) {
19719         U32 lo = ARG1(o), hi = ARG2(o);
19720         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19721             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19722         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19723         if (hi == REG_INFTY)
19724             sv_catpvs(sv, "INFTY");
19725         else
19726             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19727         sv_catpvs(sv, "}");
19728     }
19729     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19730         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19731     else if (k == REF || k == OPEN || k == CLOSE
19732              || k == GROUPP || OP(o)==ACCEPT)
19733     {
19734         AV *name_list= NULL;
19735         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19736         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19737         if ( RXp_PAREN_NAMES(prog) ) {
19738             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19739         } else if ( pRExC_state ) {
19740             name_list= RExC_paren_name_list;
19741         }
19742         if (name_list) {
19743             if ( k != REF || (OP(o) < NREF)) {
19744                 SV **name= av_fetch(name_list, parno, 0 );
19745                 if (name)
19746                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19747             }
19748             else {
19749                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19750                 I32 *nums=(I32*)SvPVX(sv_dat);
19751                 SV **name= av_fetch(name_list, nums[0], 0 );
19752                 I32 n;
19753                 if (name) {
19754                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19755                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19756                                     (n ? "," : ""), (IV)nums[n]);
19757                     }
19758                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19759                 }
19760             }
19761         }
19762         if ( k == REF && reginfo) {
19763             U32 n = ARG(o);  /* which paren pair */
19764             I32 ln = prog->offs[n].start;
19765             if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
19766                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19767             else if (ln == prog->offs[n].end)
19768                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19769             else {
19770                 const char *s = reginfo->strbeg + ln;
19771                 Perl_sv_catpvf(aTHX_ sv, ": ");
19772                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19773                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19774             }
19775         }
19776     } else if (k == GOSUB) {
19777         AV *name_list= NULL;
19778         if ( RXp_PAREN_NAMES(prog) ) {
19779             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19780         } else if ( pRExC_state ) {
19781             name_list= RExC_paren_name_list;
19782         }
19783
19784         /* Paren and offset */
19785         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19786                 (int)((o + (int)ARG2L(o)) - progi->program) );
19787         if (name_list) {
19788             SV **name= av_fetch(name_list, ARG(o), 0 );
19789             if (name)
19790                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19791         }
19792     }
19793     else if (k == LOGICAL)
19794         /* 2: embedded, otherwise 1 */
19795         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19796     else if (k == ANYOF) {
19797         const U8 flags = ANYOF_FLAGS(o);
19798         bool do_sep = FALSE;    /* Do we need to separate various components of
19799                                    the output? */
19800         /* Set if there is still an unresolved user-defined property */
19801         SV *unresolved                = NULL;
19802
19803         /* Things that are ignored except when the runtime locale is UTF-8 */
19804         SV *only_utf8_locale_invlist = NULL;
19805
19806         /* Code points that don't fit in the bitmap */
19807         SV *nonbitmap_invlist = NULL;
19808
19809         /* And things that aren't in the bitmap, but are small enough to be */
19810         SV* bitmap_range_not_in_bitmap = NULL;
19811
19812         const bool inverted = flags & ANYOF_INVERT;
19813
19814         if (OP(o) == ANYOFL) {
19815             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19816                 sv_catpvs(sv, "{utf8-locale-reqd}");
19817             }
19818             if (flags & ANYOFL_FOLD) {
19819                 sv_catpvs(sv, "{i}");
19820             }
19821         }
19822
19823         /* If there is stuff outside the bitmap, get it */
19824         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19825             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19826                                                 &unresolved,
19827                                                 &only_utf8_locale_invlist,
19828                                                 &nonbitmap_invlist);
19829             /* The non-bitmap data may contain stuff that could fit in the
19830              * bitmap.  This could come from a user-defined property being
19831              * finally resolved when this call was done; or much more likely
19832              * because there are matches that require UTF-8 to be valid, and so
19833              * aren't in the bitmap.  This is teased apart later */
19834             _invlist_intersection(nonbitmap_invlist,
19835                                   PL_InBitmap,
19836                                   &bitmap_range_not_in_bitmap);
19837             /* Leave just the things that don't fit into the bitmap */
19838             _invlist_subtract(nonbitmap_invlist,
19839                               PL_InBitmap,
19840                               &nonbitmap_invlist);
19841         }
19842
19843         /* Obey this flag to add all above-the-bitmap code points */
19844         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19845             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19846                                                       NUM_ANYOF_CODE_POINTS,
19847                                                       UV_MAX);
19848         }
19849
19850         /* Ready to start outputting.  First, the initial left bracket */
19851         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19852
19853         /* Then all the things that could fit in the bitmap */
19854         do_sep = put_charclass_bitmap_innards(sv,
19855                                               ANYOF_BITMAP(o),
19856                                               bitmap_range_not_in_bitmap,
19857                                               only_utf8_locale_invlist,
19858                                               o,
19859
19860                                               /* Can't try inverting for a
19861                                                * better display if there are
19862                                                * things that haven't been
19863                                                * resolved */
19864                                               unresolved != NULL);
19865         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19866
19867         /* If there are user-defined properties which haven't been defined yet,
19868          * output them.  If the result is not to be inverted, it is clearest to
19869          * output them in a separate [] from the bitmap range stuff.  If the
19870          * result is to be complemented, we have to show everything in one [],
19871          * as the inversion applies to the whole thing.  Use {braces} to
19872          * separate them from anything in the bitmap and anything above the
19873          * bitmap. */
19874         if (unresolved) {
19875             if (inverted) {
19876                 if (! do_sep) { /* If didn't output anything in the bitmap */
19877                     sv_catpvs(sv, "^");
19878                 }
19879                 sv_catpvs(sv, "{");
19880             }
19881             else if (do_sep) {
19882                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19883             }
19884             sv_catsv(sv, unresolved);
19885             if (inverted) {
19886                 sv_catpvs(sv, "}");
19887             }
19888             do_sep = ! inverted;
19889         }
19890
19891         /* And, finally, add the above-the-bitmap stuff */
19892         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19893             SV* contents;
19894
19895             /* See if truncation size is overridden */
19896             const STRLEN dump_len = (PL_dump_re_max_len > 256)
19897                                     ? PL_dump_re_max_len
19898                                     : 256;
19899
19900             /* This is output in a separate [] */
19901             if (do_sep) {
19902                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19903             }
19904
19905             /* And, for easy of understanding, it is shown in the
19906              * uncomplemented form if possible.  The one exception being if
19907              * there are unresolved items, where the inversion has to be
19908              * delayed until runtime */
19909             if (inverted && ! unresolved) {
19910                 _invlist_invert(nonbitmap_invlist);
19911                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19912             }
19913
19914             contents = invlist_contents(nonbitmap_invlist,
19915                                         FALSE /* output suitable for catsv */
19916                                        );
19917
19918             /* If the output is shorter than the permissible maximum, just do it. */
19919             if (SvCUR(contents) <= dump_len) {
19920                 sv_catsv(sv, contents);
19921             }
19922             else {
19923                 const char * contents_string = SvPVX(contents);
19924                 STRLEN i = dump_len;
19925
19926                 /* Otherwise, start at the permissible max and work back to the
19927                  * first break possibility */
19928                 while (i > 0 && contents_string[i] != ' ') {
19929                     i--;
19930                 }
19931                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19932                                        find a legal break */
19933                     i = dump_len;
19934                 }
19935
19936                 sv_catpvn(sv, contents_string, i);
19937                 sv_catpvs(sv, "...");
19938             }
19939
19940             SvREFCNT_dec_NN(contents);
19941             SvREFCNT_dec_NN(nonbitmap_invlist);
19942         }
19943
19944         /* And finally the matching, closing ']' */
19945         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19946
19947         SvREFCNT_dec(unresolved);
19948     }
19949     else if (k == ANYOFM) {
19950         SV * cp_list = get_ANYOFM_contents(o);
19951
19952         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19953         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, TRUE);
19954         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19955
19956         SvREFCNT_dec(cp_list);
19957     }
19958     else if (k == POSIXD || k == NPOSIXD) {
19959         U8 index = FLAGS(o) * 2;
19960         if (index < C_ARRAY_LENGTH(anyofs)) {
19961             if (*anyofs[index] != '[')  {
19962                 sv_catpv(sv, "[");
19963             }
19964             sv_catpv(sv, anyofs[index]);
19965             if (*anyofs[index] != '[')  {
19966                 sv_catpv(sv, "]");
19967             }
19968         }
19969         else {
19970             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19971         }
19972     }
19973     else if (k == BOUND || k == NBOUND) {
19974         /* Must be synced with order of 'bound_type' in regcomp.h */
19975         const char * const bounds[] = {
19976             "",      /* Traditional */
19977             "{gcb}",
19978             "{lb}",
19979             "{sb}",
19980             "{wb}"
19981         };
19982         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19983         sv_catpv(sv, bounds[FLAGS(o)]);
19984     }
19985     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19986         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19987     else if (OP(o) == SBOL)
19988         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19989
19990     /* add on the verb argument if there is one */
19991     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19992         if ( ARG(o) )
19993             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19994                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19995         else
19996             sv_catpvs(sv, ":NULL");
19997     }
19998 #else
19999     PERL_UNUSED_CONTEXT;
20000     PERL_UNUSED_ARG(sv);
20001     PERL_UNUSED_ARG(o);
20002     PERL_UNUSED_ARG(prog);
20003     PERL_UNUSED_ARG(reginfo);
20004     PERL_UNUSED_ARG(pRExC_state);
20005 #endif  /* DEBUGGING */
20006 }
20007
20008
20009
20010 SV *
20011 Perl_re_intuit_string(pTHX_ REGEXP * const r)
20012 {                               /* Assume that RE_INTUIT is set */
20013     struct regexp *const prog = ReANY(r);
20014     GET_RE_DEBUG_FLAGS_DECL;
20015
20016     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
20017     PERL_UNUSED_CONTEXT;
20018
20019     DEBUG_COMPILE_r(
20020         {
20021             const char * const s = SvPV_nolen_const(RX_UTF8(r)
20022                       ? prog->check_utf8 : prog->check_substr);
20023
20024             if (!PL_colorset) reginitcolors();
20025             Perl_re_printf( aTHX_
20026                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
20027                       PL_colors[4],
20028                       RX_UTF8(r) ? "utf8 " : "",
20029                       PL_colors[5],PL_colors[0],
20030                       s,
20031                       PL_colors[1],
20032                       (strlen(s) > PL_dump_re_max_len ? "..." : ""));
20033         } );
20034
20035     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
20036     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
20037 }
20038
20039 /*
20040    pregfree()
20041
20042    handles refcounting and freeing the perl core regexp structure. When
20043    it is necessary to actually free the structure the first thing it
20044    does is call the 'free' method of the regexp_engine associated to
20045    the regexp, allowing the handling of the void *pprivate; member
20046    first. (This routine is not overridable by extensions, which is why
20047    the extensions free is called first.)
20048
20049    See regdupe and regdupe_internal if you change anything here.
20050 */
20051 #ifndef PERL_IN_XSUB_RE
20052 void
20053 Perl_pregfree(pTHX_ REGEXP *r)
20054 {
20055     SvREFCNT_dec(r);
20056 }
20057
20058 void
20059 Perl_pregfree2(pTHX_ REGEXP *rx)
20060 {
20061     struct regexp *const r = ReANY(rx);
20062     GET_RE_DEBUG_FLAGS_DECL;
20063
20064     PERL_ARGS_ASSERT_PREGFREE2;
20065
20066     if (r->mother_re) {
20067         ReREFCNT_dec(r->mother_re);
20068     } else {
20069         CALLREGFREE_PVT(rx); /* free the private data */
20070         SvREFCNT_dec(RXp_PAREN_NAMES(r));
20071     }
20072     if (r->substrs) {
20073         int i;
20074         for (i = 0; i < 2; i++) {
20075             SvREFCNT_dec(r->substrs->data[i].substr);
20076             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
20077         }
20078         Safefree(r->substrs);
20079     }
20080     RX_MATCH_COPY_FREE(rx);
20081 #ifdef PERL_ANY_COW
20082     SvREFCNT_dec(r->saved_copy);
20083 #endif
20084     Safefree(r->offs);
20085     SvREFCNT_dec(r->qr_anoncv);
20086     if (r->recurse_locinput)
20087         Safefree(r->recurse_locinput);
20088 }
20089
20090
20091 /*  reg_temp_copy()
20092
20093     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
20094     except that dsv will be created if NULL.
20095
20096     This function is used in two main ways. First to implement
20097         $r = qr/....; $s = $$r;
20098
20099     Secondly, it is used as a hacky workaround to the structural issue of
20100     match results
20101     being stored in the regexp structure which is in turn stored in
20102     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
20103     could be PL_curpm in multiple contexts, and could require multiple
20104     result sets being associated with the pattern simultaneously, such
20105     as when doing a recursive match with (??{$qr})
20106
20107     The solution is to make a lightweight copy of the regexp structure
20108     when a qr// is returned from the code executed by (??{$qr}) this
20109     lightweight copy doesn't actually own any of its data except for
20110     the starp/end and the actual regexp structure itself.
20111
20112 */
20113
20114
20115 REGEXP *
20116 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
20117 {
20118     struct regexp *drx;
20119     struct regexp *const srx = ReANY(ssv);
20120     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
20121
20122     PERL_ARGS_ASSERT_REG_TEMP_COPY;
20123
20124     if (!dsv)
20125         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
20126     else {
20127         SvOK_off((SV *)dsv);
20128         if (islv) {
20129             /* For PVLVs, the head (sv_any) points to an XPVLV, while
20130              * the LV's xpvlenu_rx will point to a regexp body, which
20131              * we allocate here */
20132             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
20133             assert(!SvPVX(dsv));
20134             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
20135             temp->sv_any = NULL;
20136             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
20137             SvREFCNT_dec_NN(temp);
20138             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
20139                ing below will not set it. */
20140             SvCUR_set(dsv, SvCUR(ssv));
20141         }
20142     }
20143     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
20144        sv_force_normal(sv) is called.  */
20145     SvFAKE_on(dsv);
20146     drx = ReANY(dsv);
20147
20148     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
20149     SvPV_set(dsv, RX_WRAPPED(ssv));
20150     /* We share the same string buffer as the original regexp, on which we
20151        hold a reference count, incremented when mother_re is set below.
20152        The string pointer is copied here, being part of the regexp struct.
20153      */
20154     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
20155            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
20156     if (!islv)
20157         SvLEN_set(dsv, 0);
20158     if (srx->offs) {
20159         const I32 npar = srx->nparens+1;
20160         Newx(drx->offs, npar, regexp_paren_pair);
20161         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
20162     }
20163     if (srx->substrs) {
20164         int i;
20165         Newx(drx->substrs, 1, struct reg_substr_data);
20166         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
20167
20168         for (i = 0; i < 2; i++) {
20169             SvREFCNT_inc_void(drx->substrs->data[i].substr);
20170             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
20171         }
20172
20173         /* check_substr and check_utf8, if non-NULL, point to either their
20174            anchored or float namesakes, and don't hold a second reference.  */
20175     }
20176     RX_MATCH_COPIED_off(dsv);
20177 #ifdef PERL_ANY_COW
20178     drx->saved_copy = NULL;
20179 #endif
20180     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
20181     SvREFCNT_inc_void(drx->qr_anoncv);
20182     if (srx->recurse_locinput)
20183         Newx(drx->recurse_locinput,srx->nparens + 1,char *);
20184
20185     return dsv;
20186 }
20187 #endif
20188
20189
20190 /* regfree_internal()
20191
20192    Free the private data in a regexp. This is overloadable by
20193    extensions. Perl takes care of the regexp structure in pregfree(),
20194    this covers the *pprivate pointer which technically perl doesn't
20195    know about, however of course we have to handle the
20196    regexp_internal structure when no extension is in use.
20197
20198    Note this is called before freeing anything in the regexp
20199    structure.
20200  */
20201
20202 void
20203 Perl_regfree_internal(pTHX_ REGEXP * const rx)
20204 {
20205     struct regexp *const r = ReANY(rx);
20206     RXi_GET_DECL(r,ri);
20207     GET_RE_DEBUG_FLAGS_DECL;
20208
20209     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
20210
20211     DEBUG_COMPILE_r({
20212         if (!PL_colorset)
20213             reginitcolors();
20214         {
20215             SV *dsv= sv_newmortal();
20216             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
20217                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
20218             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
20219                 PL_colors[4],PL_colors[5],s);
20220         }
20221     });
20222 #ifdef RE_TRACK_PATTERN_OFFSETS
20223     if (ri->u.offsets)
20224         Safefree(ri->u.offsets);             /* 20010421 MJD */
20225 #endif
20226     if (ri->code_blocks)
20227         S_free_codeblocks(aTHX_ ri->code_blocks);
20228
20229     if (ri->data) {
20230         int n = ri->data->count;
20231
20232         while (--n >= 0) {
20233           /* If you add a ->what type here, update the comment in regcomp.h */
20234             switch (ri->data->what[n]) {
20235             case 'a':
20236             case 'r':
20237             case 's':
20238             case 'S':
20239             case 'u':
20240                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
20241                 break;
20242             case 'f':
20243                 Safefree(ri->data->data[n]);
20244                 break;
20245             case 'l':
20246             case 'L':
20247                 break;
20248             case 'T':
20249                 { /* Aho Corasick add-on structure for a trie node.
20250                      Used in stclass optimization only */
20251                     U32 refcount;
20252                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
20253 #ifdef USE_ITHREADS
20254                     dVAR;
20255 #endif
20256                     OP_REFCNT_LOCK;
20257                     refcount = --aho->refcount;
20258                     OP_REFCNT_UNLOCK;
20259                     if ( !refcount ) {
20260                         PerlMemShared_free(aho->states);
20261                         PerlMemShared_free(aho->fail);
20262                          /* do this last!!!! */
20263                         PerlMemShared_free(ri->data->data[n]);
20264                         /* we should only ever get called once, so
20265                          * assert as much, and also guard the free
20266                          * which /might/ happen twice. At the least
20267                          * it will make code anlyzers happy and it
20268                          * doesn't cost much. - Yves */
20269                         assert(ri->regstclass);
20270                         if (ri->regstclass) {
20271                             PerlMemShared_free(ri->regstclass);
20272                             ri->regstclass = 0;
20273                         }
20274                     }
20275                 }
20276                 break;
20277             case 't':
20278                 {
20279                     /* trie structure. */
20280                     U32 refcount;
20281                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
20282 #ifdef USE_ITHREADS
20283                     dVAR;
20284 #endif
20285                     OP_REFCNT_LOCK;
20286                     refcount = --trie->refcount;
20287                     OP_REFCNT_UNLOCK;
20288                     if ( !refcount ) {
20289                         PerlMemShared_free(trie->charmap);
20290                         PerlMemShared_free(trie->states);
20291                         PerlMemShared_free(trie->trans);
20292                         if (trie->bitmap)
20293                             PerlMemShared_free(trie->bitmap);
20294                         if (trie->jump)
20295                             PerlMemShared_free(trie->jump);
20296                         PerlMemShared_free(trie->wordinfo);
20297                         /* do this last!!!! */
20298                         PerlMemShared_free(ri->data->data[n]);
20299                     }
20300                 }
20301                 break;
20302             default:
20303                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
20304                                                     ri->data->what[n]);
20305             }
20306         }
20307         Safefree(ri->data->what);
20308         Safefree(ri->data);
20309     }
20310
20311     Safefree(ri);
20312 }
20313
20314 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
20315 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
20316 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
20317
20318 /*
20319    re_dup_guts - duplicate a regexp.
20320
20321    This routine is expected to clone a given regexp structure. It is only
20322    compiled under USE_ITHREADS.
20323
20324    After all of the core data stored in struct regexp is duplicated
20325    the regexp_engine.dupe method is used to copy any private data
20326    stored in the *pprivate pointer. This allows extensions to handle
20327    any duplication it needs to do.
20328
20329    See pregfree() and regfree_internal() if you change anything here.
20330 */
20331 #if defined(USE_ITHREADS)
20332 #ifndef PERL_IN_XSUB_RE
20333 void
20334 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
20335 {
20336     dVAR;
20337     I32 npar;
20338     const struct regexp *r = ReANY(sstr);
20339     struct regexp *ret = ReANY(dstr);
20340
20341     PERL_ARGS_ASSERT_RE_DUP_GUTS;
20342
20343     npar = r->nparens+1;
20344     Newx(ret->offs, npar, regexp_paren_pair);
20345     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
20346
20347     if (ret->substrs) {
20348         /* Do it this way to avoid reading from *r after the StructCopy().
20349            That way, if any of the sv_dup_inc()s dislodge *r from the L1
20350            cache, it doesn't matter.  */
20351         int i;
20352         const bool anchored = r->check_substr
20353             ? r->check_substr == r->substrs->data[0].substr
20354             : r->check_utf8   == r->substrs->data[0].utf8_substr;
20355         Newx(ret->substrs, 1, struct reg_substr_data);
20356         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
20357
20358         for (i = 0; i < 2; i++) {
20359             ret->substrs->data[i].substr =
20360                         sv_dup_inc(ret->substrs->data[i].substr, param);
20361             ret->substrs->data[i].utf8_substr =
20362                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
20363         }
20364
20365         /* check_substr and check_utf8, if non-NULL, point to either their
20366            anchored or float namesakes, and don't hold a second reference.  */
20367
20368         if (ret->check_substr) {
20369             if (anchored) {
20370                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
20371
20372                 ret->check_substr = ret->substrs->data[0].substr;
20373                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
20374             } else {
20375                 assert(r->check_substr == r->substrs->data[1].substr);
20376                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
20377
20378                 ret->check_substr = ret->substrs->data[1].substr;
20379                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
20380             }
20381         } else if (ret->check_utf8) {
20382             if (anchored) {
20383                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
20384             } else {
20385                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
20386             }
20387         }
20388     }
20389
20390     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
20391     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
20392     if (r->recurse_locinput)
20393         Newx(ret->recurse_locinput,r->nparens + 1,char *);
20394
20395     if (ret->pprivate)
20396         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
20397
20398     if (RX_MATCH_COPIED(dstr))
20399         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
20400     else
20401         ret->subbeg = NULL;
20402 #ifdef PERL_ANY_COW
20403     ret->saved_copy = NULL;
20404 #endif
20405
20406     /* Whether mother_re be set or no, we need to copy the string.  We
20407        cannot refrain from copying it when the storage points directly to
20408        our mother regexp, because that's
20409                1: a buffer in a different thread
20410                2: something we no longer hold a reference on
20411                so we need to copy it locally.  */
20412     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
20413     ret->mother_re   = NULL;
20414 }
20415 #endif /* PERL_IN_XSUB_RE */
20416
20417 /*
20418    regdupe_internal()
20419
20420    This is the internal complement to regdupe() which is used to copy
20421    the structure pointed to by the *pprivate pointer in the regexp.
20422    This is the core version of the extension overridable cloning hook.
20423    The regexp structure being duplicated will be copied by perl prior
20424    to this and will be provided as the regexp *r argument, however
20425    with the /old/ structures pprivate pointer value. Thus this routine
20426    may override any copying normally done by perl.
20427
20428    It returns a pointer to the new regexp_internal structure.
20429 */
20430
20431 void *
20432 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
20433 {
20434     dVAR;
20435     struct regexp *const r = ReANY(rx);
20436     regexp_internal *reti;
20437     int len;
20438     RXi_GET_DECL(r,ri);
20439
20440     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
20441
20442     len = ProgLen(ri);
20443
20444     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
20445           char, regexp_internal);
20446     Copy(ri->program, reti->program, len+1, regnode);
20447
20448
20449     if (ri->code_blocks) {
20450         int n;
20451         Newx(reti->code_blocks, 1, struct reg_code_blocks);
20452         Newx(reti->code_blocks->cb, ri->code_blocks->count,
20453                     struct reg_code_block);
20454         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
20455              ri->code_blocks->count, struct reg_code_block);
20456         for (n = 0; n < ri->code_blocks->count; n++)
20457              reti->code_blocks->cb[n].src_regex = (REGEXP*)
20458                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
20459         reti->code_blocks->count = ri->code_blocks->count;
20460         reti->code_blocks->refcnt = 1;
20461     }
20462     else
20463         reti->code_blocks = NULL;
20464
20465     reti->regstclass = NULL;
20466
20467     if (ri->data) {
20468         struct reg_data *d;
20469         const int count = ri->data->count;
20470         int i;
20471
20472         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
20473                 char, struct reg_data);
20474         Newx(d->what, count, U8);
20475
20476         d->count = count;
20477         for (i = 0; i < count; i++) {
20478             d->what[i] = ri->data->what[i];
20479             switch (d->what[i]) {
20480                 /* see also regcomp.h and regfree_internal() */
20481             case 'a': /* actually an AV, but the dup function is identical.
20482                          values seem to be "plain sv's" generally. */
20483             case 'r': /* a compiled regex (but still just another SV) */
20484             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
20485                          this use case should go away, the code could have used
20486                          'a' instead - see S_set_ANYOF_arg() for array contents. */
20487             case 'S': /* actually an SV, but the dup function is identical.  */
20488             case 'u': /* actually an HV, but the dup function is identical.
20489                          values are "plain sv's" */
20490                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
20491                 break;
20492             case 'f':
20493                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
20494                  * patterns which could start with several different things. Pre-TRIE
20495                  * this was more important than it is now, however this still helps
20496                  * in some places, for instance /x?a+/ might produce a SSC equivalent
20497                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
20498                  * in regexec.c
20499                  */
20500                 /* This is cheating. */
20501                 Newx(d->data[i], 1, regnode_ssc);
20502                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
20503                 reti->regstclass = (regnode*)d->data[i];
20504                 break;
20505             case 'T':
20506                 /* AHO-CORASICK fail table */
20507                 /* Trie stclasses are readonly and can thus be shared
20508                  * without duplication. We free the stclass in pregfree
20509                  * when the corresponding reg_ac_data struct is freed.
20510                  */
20511                 reti->regstclass= ri->regstclass;
20512                 /* FALLTHROUGH */
20513             case 't':
20514                 /* TRIE transition table */
20515                 OP_REFCNT_LOCK;
20516                 ((reg_trie_data*)ri->data->data[i])->refcount++;
20517                 OP_REFCNT_UNLOCK;
20518                 /* FALLTHROUGH */
20519             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
20520             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
20521                          is not from another regexp */
20522                 d->data[i] = ri->data->data[i];
20523                 break;
20524             default:
20525                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
20526                                                            ri->data->what[i]);
20527             }
20528         }
20529
20530         reti->data = d;
20531     }
20532     else
20533         reti->data = NULL;
20534
20535     reti->name_list_idx = ri->name_list_idx;
20536
20537 #ifdef RE_TRACK_PATTERN_OFFSETS
20538     if (ri->u.offsets) {
20539         Newx(reti->u.offsets, 2*len+1, U32);
20540         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
20541     }
20542 #else
20543     SetProgLen(reti,len);
20544 #endif
20545
20546     return (void*)reti;
20547 }
20548
20549 #endif    /* USE_ITHREADS */
20550
20551 #ifndef PERL_IN_XSUB_RE
20552
20553 /*
20554  - regnext - dig the "next" pointer out of a node
20555  */
20556 regnode *
20557 Perl_regnext(pTHX_ regnode *p)
20558 {
20559     I32 offset;
20560
20561     if (!p)
20562         return(NULL);
20563
20564     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
20565         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
20566                                                 (int)OP(p), (int)REGNODE_MAX);
20567     }
20568
20569     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
20570     if (offset == 0)
20571         return(NULL);
20572
20573     return(p+offset);
20574 }
20575 #endif
20576
20577 STATIC void
20578 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
20579 {
20580     va_list args;
20581     STRLEN l1 = strlen(pat1);
20582     STRLEN l2 = strlen(pat2);
20583     char buf[512];
20584     SV *msv;
20585     const char *message;
20586
20587     PERL_ARGS_ASSERT_RE_CROAK2;
20588
20589     if (l1 > 510)
20590         l1 = 510;
20591     if (l1 + l2 > 510)
20592         l2 = 510 - l1;
20593     Copy(pat1, buf, l1 , char);
20594     Copy(pat2, buf + l1, l2 , char);
20595     buf[l1 + l2] = '\n';
20596     buf[l1 + l2 + 1] = '\0';
20597     va_start(args, pat2);
20598     msv = vmess(buf, &args);
20599     va_end(args);
20600     message = SvPV_const(msv,l1);
20601     if (l1 > 512)
20602         l1 = 512;
20603     Copy(message, buf, l1 , char);
20604     /* l1-1 to avoid \n */
20605     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
20606 }
20607
20608 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
20609
20610 #ifndef PERL_IN_XSUB_RE
20611 void
20612 Perl_save_re_context(pTHX)
20613 {
20614     I32 nparens = -1;
20615     I32 i;
20616
20617     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
20618
20619     if (PL_curpm) {
20620         const REGEXP * const rx = PM_GETRE(PL_curpm);
20621         if (rx)
20622             nparens = RX_NPARENS(rx);
20623     }
20624
20625     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
20626      * that PL_curpm will be null, but that utf8.pm and the modules it
20627      * loads will only use $1..$3.
20628      * The t/porting/re_context.t test file checks this assumption.
20629      */
20630     if (nparens == -1)
20631         nparens = 3;
20632
20633     for (i = 1; i <= nparens; i++) {
20634         char digits[TYPE_CHARS(long)];
20635         const STRLEN len = my_snprintf(digits, sizeof(digits),
20636                                        "%lu", (long)i);
20637         GV *const *const gvp
20638             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
20639
20640         if (gvp) {
20641             GV * const gv = *gvp;
20642             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
20643                 save_scalar(gv);
20644         }
20645     }
20646 }
20647 #endif
20648
20649 #ifdef DEBUGGING
20650
20651 STATIC void
20652 S_put_code_point(pTHX_ SV *sv, UV c)
20653 {
20654     PERL_ARGS_ASSERT_PUT_CODE_POINT;
20655
20656     if (c > 255) {
20657         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
20658     }
20659     else if (isPRINT(c)) {
20660         const char string = (char) c;
20661
20662         /* We use {phrase} as metanotation in the class, so also escape literal
20663          * braces */
20664         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
20665             sv_catpvs(sv, "\\");
20666         sv_catpvn(sv, &string, 1);
20667     }
20668     else if (isMNEMONIC_CNTRL(c)) {
20669         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
20670     }
20671     else {
20672         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
20673     }
20674 }
20675
20676 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
20677
20678 STATIC void
20679 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
20680 {
20681     /* Appends to 'sv' a displayable version of the range of code points from
20682      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
20683      * that have them, when they occur at the beginning or end of the range.
20684      * It uses hex to output the remaining code points, unless 'allow_literals'
20685      * is true, in which case the printable ASCII ones are output as-is (though
20686      * some of these will be escaped by put_code_point()).
20687      *
20688      * NOTE:  This is designed only for printing ranges of code points that fit
20689      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
20690      */
20691
20692     const unsigned int min_range_count = 3;
20693
20694     assert(start <= end);
20695
20696     PERL_ARGS_ASSERT_PUT_RANGE;
20697
20698     while (start <= end) {
20699         UV this_end;
20700         const char * format;
20701
20702         if (end - start < min_range_count) {
20703
20704             /* Output chars individually when they occur in short ranges */
20705             for (; start <= end; start++) {
20706                 put_code_point(sv, start);
20707             }
20708             break;
20709         }
20710
20711         /* If permitted by the input options, and there is a possibility that
20712          * this range contains a printable literal, look to see if there is
20713          * one. */
20714         if (allow_literals && start <= MAX_PRINT_A) {
20715
20716             /* If the character at the beginning of the range isn't an ASCII
20717              * printable, effectively split the range into two parts:
20718              *  1) the portion before the first such printable,
20719              *  2) the rest
20720              * and output them separately. */
20721             if (! isPRINT_A(start)) {
20722                 UV temp_end = start + 1;
20723
20724                 /* There is no point looking beyond the final possible
20725                  * printable, in MAX_PRINT_A */
20726                 UV max = MIN(end, MAX_PRINT_A);
20727
20728                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
20729                     temp_end++;
20730                 }
20731
20732                 /* Here, temp_end points to one beyond the first printable if
20733                  * found, or to one beyond 'max' if not.  If none found, make
20734                  * sure that we use the entire range */
20735                 if (temp_end > MAX_PRINT_A) {
20736                     temp_end = end + 1;
20737                 }
20738
20739                 /* Output the first part of the split range: the part that
20740                  * doesn't have printables, with the parameter set to not look
20741                  * for literals (otherwise we would infinitely recurse) */
20742                 put_range(sv, start, temp_end - 1, FALSE);
20743
20744                 /* The 2nd part of the range (if any) starts here. */
20745                 start = temp_end;
20746
20747                 /* We do a continue, instead of dropping down, because even if
20748                  * the 2nd part is non-empty, it could be so short that we want
20749                  * to output it as individual characters, as tested for at the
20750                  * top of this loop.  */
20751                 continue;
20752             }
20753
20754             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
20755              * output a sub-range of just the digits or letters, then process
20756              * the remaining portion as usual. */
20757             if (isALPHANUMERIC_A(start)) {
20758                 UV mask = (isDIGIT_A(start))
20759                            ? _CC_DIGIT
20760                              : isUPPER_A(start)
20761                                ? _CC_UPPER
20762                                : _CC_LOWER;
20763                 UV temp_end = start + 1;
20764
20765                 /* Find the end of the sub-range that includes just the
20766                  * characters in the same class as the first character in it */
20767                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20768                     temp_end++;
20769                 }
20770                 temp_end--;
20771
20772                 /* For short ranges, don't duplicate the code above to output
20773                  * them; just call recursively */
20774                 if (temp_end - start < min_range_count) {
20775                     put_range(sv, start, temp_end, FALSE);
20776                 }
20777                 else {  /* Output as a range */
20778                     put_code_point(sv, start);
20779                     sv_catpvs(sv, "-");
20780                     put_code_point(sv, temp_end);
20781                 }
20782                 start = temp_end + 1;
20783                 continue;
20784             }
20785
20786             /* We output any other printables as individual characters */
20787             if (isPUNCT_A(start) || isSPACE_A(start)) {
20788                 while (start <= end && (isPUNCT_A(start)
20789                                         || isSPACE_A(start)))
20790                 {
20791                     put_code_point(sv, start);
20792                     start++;
20793                 }
20794                 continue;
20795             }
20796         } /* End of looking for literals */
20797
20798         /* Here is not to output as a literal.  Some control characters have
20799          * mnemonic names.  Split off any of those at the beginning and end of
20800          * the range to print mnemonically.  It isn't possible for many of
20801          * these to be in a row, so this won't overwhelm with output */
20802         if (   start <= end
20803             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20804         {
20805             while (isMNEMONIC_CNTRL(start) && start <= end) {
20806                 put_code_point(sv, start);
20807                 start++;
20808             }
20809
20810             /* If this didn't take care of the whole range ... */
20811             if (start <= end) {
20812
20813                 /* Look backwards from the end to find the final non-mnemonic
20814                  * */
20815                 UV temp_end = end;
20816                 while (isMNEMONIC_CNTRL(temp_end)) {
20817                     temp_end--;
20818                 }
20819
20820                 /* And separately output the interior range that doesn't start
20821                  * or end with mnemonics */
20822                 put_range(sv, start, temp_end, FALSE);
20823
20824                 /* Then output the mnemonic trailing controls */
20825                 start = temp_end + 1;
20826                 while (start <= end) {
20827                     put_code_point(sv, start);
20828                     start++;
20829                 }
20830                 break;
20831             }
20832         }
20833
20834         /* As a final resort, output the range or subrange as hex. */
20835
20836         this_end = (end < NUM_ANYOF_CODE_POINTS)
20837                     ? end
20838                     : NUM_ANYOF_CODE_POINTS - 1;
20839 #if NUM_ANYOF_CODE_POINTS > 256
20840         format = (this_end < 256)
20841                  ? "\\x%02" UVXf "-\\x%02" UVXf
20842                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20843 #else
20844         format = "\\x%02" UVXf "-\\x%02" UVXf;
20845 #endif
20846         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
20847         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20848         GCC_DIAG_RESTORE_STMT;
20849         break;
20850     }
20851 }
20852
20853 STATIC void
20854 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20855 {
20856     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20857      * 'invlist' */
20858
20859     UV start, end;
20860     bool allow_literals = TRUE;
20861
20862     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20863
20864     /* Generally, it is more readable if printable characters are output as
20865      * literals, but if a range (nearly) spans all of them, it's best to output
20866      * it as a single range.  This code will use a single range if all but 2
20867      * ASCII printables are in it */
20868     invlist_iterinit(invlist);
20869     while (invlist_iternext(invlist, &start, &end)) {
20870
20871         /* If the range starts beyond the final printable, it doesn't have any
20872          * in it */
20873         if (start > MAX_PRINT_A) {
20874             break;
20875         }
20876
20877         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20878          * all but two, the range must start and end no later than 2 from
20879          * either end */
20880         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20881             if (end > MAX_PRINT_A) {
20882                 end = MAX_PRINT_A;
20883             }
20884             if (start < ' ') {
20885                 start = ' ';
20886             }
20887             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20888                 allow_literals = FALSE;
20889             }
20890             break;
20891         }
20892     }
20893     invlist_iterfinish(invlist);
20894
20895     /* Here we have figured things out.  Output each range */
20896     invlist_iterinit(invlist);
20897     while (invlist_iternext(invlist, &start, &end)) {
20898         if (start >= NUM_ANYOF_CODE_POINTS) {
20899             break;
20900         }
20901         put_range(sv, start, end, allow_literals);
20902     }
20903     invlist_iterfinish(invlist);
20904
20905     return;
20906 }
20907
20908 STATIC SV*
20909 S_put_charclass_bitmap_innards_common(pTHX_
20910         SV* invlist,            /* The bitmap */
20911         SV* posixes,            /* Under /l, things like [:word:], \S */
20912         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20913         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20914         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20915         const bool invert       /* Is the result to be inverted? */
20916 )
20917 {
20918     /* Create and return an SV containing a displayable version of the bitmap
20919      * and associated information determined by the input parameters.  If the
20920      * output would have been only the inversion indicator '^', NULL is instead
20921      * returned. */
20922
20923     SV * output;
20924
20925     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20926
20927     if (invert) {
20928         output = newSVpvs("^");
20929     }
20930     else {
20931         output = newSVpvs("");
20932     }
20933
20934     /* First, the code points in the bitmap that are unconditionally there */
20935     put_charclass_bitmap_innards_invlist(output, invlist);
20936
20937     /* Traditionally, these have been placed after the main code points */
20938     if (posixes) {
20939         sv_catsv(output, posixes);
20940     }
20941
20942     if (only_utf8 && _invlist_len(only_utf8)) {
20943         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20944         put_charclass_bitmap_innards_invlist(output, only_utf8);
20945     }
20946
20947     if (not_utf8 && _invlist_len(not_utf8)) {
20948         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20949         put_charclass_bitmap_innards_invlist(output, not_utf8);
20950     }
20951
20952     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20953         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20954         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20955
20956         /* This is the only list in this routine that can legally contain code
20957          * points outside the bitmap range.  The call just above to
20958          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20959          * output them here.  There's about a half-dozen possible, and none in
20960          * contiguous ranges longer than 2 */
20961         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20962             UV start, end;
20963             SV* above_bitmap = NULL;
20964
20965             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20966
20967             invlist_iterinit(above_bitmap);
20968             while (invlist_iternext(above_bitmap, &start, &end)) {
20969                 UV i;
20970
20971                 for (i = start; i <= end; i++) {
20972                     put_code_point(output, i);
20973                 }
20974             }
20975             invlist_iterfinish(above_bitmap);
20976             SvREFCNT_dec_NN(above_bitmap);
20977         }
20978     }
20979
20980     if (invert && SvCUR(output) == 1) {
20981         return NULL;
20982     }
20983
20984     return output;
20985 }
20986
20987 STATIC bool
20988 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20989                                      char *bitmap,
20990                                      SV *nonbitmap_invlist,
20991                                      SV *only_utf8_locale_invlist,
20992                                      const regnode * const node,
20993                                      const bool force_as_is_display)
20994 {
20995     /* Appends to 'sv' a displayable version of the innards of the bracketed
20996      * character class defined by the other arguments:
20997      *  'bitmap' points to the bitmap, or NULL if to ignore that.
20998      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20999      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
21000      *      none.  The reasons for this could be that they require some
21001      *      condition such as the target string being or not being in UTF-8
21002      *      (under /d), or because they came from a user-defined property that
21003      *      was not resolved at the time of the regex compilation (under /u)
21004      *  'only_utf8_locale_invlist' is an inversion list of the code points that
21005      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
21006      *  'node' is the regex pattern ANYOF node.  It is needed only when the
21007      *      above two parameters are not null, and is passed so that this
21008      *      routine can tease apart the various reasons for them.
21009      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
21010      *      to invert things to see if that leads to a cleaner display.  If
21011      *      FALSE, this routine is free to use its judgment about doing this.
21012      *
21013      * It returns TRUE if there was actually something output.  (It may be that
21014      * the bitmap, etc is empty.)
21015      *
21016      * When called for outputting the bitmap of a non-ANYOF node, just pass the
21017      * bitmap, with the succeeding parameters set to NULL, and the final one to
21018      * FALSE.
21019      */
21020
21021     /* In general, it tries to display the 'cleanest' representation of the
21022      * innards, choosing whether to display them inverted or not, regardless of
21023      * whether the class itself is to be inverted.  However,  there are some
21024      * cases where it can't try inverting, as what actually matches isn't known
21025      * until runtime, and hence the inversion isn't either. */
21026     bool inverting_allowed = ! force_as_is_display;
21027
21028     int i;
21029     STRLEN orig_sv_cur = SvCUR(sv);
21030
21031     SV* invlist;            /* Inversion list we accumulate of code points that
21032                                are unconditionally matched */
21033     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
21034                                UTF-8 */
21035     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
21036                              */
21037     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
21038     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
21039                                        is UTF-8 */
21040
21041     SV* as_is_display;      /* The output string when we take the inputs
21042                                literally */
21043     SV* inverted_display;   /* The output string when we invert the inputs */
21044
21045     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
21046
21047     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
21048                                                    to match? */
21049     /* We are biased in favor of displaying things without them being inverted,
21050      * as that is generally easier to understand */
21051     const int bias = 5;
21052
21053     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
21054
21055     /* Start off with whatever code points are passed in.  (We clone, so we
21056      * don't change the caller's list) */
21057     if (nonbitmap_invlist) {
21058         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
21059         invlist = invlist_clone(nonbitmap_invlist);
21060     }
21061     else {  /* Worst case size is every other code point is matched */
21062         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
21063     }
21064
21065     if (flags) {
21066         if (OP(node) == ANYOFD) {
21067
21068             /* This flag indicates that the code points below 0x100 in the
21069              * nonbitmap list are precisely the ones that match only when the
21070              * target is UTF-8 (they should all be non-ASCII). */
21071             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
21072             {
21073                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
21074                 _invlist_subtract(invlist, only_utf8, &invlist);
21075             }
21076
21077             /* And this flag for matching all non-ASCII 0xFF and below */
21078             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
21079             {
21080                 not_utf8 = invlist_clone(PL_UpperLatin1);
21081             }
21082         }
21083         else if (OP(node) == ANYOFL) {
21084
21085             /* If either of these flags are set, what matches isn't
21086              * determinable except during execution, so don't know enough here
21087              * to invert */
21088             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
21089                 inverting_allowed = FALSE;
21090             }
21091
21092             /* What the posix classes match also varies at runtime, so these
21093              * will be output symbolically. */
21094             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
21095                 int i;
21096
21097                 posixes = newSVpvs("");
21098                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
21099                     if (ANYOF_POSIXL_TEST(node,i)) {
21100                         sv_catpv(posixes, anyofs[i]);
21101                     }
21102                 }
21103             }
21104         }
21105     }
21106
21107     /* Accumulate the bit map into the unconditional match list */
21108     if (bitmap) {
21109         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
21110             if (BITMAP_TEST(bitmap, i)) {
21111                 int start = i++;
21112                 for (;
21113                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
21114                      i++)
21115                 { /* empty */ }
21116                 invlist = _add_range_to_invlist(invlist, start, i-1);
21117             }
21118         }
21119     }
21120
21121     /* Make sure that the conditional match lists don't have anything in them
21122      * that match unconditionally; otherwise the output is quite confusing.
21123      * This could happen if the code that populates these misses some
21124      * duplication. */
21125     if (only_utf8) {
21126         _invlist_subtract(only_utf8, invlist, &only_utf8);
21127     }
21128     if (not_utf8) {
21129         _invlist_subtract(not_utf8, invlist, &not_utf8);
21130     }
21131
21132     if (only_utf8_locale_invlist) {
21133
21134         /* Since this list is passed in, we have to make a copy before
21135          * modifying it */
21136         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
21137
21138         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
21139
21140         /* And, it can get really weird for us to try outputting an inverted
21141          * form of this list when it has things above the bitmap, so don't even
21142          * try */
21143         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21144             inverting_allowed = FALSE;
21145         }
21146     }
21147
21148     /* Calculate what the output would be if we take the input as-is */
21149     as_is_display = put_charclass_bitmap_innards_common(invlist,
21150                                                     posixes,
21151                                                     only_utf8,
21152                                                     not_utf8,
21153                                                     only_utf8_locale,
21154                                                     invert);
21155
21156     /* If have to take the output as-is, just do that */
21157     if (! inverting_allowed) {
21158         if (as_is_display) {
21159             sv_catsv(sv, as_is_display);
21160             SvREFCNT_dec_NN(as_is_display);
21161         }
21162     }
21163     else { /* But otherwise, create the output again on the inverted input, and
21164               use whichever version is shorter */
21165
21166         int inverted_bias, as_is_bias;
21167
21168         /* We will apply our bias to whichever of the the results doesn't have
21169          * the '^' */
21170         if (invert) {
21171             invert = FALSE;
21172             as_is_bias = bias;
21173             inverted_bias = 0;
21174         }
21175         else {
21176             invert = TRUE;
21177             as_is_bias = 0;
21178             inverted_bias = bias;
21179         }
21180
21181         /* Now invert each of the lists that contribute to the output,
21182          * excluding from the result things outside the possible range */
21183
21184         /* For the unconditional inversion list, we have to add in all the
21185          * conditional code points, so that when inverted, they will be gone
21186          * from it */
21187         _invlist_union(only_utf8, invlist, &invlist);
21188         _invlist_union(not_utf8, invlist, &invlist);
21189         _invlist_union(only_utf8_locale, invlist, &invlist);
21190         _invlist_invert(invlist);
21191         _invlist_intersection(invlist, PL_InBitmap, &invlist);
21192
21193         if (only_utf8) {
21194             _invlist_invert(only_utf8);
21195             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
21196         }
21197         else if (not_utf8) {
21198
21199             /* If a code point matches iff the target string is not in UTF-8,
21200              * then complementing the result has it not match iff not in UTF-8,
21201              * which is the same thing as matching iff it is UTF-8. */
21202             only_utf8 = not_utf8;
21203             not_utf8 = NULL;
21204         }
21205
21206         if (only_utf8_locale) {
21207             _invlist_invert(only_utf8_locale);
21208             _invlist_intersection(only_utf8_locale,
21209                                   PL_InBitmap,
21210                                   &only_utf8_locale);
21211         }
21212
21213         inverted_display = put_charclass_bitmap_innards_common(
21214                                             invlist,
21215                                             posixes,
21216                                             only_utf8,
21217                                             not_utf8,
21218                                             only_utf8_locale, invert);
21219
21220         /* Use the shortest representation, taking into account our bias
21221          * against showing it inverted */
21222         if (   inverted_display
21223             && (   ! as_is_display
21224                 || (  SvCUR(inverted_display) + inverted_bias
21225                     < SvCUR(as_is_display)    + as_is_bias)))
21226         {
21227             sv_catsv(sv, inverted_display);
21228         }
21229         else if (as_is_display) {
21230             sv_catsv(sv, as_is_display);
21231         }
21232
21233         SvREFCNT_dec(as_is_display);
21234         SvREFCNT_dec(inverted_display);
21235     }
21236
21237     SvREFCNT_dec_NN(invlist);
21238     SvREFCNT_dec(only_utf8);
21239     SvREFCNT_dec(not_utf8);
21240     SvREFCNT_dec(posixes);
21241     SvREFCNT_dec(only_utf8_locale);
21242
21243     return SvCUR(sv) > orig_sv_cur;
21244 }
21245
21246 #define CLEAR_OPTSTART                                                       \
21247     if (optstart) STMT_START {                                               \
21248         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
21249                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
21250         optstart=NULL;                                                       \
21251     } STMT_END
21252
21253 #define DUMPUNTIL(b,e)                                                       \
21254                     CLEAR_OPTSTART;                                          \
21255                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
21256
21257 STATIC const regnode *
21258 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
21259             const regnode *last, const regnode *plast,
21260             SV* sv, I32 indent, U32 depth)
21261 {
21262     U8 op = PSEUDO;     /* Arbitrary non-END op. */
21263     const regnode *next;
21264     const regnode *optstart= NULL;
21265
21266     RXi_GET_DECL(r,ri);
21267     GET_RE_DEBUG_FLAGS_DECL;
21268
21269     PERL_ARGS_ASSERT_DUMPUNTIL;
21270
21271 #ifdef DEBUG_DUMPUNTIL
21272     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
21273         last ? last-start : 0,plast ? plast-start : 0);
21274 #endif
21275
21276     if (plast && plast < last)
21277         last= plast;
21278
21279     while (PL_regkind[op] != END && (!last || node < last)) {
21280         assert(node);
21281         /* While that wasn't END last time... */
21282         NODE_ALIGN(node);
21283         op = OP(node);
21284         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
21285             indent--;
21286         next = regnext((regnode *)node);
21287
21288         /* Where, what. */
21289         if (OP(node) == OPTIMIZED) {
21290             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
21291                 optstart = node;
21292             else
21293                 goto after_print;
21294         } else
21295             CLEAR_OPTSTART;
21296
21297         regprop(r, sv, node, NULL, NULL);
21298         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
21299                       (int)(2*indent + 1), "", SvPVX_const(sv));
21300
21301         if (OP(node) != OPTIMIZED) {
21302             if (next == NULL)           /* Next ptr. */
21303                 Perl_re_printf( aTHX_  " (0)");
21304             else if (PL_regkind[(U8)op] == BRANCH
21305                      && PL_regkind[OP(next)] != BRANCH )
21306                 Perl_re_printf( aTHX_  " (FAIL)");
21307             else
21308                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
21309             Perl_re_printf( aTHX_ "\n");
21310         }
21311
21312       after_print:
21313         if (PL_regkind[(U8)op] == BRANCHJ) {
21314             assert(next);
21315             {
21316                 const regnode *nnode = (OP(next) == LONGJMP
21317                                        ? regnext((regnode *)next)
21318                                        : next);
21319                 if (last && nnode > last)
21320                     nnode = last;
21321                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
21322             }
21323         }
21324         else if (PL_regkind[(U8)op] == BRANCH) {
21325             assert(next);
21326             DUMPUNTIL(NEXTOPER(node), next);
21327         }
21328         else if ( PL_regkind[(U8)op]  == TRIE ) {
21329             const regnode *this_trie = node;
21330             const char op = OP(node);
21331             const U32 n = ARG(node);
21332             const reg_ac_data * const ac = op>=AHOCORASICK ?
21333                (reg_ac_data *)ri->data->data[n] :
21334                NULL;
21335             const reg_trie_data * const trie =
21336                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
21337 #ifdef DEBUGGING
21338             AV *const trie_words
21339                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
21340 #endif
21341             const regnode *nextbranch= NULL;
21342             I32 word_idx;
21343             SvPVCLEAR(sv);
21344             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
21345                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
21346
21347                 Perl_re_indentf( aTHX_  "%s ",
21348                     indent+3,
21349                     elem_ptr
21350                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
21351                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
21352                                 PL_colors[0], PL_colors[1],
21353                                 (SvUTF8(*elem_ptr)
21354                                  ? PERL_PV_ESCAPE_UNI
21355                                  : 0)
21356                                 | PERL_PV_PRETTY_ELLIPSES
21357                                 | PERL_PV_PRETTY_LTGT
21358                             )
21359                     : "???"
21360                 );
21361                 if (trie->jump) {
21362                     U16 dist= trie->jump[word_idx+1];
21363                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
21364                                (UV)((dist ? this_trie + dist : next) - start));
21365                     if (dist) {
21366                         if (!nextbranch)
21367                             nextbranch= this_trie + trie->jump[0];
21368                         DUMPUNTIL(this_trie + dist, nextbranch);
21369                     }
21370                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
21371                         nextbranch= regnext((regnode *)nextbranch);
21372                 } else {
21373                     Perl_re_printf( aTHX_  "\n");
21374                 }
21375             }
21376             if (last && next > last)
21377                 node= last;
21378             else
21379                 node= next;
21380         }
21381         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
21382             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
21383                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
21384         }
21385         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
21386             assert(next);
21387             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
21388         }
21389         else if ( op == PLUS || op == STAR) {
21390             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
21391         }
21392         else if (PL_regkind[(U8)op] == ANYOF) {
21393             /* arglen 1 + class block */
21394             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
21395                           ? ANYOF_POSIXL_SKIP
21396                           : ANYOF_SKIP);
21397             node = NEXTOPER(node);
21398         }
21399         else if (PL_regkind[(U8)op] == EXACT) {
21400             /* Literal string, where present. */
21401             node += NODE_SZ_STR(node) - 1;
21402             node = NEXTOPER(node);
21403         }
21404         else {
21405             node = NEXTOPER(node);
21406             node += regarglen[(U8)op];
21407         }
21408         if (op == CURLYX || op == OPEN || op == SROPEN)
21409             indent++;
21410     }
21411     CLEAR_OPTSTART;
21412 #ifdef DEBUG_DUMPUNTIL
21413     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
21414 #endif
21415     return node;
21416 }
21417
21418 #endif  /* DEBUGGING */
21419
21420 /*
21421  * ex: set ts=8 sts=4 sw=4 et:
21422  */