This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_scalarvoid(): add comment saying what it does
[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 #define REG_COMP_C
78 #ifdef PERL_IN_XSUB_RE
79 #  include "re_comp.h"
80 EXTERN_C const struct regexp_engine my_reg_engine;
81 #else
82 #  include "regcomp.h"
83 #endif
84
85 #include "dquote_inline.h"
86 #include "invlist_inline.h"
87 #include "unicode_constants.h"
88
89 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
90  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
91 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
92  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
93 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
94 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
95
96 #ifndef STATIC
97 #define STATIC  static
98 #endif
99
100 /* this is a chain of data about sub patterns we are processing that
101    need to be handled separately/specially in study_chunk. Its so
102    we can simulate recursion without losing state.  */
103 struct scan_frame;
104 typedef struct scan_frame {
105     regnode *last_regnode;      /* last node to process in this frame */
106     regnode *next_regnode;      /* next node to process when last is reached */
107     U32 prev_recursed_depth;
108     I32 stopparen;              /* what stopparen do we use */
109
110     struct scan_frame *this_prev_frame; /* this previous frame */
111     struct scan_frame *prev_frame;      /* previous frame */
112     struct scan_frame *next_frame;      /* next frame */
113 } scan_frame;
114
115 /* Certain characters are output as a sequence with the first being a
116  * backslash. */
117 #define isBACKSLASHED_PUNCT(c)  strchr("-[]\\^", c)
118
119
120 struct RExC_state_t {
121     U32         flags;                  /* RXf_* are we folding, multilining? */
122     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
123     char        *precomp;               /* uncompiled string. */
124     char        *precomp_end;           /* pointer to end of uncompiled string. */
125     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
126     regexp      *rx;                    /* perl core regexp structure */
127     regexp_internal     *rxi;           /* internal data for regexp object
128                                            pprivate field */
129     char        *start;                 /* Start of input for compile */
130     char        *end;                   /* End of input for compile */
131     char        *parse;                 /* Input-scan pointer. */
132     char        *copy_start;            /* start of copy of input within
133                                            constructed parse string */
134     char        *save_copy_start;       /* Provides one level of saving
135                                            and restoring 'copy_start' */
136     char        *copy_start_in_input;   /* Position in input string
137                                            corresponding to copy_start */
138     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
139     regnode     *emit_start;            /* Start of emitted-code area */
140     regnode_offset emit;                /* Code-emit pointer */
141     I32         naughty;                /* How bad is this pattern? */
142     I32         sawback;                /* Did we see \1, ...? */
143     U32         seen;
144     SSize_t     size;                   /* Number of regnode equivalents in
145                                            pattern */
146
147     /* position beyond 'precomp' of the warning message furthest away from
148      * 'precomp'.  During the parse, no warnings are raised for any problems
149      * earlier in the parse than this position.  This works if warnings are
150      * raised the first time a given spot is parsed, and if only one
151      * independent warning is raised for any given spot */
152     Size_t      latest_warn_offset;
153
154     I32         npar;                   /* Capture buffer count so far in the
155                                            parse, (OPEN) plus one. ("par" 0 is
156                                            the whole pattern)*/
157     I32         total_par;              /* During initial parse, is either 0,
158                                            or -1; the latter indicating a
159                                            reparse is needed.  After that pass,
160                                            it is what 'npar' became after the
161                                            pass.  Hence, it being > 0 indicates
162                                            we are in a reparse situation */
163     I32         nestroot;               /* root parens we are in - used by
164                                            accept */
165     I32         seen_zerolen;
166     regnode_offset *open_parens;        /* offsets to open parens */
167     regnode_offset *close_parens;       /* offsets to close parens */
168     I32      parens_buf_size;           /* #slots malloced open/close_parens */
169     regnode     *end_op;                /* END node in program */
170     I32         utf8;           /* whether the pattern is utf8 or not */
171     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
172                                 /* XXX use this for future optimisation of case
173                                  * where pattern must be upgraded to utf8. */
174     I32         uni_semantics;  /* If a d charset modifier should use unicode
175                                    rules, even if the pattern is not in
176                                    utf8 */
177     HV          *paren_names;           /* Paren names */
178
179     regnode     **recurse;              /* Recurse regops */
180     I32         recurse_count;          /* Number of recurse regops we have generated */
181     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
182                                            through */
183     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
184     I32         in_lookbehind;
185     I32         contains_locale;
186     I32         override_recoding;
187 #ifdef EBCDIC
188     I32         recode_x_to_native;
189 #endif
190     I32         in_multi_char_class;
191     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
192                                             within pattern */
193     int         code_index;             /* next code_blocks[] slot */
194     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
195     scan_frame *frame_head;
196     scan_frame *frame_last;
197     U32         frame_count;
198     AV         *warn_text;
199     HV         *unlexed_names;
200 #ifdef ADD_TO_REGEXEC
201     char        *starttry;              /* -Dr: where regtry was called. */
202 #define RExC_starttry   (pRExC_state->starttry)
203 #endif
204     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
205 #ifdef DEBUGGING
206     const char  *lastparse;
207     I32         lastnum;
208     AV          *paren_name_list;       /* idx -> name */
209     U32         study_chunk_recursed_count;
210     SV          *mysv1;
211     SV          *mysv2;
212
213 #define RExC_lastparse  (pRExC_state->lastparse)
214 #define RExC_lastnum    (pRExC_state->lastnum)
215 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
216 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
217 #define RExC_mysv       (pRExC_state->mysv1)
218 #define RExC_mysv1      (pRExC_state->mysv1)
219 #define RExC_mysv2      (pRExC_state->mysv2)
220
221 #endif
222     bool        seen_d_op;
223     bool        strict;
224     bool        study_started;
225     bool        in_script_run;
226     bool        use_BRANCHJ;
227 };
228
229 #define RExC_flags      (pRExC_state->flags)
230 #define RExC_pm_flags   (pRExC_state->pm_flags)
231 #define RExC_precomp    (pRExC_state->precomp)
232 #define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
233 #define RExC_copy_start_in_constructed  (pRExC_state->copy_start)
234 #define RExC_save_copy_start_in_constructed  (pRExC_state->save_copy_start)
235 #define RExC_precomp_end (pRExC_state->precomp_end)
236 #define RExC_rx_sv      (pRExC_state->rx_sv)
237 #define RExC_rx         (pRExC_state->rx)
238 #define RExC_rxi        (pRExC_state->rxi)
239 #define RExC_start      (pRExC_state->start)
240 #define RExC_end        (pRExC_state->end)
241 #define RExC_parse      (pRExC_state->parse)
242 #define RExC_latest_warn_offset (pRExC_state->latest_warn_offset )
243 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
244 #define RExC_seen_d_op (pRExC_state->seen_d_op) /* Seen something that differs
245                                                    under /d from /u ? */
246
247
248 #ifdef RE_TRACK_PATTERN_OFFSETS
249 #  define RExC_offsets  (RExC_rxi->u.offsets) /* I am not like the
250                                                          others */
251 #endif
252 #define RExC_emit       (pRExC_state->emit)
253 #define RExC_emit_start (pRExC_state->emit_start)
254 #define RExC_sawback    (pRExC_state->sawback)
255 #define RExC_seen       (pRExC_state->seen)
256 #define RExC_size       (pRExC_state->size)
257 #define RExC_maxlen        (pRExC_state->maxlen)
258 #define RExC_npar       (pRExC_state->npar)
259 #define RExC_total_parens       (pRExC_state->total_par)
260 #define RExC_parens_buf_size    (pRExC_state->parens_buf_size)
261 #define RExC_nestroot   (pRExC_state->nestroot)
262 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
263 #define RExC_utf8       (pRExC_state->utf8)
264 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
265 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
266 #define RExC_open_parens        (pRExC_state->open_parens)
267 #define RExC_close_parens       (pRExC_state->close_parens)
268 #define RExC_end_op     (pRExC_state->end_op)
269 #define RExC_paren_names        (pRExC_state->paren_names)
270 #define RExC_recurse    (pRExC_state->recurse)
271 #define RExC_recurse_count      (pRExC_state->recurse_count)
272 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
273 #define RExC_study_chunk_recursed_bytes  \
274                                    (pRExC_state->study_chunk_recursed_bytes)
275 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
276 #define RExC_contains_locale    (pRExC_state->contains_locale)
277 #ifdef EBCDIC
278 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
279 #endif
280 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
281 #define RExC_frame_head (pRExC_state->frame_head)
282 #define RExC_frame_last (pRExC_state->frame_last)
283 #define RExC_frame_count (pRExC_state->frame_count)
284 #define RExC_strict (pRExC_state->strict)
285 #define RExC_study_started      (pRExC_state->study_started)
286 #define RExC_warn_text (pRExC_state->warn_text)
287 #define RExC_in_script_run      (pRExC_state->in_script_run)
288 #define RExC_use_BRANCHJ        (pRExC_state->use_BRANCHJ)
289 #define RExC_unlexed_names (pRExC_state->unlexed_names)
290
291 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
292  * a flag to disable back-off on the fixed/floating substrings - if it's
293  * a high complexity pattern we assume the benefit of avoiding a full match
294  * is worth the cost of checking for the substrings even if they rarely help.
295  */
296 #define RExC_naughty    (pRExC_state->naughty)
297 #define TOO_NAUGHTY (10)
298 #define MARK_NAUGHTY(add) \
299     if (RExC_naughty < TOO_NAUGHTY) \
300         RExC_naughty += (add)
301 #define MARK_NAUGHTY_EXP(exp, add) \
302     if (RExC_naughty < TOO_NAUGHTY) \
303         RExC_naughty += RExC_naughty / (exp) + (add)
304
305 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
306 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
307         ((*s) == '{' && regcurly(s)))
308
309 /*
310  * Flags to be passed up and down.
311  */
312 #define WORST           0       /* Worst case. */
313 #define HASWIDTH        0x01    /* Known to not match null strings, could match
314                                    non-null ones. */
315
316 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
317  * character.  (There needs to be a case: in the switch statement in regexec.c
318  * for any node marked SIMPLE.)  Note that this is not the same thing as
319  * REGNODE_SIMPLE */
320 #define SIMPLE          0x02
321 #define SPSTART         0x04    /* Starts with * or + */
322 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
323 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
324 #define RESTART_PARSE   0x20    /* Need to redo the parse */
325 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PARSE, need to
326                                    calcuate sizes as UTF-8 */
327
328 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
329
330 /* whether trie related optimizations are enabled */
331 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
332 #define TRIE_STUDY_OPT
333 #define FULL_TRIE_STUDY
334 #define TRIE_STCLASS
335 #endif
336
337
338
339 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
340 #define PBITVAL(paren) (1 << ((paren) & 7))
341 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
342 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
343 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
344
345 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
346                                      if (!UTF) {                           \
347                                          *flagp = RESTART_PARSE|NEED_UTF8; \
348                                          return 0;                         \
349                                      }                                     \
350                              } STMT_END
351
352 /* Change from /d into /u rules, and restart the parse.  RExC_uni_semantics is
353  * a flag that indicates we need to override /d with /u as a result of
354  * something in the pattern.  It should only be used in regards to calling
355  * set_regex_charset() or get_regex_charse() */
356 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
357     STMT_START {                                                            \
358             if (DEPENDS_SEMANTICS) {                                        \
359                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
360                 RExC_uni_semantics = 1;                                     \
361                 if (RExC_seen_d_op && LIKELY(! IN_PARENS_PASS)) {           \
362                     /* No need to restart the parse if we haven't seen      \
363                      * anything that differs between /u and /d, and no need \
364                      * to restart immediately if we're going to reparse     \
365                      * anyway to count parens */                            \
366                     *flagp |= RESTART_PARSE;                                \
367                     return restart_retval;                                  \
368                 }                                                           \
369             }                                                               \
370     } STMT_END
371
372 #define REQUIRE_BRANCHJ(flagp, restart_retval)                              \
373     STMT_START {                                                            \
374                 RExC_use_BRANCHJ = 1;                                       \
375                 if (LIKELY(! IN_PARENS_PASS)) {                             \
376                     /* No need to restart the parse immediately if we're    \
377                      * going to reparse anyway to count parens */           \
378                     *flagp |= RESTART_PARSE;                                \
379                     return restart_retval;                                  \
380                 }                                                           \
381     } STMT_END
382
383 /* Until we have completed the parse, we leave RExC_total_parens at 0 or
384  * less.  After that, it must always be positive, because the whole re is
385  * considered to be surrounded by virtual parens.  Setting it to negative
386  * indicates there is some construct that needs to know the actual number of
387  * parens to be properly handled.  And that means an extra pass will be
388  * required after we've counted them all */
389 #define ALL_PARENS_COUNTED (RExC_total_parens > 0)
390 #define REQUIRE_PARENS_PASS                                                 \
391     STMT_START {  /* No-op if have completed a pass */                      \
392                     if (! ALL_PARENS_COUNTED) RExC_total_parens = -1;       \
393     } STMT_END
394 #define IN_PARENS_PASS (RExC_total_parens < 0)
395
396
397 /* This is used to return failure (zero) early from the calling function if
398  * various flags in 'flags' are set.  Two flags always cause a return:
399  * 'RESTART_PARSE' and 'NEED_UTF8'.   'extra' can be used to specify any
400  * additional flags that should cause a return; 0 if none.  If the return will
401  * be done, '*flagp' is first set to be all of the flags that caused the
402  * return. */
403 #define RETURN_FAIL_ON_RESTART_OR_FLAGS(flags,flagp,extra)                  \
404     STMT_START {                                                            \
405             if ((flags) & (RESTART_PARSE|NEED_UTF8|(extra))) {              \
406                 *(flagp) = (flags) & (RESTART_PARSE|NEED_UTF8|(extra));     \
407                 return 0;                                                   \
408             }                                                               \
409     } STMT_END
410
411 #define MUST_RESTART(flags) ((flags) & (RESTART_PARSE))
412
413 #define RETURN_FAIL_ON_RESTART(flags,flagp)                                 \
414                         RETURN_FAIL_ON_RESTART_OR_FLAGS( flags, flagp, 0)
415 #define RETURN_FAIL_ON_RESTART_FLAGP(flagp)                                 \
416                                     if (MUST_RESTART(*(flagp))) return 0
417
418 /* This converts the named class defined in regcomp.h to its equivalent class
419  * number defined in handy.h. */
420 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
421 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
422
423 #define _invlist_union_complement_2nd(a, b, output) \
424                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
425 #define _invlist_intersection_complement_2nd(a, b, output) \
426                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
427
428 /* About scan_data_t.
429
430   During optimisation we recurse through the regexp program performing
431   various inplace (keyhole style) optimisations. In addition study_chunk
432   and scan_commit populate this data structure with information about
433   what strings MUST appear in the pattern. We look for the longest
434   string that must appear at a fixed location, and we look for the
435   longest string that may appear at a floating location. So for instance
436   in the pattern:
437
438     /FOO[xX]A.*B[xX]BAR/
439
440   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
441   strings (because they follow a .* construct). study_chunk will identify
442   both FOO and BAR as being the longest fixed and floating strings respectively.
443
444   The strings can be composites, for instance
445
446      /(f)(o)(o)/
447
448   will result in a composite fixed substring 'foo'.
449
450   For each string some basic information is maintained:
451
452   - min_offset
453     This is the position the string must appear at, or not before.
454     It also implicitly (when combined with minlenp) tells us how many
455     characters must match before the string we are searching for.
456     Likewise when combined with minlenp and the length of the string it
457     tells us how many characters must appear after the string we have
458     found.
459
460   - max_offset
461     Only used for floating strings. This is the rightmost point that
462     the string can appear at. If set to SSize_t_MAX it indicates that the
463     string can occur infinitely far to the right.
464     For fixed strings, it is equal to min_offset.
465
466   - minlenp
467     A pointer to the minimum number of characters of the pattern that the
468     string was found inside. This is important as in the case of positive
469     lookahead or positive lookbehind we can have multiple patterns
470     involved. Consider
471
472     /(?=FOO).*F/
473
474     The minimum length of the pattern overall is 3, the minimum length
475     of the lookahead part is 3, but the minimum length of the part that
476     will actually match is 1. So 'FOO's minimum length is 3, but the
477     minimum length for the F is 1. This is important as the minimum length
478     is used to determine offsets in front of and behind the string being
479     looked for.  Since strings can be composites this is the length of the
480     pattern at the time it was committed with a scan_commit. Note that
481     the length is calculated by study_chunk, so that the minimum lengths
482     are not known until the full pattern has been compiled, thus the
483     pointer to the value.
484
485   - lookbehind
486
487     In the case of lookbehind the string being searched for can be
488     offset past the start point of the final matching string.
489     If this value was just blithely removed from the min_offset it would
490     invalidate some of the calculations for how many chars must match
491     before or after (as they are derived from min_offset and minlen and
492     the length of the string being searched for).
493     When the final pattern is compiled and the data is moved from the
494     scan_data_t structure into the regexp structure the information
495     about lookbehind is factored in, with the information that would
496     have been lost precalculated in the end_shift field for the
497     associated string.
498
499   The fields pos_min and pos_delta are used to store the minimum offset
500   and the delta to the maximum offset at the current point in the pattern.
501
502 */
503
504 struct scan_data_substrs {
505     SV      *str;       /* longest substring found in pattern */
506     SSize_t min_offset; /* earliest point in string it can appear */
507     SSize_t max_offset; /* latest point in string it can appear */
508     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
509     SSize_t lookbehind; /* is the pos of the string modified by LB */
510     I32 flags;          /* per substring SF_* and SCF_* flags */
511 };
512
513 typedef struct scan_data_t {
514     /*I32 len_min;      unused */
515     /*I32 len_delta;    unused */
516     SSize_t pos_min;
517     SSize_t pos_delta;
518     SV *last_found;
519     SSize_t last_end;       /* min value, <0 unless valid. */
520     SSize_t last_start_min;
521     SSize_t last_start_max;
522     U8      cur_is_floating; /* whether the last_* values should be set as
523                               * the next fixed (0) or floating (1)
524                               * substring */
525
526     /* [0] is longest fixed substring so far, [1] is longest float so far */
527     struct scan_data_substrs  substrs[2];
528
529     I32 flags;             /* common SF_* and SCF_* flags */
530     I32 whilem_c;
531     SSize_t *last_closep;
532     regnode_ssc *start_class;
533 } scan_data_t;
534
535 /*
536  * Forward declarations for pregcomp()'s friends.
537  */
538
539 static const scan_data_t zero_scan_data = {
540     0, 0, NULL, 0, 0, 0, 0,
541     {
542         { NULL, 0, 0, 0, 0, 0 },
543         { NULL, 0, 0, 0, 0, 0 },
544     },
545     0, 0, NULL, NULL
546 };
547
548 /* study flags */
549
550 #define SF_BEFORE_SEOL          0x0001
551 #define SF_BEFORE_MEOL          0x0002
552 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
553
554 #define SF_IS_INF               0x0040
555 #define SF_HAS_PAR              0x0080
556 #define SF_IN_PAR               0x0100
557 #define SF_HAS_EVAL             0x0200
558
559
560 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
561  * longest substring in the pattern. When it is not set the optimiser keeps
562  * track of position, but does not keep track of the actual strings seen,
563  *
564  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
565  * /foo/i will not.
566  *
567  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
568  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
569  * turned off because of the alternation (BRANCH). */
570 #define SCF_DO_SUBSTR           0x0400
571
572 #define SCF_DO_STCLASS_AND      0x0800
573 #define SCF_DO_STCLASS_OR       0x1000
574 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
575 #define SCF_WHILEM_VISITED_POS  0x2000
576
577 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
578 #define SCF_SEEN_ACCEPT         0x8000
579 #define SCF_TRIE_DOING_RESTUDY 0x10000
580 #define SCF_IN_DEFINE          0x20000
581
582
583
584
585 #define UTF cBOOL(RExC_utf8)
586
587 /* The enums for all these are ordered so things work out correctly */
588 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
589 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
590                                                      == REGEX_DEPENDS_CHARSET)
591 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
592 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
593                                                      >= REGEX_UNICODE_CHARSET)
594 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
595                                             == REGEX_ASCII_RESTRICTED_CHARSET)
596 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
597                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
598 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
599                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
600
601 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
602
603 /* For programs that want to be strictly Unicode compatible by dying if any
604  * attempt is made to match a non-Unicode code point against a Unicode
605  * property.  */
606 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
607
608 #define OOB_NAMEDCLASS          -1
609
610 /* There is no code point that is out-of-bounds, so this is problematic.  But
611  * its only current use is to initialize a variable that is always set before
612  * looked at. */
613 #define OOB_UNICODE             0xDEADBEEF
614
615 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
616
617
618 /* length of regex to show in messages that don't mark a position within */
619 #define RegexLengthToShowInErrorMessages 127
620
621 /*
622  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
623  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
624  * op/pragma/warn/regcomp.
625  */
626 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
627 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
628
629 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
630                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
631
632 /* The code in this file in places uses one level of recursion with parsing
633  * rebased to an alternate string constructed by us in memory.  This can take
634  * the form of something that is completely different from the input, or
635  * something that uses the input as part of the alternate.  In the first case,
636  * there should be no possibility of an error, as we are in complete control of
637  * the alternate string.  But in the second case we don't completely control
638  * the input portion, so there may be errors in that.  Here's an example:
639  *      /[abc\x{DF}def]/ui
640  * is handled specially because \x{df} folds to a sequence of more than one
641  * character: 'ss'.  What is done is to create and parse an alternate string,
642  * which looks like this:
643  *      /(?:\x{DF}|[abc\x{DF}def])/ui
644  * where it uses the input unchanged in the middle of something it constructs,
645  * which is a branch for the DF outside the character class, and clustering
646  * parens around the whole thing. (It knows enough to skip the DF inside the
647  * class while in this substitute parse.) 'abc' and 'def' may have errors that
648  * need to be reported.  The general situation looks like this:
649  *
650  *                                       |<------- identical ------>|
651  *              sI                       tI               xI       eI
652  * Input:       ---------------------------------------------------------------
653  * Constructed:         ---------------------------------------------------
654  *                      sC               tC               xC       eC     EC
655  *                                       |<------- identical ------>|
656  *
657  * sI..eI   is the portion of the input pattern we are concerned with here.
658  * sC..EC   is the constructed substitute parse string.
659  *  sC..tC  is constructed by us
660  *  tC..eC  is an exact duplicate of the portion of the input pattern tI..eI.
661  *          In the diagram, these are vertically aligned.
662  *  eC..EC  is also constructed by us.
663  * xC       is the position in the substitute parse string where we found a
664  *          problem.
665  * xI       is the position in the original pattern corresponding to xC.
666  *
667  * We want to display a message showing the real input string.  Thus we need to
668  * translate from xC to xI.  We know that xC >= tC, since the portion of the
669  * string sC..tC has been constructed by us, and so shouldn't have errors.  We
670  * get:
671  *      xI = tI + (xC - tC)
672  *
673  * When the substitute parse is constructed, the code needs to set:
674  *      RExC_start (sC)
675  *      RExC_end (eC)
676  *      RExC_copy_start_in_input  (tI)
677  *      RExC_copy_start_in_constructed (tC)
678  * and restore them when done.
679  *
680  * During normal processing of the input pattern, both
681  * 'RExC_copy_start_in_input' and 'RExC_copy_start_in_constructed' are set to
682  * sI, so that xC equals xI.
683  */
684
685 #define sI              RExC_precomp
686 #define eI              RExC_precomp_end
687 #define sC              RExC_start
688 #define eC              RExC_end
689 #define tI              RExC_copy_start_in_input
690 #define tC              RExC_copy_start_in_constructed
691 #define xI(xC)          (tI + (xC - tC))
692 #define xI_offset(xC)   (xI(xC) - sI)
693
694 #define REPORT_LOCATION_ARGS(xC)                                            \
695     UTF8fARG(UTF,                                                           \
696              (xI(xC) > eI) /* Don't run off end */                          \
697               ? eI - sI   /* Length before the <--HERE */                   \
698               : ((xI_offset(xC) >= 0)                                       \
699                  ? xI_offset(xC)                                            \
700                  : (Perl_croak(aTHX_ "panic: %s: %d: negative offset: %"    \
701                                     IVdf " trying to output message for "   \
702                                     " pattern %.*s",                        \
703                                     __FILE__, __LINE__, (IV) xI_offset(xC), \
704                                     ((int) (eC - sC)), sC), 0)),            \
705              sI),         /* The input pattern printed up to the <--HERE */ \
706     UTF8fARG(UTF,                                                           \
707              (xI(xC) > eI) ? 0 : eI - xI(xC), /* Length after <--HERE */    \
708              (xI(xC) > eI) ? eI : xI(xC))     /* pattern after <--HERE */
709
710 /* Used to point after bad bytes for an error message, but avoid skipping
711  * past a nul byte. */
712 #define SKIP_IF_CHAR(s, e) (!*(s) ? 0 : UTF ? UTF8_SAFE_SKIP(s, e) : 1)
713
714 /* Set up to clean up after our imminent demise */
715 #define PREPARE_TO_DIE                                                      \
716     STMT_START {                                                            \
717         if (RExC_rx_sv)                                                     \
718             SAVEFREESV(RExC_rx_sv);                                         \
719         if (RExC_open_parens)                                               \
720             SAVEFREEPV(RExC_open_parens);                                   \
721         if (RExC_close_parens)                                              \
722             SAVEFREEPV(RExC_close_parens);                                  \
723     } STMT_END
724
725 /*
726  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
727  * arg. Show regex, up to a maximum length. If it's too long, chop and add
728  * "...".
729  */
730 #define _FAIL(code) STMT_START {                                        \
731     const char *ellipses = "";                                          \
732     IV len = RExC_precomp_end - RExC_precomp;                           \
733                                                                         \
734     PREPARE_TO_DIE;                                                     \
735     if (len > RegexLengthToShowInErrorMessages) {                       \
736         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
737         len = RegexLengthToShowInErrorMessages - 10;                    \
738         ellipses = "...";                                               \
739     }                                                                   \
740     code;                                                               \
741 } STMT_END
742
743 #define FAIL(msg) _FAIL(                            \
744     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
745             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
746
747 #define FAIL2(msg,arg) _FAIL(                       \
748     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
749             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
750
751 /*
752  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
753  */
754 #define Simple_vFAIL(m) STMT_START {                                    \
755     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
756             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
757 } STMT_END
758
759 /*
760  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
761  */
762 #define vFAIL(m) STMT_START {                           \
763     PREPARE_TO_DIE;                                     \
764     Simple_vFAIL(m);                                    \
765 } STMT_END
766
767 /*
768  * Like Simple_vFAIL(), but accepts two arguments.
769  */
770 #define Simple_vFAIL2(m,a1) STMT_START {                        \
771     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
772                       REPORT_LOCATION_ARGS(RExC_parse));        \
773 } STMT_END
774
775 /*
776  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
777  */
778 #define vFAIL2(m,a1) STMT_START {                       \
779     PREPARE_TO_DIE;                                     \
780     Simple_vFAIL2(m, a1);                               \
781 } STMT_END
782
783
784 /*
785  * Like Simple_vFAIL(), but accepts three arguments.
786  */
787 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
788     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
789             REPORT_LOCATION_ARGS(RExC_parse));                  \
790 } STMT_END
791
792 /*
793  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
794  */
795 #define vFAIL3(m,a1,a2) STMT_START {                    \
796     PREPARE_TO_DIE;                                     \
797     Simple_vFAIL3(m, a1, a2);                           \
798 } STMT_END
799
800 /*
801  * Like Simple_vFAIL(), but accepts four arguments.
802  */
803 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
804     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
805             REPORT_LOCATION_ARGS(RExC_parse));                  \
806 } STMT_END
807
808 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
809     PREPARE_TO_DIE;                                     \
810     Simple_vFAIL4(m, a1, a2, a3);                       \
811 } STMT_END
812
813 /* A specialized version of vFAIL2 that works with UTF8f */
814 #define vFAIL2utf8f(m, a1) STMT_START {             \
815     PREPARE_TO_DIE;                                 \
816     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
817             REPORT_LOCATION_ARGS(RExC_parse));      \
818 } STMT_END
819
820 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
821     PREPARE_TO_DIE;                                     \
822     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
823             REPORT_LOCATION_ARGS(RExC_parse));          \
824 } STMT_END
825
826 /* Setting this to NULL is a signal to not output warnings */
827 #define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE                               \
828     STMT_START {                                                            \
829       RExC_save_copy_start_in_constructed  = RExC_copy_start_in_constructed;\
830       RExC_copy_start_in_constructed = NULL;                                \
831     } STMT_END
832 #define RESTORE_WARNINGS                                                    \
833     RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
834
835 /* Since a warning can be generated multiple times as the input is reparsed, we
836  * output it the first time we come to that point in the parse, but suppress it
837  * otherwise.  'RExC_copy_start_in_constructed' being NULL is a flag to not
838  * generate any warnings */
839 #define TO_OUTPUT_WARNINGS(loc)                                         \
840   (   RExC_copy_start_in_constructed                                    \
841    && ((xI(loc)) - RExC_precomp) > (Ptrdiff_t) RExC_latest_warn_offset)
842
843 /* After we've emitted a warning, we save the position in the input so we don't
844  * output it again */
845 #define UPDATE_WARNINGS_LOC(loc)                                        \
846     STMT_START {                                                        \
847         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
848             RExC_latest_warn_offset = (xI(loc)) - RExC_precomp;         \
849         }                                                               \
850     } STMT_END
851
852 /* 'warns' is the output of the packWARNx macro used in 'code' */
853 #define _WARN_HELPER(loc, warns, code)                                  \
854     STMT_START {                                                        \
855         if (! RExC_copy_start_in_constructed) {                         \
856             Perl_croak( aTHX_ "panic! %s: %d: Tried to warn when none"  \
857                               " expected at '%s'",                      \
858                               __FILE__, __LINE__, loc);                 \
859         }                                                               \
860         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
861             if (ckDEAD(warns))                                          \
862                 PREPARE_TO_DIE;                                         \
863             code;                                                       \
864             UPDATE_WARNINGS_LOC(loc);                                   \
865         }                                                               \
866     } STMT_END
867
868 /* m is not necessarily a "literal string", in this macro */
869 #define reg_warn_non_literal_string(loc, m)                             \
870     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
871                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
872                                        "%s" REPORT_LOCATION,            \
873                                   m, REPORT_LOCATION_ARGS(loc)))
874
875 #define ckWARNreg(loc,m)                                                \
876     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
877                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
878                                           m REPORT_LOCATION,            \
879                                           REPORT_LOCATION_ARGS(loc)))
880
881 #define vWARN(loc, m)                                                   \
882     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
883                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
884                                        m REPORT_LOCATION,               \
885                                        REPORT_LOCATION_ARGS(loc)))      \
886
887 #define vWARN_dep(loc, m)                                               \
888     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
889                       Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),      \
890                                        m REPORT_LOCATION,               \
891                                        REPORT_LOCATION_ARGS(loc)))
892
893 #define ckWARNdep(loc,m)                                                \
894     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
895                       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
896                                             m REPORT_LOCATION,          \
897                                             REPORT_LOCATION_ARGS(loc)))
898
899 #define ckWARNregdep(loc,m)                                                 \
900     _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP),              \
901                       Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,     \
902                                                       WARN_REGEXP),         \
903                                              m REPORT_LOCATION,             \
904                                              REPORT_LOCATION_ARGS(loc)))
905
906 #define ckWARN2reg_d(loc,m, a1)                                             \
907     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
908                       Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),         \
909                                             m REPORT_LOCATION,              \
910                                             a1, REPORT_LOCATION_ARGS(loc)))
911
912 #define ckWARN2reg(loc, m, a1)                                              \
913     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
914                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
915                                           m REPORT_LOCATION,                \
916                                           a1, REPORT_LOCATION_ARGS(loc)))
917
918 #define vWARN3(loc, m, a1, a2)                                              \
919     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
920                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),              \
921                                        m REPORT_LOCATION,                   \
922                                        a1, a2, REPORT_LOCATION_ARGS(loc)))
923
924 #define ckWARN3reg(loc, m, a1, a2)                                          \
925     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
926                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
927                                           m REPORT_LOCATION,                \
928                                           a1, a2,                           \
929                                           REPORT_LOCATION_ARGS(loc)))
930
931 #define vWARN4(loc, m, a1, a2, a3)                                      \
932     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
933                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
934                                        m REPORT_LOCATION,               \
935                                        a1, a2, a3,                      \
936                                        REPORT_LOCATION_ARGS(loc)))
937
938 #define ckWARN4reg(loc, m, a1, a2, a3)                                  \
939     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
940                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
941                                           m REPORT_LOCATION,            \
942                                           a1, a2, a3,                   \
943                                           REPORT_LOCATION_ARGS(loc)))
944
945 #define vWARN5(loc, m, a1, a2, a3, a4)                                  \
946     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
947                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
948                                        m REPORT_LOCATION,               \
949                                        a1, a2, a3, a4,                  \
950                                        REPORT_LOCATION_ARGS(loc)))
951
952 #define ckWARNexperimental(loc, class, m)                               \
953     _WARN_HELPER(loc, packWARN(class),                                  \
954                       Perl_ck_warner_d(aTHX_ packWARN(class),           \
955                                             m REPORT_LOCATION,          \
956                                             REPORT_LOCATION_ARGS(loc)))
957
958 /* Convert between a pointer to a node and its offset from the beginning of the
959  * program */
960 #define REGNODE_p(offset)    (RExC_emit_start + (offset))
961 #define REGNODE_OFFSET(node) ((node) - RExC_emit_start)
962
963 /* Macros for recording node offsets.   20001227 mjd@plover.com
964  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
965  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
966  * Element 0 holds the number n.
967  * Position is 1 indexed.
968  */
969 #ifndef RE_TRACK_PATTERN_OFFSETS
970 #define Set_Node_Offset_To_R(offset,byte)
971 #define Set_Node_Offset(node,byte)
972 #define Set_Cur_Node_Offset
973 #define Set_Node_Length_To_R(node,len)
974 #define Set_Node_Length(node,len)
975 #define Set_Node_Cur_Length(node,start)
976 #define Node_Offset(n)
977 #define Node_Length(n)
978 #define Set_Node_Offset_Length(node,offset,len)
979 #define ProgLen(ri) ri->u.proglen
980 #define SetProgLen(ri,x) ri->u.proglen = x
981 #define Track_Code(code)
982 #else
983 #define ProgLen(ri) ri->u.offsets[0]
984 #define SetProgLen(ri,x) ri->u.offsets[0] = x
985 #define Set_Node_Offset_To_R(offset,byte) STMT_START {                  \
986         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
987                     __LINE__, (int)(offset), (int)(byte)));             \
988         if((offset) < 0) {                                              \
989             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
990                                          (int)(offset));                \
991         } else {                                                        \
992             RExC_offsets[2*(offset)-1] = (byte);                        \
993         }                                                               \
994 } STMT_END
995
996 #define Set_Node_Offset(node,byte)                                      \
997     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (byte)-RExC_start)
998 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
999
1000 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
1001         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
1002                 __LINE__, (int)(node), (int)(len)));                    \
1003         if((node) < 0) {                                                \
1004             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
1005                                          (int)(node));                  \
1006         } else {                                                        \
1007             RExC_offsets[2*(node)] = (len);                             \
1008         }                                                               \
1009 } STMT_END
1010
1011 #define Set_Node_Length(node,len) \
1012     Set_Node_Length_To_R(REGNODE_OFFSET(node), len)
1013 #define Set_Node_Cur_Length(node, start)                \
1014     Set_Node_Length(node, RExC_parse - start)
1015
1016 /* Get offsets and lengths */
1017 #define Node_Offset(n) (RExC_offsets[2*(REGNODE_OFFSET(n))-1])
1018 #define Node_Length(n) (RExC_offsets[2*(REGNODE_OFFSET(n))])
1019
1020 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
1021     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (offset));       \
1022     Set_Node_Length_To_R(REGNODE_OFFSET(node), (len));  \
1023 } STMT_END
1024
1025 #define Track_Code(code) STMT_START { code } STMT_END
1026 #endif
1027
1028 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
1029 #define EXPERIMENTAL_INPLACESCAN
1030 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
1031
1032 #ifdef DEBUGGING
1033 int
1034 Perl_re_printf(pTHX_ const char *fmt, ...)
1035 {
1036     va_list ap;
1037     int result;
1038     PerlIO *f= Perl_debug_log;
1039     PERL_ARGS_ASSERT_RE_PRINTF;
1040     va_start(ap, fmt);
1041     result = PerlIO_vprintf(f, fmt, ap);
1042     va_end(ap);
1043     return result;
1044 }
1045
1046 int
1047 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
1048 {
1049     va_list ap;
1050     int result;
1051     PerlIO *f= Perl_debug_log;
1052     PERL_ARGS_ASSERT_RE_INDENTF;
1053     va_start(ap, depth);
1054     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
1055     result = PerlIO_vprintf(f, fmt, ap);
1056     va_end(ap);
1057     return result;
1058 }
1059 #endif /* DEBUGGING */
1060
1061 #define DEBUG_RExC_seen()                                                   \
1062         DEBUG_OPTIMISE_MORE_r({                                             \
1063             Perl_re_printf( aTHX_ "RExC_seen: ");                           \
1064                                                                             \
1065             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
1066                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                \
1067                                                                             \
1068             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
1069                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");              \
1070                                                                             \
1071             if (RExC_seen & REG_GPOS_SEEN)                                  \
1072                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                    \
1073                                                                             \
1074             if (RExC_seen & REG_RECURSE_SEEN)                               \
1075                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                 \
1076                                                                             \
1077             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
1078                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");      \
1079                                                                             \
1080             if (RExC_seen & REG_VERBARG_SEEN)                               \
1081                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                 \
1082                                                                             \
1083             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
1084                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                \
1085                                                                             \
1086             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
1087                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");          \
1088                                                                             \
1089             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
1090                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");          \
1091                                                                             \
1092             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
1093                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");    \
1094                                                                             \
1095             Perl_re_printf( aTHX_ "\n");                                    \
1096         });
1097
1098 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
1099   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
1100
1101
1102 #ifdef DEBUGGING
1103 static void
1104 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
1105                                     const char *close_str)
1106 {
1107     if (!flags)
1108         return;
1109
1110     Perl_re_printf( aTHX_  "%s", open_str);
1111     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
1112     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
1113     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
1114     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
1115     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
1116     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
1117     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
1118     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
1119     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
1120     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
1121     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
1122     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1123     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1124     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1125     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1126     Perl_re_printf( aTHX_  "%s", close_str);
1127 }
1128
1129
1130 static void
1131 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1132                     U32 depth, int is_inf)
1133 {
1134     GET_RE_DEBUG_FLAGS_DECL;
1135
1136     DEBUG_OPTIMISE_MORE_r({
1137         if (!data)
1138             return;
1139         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1140             depth,
1141             where,
1142             (IV)data->pos_min,
1143             (IV)data->pos_delta,
1144             (UV)data->flags
1145         );
1146
1147         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1148
1149         Perl_re_printf( aTHX_
1150             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1151             (IV)data->whilem_c,
1152             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1153             is_inf ? "INF " : ""
1154         );
1155
1156         if (data->last_found) {
1157             int i;
1158             Perl_re_printf(aTHX_
1159                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1160                     SvPVX_const(data->last_found),
1161                     (IV)data->last_end,
1162                     (IV)data->last_start_min,
1163                     (IV)data->last_start_max
1164             );
1165
1166             for (i = 0; i < 2; i++) {
1167                 Perl_re_printf(aTHX_
1168                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1169                     data->cur_is_floating == i ? "*" : "",
1170                     i ? "Float" : "Fixed",
1171                     SvPVX_const(data->substrs[i].str),
1172                     (IV)data->substrs[i].min_offset,
1173                     (IV)data->substrs[i].max_offset
1174                 );
1175                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1176             }
1177         }
1178
1179         Perl_re_printf( aTHX_ "\n");
1180     });
1181 }
1182
1183
1184 static void
1185 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1186                 regnode *scan, U32 depth, U32 flags)
1187 {
1188     GET_RE_DEBUG_FLAGS_DECL;
1189
1190     DEBUG_OPTIMISE_r({
1191         regnode *Next;
1192
1193         if (!scan)
1194             return;
1195         Next = regnext(scan);
1196         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1197         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1198             depth,
1199             str,
1200             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1201             Next ? (REG_NODE_NUM(Next)) : 0 );
1202         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1203         Perl_re_printf( aTHX_  "\n");
1204    });
1205 }
1206
1207
1208 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1209                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1210
1211 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1212                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1213
1214 #else
1215 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1216 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1217 #endif
1218
1219
1220 /* =========================================================
1221  * BEGIN edit_distance stuff.
1222  *
1223  * This calculates how many single character changes of any type are needed to
1224  * transform a string into another one.  It is taken from version 3.1 of
1225  *
1226  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1227  */
1228
1229 /* Our unsorted dictionary linked list.   */
1230 /* Note we use UVs, not chars. */
1231
1232 struct dictionary{
1233   UV key;
1234   UV value;
1235   struct dictionary* next;
1236 };
1237 typedef struct dictionary item;
1238
1239
1240 PERL_STATIC_INLINE item*
1241 push(UV key, item* curr)
1242 {
1243     item* head;
1244     Newx(head, 1, item);
1245     head->key = key;
1246     head->value = 0;
1247     head->next = curr;
1248     return head;
1249 }
1250
1251
1252 PERL_STATIC_INLINE item*
1253 find(item* head, UV key)
1254 {
1255     item* iterator = head;
1256     while (iterator){
1257         if (iterator->key == key){
1258             return iterator;
1259         }
1260         iterator = iterator->next;
1261     }
1262
1263     return NULL;
1264 }
1265
1266 PERL_STATIC_INLINE item*
1267 uniquePush(item* head, UV key)
1268 {
1269     item* iterator = head;
1270
1271     while (iterator){
1272         if (iterator->key == key) {
1273             return head;
1274         }
1275         iterator = iterator->next;
1276     }
1277
1278     return push(key, head);
1279 }
1280
1281 PERL_STATIC_INLINE void
1282 dict_free(item* head)
1283 {
1284     item* iterator = head;
1285
1286     while (iterator) {
1287         item* temp = iterator;
1288         iterator = iterator->next;
1289         Safefree(temp);
1290     }
1291
1292     head = NULL;
1293 }
1294
1295 /* End of Dictionary Stuff */
1296
1297 /* All calculations/work are done here */
1298 STATIC int
1299 S_edit_distance(const UV* src,
1300                 const UV* tgt,
1301                 const STRLEN x,             /* length of src[] */
1302                 const STRLEN y,             /* length of tgt[] */
1303                 const SSize_t maxDistance
1304 )
1305 {
1306     item *head = NULL;
1307     UV swapCount, swapScore, targetCharCount, i, j;
1308     UV *scores;
1309     UV score_ceil = x + y;
1310
1311     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1312
1313     /* intialize matrix start values */
1314     Newx(scores, ( (x + 2) * (y + 2)), UV);
1315     scores[0] = score_ceil;
1316     scores[1 * (y + 2) + 0] = score_ceil;
1317     scores[0 * (y + 2) + 1] = score_ceil;
1318     scores[1 * (y + 2) + 1] = 0;
1319     head = uniquePush(uniquePush(head, src[0]), tgt[0]);
1320
1321     /* work loops    */
1322     /* i = src index */
1323     /* j = tgt index */
1324     for (i=1;i<=x;i++) {
1325         if (i < x)
1326             head = uniquePush(head, src[i]);
1327         scores[(i+1) * (y + 2) + 1] = i;
1328         scores[(i+1) * (y + 2) + 0] = score_ceil;
1329         swapCount = 0;
1330
1331         for (j=1;j<=y;j++) {
1332             if (i == 1) {
1333                 if(j < y)
1334                 head = uniquePush(head, tgt[j]);
1335                 scores[1 * (y + 2) + (j + 1)] = j;
1336                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1337             }
1338
1339             targetCharCount = find(head, tgt[j-1])->value;
1340             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1341
1342             if (src[i-1] != tgt[j-1]){
1343                 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));
1344             }
1345             else {
1346                 swapCount = j;
1347                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1348             }
1349         }
1350
1351         find(head, src[i-1])->value = i;
1352     }
1353
1354     {
1355         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1356         dict_free(head);
1357         Safefree(scores);
1358         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1359     }
1360 }
1361
1362 /* END of edit_distance() stuff
1363  * ========================================================= */
1364
1365 /* is c a control character for which we have a mnemonic? */
1366 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1367
1368 STATIC const char *
1369 S_cntrl_to_mnemonic(const U8 c)
1370 {
1371     /* Returns the mnemonic string that represents character 'c', if one
1372      * exists; NULL otherwise.  The only ones that exist for the purposes of
1373      * this routine are a few control characters */
1374
1375     switch (c) {
1376         case '\a':       return "\\a";
1377         case '\b':       return "\\b";
1378         case ESC_NATIVE: return "\\e";
1379         case '\f':       return "\\f";
1380         case '\n':       return "\\n";
1381         case '\r':       return "\\r";
1382         case '\t':       return "\\t";
1383     }
1384
1385     return NULL;
1386 }
1387
1388 /* Mark that we cannot extend a found fixed substring at this point.
1389    Update the longest found anchored substring or the longest found
1390    floating substrings if needed. */
1391
1392 STATIC void
1393 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1394                     SSize_t *minlenp, int is_inf)
1395 {
1396     const STRLEN l = CHR_SVLEN(data->last_found);
1397     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1398     const STRLEN old_l = CHR_SVLEN(longest_sv);
1399     GET_RE_DEBUG_FLAGS_DECL;
1400
1401     PERL_ARGS_ASSERT_SCAN_COMMIT;
1402
1403     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1404         const U8 i = data->cur_is_floating;
1405         SvSetMagicSV(longest_sv, data->last_found);
1406         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1407
1408         if (!i) /* fixed */
1409             data->substrs[0].max_offset = data->substrs[0].min_offset;
1410         else { /* float */
1411             data->substrs[1].max_offset = (l
1412                           ? data->last_start_max
1413                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1414                                          ? SSize_t_MAX
1415                                          : data->pos_min + data->pos_delta));
1416             if (is_inf
1417                  || (STRLEN)data->substrs[1].max_offset > (STRLEN)SSize_t_MAX)
1418                 data->substrs[1].max_offset = SSize_t_MAX;
1419         }
1420
1421         if (data->flags & SF_BEFORE_EOL)
1422             data->substrs[i].flags |= (data->flags & SF_BEFORE_EOL);
1423         else
1424             data->substrs[i].flags &= ~SF_BEFORE_EOL;
1425         data->substrs[i].minlenp = minlenp;
1426         data->substrs[i].lookbehind = 0;
1427     }
1428
1429     SvCUR_set(data->last_found, 0);
1430     {
1431         SV * const sv = data->last_found;
1432         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1433             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1434             if (mg)
1435                 mg->mg_len = 0;
1436         }
1437     }
1438     data->last_end = -1;
1439     data->flags &= ~SF_BEFORE_EOL;
1440     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1441 }
1442
1443 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1444  * list that describes which code points it matches */
1445
1446 STATIC void
1447 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1448 {
1449     /* Set the SSC 'ssc' to match an empty string or any code point */
1450
1451     PERL_ARGS_ASSERT_SSC_ANYTHING;
1452
1453     assert(is_ANYOF_SYNTHETIC(ssc));
1454
1455     /* mortalize so won't leak */
1456     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1457     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1458 }
1459
1460 STATIC int
1461 S_ssc_is_anything(const regnode_ssc *ssc)
1462 {
1463     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1464      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1465      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1466      * in any way, so there's no point in using it */
1467
1468     UV start, end;
1469     bool ret;
1470
1471     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1472
1473     assert(is_ANYOF_SYNTHETIC(ssc));
1474
1475     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1476         return FALSE;
1477     }
1478
1479     /* See if the list consists solely of the range 0 - Infinity */
1480     invlist_iterinit(ssc->invlist);
1481     ret = invlist_iternext(ssc->invlist, &start, &end)
1482           && start == 0
1483           && end == UV_MAX;
1484
1485     invlist_iterfinish(ssc->invlist);
1486
1487     if (ret) {
1488         return TRUE;
1489     }
1490
1491     /* If e.g., both \w and \W are set, matches everything */
1492     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1493         int i;
1494         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1495             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1496                 return TRUE;
1497             }
1498         }
1499     }
1500
1501     return FALSE;
1502 }
1503
1504 STATIC void
1505 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1506 {
1507     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1508      * string, any code point, or any posix class under locale */
1509
1510     PERL_ARGS_ASSERT_SSC_INIT;
1511
1512     Zero(ssc, 1, regnode_ssc);
1513     set_ANYOF_SYNTHETIC(ssc);
1514     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1515     ssc_anything(ssc);
1516
1517     /* If any portion of the regex is to operate under locale rules that aren't
1518      * fully known at compile time, initialization includes it.  The reason
1519      * this isn't done for all regexes is that the optimizer was written under
1520      * the assumption that locale was all-or-nothing.  Given the complexity and
1521      * lack of documentation in the optimizer, and that there are inadequate
1522      * test cases for locale, many parts of it may not work properly, it is
1523      * safest to avoid locale unless necessary. */
1524     if (RExC_contains_locale) {
1525         ANYOF_POSIXL_SETALL(ssc);
1526     }
1527     else {
1528         ANYOF_POSIXL_ZERO(ssc);
1529     }
1530 }
1531
1532 STATIC int
1533 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1534                         const regnode_ssc *ssc)
1535 {
1536     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1537      * to the list of code points matched, and locale posix classes; hence does
1538      * not check its flags) */
1539
1540     UV start, end;
1541     bool ret;
1542
1543     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1544
1545     assert(is_ANYOF_SYNTHETIC(ssc));
1546
1547     invlist_iterinit(ssc->invlist);
1548     ret = invlist_iternext(ssc->invlist, &start, &end)
1549           && start == 0
1550           && end == UV_MAX;
1551
1552     invlist_iterfinish(ssc->invlist);
1553
1554     if (! ret) {
1555         return FALSE;
1556     }
1557
1558     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1559         return FALSE;
1560     }
1561
1562     return TRUE;
1563 }
1564
1565 #define INVLIST_INDEX 0
1566 #define ONLY_LOCALE_MATCHES_INDEX 1
1567 #define DEFERRED_USER_DEFINED_INDEX 2
1568
1569 STATIC SV*
1570 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1571                                const regnode_charclass* const node)
1572 {
1573     /* Returns a mortal inversion list defining which code points are matched
1574      * by 'node', which is of type ANYOF.  Handles complementing the result if
1575      * appropriate.  If some code points aren't knowable at this time, the
1576      * returned list must, and will, contain every code point that is a
1577      * possibility. */
1578
1579     dVAR;
1580     SV* invlist = NULL;
1581     SV* only_utf8_locale_invlist = NULL;
1582     unsigned int i;
1583     const U32 n = ARG(node);
1584     bool new_node_has_latin1 = FALSE;
1585     const U8 flags = OP(node) == ANYOFHb ? 0 : ANYOF_FLAGS(node);
1586
1587     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1588
1589     /* Look at the data structure created by S_set_ANYOF_arg() */
1590     if (n != ANYOF_ONLY_HAS_BITMAP) {
1591         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1592         AV * const av = MUTABLE_AV(SvRV(rv));
1593         SV **const ary = AvARRAY(av);
1594         assert(RExC_rxi->data->what[n] == 's');
1595
1596         if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
1597
1598             /* Here there are things that won't be known until runtime -- we
1599              * have to assume it could be anything */
1600             invlist = sv_2mortal(_new_invlist(1));
1601             return _add_range_to_invlist(invlist, 0, UV_MAX);
1602         }
1603         else if (ary[INVLIST_INDEX]) {
1604
1605             /* Use the node's inversion list */
1606             invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL));
1607         }
1608
1609         /* Get the code points valid only under UTF-8 locales */
1610         if (   (flags & ANYOFL_FOLD)
1611             &&  av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX)
1612         {
1613             only_utf8_locale_invlist = ary[ONLY_LOCALE_MATCHES_INDEX];
1614         }
1615     }
1616
1617     if (! invlist) {
1618         invlist = sv_2mortal(_new_invlist(0));
1619     }
1620
1621     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1622      * code points, and an inversion list for the others, but if there are code
1623      * points that should match only conditionally on the target string being
1624      * UTF-8, those are placed in the inversion list, and not the bitmap.
1625      * Since there are circumstances under which they could match, they are
1626      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1627      * to exclude them here, so that when we invert below, the end result
1628      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1629      * have to do this here before we add the unconditionally matched code
1630      * points */
1631     if (flags & ANYOF_INVERT) {
1632         _invlist_intersection_complement_2nd(invlist,
1633                                              PL_UpperLatin1,
1634                                              &invlist);
1635     }
1636
1637     /* Add in the points from the bit map */
1638     if (OP(node) != ANYOFH && OP(node) != ANYOFHb) {
1639         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1640             if (ANYOF_BITMAP_TEST(node, i)) {
1641                 unsigned int start = i++;
1642
1643                 for (;    i < NUM_ANYOF_CODE_POINTS
1644                        && ANYOF_BITMAP_TEST(node, i); ++i)
1645                 {
1646                     /* empty */
1647                 }
1648                 invlist = _add_range_to_invlist(invlist, start, i-1);
1649                 new_node_has_latin1 = TRUE;
1650             }
1651         }
1652     }
1653
1654     /* If this can match all upper Latin1 code points, have to add them
1655      * as well.  But don't add them if inverting, as when that gets done below,
1656      * it would exclude all these characters, including the ones it shouldn't
1657      * that were added just above */
1658     if (! (flags & ANYOF_INVERT) && OP(node) == ANYOFD
1659         && (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1660     {
1661         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1662     }
1663
1664     /* Similarly for these */
1665     if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1666         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1667     }
1668
1669     if (flags & ANYOF_INVERT) {
1670         _invlist_invert(invlist);
1671     }
1672     else if (flags & ANYOFL_FOLD) {
1673         if (new_node_has_latin1) {
1674
1675             /* Under /li, any 0-255 could fold to any other 0-255, depending on
1676              * the locale.  We can skip this if there are no 0-255 at all. */
1677             _invlist_union(invlist, PL_Latin1, &invlist);
1678
1679             invlist = add_cp_to_invlist(invlist, LATIN_SMALL_LETTER_DOTLESS_I);
1680             invlist = add_cp_to_invlist(invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
1681         }
1682         else {
1683             if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) {
1684                 invlist = add_cp_to_invlist(invlist, 'I');
1685             }
1686             if (_invlist_contains_cp(invlist,
1687                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE))
1688             {
1689                 invlist = add_cp_to_invlist(invlist, 'i');
1690             }
1691         }
1692     }
1693
1694     /* Similarly add the UTF-8 locale possible matches.  These have to be
1695      * deferred until after the non-UTF-8 locale ones are taken care of just
1696      * above, or it leads to wrong results under ANYOF_INVERT */
1697     if (only_utf8_locale_invlist) {
1698         _invlist_union_maybe_complement_2nd(invlist,
1699                                             only_utf8_locale_invlist,
1700                                             flags & ANYOF_INVERT,
1701                                             &invlist);
1702     }
1703
1704     return invlist;
1705 }
1706
1707 /* These two functions currently do the exact same thing */
1708 #define ssc_init_zero           ssc_init
1709
1710 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1711 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1712
1713 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1714  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1715  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1716
1717 STATIC void
1718 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1719                 const regnode_charclass *and_with)
1720 {
1721     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1722      * another SSC or a regular ANYOF class.  Can create false positives. */
1723
1724     SV* anded_cp_list;
1725     U8  and_with_flags = (OP(and_with) == ANYOFHb) ? 0 : ANYOF_FLAGS(and_with);
1726     U8  anded_flags;
1727
1728     PERL_ARGS_ASSERT_SSC_AND;
1729
1730     assert(is_ANYOF_SYNTHETIC(ssc));
1731
1732     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1733      * the code point inversion list and just the relevant flags */
1734     if (is_ANYOF_SYNTHETIC(and_with)) {
1735         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1736         anded_flags = and_with_flags;
1737
1738         /* XXX This is a kludge around what appears to be deficiencies in the
1739          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1740          * there are paths through the optimizer where it doesn't get weeded
1741          * out when it should.  And if we don't make some extra provision for
1742          * it like the code just below, it doesn't get added when it should.
1743          * This solution is to add it only when AND'ing, which is here, and
1744          * only when what is being AND'ed is the pristine, original node
1745          * matching anything.  Thus it is like adding it to ssc_anything() but
1746          * only when the result is to be AND'ed.  Probably the same solution
1747          * could be adopted for the same problem we have with /l matching,
1748          * which is solved differently in S_ssc_init(), and that would lead to
1749          * fewer false positives than that solution has.  But if this solution
1750          * creates bugs, the consequences are only that a warning isn't raised
1751          * that should be; while the consequences for having /l bugs is
1752          * incorrect matches */
1753         if (ssc_is_anything((regnode_ssc *)and_with)) {
1754             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1755         }
1756     }
1757     else {
1758         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1759         if (OP(and_with) == ANYOFD) {
1760             anded_flags = and_with_flags & ANYOF_COMMON_FLAGS;
1761         }
1762         else {
1763             anded_flags = and_with_flags
1764             &( ANYOF_COMMON_FLAGS
1765               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1766               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1767             if (ANYOFL_UTF8_LOCALE_REQD(and_with_flags)) {
1768                 anded_flags &=
1769                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1770             }
1771         }
1772     }
1773
1774     ANYOF_FLAGS(ssc) &= anded_flags;
1775
1776     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1777      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1778      * 'and_with' may be inverted.  When not inverted, we have the situation of
1779      * computing:
1780      *  (C1 | P1) & (C2 | P2)
1781      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1782      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1783      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1784      *                    <=  ((C1 & C2) | P1 | P2)
1785      * Alternatively, the last few steps could be:
1786      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1787      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1788      *                    <=  (C1 | C2 | (P1 & P2))
1789      * We favor the second approach if either P1 or P2 is non-empty.  This is
1790      * because these components are a barrier to doing optimizations, as what
1791      * they match cannot be known until the moment of matching as they are
1792      * dependent on the current locale, 'AND"ing them likely will reduce or
1793      * eliminate them.
1794      * But we can do better if we know that C1,P1 are in their initial state (a
1795      * frequent occurrence), each matching everything:
1796      *  (<everything>) & (C2 | P2) =  C2 | P2
1797      * Similarly, if C2,P2 are in their initial state (again a frequent
1798      * occurrence), the result is a no-op
1799      *  (C1 | P1) & (<everything>) =  C1 | P1
1800      *
1801      * Inverted, we have
1802      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1803      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1804      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1805      * */
1806
1807     if ((and_with_flags & ANYOF_INVERT)
1808         && ! is_ANYOF_SYNTHETIC(and_with))
1809     {
1810         unsigned int i;
1811
1812         ssc_intersection(ssc,
1813                          anded_cp_list,
1814                          FALSE /* Has already been inverted */
1815                          );
1816
1817         /* If either P1 or P2 is empty, the intersection will be also; can skip
1818          * the loop */
1819         if (! (and_with_flags & ANYOF_MATCHES_POSIXL)) {
1820             ANYOF_POSIXL_ZERO(ssc);
1821         }
1822         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1823
1824             /* Note that the Posix class component P from 'and_with' actually
1825              * looks like:
1826              *      P = Pa | Pb | ... | Pn
1827              * where each component is one posix class, such as in [\w\s].
1828              * Thus
1829              *      ~P = ~(Pa | Pb | ... | Pn)
1830              *         = ~Pa & ~Pb & ... & ~Pn
1831              *        <= ~Pa | ~Pb | ... | ~Pn
1832              * The last is something we can easily calculate, but unfortunately
1833              * is likely to have many false positives.  We could do better
1834              * in some (but certainly not all) instances if two classes in
1835              * P have known relationships.  For example
1836              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1837              * So
1838              *      :lower: & :print: = :lower:
1839              * And similarly for classes that must be disjoint.  For example,
1840              * since \s and \w can have no elements in common based on rules in
1841              * the POSIX standard,
1842              *      \w & ^\S = nothing
1843              * Unfortunately, some vendor locales do not meet the Posix
1844              * standard, in particular almost everything by Microsoft.
1845              * The loop below just changes e.g., \w into \W and vice versa */
1846
1847             regnode_charclass_posixl temp;
1848             int add = 1;    /* To calculate the index of the complement */
1849
1850             Zero(&temp, 1, regnode_charclass_posixl);
1851             ANYOF_POSIXL_ZERO(&temp);
1852             for (i = 0; i < ANYOF_MAX; i++) {
1853                 assert(i % 2 != 0
1854                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1855                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1856
1857                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1858                     ANYOF_POSIXL_SET(&temp, i + add);
1859                 }
1860                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1861             }
1862             ANYOF_POSIXL_AND(&temp, ssc);
1863
1864         } /* else ssc already has no posixes */
1865     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1866          in its initial state */
1867     else if (! is_ANYOF_SYNTHETIC(and_with)
1868              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1869     {
1870         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1871          * copy it over 'ssc' */
1872         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1873             if (is_ANYOF_SYNTHETIC(and_with)) {
1874                 StructCopy(and_with, ssc, regnode_ssc);
1875             }
1876             else {
1877                 ssc->invlist = anded_cp_list;
1878                 ANYOF_POSIXL_ZERO(ssc);
1879                 if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1880                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1881                 }
1882             }
1883         }
1884         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1885                  || (and_with_flags & ANYOF_MATCHES_POSIXL))
1886         {
1887             /* One or the other of P1, P2 is non-empty. */
1888             if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1889                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1890             }
1891             ssc_union(ssc, anded_cp_list, FALSE);
1892         }
1893         else { /* P1 = P2 = empty */
1894             ssc_intersection(ssc, anded_cp_list, FALSE);
1895         }
1896     }
1897 }
1898
1899 STATIC void
1900 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1901                const regnode_charclass *or_with)
1902 {
1903     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1904      * another SSC or a regular ANYOF class.  Can create false positives if
1905      * 'or_with' is to be inverted. */
1906
1907     SV* ored_cp_list;
1908     U8 ored_flags;
1909     U8  or_with_flags = (OP(or_with) == ANYOFHb) ? 0 : ANYOF_FLAGS(or_with);
1910
1911     PERL_ARGS_ASSERT_SSC_OR;
1912
1913     assert(is_ANYOF_SYNTHETIC(ssc));
1914
1915     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1916      * the code point inversion list and just the relevant flags */
1917     if (is_ANYOF_SYNTHETIC(or_with)) {
1918         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1919         ored_flags = or_with_flags;
1920     }
1921     else {
1922         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1923         ored_flags = or_with_flags & ANYOF_COMMON_FLAGS;
1924         if (OP(or_with) != ANYOFD) {
1925             ored_flags
1926             |= or_with_flags
1927              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1928                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1929             if (ANYOFL_UTF8_LOCALE_REQD(or_with_flags)) {
1930                 ored_flags |=
1931                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1932             }
1933         }
1934     }
1935
1936     ANYOF_FLAGS(ssc) |= ored_flags;
1937
1938     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1939      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1940      * 'or_with' may be inverted.  When not inverted, we have the simple
1941      * situation of computing:
1942      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1943      * If P1|P2 yields a situation with both a class and its complement are
1944      * set, like having both \w and \W, this matches all code points, and we
1945      * can delete these from the P component of the ssc going forward.  XXX We
1946      * might be able to delete all the P components, but I (khw) am not certain
1947      * about this, and it is better to be safe.
1948      *
1949      * Inverted, we have
1950      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1951      *                         <=  (C1 | P1) | ~C2
1952      *                         <=  (C1 | ~C2) | P1
1953      * (which results in actually simpler code than the non-inverted case)
1954      * */
1955
1956     if ((or_with_flags & ANYOF_INVERT)
1957         && ! is_ANYOF_SYNTHETIC(or_with))
1958     {
1959         /* We ignore P2, leaving P1 going forward */
1960     }   /* else  Not inverted */
1961     else if (or_with_flags & ANYOF_MATCHES_POSIXL) {
1962         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1963         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1964             unsigned int i;
1965             for (i = 0; i < ANYOF_MAX; i += 2) {
1966                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1967                 {
1968                     ssc_match_all_cp(ssc);
1969                     ANYOF_POSIXL_CLEAR(ssc, i);
1970                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1971                 }
1972             }
1973         }
1974     }
1975
1976     ssc_union(ssc,
1977               ored_cp_list,
1978               FALSE /* Already has been inverted */
1979               );
1980 }
1981
1982 PERL_STATIC_INLINE void
1983 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1984 {
1985     PERL_ARGS_ASSERT_SSC_UNION;
1986
1987     assert(is_ANYOF_SYNTHETIC(ssc));
1988
1989     _invlist_union_maybe_complement_2nd(ssc->invlist,
1990                                         invlist,
1991                                         invert2nd,
1992                                         &ssc->invlist);
1993 }
1994
1995 PERL_STATIC_INLINE void
1996 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1997                          SV* const invlist,
1998                          const bool invert2nd)
1999 {
2000     PERL_ARGS_ASSERT_SSC_INTERSECTION;
2001
2002     assert(is_ANYOF_SYNTHETIC(ssc));
2003
2004     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
2005                                                invlist,
2006                                                invert2nd,
2007                                                &ssc->invlist);
2008 }
2009
2010 PERL_STATIC_INLINE void
2011 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
2012 {
2013     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
2014
2015     assert(is_ANYOF_SYNTHETIC(ssc));
2016
2017     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
2018 }
2019
2020 PERL_STATIC_INLINE void
2021 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
2022 {
2023     /* AND just the single code point 'cp' into the SSC 'ssc' */
2024
2025     SV* cp_list = _new_invlist(2);
2026
2027     PERL_ARGS_ASSERT_SSC_CP_AND;
2028
2029     assert(is_ANYOF_SYNTHETIC(ssc));
2030
2031     cp_list = add_cp_to_invlist(cp_list, cp);
2032     ssc_intersection(ssc, cp_list,
2033                      FALSE /* Not inverted */
2034                      );
2035     SvREFCNT_dec_NN(cp_list);
2036 }
2037
2038 PERL_STATIC_INLINE void
2039 S_ssc_clear_locale(regnode_ssc *ssc)
2040 {
2041     /* Set the SSC 'ssc' to not match any locale things */
2042     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
2043
2044     assert(is_ANYOF_SYNTHETIC(ssc));
2045
2046     ANYOF_POSIXL_ZERO(ssc);
2047     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
2048 }
2049
2050 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
2051
2052 STATIC bool
2053 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
2054 {
2055     /* The synthetic start class is used to hopefully quickly winnow down
2056      * places where a pattern could start a match in the target string.  If it
2057      * doesn't really narrow things down that much, there isn't much point to
2058      * having the overhead of using it.  This function uses some very crude
2059      * heuristics to decide if to use the ssc or not.
2060      *
2061      * It returns TRUE if 'ssc' rules out more than half what it considers to
2062      * be the "likely" possible matches, but of course it doesn't know what the
2063      * actual things being matched are going to be; these are only guesses
2064      *
2065      * For /l matches, it assumes that the only likely matches are going to be
2066      *      in the 0-255 range, uniformly distributed, so half of that is 127
2067      * For /a and /d matches, it assumes that the likely matches will be just
2068      *      the ASCII range, so half of that is 63
2069      * For /u and there isn't anything matching above the Latin1 range, it
2070      *      assumes that that is the only range likely to be matched, and uses
2071      *      half that as the cut-off: 127.  If anything matches above Latin1,
2072      *      it assumes that all of Unicode could match (uniformly), except for
2073      *      non-Unicode code points and things in the General Category "Other"
2074      *      (unassigned, private use, surrogates, controls and formats).  This
2075      *      is a much large number. */
2076
2077     U32 count = 0;      /* Running total of number of code points matched by
2078                            'ssc' */
2079     UV start, end;      /* Start and end points of current range in inversion
2080                            XXX outdated.  UTF-8 locales are common, what about invert? list */
2081     const U32 max_code_points = (LOC)
2082                                 ?  256
2083                                 : ((  ! UNI_SEMANTICS
2084                                     ||  invlist_highest(ssc->invlist) < 256)
2085                                   ? 128
2086                                   : NON_OTHER_COUNT);
2087     const U32 max_match = max_code_points / 2;
2088
2089     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
2090
2091     invlist_iterinit(ssc->invlist);
2092     while (invlist_iternext(ssc->invlist, &start, &end)) {
2093         if (start >= max_code_points) {
2094             break;
2095         }
2096         end = MIN(end, max_code_points - 1);
2097         count += end - start + 1;
2098         if (count >= max_match) {
2099             invlist_iterfinish(ssc->invlist);
2100             return FALSE;
2101         }
2102     }
2103
2104     return TRUE;
2105 }
2106
2107
2108 STATIC void
2109 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
2110 {
2111     /* The inversion list in the SSC is marked mortal; now we need a more
2112      * permanent copy, which is stored the same way that is done in a regular
2113      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
2114      * map */
2115
2116     SV* invlist = invlist_clone(ssc->invlist, NULL);
2117
2118     PERL_ARGS_ASSERT_SSC_FINALIZE;
2119
2120     assert(is_ANYOF_SYNTHETIC(ssc));
2121
2122     /* The code in this file assumes that all but these flags aren't relevant
2123      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
2124      * by the time we reach here */
2125     assert(! (ANYOF_FLAGS(ssc)
2126         & ~( ANYOF_COMMON_FLAGS
2127             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2128             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
2129
2130     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
2131
2132     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL);
2133
2134     /* Make sure is clone-safe */
2135     ssc->invlist = NULL;
2136
2137     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2138         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
2139         OP(ssc) = ANYOFPOSIXL;
2140     }
2141     else if (RExC_contains_locale) {
2142         OP(ssc) = ANYOFL;
2143     }
2144
2145     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2146 }
2147
2148 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2149 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2150 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2151 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2152                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2153                                : 0 )
2154
2155
2156 #ifdef DEBUGGING
2157 /*
2158    dump_trie(trie,widecharmap,revcharmap)
2159    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2160    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2161
2162    These routines dump out a trie in a somewhat readable format.
2163    The _interim_ variants are used for debugging the interim
2164    tables that are used to generate the final compressed
2165    representation which is what dump_trie expects.
2166
2167    Part of the reason for their existence is to provide a form
2168    of documentation as to how the different representations function.
2169
2170 */
2171
2172 /*
2173   Dumps the final compressed table form of the trie to Perl_debug_log.
2174   Used for debugging make_trie().
2175 */
2176
2177 STATIC void
2178 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2179             AV *revcharmap, U32 depth)
2180 {
2181     U32 state;
2182     SV *sv=sv_newmortal();
2183     int colwidth= widecharmap ? 6 : 4;
2184     U16 word;
2185     GET_RE_DEBUG_FLAGS_DECL;
2186
2187     PERL_ARGS_ASSERT_DUMP_TRIE;
2188
2189     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2190         depth+1, "Match","Base","Ofs" );
2191
2192     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2193         SV ** const tmp = av_fetch( revcharmap, state, 0);
2194         if ( tmp ) {
2195             Perl_re_printf( aTHX_  "%*s",
2196                 colwidth,
2197                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2198                             PL_colors[0], PL_colors[1],
2199                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2200                             PERL_PV_ESCAPE_FIRSTCHAR
2201                 )
2202             );
2203         }
2204     }
2205     Perl_re_printf( aTHX_  "\n");
2206     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2207
2208     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2209         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2210     Perl_re_printf( aTHX_  "\n");
2211
2212     for( state = 1 ; state < trie->statecount ; state++ ) {
2213         const U32 base = trie->states[ state ].trans.base;
2214
2215         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2216
2217         if ( trie->states[ state ].wordnum ) {
2218             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2219         } else {
2220             Perl_re_printf( aTHX_  "%6s", "" );
2221         }
2222
2223         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2224
2225         if ( base ) {
2226             U32 ofs = 0;
2227
2228             while( ( base + ofs  < trie->uniquecharcount ) ||
2229                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2230                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2231                                                                     != state))
2232                     ofs++;
2233
2234             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2235
2236             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2237                 if ( ( base + ofs >= trie->uniquecharcount )
2238                         && ( base + ofs - trie->uniquecharcount
2239                                                         < trie->lasttrans )
2240                         && trie->trans[ base + ofs
2241                                     - trie->uniquecharcount ].check == state )
2242                 {
2243                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2244                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2245                    );
2246                 } else {
2247                     Perl_re_printf( aTHX_  "%*s", colwidth,"   ." );
2248                 }
2249             }
2250
2251             Perl_re_printf( aTHX_  "]");
2252
2253         }
2254         Perl_re_printf( aTHX_  "\n" );
2255     }
2256     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2257                                 depth);
2258     for (word=1; word <= trie->wordcount; word++) {
2259         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2260             (int)word, (int)(trie->wordinfo[word].prev),
2261             (int)(trie->wordinfo[word].len));
2262     }
2263     Perl_re_printf( aTHX_  "\n" );
2264 }
2265 /*
2266   Dumps a fully constructed but uncompressed trie in list form.
2267   List tries normally only are used for construction when the number of
2268   possible chars (trie->uniquecharcount) is very high.
2269   Used for debugging make_trie().
2270 */
2271 STATIC void
2272 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2273                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2274                          U32 depth)
2275 {
2276     U32 state;
2277     SV *sv=sv_newmortal();
2278     int colwidth= widecharmap ? 6 : 4;
2279     GET_RE_DEBUG_FLAGS_DECL;
2280
2281     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2282
2283     /* print out the table precompression.  */
2284     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2285             depth+1 );
2286     Perl_re_indentf( aTHX_  "%s",
2287             depth+1, "------:-----+-----------------\n" );
2288
2289     for( state=1 ; state < next_alloc ; state ++ ) {
2290         U16 charid;
2291
2292         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2293             depth+1, (UV)state  );
2294         if ( ! trie->states[ state ].wordnum ) {
2295             Perl_re_printf( aTHX_  "%5s| ","");
2296         } else {
2297             Perl_re_printf( aTHX_  "W%4x| ",
2298                 trie->states[ state ].wordnum
2299             );
2300         }
2301         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2302             SV ** const tmp = av_fetch( revcharmap,
2303                                         TRIE_LIST_ITEM(state, charid).forid, 0);
2304             if ( tmp ) {
2305                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2306                     colwidth,
2307                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2308                               colwidth,
2309                               PL_colors[0], PL_colors[1],
2310                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2311                               | PERL_PV_ESCAPE_FIRSTCHAR
2312                     ) ,
2313                     TRIE_LIST_ITEM(state, charid).forid,
2314                     (UV)TRIE_LIST_ITEM(state, charid).newstate
2315                 );
2316                 if (!(charid % 10))
2317                     Perl_re_printf( aTHX_  "\n%*s| ",
2318                         (int)((depth * 2) + 14), "");
2319             }
2320         }
2321         Perl_re_printf( aTHX_  "\n");
2322     }
2323 }
2324
2325 /*
2326   Dumps a fully constructed but uncompressed trie in table form.
2327   This is the normal DFA style state transition table, with a few
2328   twists to facilitate compression later.
2329   Used for debugging make_trie().
2330 */
2331 STATIC void
2332 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2333                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2334                           U32 depth)
2335 {
2336     U32 state;
2337     U16 charid;
2338     SV *sv=sv_newmortal();
2339     int colwidth= widecharmap ? 6 : 4;
2340     GET_RE_DEBUG_FLAGS_DECL;
2341
2342     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2343
2344     /*
2345        print out the table precompression so that we can do a visual check
2346        that they are identical.
2347      */
2348
2349     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2350
2351     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2352         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2353         if ( tmp ) {
2354             Perl_re_printf( aTHX_  "%*s",
2355                 colwidth,
2356                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2357                             PL_colors[0], PL_colors[1],
2358                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2359                             PERL_PV_ESCAPE_FIRSTCHAR
2360                 )
2361             );
2362         }
2363     }
2364
2365     Perl_re_printf( aTHX_ "\n");
2366     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2367
2368     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2369         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2370     }
2371
2372     Perl_re_printf( aTHX_  "\n" );
2373
2374     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2375
2376         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2377             depth+1,
2378             (UV)TRIE_NODENUM( state ) );
2379
2380         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2381             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2382             if (v)
2383                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2384             else
2385                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2386         }
2387         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2388             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2389                                             (UV)trie->trans[ state ].check );
2390         } else {
2391             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2392                                             (UV)trie->trans[ state ].check,
2393             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2394         }
2395     }
2396 }
2397
2398 #endif
2399
2400
2401 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2402   startbranch: the first branch in the whole branch sequence
2403   first      : start branch of sequence of branch-exact nodes.
2404                May be the same as startbranch
2405   last       : Thing following the last branch.
2406                May be the same as tail.
2407   tail       : item following the branch sequence
2408   count      : words in the sequence
2409   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2410   depth      : indent depth
2411
2412 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2413
2414 A trie is an N'ary tree where the branches are determined by digital
2415 decomposition of the key. IE, at the root node you look up the 1st character and
2416 follow that branch repeat until you find the end of the branches. Nodes can be
2417 marked as "accepting" meaning they represent a complete word. Eg:
2418
2419   /he|she|his|hers/
2420
2421 would convert into the following structure. Numbers represent states, letters
2422 following numbers represent valid transitions on the letter from that state, if
2423 the number is in square brackets it represents an accepting state, otherwise it
2424 will be in parenthesis.
2425
2426       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2427       |    |
2428       |   (2)
2429       |    |
2430      (1)   +-i->(6)-+-s->[7]
2431       |
2432       +-s->(3)-+-h->(4)-+-e->[5]
2433
2434       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2435
2436 This shows that when matching against the string 'hers' we will begin at state 1
2437 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2438 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2439 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2440 single traverse. We store a mapping from accepting to state to which word was
2441 matched, and then when we have multiple possibilities we try to complete the
2442 rest of the regex in the order in which they occurred in the alternation.
2443
2444 The only prior NFA like behaviour that would be changed by the TRIE support is
2445 the silent ignoring of duplicate alternations which are of the form:
2446
2447  / (DUPE|DUPE) X? (?{ ... }) Y /x
2448
2449 Thus EVAL blocks following a trie may be called a different number of times with
2450 and without the optimisation. With the optimisations dupes will be silently
2451 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2452 the following demonstrates:
2453
2454  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2455
2456 which prints out 'word' three times, but
2457
2458  'words'=~/(word|word|word)(?{ print $1 })S/
2459
2460 which doesnt print it out at all. This is due to other optimisations kicking in.
2461
2462 Example of what happens on a structural level:
2463
2464 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2465
2466    1: CURLYM[1] {1,32767}(18)
2467    5:   BRANCH(8)
2468    6:     EXACT <ac>(16)
2469    8:   BRANCH(11)
2470    9:     EXACT <ad>(16)
2471   11:   BRANCH(14)
2472   12:     EXACT <ab>(16)
2473   16:   SUCCEED(0)
2474   17:   NOTHING(18)
2475   18: END(0)
2476
2477 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2478 and should turn into:
2479
2480    1: CURLYM[1] {1,32767}(18)
2481    5:   TRIE(16)
2482         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2483           <ac>
2484           <ad>
2485           <ab>
2486   16:   SUCCEED(0)
2487   17:   NOTHING(18)
2488   18: END(0)
2489
2490 Cases where tail != last would be like /(?foo|bar)baz/:
2491
2492    1: BRANCH(4)
2493    2:   EXACT <foo>(8)
2494    4: BRANCH(7)
2495    5:   EXACT <bar>(8)
2496    7: TAIL(8)
2497    8: EXACT <baz>(10)
2498   10: END(0)
2499
2500 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2501 and would end up looking like:
2502
2503     1: TRIE(8)
2504       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2505         <foo>
2506         <bar>
2507    7: TAIL(8)
2508    8: EXACT <baz>(10)
2509   10: END(0)
2510
2511     d = uvchr_to_utf8_flags(d, uv, 0);
2512
2513 is the recommended Unicode-aware way of saying
2514
2515     *(d++) = uv;
2516 */
2517
2518 #define TRIE_STORE_REVCHAR(val)                                            \
2519     STMT_START {                                                           \
2520         if (UTF) {                                                         \
2521             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2522             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2523             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2524             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2525             SvPOK_on(zlopp);                                               \
2526             SvUTF8_on(zlopp);                                              \
2527             av_push(revcharmap, zlopp);                                    \
2528         } else {                                                           \
2529             char ooooff = (char)val;                                           \
2530             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2531         }                                                                  \
2532         } STMT_END
2533
2534 /* This gets the next character from the input, folding it if not already
2535  * folded. */
2536 #define TRIE_READ_CHAR STMT_START {                                           \
2537     wordlen++;                                                                \
2538     if ( UTF ) {                                                              \
2539         /* if it is UTF then it is either already folded, or does not need    \
2540          * folding */                                                         \
2541         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2542     }                                                                         \
2543     else if (folder == PL_fold_latin1) {                                      \
2544         /* This folder implies Unicode rules, which in the range expressible  \
2545          *  by not UTF is the lower case, with the two exceptions, one of     \
2546          *  which should have been taken care of before calling this */       \
2547         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2548         uvc = toLOWER_L1(*uc);                                                \
2549         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2550         len = 1;                                                              \
2551     } else {                                                                  \
2552         /* raw data, will be folded later if needed */                        \
2553         uvc = (U32)*uc;                                                       \
2554         len = 1;                                                              \
2555     }                                                                         \
2556 } STMT_END
2557
2558
2559
2560 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2561     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2562         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2563         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2564         TRIE_LIST_LEN( state ) = ging;                          \
2565     }                                                           \
2566     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2567     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2568     TRIE_LIST_CUR( state )++;                                   \
2569 } STMT_END
2570
2571 #define TRIE_LIST_NEW(state) STMT_START {                       \
2572     Newx( trie->states[ state ].trans.list,                     \
2573         4, reg_trie_trans_le );                                 \
2574      TRIE_LIST_CUR( state ) = 1;                                \
2575      TRIE_LIST_LEN( state ) = 4;                                \
2576 } STMT_END
2577
2578 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2579     U16 dupe= trie->states[ state ].wordnum;                    \
2580     regnode * const noper_next = regnext( noper );              \
2581                                                                 \
2582     DEBUG_r({                                                   \
2583         /* store the word for dumping */                        \
2584         SV* tmp;                                                \
2585         if (OP(noper) != NOTHING)                               \
2586             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2587         else                                                    \
2588             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2589         av_push( trie_words, tmp );                             \
2590     });                                                         \
2591                                                                 \
2592     curword++;                                                  \
2593     trie->wordinfo[curword].prev   = 0;                         \
2594     trie->wordinfo[curword].len    = wordlen;                   \
2595     trie->wordinfo[curword].accept = state;                     \
2596                                                                 \
2597     if ( noper_next < tail ) {                                  \
2598         if (!trie->jump)                                        \
2599             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2600                                                  sizeof(U16) ); \
2601         trie->jump[curword] = (U16)(noper_next - convert);      \
2602         if (!jumper)                                            \
2603             jumper = noper_next;                                \
2604         if (!nextbranch)                                        \
2605             nextbranch= regnext(cur);                           \
2606     }                                                           \
2607                                                                 \
2608     if ( dupe ) {                                               \
2609         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2610         /* chain, so that when the bits of chain are later    */\
2611         /* linked together, the dups appear in the chain      */\
2612         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2613         trie->wordinfo[dupe].prev = curword;                    \
2614     } else {                                                    \
2615         /* we haven't inserted this word yet.                */ \
2616         trie->states[ state ].wordnum = curword;                \
2617     }                                                           \
2618 } STMT_END
2619
2620
2621 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2622      ( ( base + charid >=  ucharcount                                   \
2623          && base + charid < ubound                                      \
2624          && state == trie->trans[ base - ucharcount + charid ].check    \
2625          && trie->trans[ base - ucharcount + charid ].next )            \
2626            ? trie->trans[ base - ucharcount + charid ].next             \
2627            : ( state==1 ? special : 0 )                                 \
2628       )
2629
2630 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2631 STMT_START {                                                \
2632     TRIE_BITMAP_SET(trie, uvc);                             \
2633     /* store the folded codepoint */                        \
2634     if ( folder )                                           \
2635         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2636                                                             \
2637     if ( !UTF ) {                                           \
2638         /* store first byte of utf8 representation of */    \
2639         /* variant codepoints */                            \
2640         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2641             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2642         }                                                   \
2643     }                                                       \
2644 } STMT_END
2645 #define MADE_TRIE       1
2646 #define MADE_JUMP_TRIE  2
2647 #define MADE_EXACT_TRIE 4
2648
2649 STATIC I32
2650 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2651                   regnode *first, regnode *last, regnode *tail,
2652                   U32 word_count, U32 flags, U32 depth)
2653 {
2654     /* first pass, loop through and scan words */
2655     reg_trie_data *trie;
2656     HV *widecharmap = NULL;
2657     AV *revcharmap = newAV();
2658     regnode *cur;
2659     STRLEN len = 0;
2660     UV uvc = 0;
2661     U16 curword = 0;
2662     U32 next_alloc = 0;
2663     regnode *jumper = NULL;
2664     regnode *nextbranch = NULL;
2665     regnode *convert = NULL;
2666     U32 *prev_states; /* temp array mapping each state to previous one */
2667     /* we just use folder as a flag in utf8 */
2668     const U8 * folder = NULL;
2669
2670     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2671      * which stands for one trie structure, one hash, optionally followed
2672      * by two arrays */
2673 #ifdef DEBUGGING
2674     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2675     AV *trie_words = NULL;
2676     /* along with revcharmap, this only used during construction but both are
2677      * useful during debugging so we store them in the struct when debugging.
2678      */
2679 #else
2680     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2681     STRLEN trie_charcount=0;
2682 #endif
2683     SV *re_trie_maxbuff;
2684     GET_RE_DEBUG_FLAGS_DECL;
2685
2686     PERL_ARGS_ASSERT_MAKE_TRIE;
2687 #ifndef DEBUGGING
2688     PERL_UNUSED_ARG(depth);
2689 #endif
2690
2691     switch (flags) {
2692         case EXACT: case EXACT_ONLY8: case EXACTL: break;
2693         case EXACTFAA:
2694         case EXACTFUP:
2695         case EXACTFU:
2696         case EXACTFLU8: folder = PL_fold_latin1; break;
2697         case EXACTF:  folder = PL_fold; break;
2698         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2699     }
2700
2701     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2702     trie->refcount = 1;
2703     trie->startstate = 1;
2704     trie->wordcount = word_count;
2705     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2706     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2707     if (flags == EXACT || flags == EXACT_ONLY8 || flags == EXACTL)
2708         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2709     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2710                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2711
2712     DEBUG_r({
2713         trie_words = newAV();
2714     });
2715
2716     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, GV_ADD);
2717     assert(re_trie_maxbuff);
2718     if (!SvIOK(re_trie_maxbuff)) {
2719         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2720     }
2721     DEBUG_TRIE_COMPILE_r({
2722         Perl_re_indentf( aTHX_
2723           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2724           depth+1,
2725           REG_NODE_NUM(startbranch), REG_NODE_NUM(first),
2726           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2727     });
2728
2729    /* Find the node we are going to overwrite */
2730     if ( first == startbranch && OP( last ) != BRANCH ) {
2731         /* whole branch chain */
2732         convert = first;
2733     } else {
2734         /* branch sub-chain */
2735         convert = NEXTOPER( first );
2736     }
2737
2738     /*  -- First loop and Setup --
2739
2740        We first traverse the branches and scan each word to determine if it
2741        contains widechars, and how many unique chars there are, this is
2742        important as we have to build a table with at least as many columns as we
2743        have unique chars.
2744
2745        We use an array of integers to represent the character codes 0..255
2746        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2747        the native representation of the character value as the key and IV's for
2748        the coded index.
2749
2750        *TODO* If we keep track of how many times each character is used we can
2751        remap the columns so that the table compression later on is more
2752        efficient in terms of memory by ensuring the most common value is in the
2753        middle and the least common are on the outside.  IMO this would be better
2754        than a most to least common mapping as theres a decent chance the most
2755        common letter will share a node with the least common, meaning the node
2756        will not be compressible. With a middle is most common approach the worst
2757        case is when we have the least common nodes twice.
2758
2759      */
2760
2761     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2762         regnode *noper = NEXTOPER( cur );
2763         const U8 *uc;
2764         const U8 *e;
2765         int foldlen = 0;
2766         U32 wordlen      = 0;         /* required init */
2767         STRLEN minchars = 0;
2768         STRLEN maxchars = 0;
2769         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2770                                                bitmap?*/
2771
2772         if (OP(noper) == NOTHING) {
2773             /* skip past a NOTHING at the start of an alternation
2774              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2775              */
2776             regnode *noper_next= regnext(noper);
2777             if (noper_next < tail)
2778                 noper= noper_next;
2779         }
2780
2781         if (    noper < tail
2782             && (    OP(noper) == flags
2783                 || (flags == EXACT && OP(noper) == EXACT_ONLY8)
2784                 || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
2785                                          || OP(noper) == EXACTFUP))))
2786         {
2787             uc= (U8*)STRING(noper);
2788             e= uc + STR_LEN(noper);
2789         } else {
2790             trie->minlen= 0;
2791             continue;
2792         }
2793
2794
2795         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2796             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2797                                           regardless of encoding */
2798             if (OP( noper ) == EXACTFUP) {
2799                 /* false positives are ok, so just set this */
2800                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2801             }
2802         }
2803
2804         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2805                                            branch */
2806             TRIE_CHARCOUNT(trie)++;
2807             TRIE_READ_CHAR;
2808
2809             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2810              * is in effect.  Under /i, this character can match itself, or
2811              * anything that folds to it.  If not under /i, it can match just
2812              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2813              * all fold to k, and all are single characters.   But some folds
2814              * expand to more than one character, so for example LATIN SMALL
2815              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2816              * the string beginning at 'uc' is 'ffi', it could be matched by
2817              * three characters, or just by the one ligature character. (It
2818              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2819              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2820              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2821              * match.)  The trie needs to know the minimum and maximum number
2822              * of characters that could match so that it can use size alone to
2823              * quickly reject many match attempts.  The max is simple: it is
2824              * the number of folded characters in this branch (since a fold is
2825              * never shorter than what folds to it. */
2826
2827             maxchars++;
2828
2829             /* And the min is equal to the max if not under /i (indicated by
2830              * 'folder' being NULL), or there are no multi-character folds.  If
2831              * there is a multi-character fold, the min is incremented just
2832              * once, for the character that folds to the sequence.  Each
2833              * character in the sequence needs to be added to the list below of
2834              * characters in the trie, but we count only the first towards the
2835              * min number of characters needed.  This is done through the
2836              * variable 'foldlen', which is returned by the macros that look
2837              * for these sequences as the number of bytes the sequence
2838              * occupies.  Each time through the loop, we decrement 'foldlen' by
2839              * how many bytes the current char occupies.  Only when it reaches
2840              * 0 do we increment 'minchars' or look for another multi-character
2841              * sequence. */
2842             if (folder == NULL) {
2843                 minchars++;
2844             }
2845             else if (foldlen > 0) {
2846                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2847             }
2848             else {
2849                 minchars++;
2850
2851                 /* See if *uc is the beginning of a multi-character fold.  If
2852                  * so, we decrement the length remaining to look at, to account
2853                  * for the current character this iteration.  (We can use 'uc'
2854                  * instead of the fold returned by TRIE_READ_CHAR because for
2855                  * non-UTF, the latin1_safe macro is smart enough to account
2856                  * for all the unfolded characters, and because for UTF, the
2857                  * string will already have been folded earlier in the
2858                  * compilation process */
2859                 if (UTF) {
2860                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2861                         foldlen -= UTF8SKIP(uc);
2862                     }
2863                 }
2864                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2865                     foldlen--;
2866                 }
2867             }
2868
2869             /* The current character (and any potential folds) should be added
2870              * to the possible matching characters for this position in this
2871              * branch */
2872             if ( uvc < 256 ) {
2873                 if ( folder ) {
2874                     U8 folded= folder[ (U8) uvc ];
2875                     if ( !trie->charmap[ folded ] ) {
2876                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2877                         TRIE_STORE_REVCHAR( folded );
2878                     }
2879                 }
2880                 if ( !trie->charmap[ uvc ] ) {
2881                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2882                     TRIE_STORE_REVCHAR( uvc );
2883                 }
2884                 if ( set_bit ) {
2885                     /* store the codepoint in the bitmap, and its folded
2886                      * equivalent. */
2887                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2888                     set_bit = 0; /* We've done our bit :-) */
2889                 }
2890             } else {
2891
2892                 /* XXX We could come up with the list of code points that fold
2893                  * to this using PL_utf8_foldclosures, except not for
2894                  * multi-char folds, as there may be multiple combinations
2895                  * there that could work, which needs to wait until runtime to
2896                  * resolve (The comment about LIGATURE FFI above is such an
2897                  * example */
2898
2899                 SV** svpp;
2900                 if ( !widecharmap )
2901                     widecharmap = newHV();
2902
2903                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2904
2905                 if ( !svpp )
2906                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2907
2908                 if ( !SvTRUE( *svpp ) ) {
2909                     sv_setiv( *svpp, ++trie->uniquecharcount );
2910                     TRIE_STORE_REVCHAR(uvc);
2911                 }
2912             }
2913         } /* end loop through characters in this branch of the trie */
2914
2915         /* We take the min and max for this branch and combine to find the min
2916          * and max for all branches processed so far */
2917         if( cur == first ) {
2918             trie->minlen = minchars;
2919             trie->maxlen = maxchars;
2920         } else if (minchars < trie->minlen) {
2921             trie->minlen = minchars;
2922         } else if (maxchars > trie->maxlen) {
2923             trie->maxlen = maxchars;
2924         }
2925     } /* end first pass */
2926     DEBUG_TRIE_COMPILE_r(
2927         Perl_re_indentf( aTHX_
2928                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2929                 depth+1,
2930                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2931                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2932                 (int)trie->minlen, (int)trie->maxlen )
2933     );
2934
2935     /*
2936         We now know what we are dealing with in terms of unique chars and
2937         string sizes so we can calculate how much memory a naive
2938         representation using a flat table  will take. If it's over a reasonable
2939         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2940         conservative but potentially much slower representation using an array
2941         of lists.
2942
2943         At the end we convert both representations into the same compressed
2944         form that will be used in regexec.c for matching with. The latter
2945         is a form that cannot be used to construct with but has memory
2946         properties similar to the list form and access properties similar
2947         to the table form making it both suitable for fast searches and
2948         small enough that its feasable to store for the duration of a program.
2949
2950         See the comment in the code where the compressed table is produced
2951         inplace from the flat tabe representation for an explanation of how
2952         the compression works.
2953
2954     */
2955
2956
2957     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2958     prev_states[1] = 0;
2959
2960     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2961                                                     > SvIV(re_trie_maxbuff) )
2962     {
2963         /*
2964             Second Pass -- Array Of Lists Representation
2965
2966             Each state will be represented by a list of charid:state records
2967             (reg_trie_trans_le) the first such element holds the CUR and LEN
2968             points of the allocated array. (See defines above).
2969
2970             We build the initial structure using the lists, and then convert
2971             it into the compressed table form which allows faster lookups
2972             (but cant be modified once converted).
2973         */
2974
2975         STRLEN transcount = 1;
2976
2977         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2978             depth+1));
2979
2980         trie->states = (reg_trie_state *)
2981             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2982                                   sizeof(reg_trie_state) );
2983         TRIE_LIST_NEW(1);
2984         next_alloc = 2;
2985
2986         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2987
2988             regnode *noper   = NEXTOPER( cur );
2989             U32 state        = 1;         /* required init */
2990             U16 charid       = 0;         /* sanity init */
2991             U32 wordlen      = 0;         /* required init */
2992
2993             if (OP(noper) == NOTHING) {
2994                 regnode *noper_next= regnext(noper);
2995                 if (noper_next < tail)
2996                     noper= noper_next;
2997             }
2998
2999             if (    noper < tail
3000                 && (    OP(noper) == flags
3001                     || (flags == EXACT && OP(noper) == EXACT_ONLY8)
3002                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
3003                                              || OP(noper) == EXACTFUP))))
3004             {
3005                 const U8 *uc= (U8*)STRING(noper);
3006                 const U8 *e= uc + STR_LEN(noper);
3007
3008                 for ( ; uc < e ; uc += len ) {
3009
3010                     TRIE_READ_CHAR;
3011
3012                     if ( uvc < 256 ) {
3013                         charid = trie->charmap[ uvc ];
3014                     } else {
3015                         SV** const svpp = hv_fetch( widecharmap,
3016                                                     (char*)&uvc,
3017                                                     sizeof( UV ),
3018                                                     0);
3019                         if ( !svpp ) {
3020                             charid = 0;
3021                         } else {
3022                             charid=(U16)SvIV( *svpp );
3023                         }
3024                     }
3025                     /* charid is now 0 if we dont know the char read, or
3026                      * nonzero if we do */
3027                     if ( charid ) {
3028
3029                         U16 check;
3030                         U32 newstate = 0;
3031
3032                         charid--;
3033                         if ( !trie->states[ state ].trans.list ) {
3034                             TRIE_LIST_NEW( state );
3035                         }
3036                         for ( check = 1;
3037                               check <= TRIE_LIST_USED( state );
3038                               check++ )
3039                         {
3040                             if ( TRIE_LIST_ITEM( state, check ).forid
3041                                                                     == charid )
3042                             {
3043                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
3044                                 break;
3045                             }
3046                         }
3047                         if ( ! newstate ) {
3048                             newstate = next_alloc++;
3049                             prev_states[newstate] = state;
3050                             TRIE_LIST_PUSH( state, charid, newstate );
3051                             transcount++;
3052                         }
3053                         state = newstate;
3054                     } else {
3055                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3056                     }
3057                 }
3058             }
3059             TRIE_HANDLE_WORD(state);
3060
3061         } /* end second pass */
3062
3063         /* next alloc is the NEXT state to be allocated */
3064         trie->statecount = next_alloc;
3065         trie->states = (reg_trie_state *)
3066             PerlMemShared_realloc( trie->states,
3067                                    next_alloc
3068                                    * sizeof(reg_trie_state) );
3069
3070         /* and now dump it out before we compress it */
3071         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
3072                                                          revcharmap, next_alloc,
3073                                                          depth+1)
3074         );
3075
3076         trie->trans = (reg_trie_trans *)
3077             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
3078         {
3079             U32 state;
3080             U32 tp = 0;
3081             U32 zp = 0;
3082
3083
3084             for( state=1 ; state < next_alloc ; state ++ ) {
3085                 U32 base=0;
3086
3087                 /*
3088                 DEBUG_TRIE_COMPILE_MORE_r(
3089                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
3090                 );
3091                 */
3092
3093                 if (trie->states[state].trans.list) {
3094                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
3095                     U16 maxid=minid;
3096                     U16 idx;
3097
3098                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3099                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
3100                         if ( forid < minid ) {
3101                             minid=forid;
3102                         } else if ( forid > maxid ) {
3103                             maxid=forid;
3104                         }
3105                     }
3106                     if ( transcount < tp + maxid - minid + 1) {
3107                         transcount *= 2;
3108                         trie->trans = (reg_trie_trans *)
3109                             PerlMemShared_realloc( trie->trans,
3110                                                      transcount
3111                                                      * sizeof(reg_trie_trans) );
3112                         Zero( trie->trans + (transcount / 2),
3113                               transcount / 2,
3114                               reg_trie_trans );
3115                     }
3116                     base = trie->uniquecharcount + tp - minid;
3117                     if ( maxid == minid ) {
3118                         U32 set = 0;
3119                         for ( ; zp < tp ; zp++ ) {
3120                             if ( ! trie->trans[ zp ].next ) {
3121                                 base = trie->uniquecharcount + zp - minid;
3122                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
3123                                                                    1).newstate;
3124                                 trie->trans[ zp ].check = state;
3125                                 set = 1;
3126                                 break;
3127                             }
3128                         }
3129                         if ( !set ) {
3130                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
3131                                                                    1).newstate;
3132                             trie->trans[ tp ].check = state;
3133                             tp++;
3134                             zp = tp;
3135                         }
3136                     } else {
3137                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3138                             const U32 tid = base
3139                                            - trie->uniquecharcount
3140                                            + TRIE_LIST_ITEM( state, idx ).forid;
3141                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
3142                                                                 idx ).newstate;
3143                             trie->trans[ tid ].check = state;
3144                         }
3145                         tp += ( maxid - minid + 1 );
3146                     }
3147                     Safefree(trie->states[ state ].trans.list);
3148                 }
3149                 /*
3150                 DEBUG_TRIE_COMPILE_MORE_r(
3151                     Perl_re_printf( aTHX_  " base: %d\n",base);
3152                 );
3153                 */
3154                 trie->states[ state ].trans.base=base;
3155             }
3156             trie->lasttrans = tp + 1;
3157         }
3158     } else {
3159         /*
3160            Second Pass -- Flat Table Representation.
3161
3162            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3163            each.  We know that we will need Charcount+1 trans at most to store
3164            the data (one row per char at worst case) So we preallocate both
3165            structures assuming worst case.
3166
3167            We then construct the trie using only the .next slots of the entry
3168            structs.
3169
3170            We use the .check field of the first entry of the node temporarily
3171            to make compression both faster and easier by keeping track of how
3172            many non zero fields are in the node.
3173
3174            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3175            transition.
3176
3177            There are two terms at use here: state as a TRIE_NODEIDX() which is
3178            a number representing the first entry of the node, and state as a
3179            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3180            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3181            if there are 2 entrys per node. eg:
3182
3183              A B       A B
3184           1. 2 4    1. 3 7
3185           2. 0 3    3. 0 5
3186           3. 0 0    5. 0 0
3187           4. 0 0    7. 0 0
3188
3189            The table is internally in the right hand, idx form. However as we
3190            also have to deal with the states array which is indexed by nodenum
3191            we have to use TRIE_NODENUM() to convert.
3192
3193         */
3194         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3195             depth+1));
3196
3197         trie->trans = (reg_trie_trans *)
3198             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3199                                   * trie->uniquecharcount + 1,
3200                                   sizeof(reg_trie_trans) );
3201         trie->states = (reg_trie_state *)
3202             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3203                                   sizeof(reg_trie_state) );
3204         next_alloc = trie->uniquecharcount + 1;
3205
3206
3207         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3208
3209             regnode *noper   = NEXTOPER( cur );
3210
3211             U32 state        = 1;         /* required init */
3212
3213             U16 charid       = 0;         /* sanity init */
3214             U32 accept_state = 0;         /* sanity init */
3215
3216             U32 wordlen      = 0;         /* required init */
3217
3218             if (OP(noper) == NOTHING) {
3219                 regnode *noper_next= regnext(noper);
3220                 if (noper_next < tail)
3221                     noper= noper_next;
3222             }
3223
3224             if (    noper < tail
3225                 && (    OP(noper) == flags
3226                     || (flags == EXACT && OP(noper) == EXACT_ONLY8)
3227                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
3228                                              || OP(noper) == EXACTFUP))))
3229             {
3230                 const U8 *uc= (U8*)STRING(noper);
3231                 const U8 *e= uc + STR_LEN(noper);
3232
3233                 for ( ; uc < e ; uc += len ) {
3234
3235                     TRIE_READ_CHAR;
3236
3237                     if ( uvc < 256 ) {
3238                         charid = trie->charmap[ uvc ];
3239                     } else {
3240                         SV* const * const svpp = hv_fetch( widecharmap,
3241                                                            (char*)&uvc,
3242                                                            sizeof( UV ),
3243                                                            0);
3244                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3245                     }
3246                     if ( charid ) {
3247                         charid--;
3248                         if ( !trie->trans[ state + charid ].next ) {
3249                             trie->trans[ state + charid ].next = next_alloc;
3250                             trie->trans[ state ].check++;
3251                             prev_states[TRIE_NODENUM(next_alloc)]
3252                                     = TRIE_NODENUM(state);
3253                             next_alloc += trie->uniquecharcount;
3254                         }
3255                         state = trie->trans[ state + charid ].next;
3256                     } else {
3257                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3258                     }
3259                     /* charid is now 0 if we dont know the char read, or
3260                      * nonzero if we do */
3261                 }
3262             }
3263             accept_state = TRIE_NODENUM( state );
3264             TRIE_HANDLE_WORD(accept_state);
3265
3266         } /* end second pass */
3267
3268         /* and now dump it out before we compress it */
3269         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3270                                                           revcharmap,
3271                                                           next_alloc, depth+1));
3272
3273         {
3274         /*
3275            * Inplace compress the table.*
3276
3277            For sparse data sets the table constructed by the trie algorithm will
3278            be mostly 0/FAIL transitions or to put it another way mostly empty.
3279            (Note that leaf nodes will not contain any transitions.)
3280
3281            This algorithm compresses the tables by eliminating most such
3282            transitions, at the cost of a modest bit of extra work during lookup:
3283
3284            - Each states[] entry contains a .base field which indicates the
3285            index in the state[] array wheres its transition data is stored.
3286
3287            - If .base is 0 there are no valid transitions from that node.
3288
3289            - If .base is nonzero then charid is added to it to find an entry in
3290            the trans array.
3291
3292            -If trans[states[state].base+charid].check!=state then the
3293            transition is taken to be a 0/Fail transition. Thus if there are fail
3294            transitions at the front of the node then the .base offset will point
3295            somewhere inside the previous nodes data (or maybe even into a node
3296            even earlier), but the .check field determines if the transition is
3297            valid.
3298
3299            XXX - wrong maybe?
3300            The following process inplace converts the table to the compressed
3301            table: We first do not compress the root node 1,and mark all its
3302            .check pointers as 1 and set its .base pointer as 1 as well. This
3303            allows us to do a DFA construction from the compressed table later,
3304            and ensures that any .base pointers we calculate later are greater
3305            than 0.
3306
3307            - We set 'pos' to indicate the first entry of the second node.
3308
3309            - We then iterate over the columns of the node, finding the first and
3310            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3311            and set the .check pointers accordingly, and advance pos
3312            appropriately and repreat for the next node. Note that when we copy
3313            the next pointers we have to convert them from the original
3314            NODEIDX form to NODENUM form as the former is not valid post
3315            compression.
3316
3317            - If a node has no transitions used we mark its base as 0 and do not
3318            advance the pos pointer.
3319
3320            - If a node only has one transition we use a second pointer into the
3321            structure to fill in allocated fail transitions from other states.
3322            This pointer is independent of the main pointer and scans forward
3323            looking for null transitions that are allocated to a state. When it
3324            finds one it writes the single transition into the "hole".  If the
3325            pointer doesnt find one the single transition is appended as normal.
3326
3327            - Once compressed we can Renew/realloc the structures to release the
3328            excess space.
3329
3330            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3331            specifically Fig 3.47 and the associated pseudocode.
3332
3333            demq
3334         */
3335         const U32 laststate = TRIE_NODENUM( next_alloc );
3336         U32 state, charid;
3337         U32 pos = 0, zp=0;
3338         trie->statecount = laststate;
3339
3340         for ( state = 1 ; state < laststate ; state++ ) {
3341             U8 flag = 0;
3342             const U32 stateidx = TRIE_NODEIDX( state );
3343             const U32 o_used = trie->trans[ stateidx ].check;
3344             U32 used = trie->trans[ stateidx ].check;
3345             trie->trans[ stateidx ].check = 0;
3346
3347             for ( charid = 0;
3348                   used && charid < trie->uniquecharcount;
3349                   charid++ )
3350             {
3351                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3352                     if ( trie->trans[ stateidx + charid ].next ) {
3353                         if (o_used == 1) {
3354                             for ( ; zp < pos ; zp++ ) {
3355                                 if ( ! trie->trans[ zp ].next ) {
3356                                     break;
3357                                 }
3358                             }
3359                             trie->states[ state ].trans.base
3360                                                     = zp
3361                                                       + trie->uniquecharcount
3362                                                       - charid ;
3363                             trie->trans[ zp ].next
3364                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3365                                                              + charid ].next );
3366                             trie->trans[ zp ].check = state;
3367                             if ( ++zp > pos ) pos = zp;
3368                             break;
3369                         }
3370                         used--;
3371                     }
3372                     if ( !flag ) {
3373                         flag = 1;
3374                         trie->states[ state ].trans.base
3375                                        = pos + trie->uniquecharcount - charid ;
3376                     }
3377                     trie->trans[ pos ].next
3378                         = SAFE_TRIE_NODENUM(
3379                                        trie->trans[ stateidx + charid ].next );
3380                     trie->trans[ pos ].check = state;
3381                     pos++;
3382                 }
3383             }
3384         }
3385         trie->lasttrans = pos + 1;
3386         trie->states = (reg_trie_state *)
3387             PerlMemShared_realloc( trie->states, laststate
3388                                    * sizeof(reg_trie_state) );
3389         DEBUG_TRIE_COMPILE_MORE_r(
3390             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3391                 depth+1,
3392                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3393                        + 1 ),
3394                 (IV)next_alloc,
3395                 (IV)pos,
3396                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3397             );
3398
3399         } /* end table compress */
3400     }
3401     DEBUG_TRIE_COMPILE_MORE_r(
3402             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3403                 depth+1,
3404                 (UV)trie->statecount,
3405                 (UV)trie->lasttrans)
3406     );
3407     /* resize the trans array to remove unused space */
3408     trie->trans = (reg_trie_trans *)
3409         PerlMemShared_realloc( trie->trans, trie->lasttrans
3410                                * sizeof(reg_trie_trans) );
3411
3412     {   /* Modify the program and insert the new TRIE node */
3413         U8 nodetype =(U8)(flags & 0xFF);
3414         char *str=NULL;
3415
3416 #ifdef DEBUGGING
3417         regnode *optimize = NULL;
3418 #ifdef RE_TRACK_PATTERN_OFFSETS
3419
3420         U32 mjd_offset = 0;
3421         U32 mjd_nodelen = 0;
3422 #endif /* RE_TRACK_PATTERN_OFFSETS */
3423 #endif /* DEBUGGING */
3424         /*
3425            This means we convert either the first branch or the first Exact,
3426            depending on whether the thing following (in 'last') is a branch
3427            or not and whther first is the startbranch (ie is it a sub part of
3428            the alternation or is it the whole thing.)
3429            Assuming its a sub part we convert the EXACT otherwise we convert
3430            the whole branch sequence, including the first.
3431          */
3432         /* Find the node we are going to overwrite */
3433         if ( first != startbranch || OP( last ) == BRANCH ) {
3434             /* branch sub-chain */
3435             NEXT_OFF( first ) = (U16)(last - first);
3436 #ifdef RE_TRACK_PATTERN_OFFSETS
3437             DEBUG_r({
3438                 mjd_offset= Node_Offset((convert));
3439                 mjd_nodelen= Node_Length((convert));
3440             });
3441 #endif
3442             /* whole branch chain */
3443         }
3444 #ifdef RE_TRACK_PATTERN_OFFSETS
3445         else {
3446             DEBUG_r({
3447                 const  regnode *nop = NEXTOPER( convert );
3448                 mjd_offset= Node_Offset((nop));
3449                 mjd_nodelen= Node_Length((nop));
3450             });
3451         }
3452         DEBUG_OPTIMISE_r(
3453             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3454                 depth+1,
3455                 (UV)mjd_offset, (UV)mjd_nodelen)
3456         );
3457 #endif
3458         /* But first we check to see if there is a common prefix we can
3459            split out as an EXACT and put in front of the TRIE node.  */
3460         trie->startstate= 1;
3461         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3462             /* we want to find the first state that has more than
3463              * one transition, if that state is not the first state
3464              * then we have a common prefix which we can remove.
3465              */
3466             U32 state;
3467             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3468                 U32 ofs = 0;
3469                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3470                                        transition, -1 means none */
3471                 U32 count = 0;
3472                 const U32 base = trie->states[ state ].trans.base;
3473
3474                 /* does this state terminate an alternation? */
3475                 if ( trie->states[state].wordnum )
3476                         count = 1;
3477
3478                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3479                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3480                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3481                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3482                     {
3483                         if ( ++count > 1 ) {
3484                             /* we have more than one transition */
3485                             SV **tmp;
3486                             U8 *ch;
3487                             /* if this is the first state there is no common prefix
3488                              * to extract, so we can exit */
3489                             if ( state == 1 ) break;
3490                             tmp = av_fetch( revcharmap, ofs, 0);
3491                             ch = (U8*)SvPV_nolen_const( *tmp );
3492
3493                             /* if we are on count 2 then we need to initialize the
3494                              * bitmap, and store the previous char if there was one
3495                              * in it*/
3496                             if ( count == 2 ) {
3497                                 /* clear the bitmap */
3498                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3499                                 DEBUG_OPTIMISE_r(
3500                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3501                                         depth+1,
3502                                         (UV)state));
3503                                 if (first_ofs >= 0) {
3504                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3505                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3506
3507                                     TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3508                                     DEBUG_OPTIMISE_r(
3509                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3510                                     );
3511                                 }
3512                             }
3513                             /* store the current firstchar in the bitmap */
3514                             TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3515                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3516                         }
3517                         first_ofs = ofs;
3518                     }
3519                 }
3520                 if ( count == 1 ) {
3521                     /* This state has only one transition, its transition is part
3522                      * of a common prefix - we need to concatenate the char it
3523                      * represents to what we have so far. */
3524                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3525                     STRLEN len;
3526                     char *ch = SvPV( *tmp, len );
3527                     DEBUG_OPTIMISE_r({
3528                         SV *sv=sv_newmortal();
3529                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3530                             depth+1,
3531                             (UV)state, (UV)first_ofs,
3532                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3533                                 PL_colors[0], PL_colors[1],
3534                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3535                                 PERL_PV_ESCAPE_FIRSTCHAR
3536                             )
3537                         );
3538                     });
3539                     if ( state==1 ) {
3540                         OP( convert ) = nodetype;
3541                         str=STRING(convert);
3542                         STR_LEN(convert)=0;
3543                     }
3544                     STR_LEN(convert) += len;
3545                     while (len--)
3546                         *str++ = *ch++;
3547                 } else {
3548 #ifdef DEBUGGING
3549                     if (state>1)
3550                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3551 #endif
3552                     break;
3553                 }
3554             }
3555             trie->prefixlen = (state-1);
3556             if (str) {
3557                 regnode *n = convert+NODE_SZ_STR(convert);
3558                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3559                 trie->startstate = state;
3560                 trie->minlen -= (state - 1);
3561                 trie->maxlen -= (state - 1);
3562 #ifdef DEBUGGING
3563                /* At least the UNICOS C compiler choked on this
3564                 * being argument to DEBUG_r(), so let's just have
3565                 * it right here. */
3566                if (
3567 #ifdef PERL_EXT_RE_BUILD
3568                    1
3569 #else
3570                    DEBUG_r_TEST
3571 #endif
3572                    ) {
3573                    regnode *fix = convert;
3574                    U32 word = trie->wordcount;
3575 #ifdef RE_TRACK_PATTERN_OFFSETS
3576                    mjd_nodelen++;
3577 #endif
3578                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3579                    while( ++fix < n ) {
3580                        Set_Node_Offset_Length(fix, 0, 0);
3581                    }
3582                    while (word--) {
3583                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3584                        if (tmp) {
3585                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3586                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3587                            else
3588                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3589                        }
3590                    }
3591                }
3592 #endif
3593                 if (trie->maxlen) {
3594                     convert = n;
3595                 } else {
3596                     NEXT_OFF(convert) = (U16)(tail - convert);
3597                     DEBUG_r(optimize= n);
3598                 }
3599             }
3600         }
3601         if (!jumper)
3602             jumper = last;
3603         if ( trie->maxlen ) {
3604             NEXT_OFF( convert ) = (U16)(tail - convert);
3605             ARG_SET( convert, data_slot );
3606             /* Store the offset to the first unabsorbed branch in
3607                jump[0], which is otherwise unused by the jump logic.
3608                We use this when dumping a trie and during optimisation. */
3609             if (trie->jump)
3610                 trie->jump[0] = (U16)(nextbranch - convert);
3611
3612             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3613              *   and there is a bitmap
3614              *   and the first "jump target" node we found leaves enough room
3615              * then convert the TRIE node into a TRIEC node, with the bitmap
3616              * embedded inline in the opcode - this is hypothetically faster.
3617              */
3618             if ( !trie->states[trie->startstate].wordnum
3619                  && trie->bitmap
3620                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3621             {
3622                 OP( convert ) = TRIEC;
3623                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3624                 PerlMemShared_free(trie->bitmap);
3625                 trie->bitmap= NULL;
3626             } else
3627                 OP( convert ) = TRIE;
3628
3629             /* store the type in the flags */
3630             convert->flags = nodetype;
3631             DEBUG_r({
3632             optimize = convert
3633                       + NODE_STEP_REGNODE
3634                       + regarglen[ OP( convert ) ];
3635             });
3636             /* XXX We really should free up the resource in trie now,
3637                    as we won't use them - (which resources?) dmq */
3638         }
3639         /* needed for dumping*/
3640         DEBUG_r(if (optimize) {
3641             regnode *opt = convert;
3642
3643             while ( ++opt < optimize) {
3644                 Set_Node_Offset_Length(opt, 0, 0);
3645             }
3646             /*
3647                 Try to clean up some of the debris left after the
3648                 optimisation.
3649              */
3650             while( optimize < jumper ) {
3651                 Track_Code( mjd_nodelen += Node_Length((optimize)); );
3652                 OP( optimize ) = OPTIMIZED;
3653                 Set_Node_Offset_Length(optimize, 0, 0);
3654                 optimize++;
3655             }
3656             Set_Node_Offset_Length(convert, mjd_offset, mjd_nodelen);
3657         });
3658     } /* end node insert */
3659
3660     /*  Finish populating the prev field of the wordinfo array.  Walk back
3661      *  from each accept state until we find another accept state, and if
3662      *  so, point the first word's .prev field at the second word. If the
3663      *  second already has a .prev field set, stop now. This will be the
3664      *  case either if we've already processed that word's accept state,
3665      *  or that state had multiple words, and the overspill words were
3666      *  already linked up earlier.
3667      */
3668     {
3669         U16 word;
3670         U32 state;
3671         U16 prev;
3672
3673         for (word=1; word <= trie->wordcount; word++) {
3674             prev = 0;
3675             if (trie->wordinfo[word].prev)
3676                 continue;
3677             state = trie->wordinfo[word].accept;
3678             while (state) {
3679                 state = prev_states[state];
3680                 if (!state)
3681                     break;
3682                 prev = trie->states[state].wordnum;
3683                 if (prev)
3684                     break;
3685             }
3686             trie->wordinfo[word].prev = prev;
3687         }
3688         Safefree(prev_states);
3689     }
3690
3691
3692     /* and now dump out the compressed format */
3693     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3694
3695     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3696 #ifdef DEBUGGING
3697     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3698     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3699 #else
3700     SvREFCNT_dec_NN(revcharmap);
3701 #endif
3702     return trie->jump
3703            ? MADE_JUMP_TRIE
3704            : trie->startstate>1
3705              ? MADE_EXACT_TRIE
3706              : MADE_TRIE;
3707 }
3708
3709 STATIC regnode *
3710 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3711 {
3712 /* The Trie is constructed and compressed now so we can build a fail array if
3713  * it's needed
3714
3715    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3716    3.32 in the
3717    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3718    Ullman 1985/88
3719    ISBN 0-201-10088-6
3720
3721    We find the fail state for each state in the trie, this state is the longest
3722    proper suffix of the current state's 'word' that is also a proper prefix of
3723    another word in our trie. State 1 represents the word '' and is thus the
3724    default fail state. This allows the DFA not to have to restart after its
3725    tried and failed a word at a given point, it simply continues as though it
3726    had been matching the other word in the first place.
3727    Consider
3728       'abcdgu'=~/abcdefg|cdgu/
3729    When we get to 'd' we are still matching the first word, we would encounter
3730    'g' which would fail, which would bring us to the state representing 'd' in
3731    the second word where we would try 'g' and succeed, proceeding to match
3732    'cdgu'.
3733  */
3734  /* add a fail transition */
3735     const U32 trie_offset = ARG(source);
3736     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3737     U32 *q;
3738     const U32 ucharcount = trie->uniquecharcount;
3739     const U32 numstates = trie->statecount;
3740     const U32 ubound = trie->lasttrans + ucharcount;
3741     U32 q_read = 0;
3742     U32 q_write = 0;
3743     U32 charid;
3744     U32 base = trie->states[ 1 ].trans.base;
3745     U32 *fail;
3746     reg_ac_data *aho;
3747     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3748     regnode *stclass;
3749     GET_RE_DEBUG_FLAGS_DECL;
3750
3751     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3752     PERL_UNUSED_CONTEXT;
3753 #ifndef DEBUGGING
3754     PERL_UNUSED_ARG(depth);
3755 #endif
3756
3757     if ( OP(source) == TRIE ) {
3758         struct regnode_1 *op = (struct regnode_1 *)
3759             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3760         StructCopy(source, op, struct regnode_1);
3761         stclass = (regnode *)op;
3762     } else {
3763         struct regnode_charclass *op = (struct regnode_charclass *)
3764             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3765         StructCopy(source, op, struct regnode_charclass);
3766         stclass = (regnode *)op;
3767     }
3768     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3769
3770     ARG_SET( stclass, data_slot );
3771     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3772     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3773     aho->trie=trie_offset;
3774     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3775     Copy( trie->states, aho->states, numstates, reg_trie_state );
3776     Newx( q, numstates, U32);
3777     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3778     aho->refcount = 1;
3779     fail = aho->fail;
3780     /* initialize fail[0..1] to be 1 so that we always have
3781        a valid final fail state */
3782     fail[ 0 ] = fail[ 1 ] = 1;
3783
3784     for ( charid = 0; charid < ucharcount ; charid++ ) {
3785         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3786         if ( newstate ) {
3787             q[ q_write ] = newstate;
3788             /* set to point at the root */
3789             fail[ q[ q_write++ ] ]=1;
3790         }
3791     }
3792     while ( q_read < q_write) {
3793         const U32 cur = q[ q_read++ % numstates ];
3794         base = trie->states[ cur ].trans.base;
3795
3796         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3797             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3798             if (ch_state) {
3799                 U32 fail_state = cur;
3800                 U32 fail_base;
3801                 do {
3802                     fail_state = fail[ fail_state ];
3803                     fail_base = aho->states[ fail_state ].trans.base;
3804                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3805
3806                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3807                 fail[ ch_state ] = fail_state;
3808                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3809                 {
3810                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3811                 }
3812                 q[ q_write++ % numstates] = ch_state;
3813             }
3814         }
3815     }
3816     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3817        when we fail in state 1, this allows us to use the
3818        charclass scan to find a valid start char. This is based on the principle
3819        that theres a good chance the string being searched contains lots of stuff
3820        that cant be a start char.
3821      */
3822     fail[ 0 ] = fail[ 1 ] = 0;
3823     DEBUG_TRIE_COMPILE_r({
3824         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3825                       depth, (UV)numstates
3826         );
3827         for( q_read=1; q_read<numstates; q_read++ ) {
3828             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3829         }
3830         Perl_re_printf( aTHX_  "\n");
3831     });
3832     Safefree(q);
3833     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3834     return stclass;
3835 }
3836
3837
3838 /* The below joins as many adjacent EXACTish nodes as possible into a single
3839  * one.  The regop may be changed if the node(s) contain certain sequences that
3840  * require special handling.  The joining is only done if:
3841  * 1) there is room in the current conglomerated node to entirely contain the
3842  *    next one.
3843  * 2) they are compatible node types
3844  *
3845  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3846  * these get optimized out
3847  *
3848  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3849  * as possible, even if that means splitting an existing node so that its first
3850  * part is moved to the preceeding node.  This would maximise the efficiency of
3851  * memEQ during matching.
3852  *
3853  * If a node is to match under /i (folded), the number of characters it matches
3854  * can be different than its character length if it contains a multi-character
3855  * fold.  *min_subtract is set to the total delta number of characters of the
3856  * input nodes.
3857  *
3858  * And *unfolded_multi_char is set to indicate whether or not the node contains
3859  * an unfolded multi-char fold.  This happens when it won't be known until
3860  * runtime whether the fold is valid or not; namely
3861  *  1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
3862  *      target string being matched against turns out to be UTF-8 is that fold
3863  *      valid; or
3864  *  2) for EXACTFL nodes whose folding rules depend on the locale in force at
3865  *      runtime.
3866  * (Multi-char folds whose components are all above the Latin1 range are not
3867  * run-time locale dependent, and have already been folded by the time this
3868  * function is called.)
3869  *
3870  * This is as good a place as any to discuss the design of handling these
3871  * multi-character fold sequences.  It's been wrong in Perl for a very long
3872  * time.  There are three code points in Unicode whose multi-character folds
3873  * were long ago discovered to mess things up.  The previous designs for
3874  * dealing with these involved assigning a special node for them.  This
3875  * approach doesn't always work, as evidenced by this example:
3876  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3877  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3878  * would match just the \xDF, it won't be able to handle the case where a
3879  * successful match would have to cross the node's boundary.  The new approach
3880  * that hopefully generally solves the problem generates an EXACTFUP node
3881  * that is "sss" in this case.
3882  *
3883  * It turns out that there are problems with all multi-character folds, and not
3884  * just these three.  Now the code is general, for all such cases.  The
3885  * approach taken is:
3886  * 1)   This routine examines each EXACTFish node that could contain multi-
3887  *      character folded sequences.  Since a single character can fold into
3888  *      such a sequence, the minimum match length for this node is less than
3889  *      the number of characters in the node.  This routine returns in
3890  *      *min_subtract how many characters to subtract from the the actual
3891  *      length of the string to get a real minimum match length; it is 0 if
3892  *      there are no multi-char foldeds.  This delta is used by the caller to
3893  *      adjust the min length of the match, and the delta between min and max,
3894  *      so that the optimizer doesn't reject these possibilities based on size
3895  *      constraints.
3896  *
3897  * 2)   For the sequence involving the LATIN SMALL LETTER SHARP S (U+00DF)
3898  *      under /u, we fold it to 'ss' in regatom(), and in this routine, after
3899  *      joining, we scan for occurrences of the sequence 'ss' in non-UTF-8
3900  *      EXACTFU nodes.  The node type of such nodes is then changed to
3901  *      EXACTFUP, indicating it is problematic, and needs careful handling.
3902  *      (The procedures in step 1) above are sufficient to handle this case in
3903  *      UTF-8 encoded nodes.)  The reason this is problematic is that this is
3904  *      the only case where there is a possible fold length change in non-UTF-8
3905  *      patterns.  By reserving a special node type for problematic cases, the
3906  *      far more common regular EXACTFU nodes can be processed faster.
3907  *      regexec.c takes advantage of this.
3908  *
3909  *      EXACTFUP has been created as a grab-bag for (hopefully uncommon)
3910  *      problematic cases.   These all only occur when the pattern is not
3911  *      UTF-8.  In addition to the 'ss' sequence where there is a possible fold
3912  *      length change, it handles the situation where the string cannot be
3913  *      entirely folded.  The strings in an EXACTFish node are folded as much
3914  *      as possible during compilation in regcomp.c.  This saves effort in
3915  *      regex matching.  By using an EXACTFUP node when it is not possible to
3916  *      fully fold at compile time, regexec.c can know that everything in an
3917  *      EXACTFU node is folded, so folding can be skipped at runtime.  The only
3918  *      case where folding in EXACTFU nodes can't be done at compile time is
3919  *      the presumably uncommon MICRO SIGN, when the pattern isn't UTF-8.  This
3920  *      is because its fold requires UTF-8 to represent.  Thus EXACTFUP nodes
3921  *      handle two very different cases.  Alternatively, there could have been
3922  *      a node type where there are length changes, one for unfolded, and one
3923  *      for both.  If yet another special case needed to be created, the number
3924  *      of required node types would have to go to 7.  khw figures that even
3925  *      though there are plenty of node types to spare, that the maintenance
3926  *      cost wasn't worth the small speedup of doing it that way, especially
3927  *      since he thinks the MICRO SIGN is rarely encountered in practice.
3928  *
3929  *      There are other cases where folding isn't done at compile time, but
3930  *      none of them are under /u, and hence not for EXACTFU nodes.  The folds
3931  *      in EXACTFL nodes aren't known until runtime, and vary as the locale
3932  *      changes.  Some folds in EXACTF depend on if the runtime target string
3933  *      is UTF-8 or not.  (regatom() will create an EXACTFU node even under /di
3934  *      when no fold in it depends on the UTF-8ness of the target string.)
3935  *
3936  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3937  *      validity of the fold won't be known until runtime, and so must remain
3938  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFAA
3939  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3940  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3941  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3942  *      The reason this is a problem is that the optimizer part of regexec.c
3943  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3944  *      that a character in the pattern corresponds to at most a single
3945  *      character in the target string.  (And I do mean character, and not byte
3946  *      here, unlike other parts of the documentation that have never been
3947  *      updated to account for multibyte Unicode.)  Sharp s in EXACTF and
3948  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
3949  *      nodes it can match "\x{17F}\x{17F}".  These, along with other ones in
3950  *      EXACTFL nodes, violate the assumption, and they are the only instances
3951  *      where it is violated.  I'm reluctant to try to change the assumption,
3952  *      as the code involved is impenetrable to me (khw), so instead the code
3953  *      here punts.  This routine examines EXACTFL nodes, and (when the pattern
3954  *      isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
3955  *      boolean indicating whether or not the node contains such a fold.  When
3956  *      it is true, the caller sets a flag that later causes the optimizer in
3957  *      this file to not set values for the floating and fixed string lengths,
3958  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3959  *      assumption.  Thus, there is no optimization based on string lengths for
3960  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3961  *      EXACTF and EXACTFAA nodes that contain the sharp s.  (The reason the
3962  *      assumption is wrong only in these cases is that all other non-UTF-8
3963  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3964  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3965  *      EXACTF nodes because we don't know at compile time if it actually
3966  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3967  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3968  *      always matches; and EXACTFAA where it never does.  In an EXACTFAA node
3969  *      in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3970  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3971  *      string would require the pattern to be forced into UTF-8, the overhead
3972  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3973  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3974  *      locale.)
3975  *
3976  *      Similarly, the code that generates tries doesn't currently handle
3977  *      not-already-folded multi-char folds, and it looks like a pain to change
3978  *      that.  Therefore, trie generation of EXACTFAA nodes with the sharp s
3979  *      doesn't work.  Instead, such an EXACTFAA is turned into a new regnode,
3980  *      EXACTFAA_NO_TRIE, which the trie code knows not to handle.  Most people
3981  *      using /iaa matching will be doing so almost entirely with ASCII
3982  *      strings, so this should rarely be encountered in practice */
3983
3984 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3985     if (PL_regkind[OP(scan)] == EXACT) \
3986         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags), NULL, depth+1)
3987
3988 STATIC U32
3989 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3990                    UV *min_subtract, bool *unfolded_multi_char,
3991                    U32 flags, regnode *val, U32 depth)
3992 {
3993     /* Merge several consecutive EXACTish nodes into one. */
3994
3995     regnode *n = regnext(scan);
3996     U32 stringok = 1;
3997     regnode *next = scan + NODE_SZ_STR(scan);
3998     U32 merged = 0;
3999     U32 stopnow = 0;
4000 #ifdef DEBUGGING
4001     regnode *stop = scan;
4002     GET_RE_DEBUG_FLAGS_DECL;
4003 #else
4004     PERL_UNUSED_ARG(depth);
4005 #endif
4006
4007     PERL_ARGS_ASSERT_JOIN_EXACT;
4008 #ifndef EXPERIMENTAL_INPLACESCAN
4009     PERL_UNUSED_ARG(flags);
4010     PERL_UNUSED_ARG(val);
4011 #endif
4012     DEBUG_PEEP("join", scan, depth, 0);
4013
4014     assert(PL_regkind[OP(scan)] == EXACT);
4015
4016     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
4017      * EXACT ones that are mergeable to the current one. */
4018     while (    n
4019            && (    PL_regkind[OP(n)] == NOTHING
4020                || (stringok && PL_regkind[OP(n)] == EXACT))
4021            && NEXT_OFF(n)
4022            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
4023     {
4024
4025         if (OP(n) == TAIL || n > next)
4026             stringok = 0;
4027         if (PL_regkind[OP(n)] == NOTHING) {
4028             DEBUG_PEEP("skip:", n, depth, 0);
4029             NEXT_OFF(scan) += NEXT_OFF(n);
4030             next = n + NODE_STEP_REGNODE;
4031 #ifdef DEBUGGING
4032             if (stringok)
4033                 stop = n;
4034 #endif
4035             n = regnext(n);
4036         }
4037         else if (stringok) {
4038             const unsigned int oldl = STR_LEN(scan);
4039             regnode * const nnext = regnext(n);
4040
4041             /* XXX I (khw) kind of doubt that this works on platforms (should
4042              * Perl ever run on one) where U8_MAX is above 255 because of lots
4043              * of other assumptions */
4044             /* Don't join if the sum can't fit into a single node */
4045             if (oldl + STR_LEN(n) > U8_MAX)
4046                 break;
4047
4048             /* Joining something that requires UTF-8 with something that
4049              * doesn't, means the result requires UTF-8. */
4050             if (OP(scan) == EXACT && (OP(n) == EXACT_ONLY8)) {
4051                 OP(scan) = EXACT_ONLY8;
4052             }
4053             else if (OP(scan) == EXACT_ONLY8 && (OP(n) == EXACT)) {
4054                 ;   /* join is compatible, no need to change OP */
4055             }
4056             else if ((OP(scan) == EXACTFU) && (OP(n) == EXACTFU_ONLY8)) {
4057                 OP(scan) = EXACTFU_ONLY8;
4058             }
4059             else if ((OP(scan) == EXACTFU_ONLY8) && (OP(n) == EXACTFU)) {
4060                 ;   /* join is compatible, no need to change OP */
4061             }
4062             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU) {
4063                 ;   /* join is compatible, no need to change OP */
4064             }
4065             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU_S_EDGE) {
4066
4067                  /* Under /di, temporary EXACTFU_S_EDGE nodes are generated,
4068                   * which can join with EXACTFU ones.  We check for this case
4069                   * here.  These need to be resolved to either EXACTFU or
4070                   * EXACTF at joining time.  They have nothing in them that
4071                   * would forbid them from being the more desirable EXACTFU
4072                   * nodes except that they begin and/or end with a single [Ss].
4073                   * The reason this is problematic is because they could be
4074                   * joined in this loop with an adjacent node that ends and/or
4075                   * begins with [Ss] which would then form the sequence 'ss',
4076                   * which matches differently under /di than /ui, in which case
4077                   * EXACTFU can't be used.  If the 'ss' sequence doesn't get
4078                   * formed, the nodes get absorbed into any adjacent EXACTFU
4079                   * node.  And if the only adjacent node is EXACTF, they get
4080                   * absorbed into that, under the theory that a longer node is
4081                   * better than two shorter ones, even if one is EXACTFU.  Note
4082                   * that EXACTFU_ONLY8 is generated only for UTF-8 patterns,
4083                   * and the EXACTFU_S_EDGE ones only for non-UTF-8.  */
4084
4085                 if (STRING(n)[STR_LEN(n)-1] == 's') {
4086
4087                     /* Here the joined node would end with 's'.  If the node
4088                      * following the combination is an EXACTF one, it's better to
4089                      * join this trailing edge 's' node with that one, leaving the
4090                      * current one in 'scan' be the more desirable EXACTFU */
4091                     if (OP(nnext) == EXACTF) {
4092                         break;
4093                     }
4094
4095                     OP(scan) = EXACTFU_S_EDGE;
4096
4097                 }   /* Otherwise, the beginning 's' of the 2nd node just
4098                        becomes an interior 's' in 'scan' */
4099             }
4100             else if (OP(scan) == EXACTF && OP(n) == EXACTF) {
4101                 ;   /* join is compatible, no need to change OP */
4102             }
4103             else if (OP(scan) == EXACTF && OP(n) == EXACTFU_S_EDGE) {
4104
4105                 /* EXACTF nodes are compatible for joining with EXACTFU_S_EDGE
4106                  * nodes.  But the latter nodes can be also joined with EXACTFU
4107                  * ones, and that is a better outcome, so if the node following
4108                  * 'n' is EXACTFU, quit now so that those two can be joined
4109                  * later */
4110                 if (OP(nnext) == EXACTFU) {
4111                     break;
4112                 }
4113
4114                 /* The join is compatible, and the combined node will be
4115                  * EXACTF.  (These don't care if they begin or end with 's' */
4116             }
4117             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU_S_EDGE) {
4118                 if (   STRING(scan)[STR_LEN(scan)-1] == 's'
4119                     && STRING(n)[0] == 's')
4120                 {
4121                     /* When combined, we have the sequence 'ss', which means we
4122                      * have to remain /di */
4123                     OP(scan) = EXACTF;
4124                 }
4125             }
4126             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU) {
4127                 if (STRING(n)[0] == 's') {
4128                     ;   /* Here the join is compatible and the combined node
4129                            starts with 's', no need to change OP */
4130                 }
4131                 else {  /* Now the trailing 's' is in the interior */
4132                     OP(scan) = EXACTFU;
4133                 }
4134             }
4135             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTF) {
4136
4137                 /* The join is compatible, and the combined node will be
4138                  * EXACTF.  (These don't care if they begin or end with 's' */
4139                 OP(scan) = EXACTF;
4140             }
4141             else if (OP(scan) != OP(n)) {
4142
4143                 /* The only other compatible joinings are the same node type */
4144                 break;
4145             }
4146
4147             DEBUG_PEEP("merg", n, depth, 0);
4148             merged++;
4149
4150             NEXT_OFF(scan) += NEXT_OFF(n);
4151             STR_LEN(scan) += STR_LEN(n);
4152             next = n + NODE_SZ_STR(n);
4153             /* Now we can overwrite *n : */
4154             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
4155 #ifdef DEBUGGING
4156             stop = next - 1;
4157 #endif
4158             n = nnext;
4159             if (stopnow) break;
4160         }
4161
4162 #ifdef EXPERIMENTAL_INPLACESCAN
4163         if (flags && !NEXT_OFF(n)) {
4164             DEBUG_PEEP("atch", val, depth, 0);
4165             if (reg_off_by_arg[OP(n)]) {
4166                 ARG_SET(n, val - n);
4167             }
4168             else {
4169                 NEXT_OFF(n) = val - n;
4170             }
4171             stopnow = 1;
4172         }
4173 #endif
4174     }
4175
4176     /* This temporary node can now be turned into EXACTFU, and must, as
4177      * regexec.c doesn't handle it */
4178     if (OP(scan) == EXACTFU_S_EDGE) {
4179         OP(scan) = EXACTFU;
4180     }
4181
4182     *min_subtract = 0;
4183     *unfolded_multi_char = FALSE;
4184
4185     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
4186      * can now analyze for sequences of problematic code points.  (Prior to
4187      * this final joining, sequences could have been split over boundaries, and
4188      * hence missed).  The sequences only happen in folding, hence for any
4189      * non-EXACT EXACTish node */
4190     if (OP(scan) != EXACT && OP(scan) != EXACT_ONLY8 && OP(scan) != EXACTL) {
4191         U8* s0 = (U8*) STRING(scan);
4192         U8* s = s0;
4193         U8* s_end = s0 + STR_LEN(scan);
4194
4195         int total_count_delta = 0;  /* Total delta number of characters that
4196                                        multi-char folds expand to */
4197
4198         /* One pass is made over the node's string looking for all the
4199          * possibilities.  To avoid some tests in the loop, there are two main
4200          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
4201          * non-UTF-8 */
4202         if (UTF) {
4203             U8* folded = NULL;
4204
4205             if (OP(scan) == EXACTFL) {
4206                 U8 *d;
4207
4208                 /* An EXACTFL node would already have been changed to another
4209                  * node type unless there is at least one character in it that
4210                  * is problematic; likely a character whose fold definition
4211                  * won't be known until runtime, and so has yet to be folded.
4212                  * For all but the UTF-8 locale, folds are 1-1 in length, but
4213                  * to handle the UTF-8 case, we need to create a temporary
4214                  * folded copy using UTF-8 locale rules in order to analyze it.
4215                  * This is because our macros that look to see if a sequence is
4216                  * a multi-char fold assume everything is folded (otherwise the
4217                  * tests in those macros would be too complicated and slow).
4218                  * Note that here, the non-problematic folds will have already
4219                  * been done, so we can just copy such characters.  We actually
4220                  * don't completely fold the EXACTFL string.  We skip the
4221                  * unfolded multi-char folds, as that would just create work
4222                  * below to figure out the size they already are */
4223
4224                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
4225                 d = folded;
4226                 while (s < s_end) {
4227                     STRLEN s_len = UTF8SKIP(s);
4228                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
4229                         Copy(s, d, s_len, U8);
4230                         d += s_len;
4231                     }
4232                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
4233                         *unfolded_multi_char = TRUE;
4234                         Copy(s, d, s_len, U8);
4235                         d += s_len;
4236                     }
4237                     else if (isASCII(*s)) {
4238                         *(d++) = toFOLD(*s);
4239                     }
4240                     else {
4241                         STRLEN len;
4242                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
4243                         d += len;
4244                     }
4245                     s += s_len;
4246                 }
4247
4248                 /* Point the remainder of the routine to look at our temporary
4249                  * folded copy */
4250                 s = folded;
4251                 s_end = d;
4252             } /* End of creating folded copy of EXACTFL string */
4253
4254             /* Examine the string for a multi-character fold sequence.  UTF-8
4255              * patterns have all characters pre-folded by the time this code is
4256              * executed */
4257             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
4258                                      length sequence we are looking for is 2 */
4259             {
4260                 int count = 0;  /* How many characters in a multi-char fold */
4261                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
4262                 if (! len) {    /* Not a multi-char fold: get next char */
4263                     s += UTF8SKIP(s);
4264                     continue;
4265                 }
4266
4267                 { /* Here is a generic multi-char fold. */
4268                     U8* multi_end  = s + len;
4269
4270                     /* Count how many characters are in it.  In the case of
4271                      * /aa, no folds which contain ASCII code points are
4272                      * allowed, so check for those, and skip if found. */
4273                     if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
4274                         count = utf8_length(s, multi_end);
4275                         s = multi_end;
4276                     }
4277                     else {
4278                         while (s < multi_end) {
4279                             if (isASCII(*s)) {
4280                                 s++;
4281                                 goto next_iteration;
4282                             }
4283                             else {
4284                                 s += UTF8SKIP(s);
4285                             }
4286                             count++;
4287                         }
4288                     }
4289                 }
4290
4291                 /* The delta is how long the sequence is minus 1 (1 is how long
4292                  * the character that folds to the sequence is) */
4293                 total_count_delta += count - 1;
4294               next_iteration: ;
4295             }
4296
4297             /* We created a temporary folded copy of the string in EXACTFL
4298              * nodes.  Therefore we need to be sure it doesn't go below zero,
4299              * as the real string could be shorter */
4300             if (OP(scan) == EXACTFL) {
4301                 int total_chars = utf8_length((U8*) STRING(scan),
4302                                            (U8*) STRING(scan) + STR_LEN(scan));
4303                 if (total_count_delta > total_chars) {
4304                     total_count_delta = total_chars;
4305                 }
4306             }
4307
4308             *min_subtract += total_count_delta;
4309             Safefree(folded);
4310         }
4311         else if (OP(scan) == EXACTFAA) {
4312
4313             /* Non-UTF-8 pattern, EXACTFAA node.  There can't be a multi-char
4314              * fold to the ASCII range (and there are no existing ones in the
4315              * upper latin1 range).  But, as outlined in the comments preceding
4316              * this function, we need to flag any occurrences of the sharp s.
4317              * This character forbids trie formation (because of added
4318              * complexity) */
4319 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4320    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4321                                       || UNICODE_DOT_DOT_VERSION > 0)
4322             while (s < s_end) {
4323                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4324                     OP(scan) = EXACTFAA_NO_TRIE;
4325                     *unfolded_multi_char = TRUE;
4326                     break;
4327                 }
4328                 s++;
4329             }
4330         }
4331         else {
4332
4333             /* Non-UTF-8 pattern, not EXACTFAA node.  Look for the multi-char
4334              * folds that are all Latin1.  As explained in the comments
4335              * preceding this function, we look also for the sharp s in EXACTF
4336              * and EXACTFL nodes; it can be in the final position.  Otherwise
4337              * we can stop looking 1 byte earlier because have to find at least
4338              * two characters for a multi-fold */
4339             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4340                               ? s_end
4341                               : s_end -1;
4342
4343             while (s < upper) {
4344                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4345                 if (! len) {    /* Not a multi-char fold. */
4346                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4347                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4348                     {
4349                         *unfolded_multi_char = TRUE;
4350                     }
4351                     s++;
4352                     continue;
4353                 }
4354
4355                 if (len == 2
4356                     && isALPHA_FOLD_EQ(*s, 's')
4357                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4358                 {
4359
4360                     /* EXACTF nodes need to know that the minimum length
4361                      * changed so that a sharp s in the string can match this
4362                      * ss in the pattern, but they remain EXACTF nodes, as they
4363                      * won't match this unless the target string is is UTF-8,
4364                      * which we don't know until runtime.  EXACTFL nodes can't
4365                      * transform into EXACTFU nodes */
4366                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4367                         OP(scan) = EXACTFUP;
4368                     }
4369                 }
4370
4371                 *min_subtract += len - 1;
4372                 s += len;
4373             }
4374 #endif
4375         }
4376
4377         if (     STR_LEN(scan) == 1
4378             &&   isALPHA_A(* STRING(scan))
4379             &&  (         OP(scan) == EXACTFAA
4380                  || (     OP(scan) == EXACTFU
4381                      && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(scan)))))
4382         {
4383             U8 mask = ~ ('A' ^ 'a'); /* These differ in just one bit */
4384
4385             /* Replace a length 1 ASCII fold pair node with an ANYOFM node,
4386              * with the mask set to the complement of the bit that differs
4387              * between upper and lower case, and the lowest code point of the
4388              * pair (which the '&' forces) */
4389             OP(scan) = ANYOFM;
4390             ARG_SET(scan, *STRING(scan) & mask);
4391             FLAGS(scan) = mask;
4392         }
4393     }
4394
4395 #ifdef DEBUGGING
4396     /* Allow dumping but overwriting the collection of skipped
4397      * ops and/or strings with fake optimized ops */
4398     n = scan + NODE_SZ_STR(scan);
4399     while (n <= stop) {
4400         OP(n) = OPTIMIZED;
4401         FLAGS(n) = 0;
4402         NEXT_OFF(n) = 0;
4403         n++;
4404     }
4405 #endif
4406     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4407     return stopnow;
4408 }
4409
4410 /* REx optimizer.  Converts nodes into quicker variants "in place".
4411    Finds fixed substrings.  */
4412
4413 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4414    to the position after last scanned or to NULL. */
4415
4416 #define INIT_AND_WITHP \
4417     assert(!and_withp); \
4418     Newx(and_withp, 1, regnode_ssc); \
4419     SAVEFREEPV(and_withp)
4420
4421
4422 static void
4423 S_unwind_scan_frames(pTHX_ const void *p)
4424 {
4425     scan_frame *f= (scan_frame *)p;
4426     do {
4427         scan_frame *n= f->next_frame;
4428         Safefree(f);
4429         f= n;
4430     } while (f);
4431 }
4432
4433 /* the return from this sub is the minimum length that could possibly match */
4434 STATIC SSize_t
4435 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4436                         SSize_t *minlenp, SSize_t *deltap,
4437                         regnode *last,
4438                         scan_data_t *data,
4439                         I32 stopparen,
4440                         U32 recursed_depth,
4441                         regnode_ssc *and_withp,
4442                         U32 flags, U32 depth)
4443                         /* scanp: Start here (read-write). */
4444                         /* deltap: Write maxlen-minlen here. */
4445                         /* last: Stop before this one. */
4446                         /* data: string data about the pattern */
4447                         /* stopparen: treat close N as END */
4448                         /* recursed: which subroutines have we recursed into */
4449                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4450 {
4451     dVAR;
4452     /* There must be at least this number of characters to match */
4453     SSize_t min = 0;
4454     I32 pars = 0, code;
4455     regnode *scan = *scanp, *next;
4456     SSize_t delta = 0;
4457     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4458     int is_inf_internal = 0;            /* The studied chunk is infinite */
4459     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4460     scan_data_t data_fake;
4461     SV *re_trie_maxbuff = NULL;
4462     regnode *first_non_open = scan;
4463     SSize_t stopmin = SSize_t_MAX;
4464     scan_frame *frame = NULL;
4465     GET_RE_DEBUG_FLAGS_DECL;
4466
4467     PERL_ARGS_ASSERT_STUDY_CHUNK;
4468     RExC_study_started= 1;
4469
4470     Zero(&data_fake, 1, scan_data_t);
4471
4472     if ( depth == 0 ) {
4473         while (first_non_open && OP(first_non_open) == OPEN)
4474             first_non_open=regnext(first_non_open);
4475     }
4476
4477
4478   fake_study_recurse:
4479     DEBUG_r(
4480         RExC_study_chunk_recursed_count++;
4481     );
4482     DEBUG_OPTIMISE_MORE_r(
4483     {
4484         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4485             depth, (long)stopparen,
4486             (unsigned long)RExC_study_chunk_recursed_count,
4487             (unsigned long)depth, (unsigned long)recursed_depth,
4488             scan,
4489             last);
4490         if (recursed_depth) {
4491             U32 i;
4492             U32 j;
4493             for ( j = 0 ; j < recursed_depth ; j++ ) {
4494                 for ( i = 0 ; i < (U32)RExC_total_parens ; i++ ) {
4495                     if (
4496                         PAREN_TEST(RExC_study_chunk_recursed +
4497                                    ( j * RExC_study_chunk_recursed_bytes), i )
4498                         && (
4499                             !j ||
4500                             !PAREN_TEST(RExC_study_chunk_recursed +
4501                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4502                         )
4503                     ) {
4504                         Perl_re_printf( aTHX_ " %d",(int)i);
4505                         break;
4506                     }
4507                 }
4508                 if ( j + 1 < recursed_depth ) {
4509                     Perl_re_printf( aTHX_  ",");
4510                 }
4511             }
4512         }
4513         Perl_re_printf( aTHX_ "\n");
4514     }
4515     );
4516     while ( scan && OP(scan) != END && scan < last ){
4517         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4518                                    node length to get a real minimum (because
4519                                    the folded version may be shorter) */
4520         bool unfolded_multi_char = FALSE;
4521         /* Peephole optimizer: */
4522         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4523         DEBUG_PEEP("Peep", scan, depth, flags);
4524
4525
4526         /* The reason we do this here is that we need to deal with things like
4527          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4528          * parsing code, as each (?:..) is handled by a different invocation of
4529          * reg() -- Yves
4530          */
4531         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4532
4533         /* Follow the next-chain of the current node and optimize
4534            away all the NOTHINGs from it.  */
4535         if (OP(scan) != CURLYX) {
4536             const int max = (reg_off_by_arg[OP(scan)]
4537                        ? I32_MAX
4538                        /* I32 may be smaller than U16 on CRAYs! */
4539                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4540             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4541             int noff;
4542             regnode *n = scan;
4543
4544             /* Skip NOTHING and LONGJMP. */
4545             while ((n = regnext(n))
4546                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4547                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4548                    && off + noff < max)
4549                 off += noff;
4550             if (reg_off_by_arg[OP(scan)])
4551                 ARG(scan) = off;
4552             else
4553                 NEXT_OFF(scan) = off;
4554         }
4555
4556         /* The principal pseudo-switch.  Cannot be a switch, since we
4557            look into several different things.  */
4558         if ( OP(scan) == DEFINEP ) {
4559             SSize_t minlen = 0;
4560             SSize_t deltanext = 0;
4561             SSize_t fake_last_close = 0;
4562             I32 f = SCF_IN_DEFINE;
4563
4564             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4565             scan = regnext(scan);
4566             assert( OP(scan) == IFTHEN );
4567             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4568
4569             data_fake.last_closep= &fake_last_close;
4570             minlen = *minlenp;
4571             next = regnext(scan);
4572             scan = NEXTOPER(NEXTOPER(scan));
4573             DEBUG_PEEP("scan", scan, depth, flags);
4574             DEBUG_PEEP("next", next, depth, flags);
4575
4576             /* we suppose the run is continuous, last=next...
4577              * NOTE we dont use the return here! */
4578             /* DEFINEP study_chunk() recursion */
4579             (void)study_chunk(pRExC_state, &scan, &minlen,
4580                               &deltanext, next, &data_fake, stopparen,
4581                               recursed_depth, NULL, f, depth+1);
4582
4583             scan = next;
4584         } else
4585         if (
4586             OP(scan) == BRANCH  ||
4587             OP(scan) == BRANCHJ ||
4588             OP(scan) == IFTHEN
4589         ) {
4590             next = regnext(scan);
4591             code = OP(scan);
4592
4593             /* The op(next)==code check below is to see if we
4594              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4595              * IFTHEN is special as it might not appear in pairs.
4596              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4597              * we dont handle it cleanly. */
4598             if (OP(next) == code || code == IFTHEN) {
4599                 /* NOTE - There is similar code to this block below for
4600                  * handling TRIE nodes on a re-study.  If you change stuff here
4601                  * check there too. */
4602                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4603                 regnode_ssc accum;
4604                 regnode * const startbranch=scan;
4605
4606                 if (flags & SCF_DO_SUBSTR) {
4607                     /* Cannot merge strings after this. */
4608                     scan_commit(pRExC_state, data, minlenp, is_inf);
4609                 }
4610
4611                 if (flags & SCF_DO_STCLASS)
4612                     ssc_init_zero(pRExC_state, &accum);
4613
4614                 while (OP(scan) == code) {
4615                     SSize_t deltanext, minnext, fake;
4616                     I32 f = 0;
4617                     regnode_ssc this_class;
4618
4619                     DEBUG_PEEP("Branch", scan, depth, flags);
4620
4621                     num++;
4622                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4623                     if (data) {
4624                         data_fake.whilem_c = data->whilem_c;
4625                         data_fake.last_closep = data->last_closep;
4626                     }
4627                     else
4628                         data_fake.last_closep = &fake;
4629
4630                     data_fake.pos_delta = delta;
4631                     next = regnext(scan);
4632
4633                     scan = NEXTOPER(scan); /* everything */
4634                     if (code != BRANCH)    /* everything but BRANCH */
4635                         scan = NEXTOPER(scan);
4636
4637                     if (flags & SCF_DO_STCLASS) {
4638                         ssc_init(pRExC_state, &this_class);
4639                         data_fake.start_class = &this_class;
4640                         f = SCF_DO_STCLASS_AND;
4641                     }
4642                     if (flags & SCF_WHILEM_VISITED_POS)
4643                         f |= SCF_WHILEM_VISITED_POS;
4644
4645                     /* we suppose the run is continuous, last=next...*/
4646                     /* recurse study_chunk() for each BRANCH in an alternation */
4647                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4648                                       &deltanext, next, &data_fake, stopparen,
4649                                       recursed_depth, NULL, f, depth+1);
4650
4651                     if (min1 > minnext)
4652                         min1 = minnext;
4653                     if (deltanext == SSize_t_MAX) {
4654                         is_inf = is_inf_internal = 1;
4655                         max1 = SSize_t_MAX;
4656                     } else if (max1 < minnext + deltanext)
4657                         max1 = minnext + deltanext;
4658                     scan = next;
4659                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4660                         pars++;
4661                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4662                         if ( stopmin > minnext)
4663                             stopmin = min + min1;
4664                         flags &= ~SCF_DO_SUBSTR;
4665                         if (data)
4666                             data->flags |= SCF_SEEN_ACCEPT;
4667                     }
4668                     if (data) {
4669                         if (data_fake.flags & SF_HAS_EVAL)
4670                             data->flags |= SF_HAS_EVAL;
4671                         data->whilem_c = data_fake.whilem_c;
4672                     }
4673                     if (flags & SCF_DO_STCLASS)
4674                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4675                 }
4676                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4677                     min1 = 0;
4678                 if (flags & SCF_DO_SUBSTR) {
4679                     data->pos_min += min1;
4680                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4681                         data->pos_delta = SSize_t_MAX;
4682                     else
4683                         data->pos_delta += max1 - min1;
4684                     if (max1 != min1 || is_inf)
4685                         data->cur_is_floating = 1;
4686                 }
4687                 min += min1;
4688                 if (delta == SSize_t_MAX
4689                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4690                     delta = SSize_t_MAX;
4691                 else
4692                     delta += max1 - min1;
4693                 if (flags & SCF_DO_STCLASS_OR) {
4694                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4695                     if (min1) {
4696                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4697                         flags &= ~SCF_DO_STCLASS;
4698                     }
4699                 }
4700                 else if (flags & SCF_DO_STCLASS_AND) {
4701                     if (min1) {
4702                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4703                         flags &= ~SCF_DO_STCLASS;
4704                     }
4705                     else {
4706                         /* Switch to OR mode: cache the old value of
4707                          * data->start_class */
4708                         INIT_AND_WITHP;
4709                         StructCopy(data->start_class, and_withp, regnode_ssc);
4710                         flags &= ~SCF_DO_STCLASS_AND;
4711                         StructCopy(&accum, data->start_class, regnode_ssc);
4712                         flags |= SCF_DO_STCLASS_OR;
4713                     }
4714                 }
4715
4716                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4717                         OP( startbranch ) == BRANCH )
4718                 {
4719                 /* demq.
4720
4721                    Assuming this was/is a branch we are dealing with: 'scan'
4722                    now points at the item that follows the branch sequence,
4723                    whatever it is. We now start at the beginning of the
4724                    sequence and look for subsequences of
4725
4726                    BRANCH->EXACT=>x1
4727                    BRANCH->EXACT=>x2
4728                    tail
4729
4730                    which would be constructed from a pattern like
4731                    /A|LIST|OF|WORDS/
4732
4733                    If we can find such a subsequence we need to turn the first
4734                    element into a trie and then add the subsequent branch exact
4735                    strings to the trie.
4736
4737                    We have two cases
4738
4739                      1. patterns where the whole set of branches can be
4740                         converted.
4741
4742                      2. patterns where only a subset can be converted.
4743
4744                    In case 1 we can replace the whole set with a single regop
4745                    for the trie. In case 2 we need to keep the start and end
4746                    branches so
4747
4748                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4749                      becomes BRANCH TRIE; BRANCH X;
4750
4751                   There is an additional case, that being where there is a
4752                   common prefix, which gets split out into an EXACT like node
4753                   preceding the TRIE node.
4754
4755                   If x(1..n)==tail then we can do a simple trie, if not we make
4756                   a "jump" trie, such that when we match the appropriate word
4757                   we "jump" to the appropriate tail node. Essentially we turn
4758                   a nested if into a case structure of sorts.
4759
4760                 */
4761
4762                     int made=0;
4763                     if (!re_trie_maxbuff) {
4764                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4765                         if (!SvIOK(re_trie_maxbuff))
4766                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4767                     }
4768                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4769                         regnode *cur;
4770                         regnode *first = (regnode *)NULL;
4771                         regnode *last = (regnode *)NULL;
4772                         regnode *tail = scan;
4773                         U8 trietype = 0;
4774                         U32 count=0;
4775
4776                         /* var tail is used because there may be a TAIL
4777                            regop in the way. Ie, the exacts will point to the
4778                            thing following the TAIL, but the last branch will
4779                            point at the TAIL. So we advance tail. If we
4780                            have nested (?:) we may have to move through several
4781                            tails.
4782                          */
4783
4784                         while ( OP( tail ) == TAIL ) {
4785                             /* this is the TAIL generated by (?:) */
4786                             tail = regnext( tail );
4787                         }
4788
4789
4790                         DEBUG_TRIE_COMPILE_r({
4791                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4792                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4793                               depth+1,
4794                               "Looking for TRIE'able sequences. Tail node is ",
4795                               (UV) REGNODE_OFFSET(tail),
4796                               SvPV_nolen_const( RExC_mysv )
4797                             );
4798                         });
4799
4800                         /*
4801
4802                             Step through the branches
4803                                 cur represents each branch,
4804                                 noper is the first thing to be matched as part
4805                                       of that branch
4806                                 noper_next is the regnext() of that node.
4807
4808                             We normally handle a case like this
4809                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4810                             support building with NOJUMPTRIE, which restricts
4811                             the trie logic to structures like /FOO|BAR/.
4812
4813                             If noper is a trieable nodetype then the branch is
4814                             a possible optimization target. If we are building
4815                             under NOJUMPTRIE then we require that noper_next is
4816                             the same as scan (our current position in the regex
4817                             program).
4818
4819                             Once we have two or more consecutive such branches
4820                             we can create a trie of the EXACT's contents and
4821                             stitch it in place into the program.
4822
4823                             If the sequence represents all of the branches in
4824                             the alternation we replace the entire thing with a
4825                             single TRIE node.
4826
4827                             Otherwise when it is a subsequence we need to
4828                             stitch it in place and replace only the relevant
4829                             branches. This means the first branch has to remain
4830                             as it is used by the alternation logic, and its
4831                             next pointer, and needs to be repointed at the item
4832                             on the branch chain following the last branch we
4833                             have optimized away.
4834
4835                             This could be either a BRANCH, in which case the
4836                             subsequence is internal, or it could be the item
4837                             following the branch sequence in which case the
4838                             subsequence is at the end (which does not
4839                             necessarily mean the first node is the start of the
4840                             alternation).
4841
4842                             TRIE_TYPE(X) is a define which maps the optype to a
4843                             trietype.
4844
4845                                 optype          |  trietype
4846                                 ----------------+-----------
4847                                 NOTHING         | NOTHING
4848                                 EXACT           | EXACT
4849                                 EXACT_ONLY8     | EXACT
4850                                 EXACTFU         | EXACTFU
4851                                 EXACTFU_ONLY8   | EXACTFU
4852                                 EXACTFUP        | EXACTFU
4853                                 EXACTFAA        | EXACTFAA
4854                                 EXACTL          | EXACTL
4855                                 EXACTFLU8       | EXACTFLU8
4856
4857
4858                         */
4859 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4860                        ? NOTHING                                            \
4861                        : ( EXACT == (X) || EXACT_ONLY8 == (X) )             \
4862                          ? EXACT                                            \
4863                          : (     EXACTFU == (X)                             \
4864                               || EXACTFU_ONLY8 == (X)                       \
4865                               || EXACTFUP == (X) )                          \
4866                            ? EXACTFU                                        \
4867                            : ( EXACTFAA == (X) )                            \
4868                              ? EXACTFAA                                     \
4869                              : ( EXACTL == (X) )                            \
4870                                ? EXACTL                                     \
4871                                : ( EXACTFLU8 == (X) )                       \
4872                                  ? EXACTFLU8                                \
4873                                  : 0 )
4874
4875                         /* dont use tail as the end marker for this traverse */
4876                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4877                             regnode * const noper = NEXTOPER( cur );
4878                             U8 noper_type = OP( noper );
4879                             U8 noper_trietype = TRIE_TYPE( noper_type );
4880 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4881                             regnode * const noper_next = regnext( noper );
4882                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4883                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4884 #endif
4885
4886                             DEBUG_TRIE_COMPILE_r({
4887                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4888                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4889                                    depth+1,
4890                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4891
4892                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4893                                 Perl_re_printf( aTHX_  " -> %d:%s",
4894                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4895
4896                                 if ( noper_next ) {
4897                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4898                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4899                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4900                                 }
4901                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4902                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4903                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4904                                 );
4905                             });
4906
4907                             /* Is noper a trieable nodetype that can be merged
4908                              * with the current trie (if there is one)? */
4909                             if ( noper_trietype
4910                                   &&
4911                                   (
4912                                         ( noper_trietype == NOTHING )
4913                                         || ( trietype == NOTHING )
4914                                         || ( trietype == noper_trietype )
4915                                   )
4916 #ifdef NOJUMPTRIE
4917                                   && noper_next >= tail
4918 #endif
4919                                   && count < U16_MAX)
4920                             {
4921                                 /* Handle mergable triable node Either we are
4922                                  * the first node in a new trieable sequence,
4923                                  * in which case we do some bookkeeping,
4924                                  * otherwise we update the end pointer. */
4925                                 if ( !first ) {
4926                                     first = cur;
4927                                     if ( noper_trietype == NOTHING ) {
4928 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4929                                         regnode * const noper_next = regnext( noper );
4930                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4931                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4932 #endif
4933
4934                                         if ( noper_next_trietype ) {
4935                                             trietype = noper_next_trietype;
4936                                         } else if (noper_next_type)  {
4937                                             /* a NOTHING regop is 1 regop wide.
4938                                              * We need at least two for a trie
4939                                              * so we can't merge this in */
4940                                             first = NULL;
4941                                         }
4942                                     } else {
4943                                         trietype = noper_trietype;
4944                                     }
4945                                 } else {
4946                                     if ( trietype == NOTHING )
4947                                         trietype = noper_trietype;
4948                                     last = cur;
4949                                 }
4950                                 if (first)
4951                                     count++;
4952                             } /* end handle mergable triable node */
4953                             else {
4954                                 /* handle unmergable node -
4955                                  * noper may either be a triable node which can
4956                                  * not be tried together with the current trie,
4957                                  * or a non triable node */
4958                                 if ( last ) {
4959                                     /* If last is set and trietype is not
4960                                      * NOTHING then we have found at least two
4961                                      * triable branch sequences in a row of a
4962                                      * similar trietype so we can turn them
4963                                      * into a trie. If/when we allow NOTHING to
4964                                      * start a trie sequence this condition
4965                                      * will be required, and it isn't expensive
4966                                      * so we leave it in for now. */
4967                                     if ( trietype && trietype != NOTHING )
4968                                         make_trie( pRExC_state,
4969                                                 startbranch, first, cur, tail,
4970                                                 count, trietype, depth+1 );
4971                                     last = NULL; /* note: we clear/update
4972                                                     first, trietype etc below,
4973                                                     so we dont do it here */
4974                                 }
4975                                 if ( noper_trietype
4976 #ifdef NOJUMPTRIE
4977                                      && noper_next >= tail
4978 #endif
4979                                 ){
4980                                     /* noper is triable, so we can start a new
4981                                      * trie sequence */
4982                                     count = 1;
4983                                     first = cur;
4984                                     trietype = noper_trietype;
4985                                 } else if (first) {
4986                                     /* if we already saw a first but the
4987                                      * current node is not triable then we have
4988                                      * to reset the first information. */
4989                                     count = 0;
4990                                     first = NULL;
4991                                     trietype = 0;
4992                                 }
4993                             } /* end handle unmergable node */
4994                         } /* loop over branches */
4995                         DEBUG_TRIE_COMPILE_r({
4996                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4997                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4998                               depth+1, SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
4999                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
5000                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
5001                                PL_reg_name[trietype]
5002                             );
5003
5004                         });
5005                         if ( last && trietype ) {
5006                             if ( trietype != NOTHING ) {
5007                                 /* the last branch of the sequence was part of
5008                                  * a trie, so we have to construct it here
5009                                  * outside of the loop */
5010                                 made= make_trie( pRExC_state, startbranch,
5011                                                  first, scan, tail, count,
5012                                                  trietype, depth+1 );
5013 #ifdef TRIE_STUDY_OPT
5014                                 if ( ((made == MADE_EXACT_TRIE &&
5015                                      startbranch == first)
5016                                      || ( first_non_open == first )) &&
5017                                      depth==0 ) {
5018                                     flags |= SCF_TRIE_RESTUDY;
5019                                     if ( startbranch == first
5020                                          && scan >= tail )
5021                                     {
5022                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
5023                                     }
5024                                 }
5025 #endif
5026                             } else {
5027                                 /* at this point we know whatever we have is a
5028                                  * NOTHING sequence/branch AND if 'startbranch'
5029                                  * is 'first' then we can turn the whole thing
5030                                  * into a NOTHING
5031                                  */
5032                                 if ( startbranch == first ) {
5033                                     regnode *opt;
5034                                     /* the entire thing is a NOTHING sequence,
5035                                      * something like this: (?:|) So we can
5036                                      * turn it into a plain NOTHING op. */
5037                                     DEBUG_TRIE_COMPILE_r({
5038                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
5039                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
5040                                           depth+1,
5041                                           SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
5042
5043                                     });
5044                                     OP(startbranch)= NOTHING;
5045                                     NEXT_OFF(startbranch)= tail - startbranch;
5046                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
5047                                         OP(opt)= OPTIMIZED;
5048                                 }
5049                             }
5050                         } /* end if ( last) */
5051                     } /* TRIE_MAXBUF is non zero */
5052
5053                 } /* do trie */
5054
5055             }
5056             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
5057                 scan = NEXTOPER(NEXTOPER(scan));
5058             } else                      /* single branch is optimized. */
5059                 scan = NEXTOPER(scan);
5060             continue;
5061         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
5062             I32 paren = 0;
5063             regnode *start = NULL;
5064             regnode *end = NULL;
5065             U32 my_recursed_depth= recursed_depth;
5066
5067             if (OP(scan) != SUSPEND) { /* GOSUB */
5068                 /* Do setup, note this code has side effects beyond
5069                  * the rest of this block. Specifically setting
5070                  * RExC_recurse[] must happen at least once during
5071                  * study_chunk(). */
5072                 paren = ARG(scan);
5073                 RExC_recurse[ARG2L(scan)] = scan;
5074                 start = REGNODE_p(RExC_open_parens[paren]);
5075                 end   = REGNODE_p(RExC_close_parens[paren]);
5076
5077                 /* NOTE we MUST always execute the above code, even
5078                  * if we do nothing with a GOSUB */
5079                 if (
5080                     ( flags & SCF_IN_DEFINE )
5081                     ||
5082                     (
5083                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
5084                         &&
5085                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
5086                     )
5087                 ) {
5088                     /* no need to do anything here if we are in a define. */
5089                     /* or we are after some kind of infinite construct
5090                      * so we can skip recursing into this item.
5091                      * Since it is infinite we will not change the maxlen
5092                      * or delta, and if we miss something that might raise
5093                      * the minlen it will merely pessimise a little.
5094                      *
5095                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
5096                      * might result in a minlen of 1 and not of 4,
5097                      * but this doesn't make us mismatch, just try a bit
5098                      * harder than we should.
5099                      * */
5100                     scan= regnext(scan);
5101                     continue;
5102                 }
5103
5104                 if (
5105                     !recursed_depth
5106                     ||
5107                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
5108                 ) {
5109                     /* it is quite possible that there are more efficient ways
5110                      * to do this. We maintain a bitmap per level of recursion
5111                      * of which patterns we have entered so we can detect if a
5112                      * pattern creates a possible infinite loop. When we
5113                      * recurse down a level we copy the previous levels bitmap
5114                      * down. When we are at recursion level 0 we zero the top
5115                      * level bitmap. It would be nice to implement a different
5116                      * more efficient way of doing this. In particular the top
5117                      * level bitmap may be unnecessary.
5118                      */
5119                     if (!recursed_depth) {
5120                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
5121                     } else {
5122                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
5123                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
5124                              RExC_study_chunk_recursed_bytes, U8);
5125                     }
5126                     /* we havent recursed into this paren yet, so recurse into it */
5127                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
5128                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
5129                     my_recursed_depth= recursed_depth + 1;
5130                 } else {
5131                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
5132                     /* some form of infinite recursion, assume infinite length
5133                      * */
5134                     if (flags & SCF_DO_SUBSTR) {
5135                         scan_commit(pRExC_state, data, minlenp, is_inf);
5136                         data->cur_is_floating = 1;
5137                     }
5138                     is_inf = is_inf_internal = 1;
5139                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5140                         ssc_anything(data->start_class);
5141                     flags &= ~SCF_DO_STCLASS;
5142
5143                     start= NULL; /* reset start so we dont recurse later on. */
5144                 }
5145             } else {
5146                 paren = stopparen;
5147                 start = scan + 2;
5148                 end = regnext(scan);
5149             }
5150             if (start) {
5151                 scan_frame *newframe;
5152                 assert(end);
5153                 if (!RExC_frame_last) {
5154                     Newxz(newframe, 1, scan_frame);
5155                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
5156                     RExC_frame_head= newframe;
5157                     RExC_frame_count++;
5158                 } else if (!RExC_frame_last->next_frame) {
5159                     Newxz(newframe, 1, scan_frame);
5160                     RExC_frame_last->next_frame= newframe;
5161                     newframe->prev_frame= RExC_frame_last;
5162                     RExC_frame_count++;
5163                 } else {
5164                     newframe= RExC_frame_last->next_frame;
5165                 }
5166                 RExC_frame_last= newframe;
5167
5168                 newframe->next_regnode = regnext(scan);
5169                 newframe->last_regnode = last;
5170                 newframe->stopparen = stopparen;
5171                 newframe->prev_recursed_depth = recursed_depth;
5172                 newframe->this_prev_frame= frame;
5173
5174                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
5175                 DEBUG_PEEP("fnew", scan, depth, flags);
5176
5177                 frame = newframe;
5178                 scan =  start;
5179                 stopparen = paren;
5180                 last = end;
5181                 depth = depth + 1;
5182                 recursed_depth= my_recursed_depth;
5183
5184                 continue;
5185             }
5186         }
5187         else if (   OP(scan) == EXACT
5188                  || OP(scan) == EXACT_ONLY8
5189                  || OP(scan) == EXACTL)
5190         {
5191             SSize_t l = STR_LEN(scan);
5192             UV uc;
5193             assert(l);
5194             if (UTF) {
5195                 const U8 * const s = (U8*)STRING(scan);
5196                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
5197                 l = utf8_length(s, s + l);
5198             } else {
5199                 uc = *((U8*)STRING(scan));
5200             }
5201             min += l;
5202             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
5203                 /* The code below prefers earlier match for fixed
5204                    offset, later match for variable offset.  */
5205                 if (data->last_end == -1) { /* Update the start info. */
5206                     data->last_start_min = data->pos_min;
5207                     data->last_start_max = is_inf
5208                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
5209                 }
5210                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
5211                 if (UTF)
5212                     SvUTF8_on(data->last_found);
5213                 {
5214                     SV * const sv = data->last_found;
5215                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5216                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5217                     if (mg && mg->mg_len >= 0)
5218                         mg->mg_len += utf8_length((U8*)STRING(scan),
5219                                               (U8*)STRING(scan)+STR_LEN(scan));
5220                 }
5221                 data->last_end = data->pos_min + l;
5222                 data->pos_min += l; /* As in the first entry. */
5223                 data->flags &= ~SF_BEFORE_EOL;
5224             }
5225
5226             /* ANDing the code point leaves at most it, and not in locale, and
5227              * can't match null string */
5228             if (flags & SCF_DO_STCLASS_AND) {
5229                 ssc_cp_and(data->start_class, uc);
5230                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5231                 ssc_clear_locale(data->start_class);
5232             }
5233             else if (flags & SCF_DO_STCLASS_OR) {
5234                 ssc_add_cp(data->start_class, uc);
5235                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5236
5237                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5238                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5239             }
5240             flags &= ~SCF_DO_STCLASS;
5241         }
5242         else if (PL_regkind[OP(scan)] == EXACT) {
5243             /* But OP != EXACT!, so is EXACTFish */
5244             SSize_t l = STR_LEN(scan);
5245             const U8 * s = (U8*)STRING(scan);
5246
5247             /* Search for fixed substrings supports EXACT only. */
5248             if (flags & SCF_DO_SUBSTR) {
5249                 assert(data);
5250                 scan_commit(pRExC_state, data, minlenp, is_inf);
5251             }
5252             if (UTF) {
5253                 l = utf8_length(s, s + l);
5254             }
5255             if (unfolded_multi_char) {
5256                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
5257             }
5258             min += l - min_subtract;
5259             assert (min >= 0);
5260             delta += min_subtract;
5261             if (flags & SCF_DO_SUBSTR) {
5262                 data->pos_min += l - min_subtract;
5263                 if (data->pos_min < 0) {
5264                     data->pos_min = 0;
5265                 }
5266                 data->pos_delta += min_subtract;
5267                 if (min_subtract) {
5268                     data->cur_is_floating = 1; /* float */
5269                 }
5270             }
5271
5272             if (flags & SCF_DO_STCLASS) {
5273                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
5274
5275                 assert(EXACTF_invlist);
5276                 if (flags & SCF_DO_STCLASS_AND) {
5277                     if (OP(scan) != EXACTFL)
5278                         ssc_clear_locale(data->start_class);
5279                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5280                     ANYOF_POSIXL_ZERO(data->start_class);
5281                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
5282                 }
5283                 else {  /* SCF_DO_STCLASS_OR */
5284                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
5285                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5286
5287                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5288                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5289                 }
5290                 flags &= ~SCF_DO_STCLASS;
5291                 SvREFCNT_dec(EXACTF_invlist);
5292             }
5293         }
5294         else if (REGNODE_VARIES(OP(scan))) {
5295             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
5296             I32 fl = 0, f = flags;
5297             regnode * const oscan = scan;
5298             regnode_ssc this_class;
5299             regnode_ssc *oclass = NULL;
5300             I32 next_is_eval = 0;
5301
5302             switch (PL_regkind[OP(scan)]) {
5303             case WHILEM:                /* End of (?:...)* . */
5304                 scan = NEXTOPER(scan);
5305                 goto finish;
5306             case PLUS:
5307                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5308                     next = NEXTOPER(scan);
5309                     if (   OP(next) == EXACT
5310                         || OP(next) == EXACT_ONLY8
5311                         || OP(next) == EXACTL
5312                         || (flags & SCF_DO_STCLASS))
5313                     {
5314                         mincount = 1;
5315                         maxcount = REG_INFTY;
5316                         next = regnext(scan);
5317                         scan = NEXTOPER(scan);
5318                         goto do_curly;
5319                     }
5320                 }
5321                 if (flags & SCF_DO_SUBSTR)
5322                     data->pos_min++;
5323                 min++;
5324                 /* FALLTHROUGH */
5325             case STAR:
5326                 next = NEXTOPER(scan);
5327
5328                 /* This temporary node can now be turned into EXACTFU, and
5329                  * must, as regexec.c doesn't handle it */
5330                 if (OP(next) == EXACTFU_S_EDGE) {
5331                     OP(next) = EXACTFU;
5332                 }
5333
5334                 if (     STR_LEN(next) == 1
5335                     &&   isALPHA_A(* STRING(next))
5336                     && (         OP(next) == EXACTFAA
5337                         || (     OP(next) == EXACTFU
5338                             && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next)))))
5339                 {
5340                     /* These differ in just one bit */
5341                     U8 mask = ~ ('A' ^ 'a');
5342
5343                     assert(isALPHA_A(* STRING(next)));
5344
5345                     /* Then replace it by an ANYOFM node, with
5346                     * the mask set to the complement of the
5347                     * bit that differs between upper and lower
5348                     * case, and the lowest code point of the
5349                     * pair (which the '&' forces) */
5350                     OP(next) = ANYOFM;
5351                     ARG_SET(next, *STRING(next) & mask);
5352                     FLAGS(next) = mask;
5353                 }
5354
5355                 if (flags & SCF_DO_STCLASS) {
5356                     mincount = 0;
5357                     maxcount = REG_INFTY;
5358                     next = regnext(scan);
5359                     scan = NEXTOPER(scan);
5360                     goto do_curly;
5361                 }
5362                 if (flags & SCF_DO_SUBSTR) {
5363                     scan_commit(pRExC_state, data, minlenp, is_inf);
5364                     /* Cannot extend fixed substrings */
5365                     data->cur_is_floating = 1; /* float */
5366                 }
5367                 is_inf = is_inf_internal = 1;
5368                 scan = regnext(scan);
5369                 goto optimize_curly_tail;
5370             case CURLY:
5371                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5372                     && (scan->flags == stopparen))
5373                 {
5374                     mincount = 1;
5375                     maxcount = 1;
5376                 } else {
5377                     mincount = ARG1(scan);
5378                     maxcount = ARG2(scan);
5379                 }
5380                 next = regnext(scan);
5381                 if (OP(scan) == CURLYX) {
5382                     I32 lp = (data ? *(data->last_closep) : 0);
5383                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5384                 }
5385                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5386                 next_is_eval = (OP(scan) == EVAL);
5387               do_curly:
5388                 if (flags & SCF_DO_SUBSTR) {
5389                     if (mincount == 0)
5390                         scan_commit(pRExC_state, data, minlenp, is_inf);
5391                     /* Cannot extend fixed substrings */
5392                     pos_before = data->pos_min;
5393                 }
5394                 if (data) {
5395                     fl = data->flags;
5396                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5397                     if (is_inf)
5398                         data->flags |= SF_IS_INF;
5399                 }
5400                 if (flags & SCF_DO_STCLASS) {
5401                     ssc_init(pRExC_state, &this_class);
5402                     oclass = data->start_class;
5403                     data->start_class = &this_class;
5404                     f |= SCF_DO_STCLASS_AND;
5405                     f &= ~SCF_DO_STCLASS_OR;
5406                 }
5407                 /* Exclude from super-linear cache processing any {n,m}
5408                    regops for which the combination of input pos and regex
5409                    pos is not enough information to determine if a match
5410                    will be possible.
5411
5412                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5413                    regex pos at the \s*, the prospects for a match depend not
5414                    only on the input position but also on how many (bar\s*)
5415                    repeats into the {4,8} we are. */
5416                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5417                     f &= ~SCF_WHILEM_VISITED_POS;
5418
5419                 /* This will finish on WHILEM, setting scan, or on NULL: */
5420                 /* recurse study_chunk() on loop bodies */
5421                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5422                                   last, data, stopparen, recursed_depth, NULL,
5423                                   (mincount == 0
5424                                    ? (f & ~SCF_DO_SUBSTR)
5425                                    : f)
5426                                   ,depth+1);
5427
5428                 if (flags & SCF_DO_STCLASS)
5429                     data->start_class = oclass;
5430                 if (mincount == 0 || minnext == 0) {
5431                     if (flags & SCF_DO_STCLASS_OR) {
5432                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5433                     }
5434                     else if (flags & SCF_DO_STCLASS_AND) {
5435                         /* Switch to OR mode: cache the old value of
5436                          * data->start_class */
5437                         INIT_AND_WITHP;
5438                         StructCopy(data->start_class, and_withp, regnode_ssc);
5439                         flags &= ~SCF_DO_STCLASS_AND;
5440                         StructCopy(&this_class, data->start_class, regnode_ssc);
5441                         flags |= SCF_DO_STCLASS_OR;
5442                         ANYOF_FLAGS(data->start_class)
5443                                                 |= SSC_MATCHES_EMPTY_STRING;
5444                     }
5445                 } else {                /* Non-zero len */
5446                     if (flags & SCF_DO_STCLASS_OR) {
5447                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5448                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5449                     }
5450                     else if (flags & SCF_DO_STCLASS_AND)
5451                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5452                     flags &= ~SCF_DO_STCLASS;
5453                 }
5454                 if (!scan)              /* It was not CURLYX, but CURLY. */
5455                     scan = next;
5456                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5457                     /* ? quantifier ok, except for (?{ ... }) */
5458                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5459                     && (minnext == 0) && (deltanext == 0)
5460                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5461                     && maxcount <= REG_INFTY/3) /* Complement check for big
5462                                                    count */
5463                 {
5464                     _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP),
5465                         Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5466                             "Quantifier unexpected on zero-length expression "
5467                             "in regex m/%" UTF8f "/",
5468                              UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5469                                   RExC_precomp)));
5470                 }
5471
5472                 min += minnext * mincount;
5473                 is_inf_internal |= deltanext == SSize_t_MAX
5474                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5475                 is_inf |= is_inf_internal;
5476                 if (is_inf) {
5477                     delta = SSize_t_MAX;
5478                 } else {
5479                     delta += (minnext + deltanext) * maxcount
5480                              - minnext * mincount;
5481                 }
5482                 /* Try powerful optimization CURLYX => CURLYN. */
5483                 if (  OP(oscan) == CURLYX && data
5484                       && data->flags & SF_IN_PAR
5485                       && !(data->flags & SF_HAS_EVAL)
5486                       && !deltanext && minnext == 1 ) {
5487                     /* Try to optimize to CURLYN.  */
5488                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5489                     regnode * const nxt1 = nxt;
5490 #ifdef DEBUGGING
5491                     regnode *nxt2;
5492 #endif
5493
5494                     /* Skip open. */
5495                     nxt = regnext(nxt);
5496                     if (!REGNODE_SIMPLE(OP(nxt))
5497                         && !(PL_regkind[OP(nxt)] == EXACT
5498                              && STR_LEN(nxt) == 1))
5499                         goto nogo;
5500 #ifdef DEBUGGING
5501                     nxt2 = nxt;
5502 #endif
5503                     nxt = regnext(nxt);
5504                     if (OP(nxt) != CLOSE)
5505                         goto nogo;
5506                     if (RExC_open_parens) {
5507
5508                         /*open->CURLYM*/
5509                         RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5510
5511                         /*close->while*/
5512                         RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2;
5513                     }
5514                     /* Now we know that nxt2 is the only contents: */
5515                     oscan->flags = (U8)ARG(nxt);
5516                     OP(oscan) = CURLYN;
5517                     OP(nxt1) = NOTHING; /* was OPEN. */
5518
5519 #ifdef DEBUGGING
5520                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5521                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5522                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5523                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5524                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5525                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5526 #endif
5527                 }
5528               nogo:
5529
5530                 /* Try optimization CURLYX => CURLYM. */
5531                 if (  OP(oscan) == CURLYX && data
5532                       && !(data->flags & SF_HAS_PAR)
5533                       && !(data->flags & SF_HAS_EVAL)
5534                       && !deltanext     /* atom is fixed width */
5535                       && minnext != 0   /* CURLYM can't handle zero width */
5536
5537                          /* Nor characters whose fold at run-time may be
5538                           * multi-character */
5539                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5540                 ) {
5541                     /* XXXX How to optimize if data == 0? */
5542                     /* Optimize to a simpler form.  */
5543                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5544                     regnode *nxt2;
5545
5546                     OP(oscan) = CURLYM;
5547                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5548                             && (OP(nxt2) != WHILEM))
5549                         nxt = nxt2;
5550                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5551                     /* Need to optimize away parenths. */
5552                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5553                         /* Set the parenth number.  */
5554                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5555
5556                         oscan->flags = (U8)ARG(nxt);
5557                         if (RExC_open_parens) {
5558                              /*open->CURLYM*/
5559                             RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5560
5561                             /*close->NOTHING*/
5562                             RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2)
5563                                                          + 1;
5564                         }
5565                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5566                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5567
5568 #ifdef DEBUGGING
5569                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5570                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5571                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5572                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5573 #endif
5574 #if 0
5575                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5576                             regnode *nnxt = regnext(nxt1);
5577                             if (nnxt == nxt) {
5578                                 if (reg_off_by_arg[OP(nxt1)])
5579                                     ARG_SET(nxt1, nxt2 - nxt1);
5580                                 else if (nxt2 - nxt1 < U16_MAX)
5581                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5582                                 else
5583                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5584                             }
5585                             nxt1 = nnxt;
5586                         }
5587 #endif
5588                         /* Optimize again: */
5589                         /* recurse study_chunk() on optimised CURLYX => CURLYM */
5590                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5591                                     NULL, stopparen, recursed_depth, NULL, 0,
5592                                     depth+1);
5593                     }
5594                     else
5595                         oscan->flags = 0;
5596                 }
5597                 else if ((OP(oscan) == CURLYX)
5598                          && (flags & SCF_WHILEM_VISITED_POS)
5599                          /* See the comment on a similar expression above.
5600                             However, this time it's not a subexpression
5601                             we care about, but the expression itself. */
5602                          && (maxcount == REG_INFTY)
5603                          && data) {
5604                     /* This stays as CURLYX, we can put the count/of pair. */
5605                     /* Find WHILEM (as in regexec.c) */
5606                     regnode *nxt = oscan + NEXT_OFF(oscan);
5607
5608                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5609                         nxt += ARG(nxt);
5610                     nxt = PREVOPER(nxt);
5611                     if (nxt->flags & 0xf) {
5612                         /* we've already set whilem count on this node */
5613                     } else if (++data->whilem_c < 16) {
5614                         assert(data->whilem_c <= RExC_whilem_seen);
5615                         nxt->flags = (U8)(data->whilem_c
5616                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5617                     }
5618                 }
5619                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5620                     pars++;
5621                 if (flags & SCF_DO_SUBSTR) {
5622                     SV *last_str = NULL;
5623                     STRLEN last_chrs = 0;
5624                     int counted = mincount != 0;
5625
5626                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5627                                                                   string. */
5628                         SSize_t b = pos_before >= data->last_start_min
5629                             ? pos_before : data->last_start_min;
5630                         STRLEN l;
5631                         const char * const s = SvPV_const(data->last_found, l);
5632                         SSize_t old = b - data->last_start_min;
5633                         assert(old >= 0);
5634
5635                         if (UTF)
5636                             old = utf8_hop_forward((U8*)s, old,
5637                                                (U8 *) SvEND(data->last_found))
5638                                 - (U8*)s;
5639                         l -= old;
5640                         /* Get the added string: */
5641                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5642                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5643                                             (U8*)(s + old + l)) : l;
5644                         if (deltanext == 0 && pos_before == b) {
5645                             /* What was added is a constant string */
5646                             if (mincount > 1) {
5647
5648                                 SvGROW(last_str, (mincount * l) + 1);
5649                                 repeatcpy(SvPVX(last_str) + l,
5650                                           SvPVX_const(last_str), l,
5651                                           mincount - 1);
5652                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5653                                 /* Add additional parts. */
5654                                 SvCUR_set(data->last_found,
5655                                           SvCUR(data->last_found) - l);
5656                                 sv_catsv(data->last_found, last_str);
5657                                 {
5658                                     SV * sv = data->last_found;
5659                                     MAGIC *mg =
5660                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5661                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5662                                     if (mg && mg->mg_len >= 0)
5663                                         mg->mg_len += last_chrs * (mincount-1);
5664                                 }
5665                                 last_chrs *= mincount;
5666                                 data->last_end += l * (mincount - 1);
5667                             }
5668                         } else {
5669                             /* start offset must point into the last copy */
5670                             data->last_start_min += minnext * (mincount - 1);
5671                             data->last_start_max =
5672                               is_inf
5673                                ? SSize_t_MAX
5674                                : data->last_start_max +
5675                                  (maxcount - 1) * (minnext + data->pos_delta);
5676                         }
5677                     }
5678                     /* It is counted once already... */
5679                     data->pos_min += minnext * (mincount - counted);
5680 #if 0
5681 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5682                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5683                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5684     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5685     (UV)mincount);
5686 if (deltanext != SSize_t_MAX)
5687 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5688     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5689           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5690 #endif
5691                     if (deltanext == SSize_t_MAX
5692                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5693                         data->pos_delta = SSize_t_MAX;
5694                     else
5695                         data->pos_delta += - counted * deltanext +
5696                         (minnext + deltanext) * maxcount - minnext * mincount;
5697                     if (mincount != maxcount) {
5698                          /* Cannot extend fixed substrings found inside
5699                             the group.  */
5700                         scan_commit(pRExC_state, data, minlenp, is_inf);
5701                         if (mincount && last_str) {
5702                             SV * const sv = data->last_found;
5703                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5704                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5705
5706                             if (mg)
5707                                 mg->mg_len = -1;
5708                             sv_setsv(sv, last_str);
5709                             data->last_end = data->pos_min;
5710                             data->last_start_min = data->pos_min - last_chrs;
5711                             data->last_start_max = is_inf
5712                                 ? SSize_t_MAX
5713                                 : data->pos_min + data->pos_delta - last_chrs;
5714                         }
5715                         data->cur_is_floating = 1; /* float */
5716                     }
5717                     SvREFCNT_dec(last_str);
5718                 }
5719                 if (data && (fl & SF_HAS_EVAL))
5720                     data->flags |= SF_HAS_EVAL;
5721               optimize_curly_tail:
5722                 if (OP(oscan) != CURLYX) {
5723                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5724                            && NEXT_OFF(next))
5725                         NEXT_OFF(oscan) += NEXT_OFF(next);
5726                 }
5727                 continue;
5728
5729             default:
5730 #ifdef DEBUGGING
5731                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5732                                                                     OP(scan));
5733 #endif
5734             case REF:
5735             case CLUMP:
5736                 if (flags & SCF_DO_SUBSTR) {
5737                     /* Cannot expect anything... */
5738                     scan_commit(pRExC_state, data, minlenp, is_inf);
5739                     data->cur_is_floating = 1; /* float */
5740                 }
5741                 is_inf = is_inf_internal = 1;
5742                 if (flags & SCF_DO_STCLASS_OR) {
5743                     if (OP(scan) == CLUMP) {
5744                         /* Actually is any start char, but very few code points
5745                          * aren't start characters */
5746                         ssc_match_all_cp(data->start_class);
5747                     }
5748                     else {
5749                         ssc_anything(data->start_class);
5750                     }
5751                 }
5752                 flags &= ~SCF_DO_STCLASS;
5753                 break;
5754             }
5755         }
5756         else if (OP(scan) == LNBREAK) {
5757             if (flags & SCF_DO_STCLASS) {
5758                 if (flags & SCF_DO_STCLASS_AND) {
5759                     ssc_intersection(data->start_class,
5760                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5761                     ssc_clear_locale(data->start_class);
5762                     ANYOF_FLAGS(data->start_class)
5763                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5764                 }
5765                 else if (flags & SCF_DO_STCLASS_OR) {
5766                     ssc_union(data->start_class,
5767                               PL_XPosix_ptrs[_CC_VERTSPACE],
5768                               FALSE);
5769                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5770
5771                     /* See commit msg for
5772                      * 749e076fceedeb708a624933726e7989f2302f6a */
5773                     ANYOF_FLAGS(data->start_class)
5774                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5775                 }
5776                 flags &= ~SCF_DO_STCLASS;
5777             }
5778             min++;
5779             if (delta != SSize_t_MAX)
5780                 delta++;    /* Because of the 2 char string cr-lf */
5781             if (flags & SCF_DO_SUBSTR) {
5782                 /* Cannot expect anything... */
5783                 scan_commit(pRExC_state, data, minlenp, is_inf);
5784                 data->pos_min += 1;
5785                 if (data->pos_delta != SSize_t_MAX) {
5786                     data->pos_delta += 1;
5787                 }
5788                 data->cur_is_floating = 1; /* float */
5789             }
5790         }
5791         else if (REGNODE_SIMPLE(OP(scan))) {
5792
5793             if (flags & SCF_DO_SUBSTR) {
5794                 scan_commit(pRExC_state, data, minlenp, is_inf);
5795                 data->pos_min++;
5796             }
5797             min++;
5798             if (flags & SCF_DO_STCLASS) {
5799                 bool invert = 0;
5800                 SV* my_invlist = NULL;
5801                 U8 namedclass;
5802
5803                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5804                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5805
5806                 /* Some of the logic below assumes that switching
5807                    locale on will only add false positives. */
5808                 switch (OP(scan)) {
5809
5810                 default:
5811 #ifdef DEBUGGING
5812                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5813                                                                      OP(scan));
5814 #endif
5815                 case SANY:
5816                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5817                         ssc_match_all_cp(data->start_class);
5818                     break;
5819
5820                 case REG_ANY:
5821                     {
5822                         SV* REG_ANY_invlist = _new_invlist(2);
5823                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5824                                                             '\n');
5825                         if (flags & SCF_DO_STCLASS_OR) {
5826                             ssc_union(data->start_class,
5827                                       REG_ANY_invlist,
5828                                       TRUE /* TRUE => invert, hence all but \n
5829                                             */
5830                                       );
5831                         }
5832                         else if (flags & SCF_DO_STCLASS_AND) {
5833                             ssc_intersection(data->start_class,
5834                                              REG_ANY_invlist,
5835                                              TRUE  /* TRUE => invert */
5836                                              );
5837                             ssc_clear_locale(data->start_class);
5838                         }
5839                         SvREFCNT_dec_NN(REG_ANY_invlist);
5840                     }
5841                     break;
5842
5843                 case ANYOFD:
5844                 case ANYOFL:
5845                 case ANYOFPOSIXL:
5846                 case ANYOFH:
5847                 case ANYOFHb:
5848                 case ANYOF:
5849                     if (flags & SCF_DO_STCLASS_AND)
5850                         ssc_and(pRExC_state, data->start_class,
5851                                 (regnode_charclass *) scan);
5852                     else
5853                         ssc_or(pRExC_state, data->start_class,
5854                                                           (regnode_charclass *) scan);
5855                     break;
5856
5857                 case NANYOFM:
5858                 case ANYOFM:
5859                   {
5860                     SV* cp_list = get_ANYOFM_contents(scan);
5861
5862                     if (flags & SCF_DO_STCLASS_OR) {
5863                         ssc_union(data->start_class, cp_list, invert);
5864                     }
5865                     else if (flags & SCF_DO_STCLASS_AND) {
5866                         ssc_intersection(data->start_class, cp_list, invert);
5867                     }
5868
5869                     SvREFCNT_dec_NN(cp_list);
5870                     break;
5871                   }
5872
5873                 case NPOSIXL:
5874                     invert = 1;
5875                     /* FALLTHROUGH */
5876
5877                 case POSIXL:
5878                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5879                     if (flags & SCF_DO_STCLASS_AND) {
5880                         bool was_there = cBOOL(
5881                                           ANYOF_POSIXL_TEST(data->start_class,
5882                                                                  namedclass));
5883                         ANYOF_POSIXL_ZERO(data->start_class);
5884                         if (was_there) {    /* Do an AND */
5885                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5886                         }
5887                         /* No individual code points can now match */
5888                         data->start_class->invlist
5889                                                 = sv_2mortal(_new_invlist(0));
5890                     }
5891                     else {
5892                         int complement = namedclass + ((invert) ? -1 : 1);
5893
5894                         assert(flags & SCF_DO_STCLASS_OR);
5895
5896                         /* If the complement of this class was already there,
5897                          * the result is that they match all code points,
5898                          * (\d + \D == everything).  Remove the classes from
5899                          * future consideration.  Locale is not relevant in
5900                          * this case */
5901                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5902                             ssc_match_all_cp(data->start_class);
5903                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5904                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5905                         }
5906                         else {  /* The usual case; just add this class to the
5907                                    existing set */
5908                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5909                         }
5910                     }
5911                     break;
5912
5913                 case NPOSIXA:   /* For these, we always know the exact set of
5914                                    what's matched */
5915                     invert = 1;
5916                     /* FALLTHROUGH */
5917                 case POSIXA:
5918                     my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL);
5919                     goto join_posix_and_ascii;
5920
5921                 case NPOSIXD:
5922                 case NPOSIXU:
5923                     invert = 1;
5924                     /* FALLTHROUGH */
5925                 case POSIXD:
5926                 case POSIXU:
5927                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL);
5928
5929                     /* NPOSIXD matches all upper Latin1 code points unless the
5930                      * target string being matched is UTF-8, which is
5931                      * unknowable until match time.  Since we are going to
5932                      * invert, we want to get rid of all of them so that the
5933                      * inversion will match all */
5934                     if (OP(scan) == NPOSIXD) {
5935                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5936                                           &my_invlist);
5937                     }
5938
5939                   join_posix_and_ascii:
5940
5941                     if (flags & SCF_DO_STCLASS_AND) {
5942                         ssc_intersection(data->start_class, my_invlist, invert);
5943                         ssc_clear_locale(data->start_class);
5944                     }
5945                     else {
5946                         assert(flags & SCF_DO_STCLASS_OR);
5947                         ssc_union(data->start_class, my_invlist, invert);
5948                     }
5949                     SvREFCNT_dec(my_invlist);
5950                 }
5951                 if (flags & SCF_DO_STCLASS_OR)
5952                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5953                 flags &= ~SCF_DO_STCLASS;
5954             }
5955         }
5956         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5957             data->flags |= (OP(scan) == MEOL
5958                             ? SF_BEFORE_MEOL
5959                             : SF_BEFORE_SEOL);
5960             scan_commit(pRExC_state, data, minlenp, is_inf);
5961
5962         }
5963         else if (  PL_regkind[OP(scan)] == BRANCHJ
5964                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5965                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5966                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5967         {
5968             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5969                 || OP(scan) == UNLESSM )
5970             {
5971                 /* Negative Lookahead/lookbehind
5972                    In this case we can't do fixed string optimisation.
5973                 */
5974
5975                 SSize_t deltanext, minnext, fake = 0;
5976                 regnode *nscan;
5977                 regnode_ssc intrnl;
5978                 int f = 0;
5979
5980                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5981                 if (data) {
5982                     data_fake.whilem_c = data->whilem_c;
5983                     data_fake.last_closep = data->last_closep;
5984                 }
5985                 else
5986                     data_fake.last_closep = &fake;
5987                 data_fake.pos_delta = delta;
5988                 if ( flags & SCF_DO_STCLASS && !scan->flags
5989                      && OP(scan) == IFMATCH ) { /* Lookahead */
5990                     ssc_init(pRExC_state, &intrnl);
5991                     data_fake.start_class = &intrnl;
5992                     f |= SCF_DO_STCLASS_AND;
5993                 }
5994                 if (flags & SCF_WHILEM_VISITED_POS)
5995                     f |= SCF_WHILEM_VISITED_POS;
5996                 next = regnext(scan);
5997                 nscan = NEXTOPER(NEXTOPER(scan));
5998
5999                 /* recurse study_chunk() for lookahead body */
6000                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
6001                                       last, &data_fake, stopparen,
6002                                       recursed_depth, NULL, f, depth+1);
6003                 if (scan->flags) {
6004                     if (   deltanext < 0
6005                         || deltanext > (I32) U8_MAX
6006                         || minnext > (I32)U8_MAX
6007                         || minnext + deltanext > (I32)U8_MAX)
6008                     {
6009                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6010                               (UV)U8_MAX);
6011                     }
6012
6013                     /* The 'next_off' field has been repurposed to count the
6014                      * additional starting positions to try beyond the initial
6015                      * one.  (This leaves it at 0 for non-variable length
6016                      * matches to avoid breakage for those not using this
6017                      * extension) */
6018                     if (deltanext) {
6019                         scan->next_off = deltanext;
6020                         ckWARNexperimental(RExC_parse,
6021                             WARN_EXPERIMENTAL__VLB,
6022                             "Variable length lookbehind is experimental");
6023                     }
6024                     scan->flags = (U8)minnext + deltanext;
6025                 }
6026                 if (data) {
6027                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6028                         pars++;
6029                     if (data_fake.flags & SF_HAS_EVAL)
6030                         data->flags |= SF_HAS_EVAL;
6031                     data->whilem_c = data_fake.whilem_c;
6032                 }
6033                 if (f & SCF_DO_STCLASS_AND) {
6034                     if (flags & SCF_DO_STCLASS_OR) {
6035                         /* OR before, AND after: ideally we would recurse with
6036                          * data_fake to get the AND applied by study of the
6037                          * remainder of the pattern, and then derecurse;
6038                          * *** HACK *** for now just treat as "no information".
6039                          * See [perl #56690].
6040                          */
6041                         ssc_init(pRExC_state, data->start_class);
6042                     }  else {
6043                         /* AND before and after: combine and continue.  These
6044                          * assertions are zero-length, so can match an EMPTY
6045                          * string */
6046                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6047                         ANYOF_FLAGS(data->start_class)
6048                                                    |= SSC_MATCHES_EMPTY_STRING;
6049                     }
6050                 }
6051             }
6052 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
6053             else {
6054                 /* Positive Lookahead/lookbehind
6055                    In this case we can do fixed string optimisation,
6056                    but we must be careful about it. Note in the case of
6057                    lookbehind the positions will be offset by the minimum
6058                    length of the pattern, something we won't know about
6059                    until after the recurse.
6060                 */
6061                 SSize_t deltanext, fake = 0;
6062                 regnode *nscan;
6063                 regnode_ssc intrnl;
6064                 int f = 0;
6065                 /* We use SAVEFREEPV so that when the full compile
6066                     is finished perl will clean up the allocated
6067                     minlens when it's all done. This way we don't
6068                     have to worry about freeing them when we know
6069                     they wont be used, which would be a pain.
6070                  */
6071                 SSize_t *minnextp;
6072                 Newx( minnextp, 1, SSize_t );
6073                 SAVEFREEPV(minnextp);
6074
6075                 if (data) {
6076                     StructCopy(data, &data_fake, scan_data_t);
6077                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
6078                         f |= SCF_DO_SUBSTR;
6079                         if (scan->flags)
6080                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
6081                         data_fake.last_found=newSVsv(data->last_found);
6082                     }
6083                 }
6084                 else
6085                     data_fake.last_closep = &fake;
6086                 data_fake.flags = 0;
6087                 data_fake.substrs[0].flags = 0;
6088                 data_fake.substrs[1].flags = 0;
6089                 data_fake.pos_delta = delta;
6090                 if (is_inf)
6091                     data_fake.flags |= SF_IS_INF;
6092                 if ( flags & SCF_DO_STCLASS && !scan->flags
6093                      && OP(scan) == IFMATCH ) { /* Lookahead */
6094                     ssc_init(pRExC_state, &intrnl);
6095                     data_fake.start_class = &intrnl;
6096                     f |= SCF_DO_STCLASS_AND;
6097                 }
6098                 if (flags & SCF_WHILEM_VISITED_POS)
6099                     f |= SCF_WHILEM_VISITED_POS;
6100                 next = regnext(scan);
6101                 nscan = NEXTOPER(NEXTOPER(scan));
6102
6103                 /* positive lookahead study_chunk() recursion */
6104                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
6105                                         &deltanext, last, &data_fake,
6106                                         stopparen, recursed_depth, NULL,
6107                                         f, depth+1);
6108                 if (scan->flags) {
6109                     assert(0);  /* This code has never been tested since this
6110                                    is normally not compiled */
6111                     if (   deltanext < 0
6112                         || deltanext > (I32) U8_MAX
6113                         || *minnextp > (I32)U8_MAX
6114                         || *minnextp + deltanext > (I32)U8_MAX)
6115                     {
6116                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6117                               (UV)U8_MAX);
6118                     }
6119
6120                     if (deltanext) {
6121                         scan->next_off = deltanext;
6122                     }
6123                     scan->flags = (U8)*minnextp + deltanext;
6124                 }
6125
6126                 *minnextp += min;
6127
6128                 if (f & SCF_DO_STCLASS_AND) {
6129                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6130                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
6131                 }
6132                 if (data) {
6133                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6134                         pars++;
6135                     if (data_fake.flags & SF_HAS_EVAL)
6136                         data->flags |= SF_HAS_EVAL;
6137                     data->whilem_c = data_fake.whilem_c;
6138                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
6139                         int i;
6140                         if (RExC_rx->minlen<*minnextp)
6141                             RExC_rx->minlen=*minnextp;
6142                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
6143                         SvREFCNT_dec_NN(data_fake.last_found);
6144
6145                         for (i = 0; i < 2; i++) {
6146                             if (data_fake.substrs[i].minlenp != minlenp) {
6147                                 data->substrs[i].min_offset =
6148                                             data_fake.substrs[i].min_offset;
6149                                 data->substrs[i].max_offset =
6150                                             data_fake.substrs[i].max_offset;
6151                                 data->substrs[i].minlenp =
6152                                             data_fake.substrs[i].minlenp;
6153                                 data->substrs[i].lookbehind += scan->flags;
6154                             }
6155                         }
6156                     }
6157                 }
6158             }
6159 #endif
6160         }
6161
6162         else if (OP(scan) == OPEN) {
6163             if (stopparen != (I32)ARG(scan))
6164                 pars++;
6165         }
6166         else if (OP(scan) == CLOSE) {
6167             if (stopparen == (I32)ARG(scan)) {
6168                 break;
6169             }
6170             if ((I32)ARG(scan) == is_par) {
6171                 next = regnext(scan);
6172
6173                 if ( next && (OP(next) != WHILEM) && next < last)
6174                     is_par = 0;         /* Disable optimization */
6175             }
6176             if (data)
6177                 *(data->last_closep) = ARG(scan);
6178         }
6179         else if (OP(scan) == EVAL) {
6180                 if (data)
6181                     data->flags |= SF_HAS_EVAL;
6182         }
6183         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
6184             if (flags & SCF_DO_SUBSTR) {
6185                 scan_commit(pRExC_state, data, minlenp, is_inf);
6186                 flags &= ~SCF_DO_SUBSTR;
6187             }
6188             if (data && OP(scan)==ACCEPT) {
6189                 data->flags |= SCF_SEEN_ACCEPT;
6190                 if (stopmin > min)
6191                     stopmin = min;
6192             }
6193         }
6194         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
6195         {
6196                 if (flags & SCF_DO_SUBSTR) {
6197                     scan_commit(pRExC_state, data, minlenp, is_inf);
6198                     data->cur_is_floating = 1; /* float */
6199                 }
6200                 is_inf = is_inf_internal = 1;
6201                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
6202                     ssc_anything(data->start_class);
6203                 flags &= ~SCF_DO_STCLASS;
6204         }
6205         else if (OP(scan) == GPOS) {
6206             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
6207                 !(delta || is_inf || (data && data->pos_delta)))
6208             {
6209                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
6210                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
6211                 if (RExC_rx->gofs < (STRLEN)min)
6212                     RExC_rx->gofs = min;
6213             } else {
6214                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
6215                 RExC_rx->gofs = 0;
6216             }
6217         }
6218 #ifdef TRIE_STUDY_OPT
6219 #ifdef FULL_TRIE_STUDY
6220         else if (PL_regkind[OP(scan)] == TRIE) {
6221             /* NOTE - There is similar code to this block above for handling
6222                BRANCH nodes on the initial study.  If you change stuff here
6223                check there too. */
6224             regnode *trie_node= scan;
6225             regnode *tail= regnext(scan);
6226             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6227             SSize_t max1 = 0, min1 = SSize_t_MAX;
6228             regnode_ssc accum;
6229
6230             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
6231                 /* Cannot merge strings after this. */
6232                 scan_commit(pRExC_state, data, minlenp, is_inf);
6233             }
6234             if (flags & SCF_DO_STCLASS)
6235                 ssc_init_zero(pRExC_state, &accum);
6236
6237             if (!trie->jump) {
6238                 min1= trie->minlen;
6239                 max1= trie->maxlen;
6240             } else {
6241                 const regnode *nextbranch= NULL;
6242                 U32 word;
6243
6244                 for ( word=1 ; word <= trie->wordcount ; word++)
6245                 {
6246                     SSize_t deltanext=0, minnext=0, f = 0, fake;
6247                     regnode_ssc this_class;
6248
6249                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
6250                     if (data) {
6251                         data_fake.whilem_c = data->whilem_c;
6252                         data_fake.last_closep = data->last_closep;
6253                     }
6254                     else
6255                         data_fake.last_closep = &fake;
6256                     data_fake.pos_delta = delta;
6257                     if (flags & SCF_DO_STCLASS) {
6258                         ssc_init(pRExC_state, &this_class);
6259                         data_fake.start_class = &this_class;
6260                         f = SCF_DO_STCLASS_AND;
6261                     }
6262                     if (flags & SCF_WHILEM_VISITED_POS)
6263                         f |= SCF_WHILEM_VISITED_POS;
6264
6265                     if (trie->jump[word]) {
6266                         if (!nextbranch)
6267                             nextbranch = trie_node + trie->jump[0];
6268                         scan= trie_node + trie->jump[word];
6269                         /* We go from the jump point to the branch that follows
6270                            it. Note this means we need the vestigal unused
6271                            branches even though they arent otherwise used. */
6272                         /* optimise study_chunk() for TRIE */
6273                         minnext = study_chunk(pRExC_state, &scan, minlenp,
6274                             &deltanext, (regnode *)nextbranch, &data_fake,
6275                             stopparen, recursed_depth, NULL, f, depth+1);
6276                     }
6277                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
6278                         nextbranch= regnext((regnode*)nextbranch);
6279
6280                     if (min1 > (SSize_t)(minnext + trie->minlen))
6281                         min1 = minnext + trie->minlen;
6282                     if (deltanext == SSize_t_MAX) {
6283                         is_inf = is_inf_internal = 1;
6284                         max1 = SSize_t_MAX;
6285                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
6286                         max1 = minnext + deltanext + trie->maxlen;
6287
6288                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6289                         pars++;
6290                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
6291                         if ( stopmin > min + min1)
6292                             stopmin = min + min1;
6293                         flags &= ~SCF_DO_SUBSTR;
6294                         if (data)
6295                             data->flags |= SCF_SEEN_ACCEPT;
6296                     }
6297                     if (data) {
6298                         if (data_fake.flags & SF_HAS_EVAL)
6299                             data->flags |= SF_HAS_EVAL;
6300                         data->whilem_c = data_fake.whilem_c;
6301                     }
6302                     if (flags & SCF_DO_STCLASS)
6303                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
6304                 }
6305             }
6306             if (flags & SCF_DO_SUBSTR) {
6307                 data->pos_min += min1;
6308                 data->pos_delta += max1 - min1;
6309                 if (max1 != min1 || is_inf)
6310                     data->cur_is_floating = 1; /* float */
6311             }
6312             min += min1;
6313             if (delta != SSize_t_MAX) {
6314                 if (SSize_t_MAX - (max1 - min1) >= delta)
6315                     delta += max1 - min1;
6316                 else
6317                     delta = SSize_t_MAX;
6318             }
6319             if (flags & SCF_DO_STCLASS_OR) {
6320                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6321                 if (min1) {
6322                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6323                     flags &= ~SCF_DO_STCLASS;
6324                 }
6325             }
6326             else if (flags & SCF_DO_STCLASS_AND) {
6327                 if (min1) {
6328                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6329                     flags &= ~SCF_DO_STCLASS;
6330                 }
6331                 else {
6332                     /* Switch to OR mode: cache the old value of
6333                      * data->start_class */
6334                     INIT_AND_WITHP;
6335                     StructCopy(data->start_class, and_withp, regnode_ssc);
6336                     flags &= ~SCF_DO_STCLASS_AND;
6337                     StructCopy(&accum, data->start_class, regnode_ssc);
6338                     flags |= SCF_DO_STCLASS_OR;
6339                 }
6340             }
6341             scan= tail;
6342             continue;
6343         }
6344 #else
6345         else if (PL_regkind[OP(scan)] == TRIE) {
6346             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6347             U8*bang=NULL;
6348
6349             min += trie->minlen;
6350             delta += (trie->maxlen - trie->minlen);
6351             flags &= ~SCF_DO_STCLASS; /* xxx */
6352             if (flags & SCF_DO_SUBSTR) {
6353                 /* Cannot expect anything... */
6354                 scan_commit(pRExC_state, data, minlenp, is_inf);
6355                 data->pos_min += trie->minlen;
6356                 data->pos_delta += (trie->maxlen - trie->minlen);
6357                 if (trie->maxlen != trie->minlen)
6358                     data->cur_is_floating = 1; /* float */
6359             }
6360             if (trie->jump) /* no more substrings -- for now /grr*/
6361                flags &= ~SCF_DO_SUBSTR;
6362         }
6363 #endif /* old or new */
6364 #endif /* TRIE_STUDY_OPT */
6365
6366         /* Else: zero-length, ignore. */
6367         scan = regnext(scan);
6368     }
6369
6370   finish:
6371     if (frame) {
6372         /* we need to unwind recursion. */
6373         depth = depth - 1;
6374
6375         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
6376         DEBUG_PEEP("fend", scan, depth, flags);
6377
6378         /* restore previous context */
6379         last = frame->last_regnode;
6380         scan = frame->next_regnode;
6381         stopparen = frame->stopparen;
6382         recursed_depth = frame->prev_recursed_depth;
6383
6384         RExC_frame_last = frame->prev_frame;
6385         frame = frame->this_prev_frame;
6386         goto fake_study_recurse;
6387     }
6388
6389     assert(!frame);
6390     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6391
6392     *scanp = scan;
6393     *deltap = is_inf_internal ? SSize_t_MAX : delta;
6394
6395     if (flags & SCF_DO_SUBSTR && is_inf)
6396         data->pos_delta = SSize_t_MAX - data->pos_min;
6397     if (is_par > (I32)U8_MAX)
6398         is_par = 0;
6399     if (is_par && pars==1 && data) {
6400         data->flags |= SF_IN_PAR;
6401         data->flags &= ~SF_HAS_PAR;
6402     }
6403     else if (pars && data) {
6404         data->flags |= SF_HAS_PAR;
6405         data->flags &= ~SF_IN_PAR;
6406     }
6407     if (flags & SCF_DO_STCLASS_OR)
6408         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6409     if (flags & SCF_TRIE_RESTUDY)
6410         data->flags |=  SCF_TRIE_RESTUDY;
6411
6412     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6413
6414     {
6415         SSize_t final_minlen= min < stopmin ? min : stopmin;
6416
6417         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6418             if (final_minlen > SSize_t_MAX - delta)
6419                 RExC_maxlen = SSize_t_MAX;
6420             else if (RExC_maxlen < final_minlen + delta)
6421                 RExC_maxlen = final_minlen + delta;
6422         }
6423         return final_minlen;
6424     }
6425     NOT_REACHED; /* NOTREACHED */
6426 }
6427
6428 STATIC U32
6429 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6430 {
6431     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6432
6433     PERL_ARGS_ASSERT_ADD_DATA;
6434
6435     Renewc(RExC_rxi->data,
6436            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6437            char, struct reg_data);
6438     if(count)
6439         Renew(RExC_rxi->data->what, count + n, U8);
6440     else
6441         Newx(RExC_rxi->data->what, n, U8);
6442     RExC_rxi->data->count = count + n;
6443     Copy(s, RExC_rxi->data->what + count, n, U8);
6444     return count;
6445 }
6446
6447 /*XXX: todo make this not included in a non debugging perl, but appears to be
6448  * used anyway there, in 'use re' */
6449 #ifndef PERL_IN_XSUB_RE
6450 void
6451 Perl_reginitcolors(pTHX)
6452 {
6453     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6454     if (s) {
6455         char *t = savepv(s);
6456         int i = 0;
6457         PL_colors[0] = t;
6458         while (++i < 6) {
6459             t = strchr(t, '\t');
6460             if (t) {
6461                 *t = '\0';
6462                 PL_colors[i] = ++t;
6463             }
6464             else
6465                 PL_colors[i] = t = (char *)"";
6466         }
6467     } else {
6468         int i = 0;
6469         while (i < 6)
6470             PL_colors[i++] = (char *)"";
6471     }
6472     PL_colorset = 1;
6473 }
6474 #endif
6475
6476
6477 #ifdef TRIE_STUDY_OPT
6478 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6479     STMT_START {                                            \
6480         if (                                                \
6481               (data.flags & SCF_TRIE_RESTUDY)               \
6482               && ! restudied++                              \
6483         ) {                                                 \
6484             dOsomething;                                    \
6485             goto reStudy;                                   \
6486         }                                                   \
6487     } STMT_END
6488 #else
6489 #define CHECK_RESTUDY_GOTO_butfirst
6490 #endif
6491
6492 /*
6493  * pregcomp - compile a regular expression into internal code
6494  *
6495  * Decides which engine's compiler to call based on the hint currently in
6496  * scope
6497  */
6498
6499 #ifndef PERL_IN_XSUB_RE
6500
6501 /* return the currently in-scope regex engine (or the default if none)  */
6502
6503 regexp_engine const *
6504 Perl_current_re_engine(pTHX)
6505 {
6506     if (IN_PERL_COMPILETIME) {
6507         HV * const table = GvHV(PL_hintgv);
6508         SV **ptr;
6509
6510         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6511             return &PL_core_reg_engine;
6512         ptr = hv_fetchs(table, "regcomp", FALSE);
6513         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6514             return &PL_core_reg_engine;
6515         return INT2PTR(regexp_engine*, SvIV(*ptr));
6516     }
6517     else {
6518         SV *ptr;
6519         if (!PL_curcop->cop_hints_hash)
6520             return &PL_core_reg_engine;
6521         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6522         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6523             return &PL_core_reg_engine;
6524         return INT2PTR(regexp_engine*, SvIV(ptr));
6525     }
6526 }
6527
6528
6529 REGEXP *
6530 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6531 {
6532     regexp_engine const *eng = current_re_engine();
6533     GET_RE_DEBUG_FLAGS_DECL;
6534
6535     PERL_ARGS_ASSERT_PREGCOMP;
6536
6537     /* Dispatch a request to compile a regexp to correct regexp engine. */
6538     DEBUG_COMPILE_r({
6539         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6540                         PTR2UV(eng));
6541     });
6542     return CALLREGCOMP_ENG(eng, pattern, flags);
6543 }
6544 #endif
6545
6546 /* public(ish) entry point for the perl core's own regex compiling code.
6547  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6548  * pattern rather than a list of OPs, and uses the internal engine rather
6549  * than the current one */
6550
6551 REGEXP *
6552 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6553 {
6554     SV *pat = pattern; /* defeat constness! */
6555     PERL_ARGS_ASSERT_RE_COMPILE;
6556     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6557 #ifdef PERL_IN_XSUB_RE
6558                                 &my_reg_engine,
6559 #else
6560                                 &PL_core_reg_engine,
6561 #endif
6562                                 NULL, NULL, rx_flags, 0);
6563 }
6564
6565
6566 static void
6567 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6568 {
6569     int n;
6570
6571     if (--cbs->refcnt > 0)
6572         return;
6573     for (n = 0; n < cbs->count; n++) {
6574         REGEXP *rx = cbs->cb[n].src_regex;
6575         if (rx) {
6576             cbs->cb[n].src_regex = NULL;
6577             SvREFCNT_dec_NN(rx);
6578         }
6579     }
6580     Safefree(cbs->cb);
6581     Safefree(cbs);
6582 }
6583
6584
6585 static struct reg_code_blocks *
6586 S_alloc_code_blocks(pTHX_  int ncode)
6587 {
6588      struct reg_code_blocks *cbs;
6589     Newx(cbs, 1, struct reg_code_blocks);
6590     cbs->count = ncode;
6591     cbs->refcnt = 1;
6592     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6593     if (ncode)
6594         Newx(cbs->cb, ncode, struct reg_code_block);
6595     else
6596         cbs->cb = NULL;
6597     return cbs;
6598 }
6599
6600
6601 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6602  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6603  * point to the realloced string and length.
6604  *
6605  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6606  * stuff added */
6607
6608 static void
6609 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6610                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6611 {
6612     U8 *const src = (U8*)*pat_p;
6613     U8 *dst, *d;
6614     int n=0;
6615     STRLEN s = 0;
6616     bool do_end = 0;
6617     GET_RE_DEBUG_FLAGS_DECL;
6618
6619     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6620         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6621
6622     /* 1 for each byte + 1 for each byte that expands to two, + trailing NUL */
6623     Newx(dst, *plen_p + variant_under_utf8_count(src, src + *plen_p) + 1, U8);
6624     d = dst;
6625
6626     while (s < *plen_p) {
6627         append_utf8_from_native_byte(src[s], &d);
6628
6629         if (n < num_code_blocks) {
6630             assert(pRExC_state->code_blocks);
6631             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6632                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6633                 assert(*(d - 1) == '(');
6634                 do_end = 1;
6635             }
6636             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6637                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6638                 assert(*(d - 1) == ')');
6639                 do_end = 0;
6640                 n++;
6641             }
6642         }
6643         s++;
6644     }
6645     *d = '\0';
6646     *plen_p = d - dst;
6647     *pat_p = (char*) dst;
6648     SAVEFREEPV(*pat_p);
6649     RExC_orig_utf8 = RExC_utf8 = 1;
6650 }
6651
6652
6653
6654 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6655  * while recording any code block indices, and handling overloading,
6656  * nested qr// objects etc.  If pat is null, it will allocate a new
6657  * string, or just return the first arg, if there's only one.
6658  *
6659  * Returns the malloced/updated pat.
6660  * patternp and pat_count is the array of SVs to be concatted;
6661  * oplist is the optional list of ops that generated the SVs;
6662  * recompile_p is a pointer to a boolean that will be set if
6663  *   the regex will need to be recompiled.
6664  * delim, if non-null is an SV that will be inserted between each element
6665  */
6666
6667 static SV*
6668 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6669                 SV *pat, SV ** const patternp, int pat_count,
6670                 OP *oplist, bool *recompile_p, SV *delim)
6671 {
6672     SV **svp;
6673     int n = 0;
6674     bool use_delim = FALSE;
6675     bool alloced = FALSE;
6676
6677     /* if we know we have at least two args, create an empty string,
6678      * then concatenate args to that. For no args, return an empty string */
6679     if (!pat && pat_count != 1) {
6680         pat = newSVpvs("");
6681         SAVEFREESV(pat);
6682         alloced = TRUE;
6683     }
6684
6685     for (svp = patternp; svp < patternp + pat_count; svp++) {
6686         SV *sv;
6687         SV *rx  = NULL;
6688         STRLEN orig_patlen = 0;
6689         bool code = 0;
6690         SV *msv = use_delim ? delim : *svp;
6691         if (!msv) msv = &PL_sv_undef;
6692
6693         /* if we've got a delimiter, we go round the loop twice for each
6694          * svp slot (except the last), using the delimiter the second
6695          * time round */
6696         if (use_delim) {
6697             svp--;
6698             use_delim = FALSE;
6699         }
6700         else if (delim)
6701             use_delim = TRUE;
6702
6703         if (SvTYPE(msv) == SVt_PVAV) {
6704             /* we've encountered an interpolated array within
6705              * the pattern, e.g. /...@a..../. Expand the list of elements,
6706              * then recursively append elements.
6707              * The code in this block is based on S_pushav() */
6708
6709             AV *const av = (AV*)msv;
6710             const SSize_t maxarg = AvFILL(av) + 1;
6711             SV **array;
6712
6713             if (oplist) {
6714                 assert(oplist->op_type == OP_PADAV
6715                     || oplist->op_type == OP_RV2AV);
6716                 oplist = OpSIBLING(oplist);
6717             }
6718
6719             if (SvRMAGICAL(av)) {
6720                 SSize_t i;
6721
6722                 Newx(array, maxarg, SV*);
6723                 SAVEFREEPV(array);
6724                 for (i=0; i < maxarg; i++) {
6725                     SV ** const svp = av_fetch(av, i, FALSE);
6726                     array[i] = svp ? *svp : &PL_sv_undef;
6727                 }
6728             }
6729             else
6730                 array = AvARRAY(av);
6731
6732             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6733                                 array, maxarg, NULL, recompile_p,
6734                                 /* $" */
6735                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6736
6737             continue;
6738         }
6739
6740
6741         /* we make the assumption here that each op in the list of
6742          * op_siblings maps to one SV pushed onto the stack,
6743          * except for code blocks, with have both an OP_NULL and
6744          * and OP_CONST.
6745          * This allows us to match up the list of SVs against the
6746          * list of OPs to find the next code block.
6747          *
6748          * Note that       PUSHMARK PADSV PADSV ..
6749          * is optimised to
6750          *                 PADRANGE PADSV  PADSV  ..
6751          * so the alignment still works. */
6752
6753         if (oplist) {
6754             if (oplist->op_type == OP_NULL
6755                 && (oplist->op_flags & OPf_SPECIAL))
6756             {
6757                 assert(n < pRExC_state->code_blocks->count);
6758                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6759                 pRExC_state->code_blocks->cb[n].block = oplist;
6760                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6761                 n++;
6762                 code = 1;
6763                 oplist = OpSIBLING(oplist); /* skip CONST */
6764                 assert(oplist);
6765             }
6766             oplist = OpSIBLING(oplist);;
6767         }
6768
6769         /* apply magic and QR overloading to arg */
6770
6771         SvGETMAGIC(msv);
6772         if (SvROK(msv) && SvAMAGIC(msv)) {
6773             SV *sv = AMG_CALLunary(msv, regexp_amg);
6774             if (sv) {
6775                 if (SvROK(sv))
6776                     sv = SvRV(sv);
6777                 if (SvTYPE(sv) != SVt_REGEXP)
6778                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6779                 msv = sv;
6780             }
6781         }
6782
6783         /* try concatenation overload ... */
6784         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6785                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6786         {
6787             sv_setsv(pat, sv);
6788             /* overloading involved: all bets are off over literal
6789              * code. Pretend we haven't seen it */
6790             if (n)
6791                 pRExC_state->code_blocks->count -= n;
6792             n = 0;
6793         }
6794         else  {
6795             /* ... or failing that, try "" overload */
6796             while (SvAMAGIC(msv)
6797                     && (sv = AMG_CALLunary(msv, string_amg))
6798                     && sv != msv
6799                     &&  !(   SvROK(msv)
6800                           && SvROK(sv)
6801                           && SvRV(msv) == SvRV(sv))
6802             ) {
6803                 msv = sv;
6804                 SvGETMAGIC(msv);
6805             }
6806             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6807                 msv = SvRV(msv);
6808
6809             if (pat) {
6810                 /* this is a partially unrolled
6811                  *     sv_catsv_nomg(pat, msv);
6812                  * that allows us to adjust code block indices if
6813                  * needed */
6814                 STRLEN dlen;
6815                 char *dst = SvPV_force_nomg(pat, dlen);
6816                 orig_patlen = dlen;
6817                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6818                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6819                     sv_setpvn(pat, dst, dlen);
6820                     SvUTF8_on(pat);
6821                 }
6822                 sv_catsv_nomg(pat, msv);
6823                 rx = msv;
6824             }
6825             else {
6826                 /* We have only one SV to process, but we need to verify
6827                  * it is properly null terminated or we will fail asserts
6828                  * later. In theory we probably shouldn't get such SV's,
6829                  * but if we do we should handle it gracefully. */
6830                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
6831                     /* not a string, or a string with a trailing null */
6832                     pat = msv;
6833                 } else {
6834                     /* a string with no trailing null, we need to copy it
6835                      * so it has a trailing null */
6836                     pat = sv_2mortal(newSVsv(msv));
6837                 }
6838             }
6839
6840             if (code)
6841                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6842         }
6843
6844         /* extract any code blocks within any embedded qr//'s */
6845         if (rx && SvTYPE(rx) == SVt_REGEXP
6846             && RX_ENGINE((REGEXP*)rx)->op_comp)
6847         {
6848
6849             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6850             if (ri->code_blocks && ri->code_blocks->count) {
6851                 int i;
6852                 /* the presence of an embedded qr// with code means
6853                  * we should always recompile: the text of the
6854                  * qr// may not have changed, but it may be a
6855                  * different closure than last time */
6856                 *recompile_p = 1;
6857                 if (pRExC_state->code_blocks) {
6858                     int new_count = pRExC_state->code_blocks->count
6859                             + ri->code_blocks->count;
6860                     Renew(pRExC_state->code_blocks->cb,
6861                             new_count, struct reg_code_block);
6862                     pRExC_state->code_blocks->count = new_count;
6863                 }
6864                 else
6865                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6866                                                     ri->code_blocks->count);
6867
6868                 for (i=0; i < ri->code_blocks->count; i++) {
6869                     struct reg_code_block *src, *dst;
6870                     STRLEN offset =  orig_patlen
6871                         + ReANY((REGEXP *)rx)->pre_prefix;
6872                     assert(n < pRExC_state->code_blocks->count);
6873                     src = &ri->code_blocks->cb[i];
6874                     dst = &pRExC_state->code_blocks->cb[n];
6875                     dst->start      = src->start + offset;
6876                     dst->end        = src->end   + offset;
6877                     dst->block      = src->block;
6878                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6879                                             src->src_regex
6880                                                 ? src->src_regex
6881                                                 : (REGEXP*)rx);
6882                     n++;
6883                 }
6884             }
6885         }
6886     }
6887     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6888     if (alloced)
6889         SvSETMAGIC(pat);
6890
6891     return pat;
6892 }
6893
6894
6895
6896 /* see if there are any run-time code blocks in the pattern.
6897  * False positives are allowed */
6898
6899 static bool
6900 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6901                     char *pat, STRLEN plen)
6902 {
6903     int n = 0;
6904     STRLEN s;
6905
6906     PERL_UNUSED_CONTEXT;
6907
6908     for (s = 0; s < plen; s++) {
6909         if (   pRExC_state->code_blocks
6910             && n < pRExC_state->code_blocks->count
6911             && s == pRExC_state->code_blocks->cb[n].start)
6912         {
6913             s = pRExC_state->code_blocks->cb[n].end;
6914             n++;
6915             continue;
6916         }
6917         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6918          * positives here */
6919         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6920             (pat[s+2] == '{'
6921                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6922         )
6923             return 1;
6924     }
6925     return 0;
6926 }
6927
6928 /* Handle run-time code blocks. We will already have compiled any direct
6929  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6930  * copy of it, but with any literal code blocks blanked out and
6931  * appropriate chars escaped; then feed it into
6932  *
6933  *    eval "qr'modified_pattern'"
6934  *
6935  * For example,
6936  *
6937  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6938  *
6939  * becomes
6940  *
6941  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6942  *
6943  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6944  * and merge them with any code blocks of the original regexp.
6945  *
6946  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6947  * instead, just save the qr and return FALSE; this tells our caller that
6948  * the original pattern needs upgrading to utf8.
6949  */
6950
6951 static bool
6952 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6953     char *pat, STRLEN plen)
6954 {
6955     SV *qr;
6956
6957     GET_RE_DEBUG_FLAGS_DECL;
6958
6959     if (pRExC_state->runtime_code_qr) {
6960         /* this is the second time we've been called; this should
6961          * only happen if the main pattern got upgraded to utf8
6962          * during compilation; re-use the qr we compiled first time
6963          * round (which should be utf8 too)
6964          */
6965         qr = pRExC_state->runtime_code_qr;
6966         pRExC_state->runtime_code_qr = NULL;
6967         assert(RExC_utf8 && SvUTF8(qr));
6968     }
6969     else {
6970         int n = 0;
6971         STRLEN s;
6972         char *p, *newpat;
6973         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6974         SV *sv, *qr_ref;
6975         dSP;
6976
6977         /* determine how many extra chars we need for ' and \ escaping */
6978         for (s = 0; s < plen; s++) {
6979             if (pat[s] == '\'' || pat[s] == '\\')
6980                 newlen++;
6981         }
6982
6983         Newx(newpat, newlen, char);
6984         p = newpat;
6985         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6986
6987         for (s = 0; s < plen; s++) {
6988             if (   pRExC_state->code_blocks
6989                 && n < pRExC_state->code_blocks->count
6990                 && s == pRExC_state->code_blocks->cb[n].start)
6991             {
6992                 /* blank out literal code block so that they aren't
6993                  * recompiled: eg change from/to:
6994                  *     /(?{xyz})/
6995                  *     /(?=====)/
6996                  * and
6997                  *     /(??{xyz})/
6998                  *     /(?======)/
6999                  * and
7000                  *     /(?(?{xyz}))/
7001                  *     /(?(?=====))/
7002                 */
7003                 assert(pat[s]   == '(');
7004                 assert(pat[s+1] == '?');
7005                 *p++ = '(';
7006                 *p++ = '?';
7007                 s += 2;
7008                 while (s < pRExC_state->code_blocks->cb[n].end) {
7009                     *p++ = '=';
7010                     s++;
7011                 }
7012                 *p++ = ')';
7013                 n++;
7014                 continue;
7015             }
7016             if (pat[s] == '\'' || pat[s] == '\\')
7017                 *p++ = '\\';
7018             *p++ = pat[s];
7019         }
7020         *p++ = '\'';
7021         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
7022             *p++ = 'x';
7023             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
7024                 *p++ = 'x';
7025             }
7026         }
7027         *p++ = '\0';
7028         DEBUG_COMPILE_r({
7029             Perl_re_printf( aTHX_
7030                 "%sre-parsing pattern for runtime code:%s %s\n",
7031                 PL_colors[4], PL_colors[5], newpat);
7032         });
7033
7034         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
7035         Safefree(newpat);
7036
7037         ENTER;
7038         SAVETMPS;
7039         save_re_context();
7040         PUSHSTACKi(PERLSI_REQUIRE);
7041         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
7042          * parsing qr''; normally only q'' does this. It also alters
7043          * hints handling */
7044         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
7045         SvREFCNT_dec_NN(sv);
7046         SPAGAIN;
7047         qr_ref = POPs;
7048         PUTBACK;
7049         {
7050             SV * const errsv = ERRSV;
7051             if (SvTRUE_NN(errsv))
7052                 /* use croak_sv ? */
7053                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
7054         }
7055         assert(SvROK(qr_ref));
7056         qr = SvRV(qr_ref);
7057         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
7058         /* the leaving below frees the tmp qr_ref.
7059          * Give qr a life of its own */
7060         SvREFCNT_inc(qr);
7061         POPSTACK;
7062         FREETMPS;
7063         LEAVE;
7064
7065     }
7066
7067     if (!RExC_utf8 && SvUTF8(qr)) {
7068         /* first time through; the pattern got upgraded; save the
7069          * qr for the next time through */
7070         assert(!pRExC_state->runtime_code_qr);
7071         pRExC_state->runtime_code_qr = qr;
7072         return 0;
7073     }
7074
7075
7076     /* extract any code blocks within the returned qr//  */
7077
7078
7079     /* merge the main (r1) and run-time (r2) code blocks into one */
7080     {
7081         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
7082         struct reg_code_block *new_block, *dst;
7083         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
7084         int i1 = 0, i2 = 0;
7085         int r1c, r2c;
7086
7087         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
7088         {
7089             SvREFCNT_dec_NN(qr);
7090             return 1;
7091         }
7092
7093         if (!r1->code_blocks)
7094             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
7095
7096         r1c = r1->code_blocks->count;
7097         r2c = r2->code_blocks->count;
7098
7099         Newx(new_block, r1c + r2c, struct reg_code_block);
7100
7101         dst = new_block;
7102
7103         while (i1 < r1c || i2 < r2c) {
7104             struct reg_code_block *src;
7105             bool is_qr = 0;
7106
7107             if (i1 == r1c) {
7108                 src = &r2->code_blocks->cb[i2++];
7109                 is_qr = 1;
7110             }
7111             else if (i2 == r2c)
7112                 src = &r1->code_blocks->cb[i1++];
7113             else if (  r1->code_blocks->cb[i1].start
7114                      < r2->code_blocks->cb[i2].start)
7115             {
7116                 src = &r1->code_blocks->cb[i1++];
7117                 assert(src->end < r2->code_blocks->cb[i2].start);
7118             }
7119             else {
7120                 assert(  r1->code_blocks->cb[i1].start
7121                        > r2->code_blocks->cb[i2].start);
7122                 src = &r2->code_blocks->cb[i2++];
7123                 is_qr = 1;
7124                 assert(src->end < r1->code_blocks->cb[i1].start);
7125             }
7126
7127             assert(pat[src->start] == '(');
7128             assert(pat[src->end]   == ')');
7129             dst->start      = src->start;
7130             dst->end        = src->end;
7131             dst->block      = src->block;
7132             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
7133                                     : src->src_regex;
7134             dst++;
7135         }
7136         r1->code_blocks->count += r2c;
7137         Safefree(r1->code_blocks->cb);
7138         r1->code_blocks->cb = new_block;
7139     }
7140
7141     SvREFCNT_dec_NN(qr);
7142     return 1;
7143 }
7144
7145
7146 STATIC bool
7147 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
7148                       struct reg_substr_datum  *rsd,
7149                       struct scan_data_substrs *sub,
7150                       STRLEN longest_length)
7151 {
7152     /* This is the common code for setting up the floating and fixed length
7153      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
7154      * as to whether succeeded or not */
7155
7156     I32 t;
7157     SSize_t ml;
7158     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
7159     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
7160
7161     if (! (longest_length
7162            || (eol /* Can't have SEOL and MULTI */
7163                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
7164           )
7165             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
7166         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
7167     {
7168         return FALSE;
7169     }
7170
7171     /* copy the information about the longest from the reg_scan_data
7172         over to the program. */
7173     if (SvUTF8(sub->str)) {
7174         rsd->substr      = NULL;
7175         rsd->utf8_substr = sub->str;
7176     } else {
7177         rsd->substr      = sub->str;
7178         rsd->utf8_substr = NULL;
7179     }
7180     /* end_shift is how many chars that must be matched that
7181         follow this item. We calculate it ahead of time as once the
7182         lookbehind offset is added in we lose the ability to correctly
7183         calculate it.*/
7184     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
7185     rsd->end_shift = ml - sub->min_offset
7186         - longest_length
7187             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
7188              * intead? - DAPM
7189             + (SvTAIL(sub->str) != 0)
7190             */
7191         + sub->lookbehind;
7192
7193     t = (eol/* Can't have SEOL and MULTI */
7194          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
7195     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
7196
7197     return TRUE;
7198 }
7199
7200 STATIC void
7201 S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx)
7202 {
7203     /* Calculates and sets in the compiled pattern 'Rx' the string to compile,
7204      * properly wrapped with the right modifiers */
7205
7206     bool has_p     = ((RExC_rx->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7207     bool has_charset = RExC_utf8 || (get_regex_charset(RExC_rx->extflags)
7208                                                 != REGEX_DEPENDS_CHARSET);
7209
7210     /* The caret is output if there are any defaults: if not all the STD
7211         * flags are set, or if no character set specifier is needed */
7212     bool has_default =
7213                 (((RExC_rx->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7214                 || ! has_charset);
7215     bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7216                                                 == REG_RUN_ON_COMMENT_SEEN);
7217     U8 reganch = (U8)((RExC_rx->extflags & RXf_PMf_STD_PMMOD)
7218                         >> RXf_PMf_STD_PMMOD_SHIFT);
7219     const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7220     char *p;
7221     STRLEN pat_len = RExC_precomp_end - RExC_precomp;
7222
7223     /* We output all the necessary flags; we never output a minus, as all
7224         * those are defaults, so are
7225         * covered by the caret */
7226     const STRLEN wraplen = pat_len + has_p + has_runon
7227         + has_default       /* If needs a caret */
7228         + PL_bitcount[reganch] /* 1 char for each set standard flag */
7229
7230             /* If needs a character set specifier */
7231         + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7232         + (sizeof("(?:)") - 1);
7233
7234     PERL_ARGS_ASSERT_SET_REGEX_PV;
7235
7236     /* make sure PL_bitcount bounds not exceeded */
7237     assert(sizeof(STD_PAT_MODS) <= 8);
7238
7239     p = sv_grow(MUTABLE_SV(Rx), wraplen + 1); /* +1 for the ending NUL */
7240     SvPOK_on(Rx);
7241     if (RExC_utf8)
7242         SvFLAGS(Rx) |= SVf_UTF8;
7243     *p++='('; *p++='?';
7244
7245     /* If a default, cover it using the caret */
7246     if (has_default) {
7247         *p++= DEFAULT_PAT_MOD;
7248     }
7249     if (has_charset) {
7250         STRLEN len;
7251         const char* name;
7252
7253         name = get_regex_charset_name(RExC_rx->extflags, &len);
7254         if (strEQ(name, DEPENDS_PAT_MODS)) {  /* /d under UTF-8 => /u */
7255             assert(RExC_utf8);
7256             name = UNICODE_PAT_MODS;
7257             len = sizeof(UNICODE_PAT_MODS) - 1;
7258         }
7259         Copy(name, p, len, char);
7260         p += len;
7261     }
7262     if (has_p)
7263         *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7264     {
7265         char ch;
7266         while((ch = *fptr++)) {
7267             if(reganch & 1)
7268                 *p++ = ch;
7269             reganch >>= 1;
7270         }
7271     }
7272
7273     *p++ = ':';
7274     Copy(RExC_precomp, p, pat_len, char);
7275     assert ((RX_WRAPPED(Rx) - p) < 16);
7276     RExC_rx->pre_prefix = p - RX_WRAPPED(Rx);
7277     p += pat_len;
7278
7279     /* Adding a trailing \n causes this to compile properly:
7280             my $R = qr / A B C # D E/x; /($R)/
7281         Otherwise the parens are considered part of the comment */
7282     if (has_runon)
7283         *p++ = '\n';
7284     *p++ = ')';
7285     *p = 0;
7286     SvCUR_set(Rx, p - RX_WRAPPED(Rx));
7287 }
7288
7289 /*
7290  * Perl_re_op_compile - the perl internal RE engine's function to compile a
7291  * regular expression into internal code.
7292  * The pattern may be passed either as:
7293  *    a list of SVs (patternp plus pat_count)
7294  *    a list of OPs (expr)
7295  * If both are passed, the SV list is used, but the OP list indicates
7296  * which SVs are actually pre-compiled code blocks
7297  *
7298  * The SVs in the list have magic and qr overloading applied to them (and
7299  * the list may be modified in-place with replacement SVs in the latter
7300  * case).
7301  *
7302  * If the pattern hasn't changed from old_re, then old_re will be
7303  * returned.
7304  *
7305  * eng is the current engine. If that engine has an op_comp method, then
7306  * handle directly (i.e. we assume that op_comp was us); otherwise, just
7307  * do the initial concatenation of arguments and pass on to the external
7308  * engine.
7309  *
7310  * If is_bare_re is not null, set it to a boolean indicating whether the
7311  * arg list reduced (after overloading) to a single bare regex which has
7312  * been returned (i.e. /$qr/).
7313  *
7314  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
7315  *
7316  * pm_flags contains the PMf_* flags, typically based on those from the
7317  * pm_flags field of the related PMOP. Currently we're only interested in
7318  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
7319  *
7320  * For many years this code had an initial sizing pass that calculated
7321  * (sometimes incorrectly, leading to security holes) the size needed for the
7322  * compiled pattern.  That was changed by commit
7323  * 7c932d07cab18751bfc7515b4320436273a459e2 in 5.29, which reallocs the size, a
7324  * node at a time, as parsing goes along.  Patches welcome to fix any obsolete
7325  * references to this sizing pass.
7326  *
7327  * Now, an initial crude guess as to the size needed is made, based on the
7328  * length of the pattern.  Patches welcome to improve that guess.  That amount
7329  * of space is malloc'd and then immediately freed, and then clawed back node
7330  * by node.  This design is to minimze, to the extent possible, memory churn
7331  * when doing the the reallocs.
7332  *
7333  * A separate parentheses counting pass may be needed in some cases.
7334  * (Previously the sizing pass did this.)  Patches welcome to reduce the number
7335  * of these cases.
7336  *
7337  * The existence of a sizing pass necessitated design decisions that are no
7338  * longer needed.  There are potential areas of simplification.
7339  *
7340  * Beware that the optimization-preparation code in here knows about some
7341  * of the structure of the compiled regexp.  [I'll say.]
7342  */
7343
7344 REGEXP *
7345 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
7346                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
7347                      bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags)
7348 {
7349     dVAR;
7350     REGEXP *Rx;         /* Capital 'R' means points to a REGEXP */
7351     STRLEN plen;
7352     char *exp;
7353     regnode *scan;
7354     I32 flags;
7355     SSize_t minlen = 0;
7356     U32 rx_flags;
7357     SV *pat;
7358     SV** new_patternp = patternp;
7359
7360     /* these are all flags - maybe they should be turned
7361      * into a single int with different bit masks */
7362     I32 sawlookahead = 0;
7363     I32 sawplus = 0;
7364     I32 sawopen = 0;
7365     I32 sawminmod = 0;
7366
7367     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
7368     bool recompile = 0;
7369     bool runtime_code = 0;
7370     scan_data_t data;
7371     RExC_state_t RExC_state;
7372     RExC_state_t * const pRExC_state = &RExC_state;
7373 #ifdef TRIE_STUDY_OPT
7374     int restudied = 0;
7375     RExC_state_t copyRExC_state;
7376 #endif
7377     GET_RE_DEBUG_FLAGS_DECL;
7378
7379     PERL_ARGS_ASSERT_RE_OP_COMPILE;
7380
7381     DEBUG_r(if (!PL_colorset) reginitcolors());
7382
7383     /* Initialize these here instead of as-needed, as is quick and avoids
7384      * having to test them each time otherwise */
7385     if (! PL_InBitmap) {
7386 #ifdef DEBUGGING
7387         char * dump_len_string;
7388 #endif
7389
7390         /* This is calculated here, because the Perl program that generates the
7391          * static global ones doesn't currently have access to
7392          * NUM_ANYOF_CODE_POINTS */
7393         PL_InBitmap = _new_invlist(2);
7394         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
7395                                                     NUM_ANYOF_CODE_POINTS - 1);
7396 #ifdef DEBUGGING
7397         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
7398         if (   ! dump_len_string
7399             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
7400         {
7401             PL_dump_re_max_len = 60;    /* A reasonable default */
7402         }
7403 #endif
7404     }
7405
7406     pRExC_state->warn_text = NULL;
7407     pRExC_state->unlexed_names = NULL;
7408     pRExC_state->code_blocks = NULL;
7409
7410     if (is_bare_re)
7411         *is_bare_re = FALSE;
7412
7413     if (expr && (expr->op_type == OP_LIST ||
7414                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
7415         /* allocate code_blocks if needed */
7416         OP *o;
7417         int ncode = 0;
7418
7419         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
7420             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
7421                 ncode++; /* count of DO blocks */
7422
7423         if (ncode)
7424             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
7425     }
7426
7427     if (!pat_count) {
7428         /* compile-time pattern with just OP_CONSTs and DO blocks */
7429
7430         int n;
7431         OP *o;
7432
7433         /* find how many CONSTs there are */
7434         assert(expr);
7435         n = 0;
7436         if (expr->op_type == OP_CONST)
7437             n = 1;
7438         else
7439             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7440                 if (o->op_type == OP_CONST)
7441                     n++;
7442             }
7443
7444         /* fake up an SV array */
7445
7446         assert(!new_patternp);
7447         Newx(new_patternp, n, SV*);
7448         SAVEFREEPV(new_patternp);
7449         pat_count = n;
7450
7451         n = 0;
7452         if (expr->op_type == OP_CONST)
7453             new_patternp[n] = cSVOPx_sv(expr);
7454         else
7455             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7456                 if (o->op_type == OP_CONST)
7457                     new_patternp[n++] = cSVOPo_sv;
7458             }
7459
7460     }
7461
7462     DEBUG_PARSE_r(Perl_re_printf( aTHX_
7463         "Assembling pattern from %d elements%s\n", pat_count,
7464             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7465
7466     /* set expr to the first arg op */
7467
7468     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
7469          && expr->op_type != OP_CONST)
7470     {
7471             expr = cLISTOPx(expr)->op_first;
7472             assert(   expr->op_type == OP_PUSHMARK
7473                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
7474                    || expr->op_type == OP_PADRANGE);
7475             expr = OpSIBLING(expr);
7476     }
7477
7478     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
7479                         expr, &recompile, NULL);
7480
7481     /* handle bare (possibly after overloading) regex: foo =~ $re */
7482     {
7483         SV *re = pat;
7484         if (SvROK(re))
7485             re = SvRV(re);
7486         if (SvTYPE(re) == SVt_REGEXP) {
7487             if (is_bare_re)
7488                 *is_bare_re = TRUE;
7489             SvREFCNT_inc(re);
7490             DEBUG_PARSE_r(Perl_re_printf( aTHX_
7491                 "Precompiled pattern%s\n",
7492                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7493
7494             return (REGEXP*)re;
7495         }
7496     }
7497
7498     exp = SvPV_nomg(pat, plen);
7499
7500     if (!eng->op_comp) {
7501         if ((SvUTF8(pat) && IN_BYTES)
7502                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7503         {
7504             /* make a temporary copy; either to convert to bytes,
7505              * or to avoid repeating get-magic / overloaded stringify */
7506             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7507                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7508         }
7509         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7510     }
7511
7512     /* ignore the utf8ness if the pattern is 0 length */
7513     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7514     RExC_uni_semantics = 0;
7515     RExC_contains_locale = 0;
7516     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7517     RExC_in_script_run = 0;
7518     RExC_study_started = 0;
7519     pRExC_state->runtime_code_qr = NULL;
7520     RExC_frame_head= NULL;
7521     RExC_frame_last= NULL;
7522     RExC_frame_count= 0;
7523     RExC_latest_warn_offset = 0;
7524     RExC_use_BRANCHJ = 0;
7525     RExC_total_parens = 0;
7526     RExC_open_parens = NULL;
7527     RExC_close_parens = NULL;
7528     RExC_paren_names = NULL;
7529     RExC_size = 0;
7530     RExC_seen_d_op = FALSE;
7531 #ifdef DEBUGGING
7532     RExC_paren_name_list = NULL;
7533 #endif
7534
7535     DEBUG_r({
7536         RExC_mysv1= sv_newmortal();
7537         RExC_mysv2= sv_newmortal();
7538     });
7539
7540     DEBUG_COMPILE_r({
7541             SV *dsv= sv_newmortal();
7542             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7543             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7544                           PL_colors[4], PL_colors[5], s);
7545         });
7546
7547     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7548      * to utf8 */
7549
7550     if ((pm_flags & PMf_USE_RE_EVAL)
7551                 /* this second condition covers the non-regex literal case,
7552                  * i.e.  $foo =~ '(?{})'. */
7553                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7554     )
7555         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7556
7557   redo_parse:
7558     /* return old regex if pattern hasn't changed */
7559     /* XXX: note in the below we have to check the flags as well as the
7560      * pattern.
7561      *
7562      * Things get a touch tricky as we have to compare the utf8 flag
7563      * independently from the compile flags.  */
7564
7565     if (   old_re
7566         && !recompile
7567         && !!RX_UTF8(old_re) == !!RExC_utf8
7568         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7569         && RX_PRECOMP(old_re)
7570         && RX_PRELEN(old_re) == plen
7571         && memEQ(RX_PRECOMP(old_re), exp, plen)
7572         && !runtime_code /* with runtime code, always recompile */ )
7573     {
7574         return old_re;
7575     }
7576
7577     /* Allocate the pattern's SV */
7578     RExC_rx_sv = Rx = (REGEXP*) newSV_type(SVt_REGEXP);
7579     RExC_rx = ReANY(Rx);
7580     if ( RExC_rx == NULL )
7581         FAIL("Regexp out of space");
7582
7583     rx_flags = orig_rx_flags;
7584
7585     if (   (UTF || RExC_uni_semantics)
7586         && initial_charset == REGEX_DEPENDS_CHARSET)
7587     {
7588
7589         /* Set to use unicode semantics if the pattern is in utf8 and has the
7590          * 'depends' charset specified, as it means unicode when utf8  */
7591         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7592         RExC_uni_semantics = 1;
7593     }
7594
7595     RExC_pm_flags = pm_flags;
7596
7597     if (runtime_code) {
7598         assert(TAINTING_get || !TAINT_get);
7599         if (TAINT_get)
7600             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7601
7602         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7603             /* whoops, we have a non-utf8 pattern, whilst run-time code
7604              * got compiled as utf8. Try again with a utf8 pattern */
7605             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7606                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7607             goto redo_parse;
7608         }
7609     }
7610     assert(!pRExC_state->runtime_code_qr);
7611
7612     RExC_sawback = 0;
7613
7614     RExC_seen = 0;
7615     RExC_maxlen = 0;
7616     RExC_in_lookbehind = 0;
7617     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7618 #ifdef EBCDIC
7619     RExC_recode_x_to_native = 0;
7620 #endif
7621     RExC_in_multi_char_class = 0;
7622
7623     RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = RExC_precomp = exp;
7624     RExC_precomp_end = RExC_end = exp + plen;
7625     RExC_nestroot = 0;
7626     RExC_whilem_seen = 0;
7627     RExC_end_op = NULL;
7628     RExC_recurse = NULL;
7629     RExC_study_chunk_recursed = NULL;
7630     RExC_study_chunk_recursed_bytes= 0;
7631     RExC_recurse_count = 0;
7632     pRExC_state->code_index = 0;
7633
7634     /* Initialize the string in the compiled pattern.  This is so that there is
7635      * something to output if necessary */
7636     set_regex_pv(pRExC_state, Rx);
7637
7638     DEBUG_PARSE_r({
7639         Perl_re_printf( aTHX_
7640             "Starting parse and generation\n");
7641         RExC_lastnum=0;
7642         RExC_lastparse=NULL;
7643     });
7644
7645     /* Allocate space and zero-initialize. Note, the two step process
7646        of zeroing when in debug mode, thus anything assigned has to
7647        happen after that */
7648     if (!  RExC_size) {
7649
7650         /* On the first pass of the parse, we guess how big this will be.  Then
7651          * we grow in one operation to that amount and then give it back.  As
7652          * we go along, we re-allocate what we need.
7653          *
7654          * XXX Currently the guess is essentially that the pattern will be an
7655          * EXACT node with one byte input, one byte output.  This is crude, and
7656          * better heuristics are welcome.
7657          *
7658          * On any subsequent passes, we guess what we actually computed in the
7659          * latest earlier pass.  Such a pass probably didn't complete so is
7660          * missing stuff.  We could improve those guesses by knowing where the
7661          * parse stopped, and use the length so far plus apply the above
7662          * assumption to what's left. */
7663         RExC_size = STR_SZ(RExC_end - RExC_start);
7664     }
7665
7666     Newxc(RExC_rxi, sizeof(regexp_internal) + RExC_size, char, regexp_internal);
7667     if ( RExC_rxi == NULL )
7668         FAIL("Regexp out of space");
7669
7670     Zero(RExC_rxi, sizeof(regexp_internal) + RExC_size, char);
7671     RXi_SET( RExC_rx, RExC_rxi );
7672
7673     /* We start from 0 (over from 0 in the case this is a reparse.  The first
7674      * node parsed will give back any excess memory we have allocated so far).
7675      * */
7676     RExC_size = 0;
7677
7678     /* non-zero initialization begins here */
7679     RExC_rx->engine= eng;
7680     RExC_rx->extflags = rx_flags;
7681     RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7682
7683     if (pm_flags & PMf_IS_QR) {
7684         RExC_rxi->code_blocks = pRExC_state->code_blocks;
7685         if (RExC_rxi->code_blocks) {
7686             RExC_rxi->code_blocks->refcnt++;
7687         }
7688     }
7689
7690     RExC_rx->intflags = 0;
7691
7692     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7693     RExC_parse = exp;
7694
7695     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7696      * code makes sure the final byte is an uncounted NUL.  But should this
7697      * ever not be the case, lots of things could read beyond the end of the
7698      * buffer: loops like
7699      *      while(isFOO(*RExC_parse)) RExC_parse++;
7700      *      strchr(RExC_parse, "foo");
7701      * etc.  So it is worth noting. */
7702     assert(*RExC_end == '\0');
7703
7704     RExC_naughty = 0;
7705     RExC_npar = 1;
7706     RExC_parens_buf_size = 0;
7707     RExC_emit_start = RExC_rxi->program;
7708     pRExC_state->code_index = 0;
7709
7710     *((char*) RExC_emit_start) = (char) REG_MAGIC;
7711     RExC_emit = 1;
7712
7713     /* Do the parse */
7714     if (reg(pRExC_state, 0, &flags, 1)) {
7715
7716         /* Success!, But we may need to redo the parse knowing how many parens
7717          * there actually are */
7718         if (IN_PARENS_PASS) {
7719             flags |= RESTART_PARSE;
7720         }
7721
7722         /* We have that number in RExC_npar */
7723         RExC_total_parens = RExC_npar;
7724     }
7725     else if (! MUST_RESTART(flags)) {
7726         ReREFCNT_dec(Rx);
7727         Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags);
7728     }
7729
7730     /* Here, we either have success, or we have to redo the parse for some reason */
7731     if (MUST_RESTART(flags)) {
7732
7733         /* It's possible to write a regexp in ascii that represents Unicode
7734         codepoints outside of the byte range, such as via \x{100}. If we
7735         detect such a sequence we have to convert the entire pattern to utf8
7736         and then recompile, as our sizing calculation will have been based
7737         on 1 byte == 1 character, but we will need to use utf8 to encode
7738         at least some part of the pattern, and therefore must convert the whole
7739         thing.
7740         -- dmq */
7741         if (flags & NEED_UTF8) {
7742
7743             /* We have stored the offset of the final warning output so far.
7744              * That must be adjusted.  Any variant characters between the start
7745              * of the pattern and this warning count for 2 bytes in the final,
7746              * so just add them again */
7747             if (UNLIKELY(RExC_latest_warn_offset > 0)) {
7748                 RExC_latest_warn_offset +=
7749                             variant_under_utf8_count((U8 *) exp, (U8 *) exp
7750                                                 + RExC_latest_warn_offset);
7751             }
7752             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7753             pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7754             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse after upgrade\n"));
7755         }
7756         else {
7757             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse\n"));
7758         }
7759
7760         if (ALL_PARENS_COUNTED) {
7761             /* Make enough room for all the known parens, and zero it */
7762             Renew(RExC_open_parens, RExC_total_parens, regnode_offset);
7763             Zero(RExC_open_parens, RExC_total_parens, regnode_offset);
7764             RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
7765
7766             Renew(RExC_close_parens, RExC_total_parens, regnode_offset);
7767             Zero(RExC_close_parens, RExC_total_parens, regnode_offset);
7768         }
7769         else { /* Parse did not complete.  Reinitialize the parentheses
7770                   structures */
7771             RExC_total_parens = 0;
7772             if (RExC_open_parens) {
7773                 Safefree(RExC_open_parens);
7774                 RExC_open_parens = NULL;
7775             }
7776             if (RExC_close_parens) {
7777                 Safefree(RExC_close_parens);
7778                 RExC_close_parens = NULL;
7779             }
7780         }
7781
7782         /* Clean up what we did in this parse */
7783         SvREFCNT_dec_NN(RExC_rx_sv);
7784
7785         goto redo_parse;
7786     }
7787
7788     /* Here, we have successfully parsed and generated the pattern's program
7789      * for the regex engine.  We are ready to finish things up and look for
7790      * optimizations. */
7791
7792     /* Update the string to compile, with correct modifiers, etc */
7793     set_regex_pv(pRExC_state, Rx);
7794
7795     RExC_rx->nparens = RExC_total_parens - 1;
7796
7797     /* Uses the upper 4 bits of the FLAGS field, so keep within that size */
7798     if (RExC_whilem_seen > 15)
7799         RExC_whilem_seen = 15;
7800
7801     DEBUG_PARSE_r({
7802         Perl_re_printf( aTHX_
7803             "Required size %" IVdf " nodes\n", (IV)RExC_size);
7804         RExC_lastnum=0;
7805         RExC_lastparse=NULL;
7806     });
7807
7808 #ifdef RE_TRACK_PATTERN_OFFSETS
7809     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7810                           "%s %" UVuf " bytes for offset annotations.\n",
7811                           RExC_offsets ? "Got" : "Couldn't get",
7812                           (UV)((RExC_offsets[0] * 2 + 1))));
7813     DEBUG_OFFSETS_r(if (RExC_offsets) {
7814         const STRLEN len = RExC_offsets[0];
7815         STRLEN i;
7816         GET_RE_DEBUG_FLAGS_DECL;
7817         Perl_re_printf( aTHX_
7818                       "Offsets: [%" UVuf "]\n\t", (UV)RExC_offsets[0]);
7819         for (i = 1; i <= len; i++) {
7820             if (RExC_offsets[i*2-1] || RExC_offsets[i*2])
7821                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7822                 (UV)i, (UV)RExC_offsets[i*2-1], (UV)RExC_offsets[i*2]);
7823         }
7824         Perl_re_printf( aTHX_  "\n");
7825     });
7826
7827 #else
7828     SetProgLen(RExC_rxi,RExC_size);
7829 #endif
7830
7831     DEBUG_OPTIMISE_r(
7832         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7833     );
7834
7835     /* XXXX To minimize changes to RE engine we always allocate
7836        3-units-long substrs field. */
7837     Newx(RExC_rx->substrs, 1, struct reg_substr_data);
7838     if (RExC_recurse_count) {
7839         Newx(RExC_recurse, RExC_recurse_count, regnode *);
7840         SAVEFREEPV(RExC_recurse);
7841     }
7842
7843     if (RExC_seen & REG_RECURSE_SEEN) {
7844         /* Note, RExC_total_parens is 1 + the number of parens in a pattern.
7845          * So its 1 if there are no parens. */
7846         RExC_study_chunk_recursed_bytes= (RExC_total_parens >> 3) +
7847                                          ((RExC_total_parens & 0x07) != 0);
7848         Newx(RExC_study_chunk_recursed,
7849              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
7850         SAVEFREEPV(RExC_study_chunk_recursed);
7851     }
7852
7853   reStudy:
7854     RExC_rx->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7855     DEBUG_r(
7856         RExC_study_chunk_recursed_count= 0;
7857     );
7858     Zero(RExC_rx->substrs, 1, struct reg_substr_data);
7859     if (RExC_study_chunk_recursed) {
7860         Zero(RExC_study_chunk_recursed,
7861              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
7862     }
7863
7864
7865 #ifdef TRIE_STUDY_OPT
7866     if (!restudied) {
7867         StructCopy(&zero_scan_data, &data, scan_data_t);
7868         copyRExC_state = RExC_state;
7869     } else {
7870         U32 seen=RExC_seen;
7871         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7872
7873         RExC_state = copyRExC_state;
7874         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7875             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7876         else
7877             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7878         StructCopy(&zero_scan_data, &data, scan_data_t);
7879     }
7880 #else
7881     StructCopy(&zero_scan_data, &data, scan_data_t);
7882 #endif
7883
7884     /* Dig out information for optimizations. */
7885     RExC_rx->extflags = RExC_flags; /* was pm_op */
7886     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7887
7888     if (UTF)
7889         SvUTF8_on(Rx);  /* Unicode in it? */
7890     RExC_rxi->regstclass = NULL;
7891     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7892         RExC_rx->intflags |= PREGf_NAUGHTY;
7893     scan = RExC_rxi->program + 1;               /* First BRANCH. */
7894
7895     /* testing for BRANCH here tells us whether there is "must appear"
7896        data in the pattern. If there is then we can use it for optimisations */
7897     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7898                                                   */
7899         SSize_t fake;
7900         STRLEN longest_length[2];
7901         regnode_ssc ch_class; /* pointed to by data */
7902         int stclass_flag;
7903         SSize_t last_close = 0; /* pointed to by data */
7904         regnode *first= scan;
7905         regnode *first_next= regnext(first);
7906         int i;
7907
7908         /*
7909          * Skip introductions and multiplicators >= 1
7910          * so that we can extract the 'meat' of the pattern that must
7911          * match in the large if() sequence following.
7912          * NOTE that EXACT is NOT covered here, as it is normally
7913          * picked up by the optimiser separately.
7914          *
7915          * This is unfortunate as the optimiser isnt handling lookahead
7916          * properly currently.
7917          *
7918          */
7919         while ((OP(first) == OPEN && (sawopen = 1)) ||
7920                /* An OR of *one* alternative - should not happen now. */
7921             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7922             /* for now we can't handle lookbehind IFMATCH*/
7923             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7924             (OP(first) == PLUS) ||
7925             (OP(first) == MINMOD) ||
7926                /* An {n,m} with n>0 */
7927             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7928             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7929         {
7930                 /*
7931                  * the only op that could be a regnode is PLUS, all the rest
7932                  * will be regnode_1 or regnode_2.
7933                  *
7934                  * (yves doesn't think this is true)
7935                  */
7936                 if (OP(first) == PLUS)
7937                     sawplus = 1;
7938                 else {
7939                     if (OP(first) == MINMOD)
7940                         sawminmod = 1;
7941                     first += regarglen[OP(first)];
7942                 }
7943                 first = NEXTOPER(first);
7944                 first_next= regnext(first);
7945         }
7946
7947         /* Starting-point info. */
7948       again:
7949         DEBUG_PEEP("first:", first, 0, 0);
7950         /* Ignore EXACT as we deal with it later. */
7951         if (PL_regkind[OP(first)] == EXACT) {
7952             if (   OP(first) == EXACT
7953                 || OP(first) == EXACT_ONLY8
7954                 || OP(first) == EXACTL)
7955             {
7956                 NOOP;   /* Empty, get anchored substr later. */
7957             }
7958             else
7959                 RExC_rxi->regstclass = first;
7960         }
7961 #ifdef TRIE_STCLASS
7962         else if (PL_regkind[OP(first)] == TRIE &&
7963                 ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0)
7964         {
7965             /* this can happen only on restudy */
7966             RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7967         }
7968 #endif
7969         else if (REGNODE_SIMPLE(OP(first)))
7970             RExC_rxi->regstclass = first;
7971         else if (PL_regkind[OP(first)] == BOUND ||
7972                  PL_regkind[OP(first)] == NBOUND)
7973             RExC_rxi->regstclass = first;
7974         else if (PL_regkind[OP(first)] == BOL) {
7975             RExC_rx->intflags |= (OP(first) == MBOL
7976                            ? PREGf_ANCH_MBOL
7977                            : PREGf_ANCH_SBOL);
7978             first = NEXTOPER(first);
7979             goto again;
7980         }
7981         else if (OP(first) == GPOS) {
7982             RExC_rx->intflags |= PREGf_ANCH_GPOS;
7983             first = NEXTOPER(first);
7984             goto again;
7985         }
7986         else if ((!sawopen || !RExC_sawback) &&
7987             !sawlookahead &&
7988             (OP(first) == STAR &&
7989             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7990             !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7991         {
7992             /* turn .* into ^.* with an implied $*=1 */
7993             const int type =
7994                 (OP(NEXTOPER(first)) == REG_ANY)
7995                     ? PREGf_ANCH_MBOL
7996                     : PREGf_ANCH_SBOL;
7997             RExC_rx->intflags |= (type | PREGf_IMPLICIT);
7998             first = NEXTOPER(first);
7999             goto again;
8000         }
8001         if (sawplus && !sawminmod && !sawlookahead
8002             && (!sawopen || !RExC_sawback)
8003             && !pRExC_state->code_blocks) /* May examine pos and $& */
8004             /* x+ must match at the 1st pos of run of x's */
8005             RExC_rx->intflags |= PREGf_SKIP;
8006
8007         /* Scan is after the zeroth branch, first is atomic matcher. */
8008 #ifdef TRIE_STUDY_OPT
8009         DEBUG_PARSE_r(
8010             if (!restudied)
8011                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8012                               (IV)(first - scan + 1))
8013         );
8014 #else
8015         DEBUG_PARSE_r(
8016             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8017                 (IV)(first - scan + 1))
8018         );
8019 #endif
8020
8021
8022         /*
8023         * If there's something expensive in the r.e., find the
8024         * longest literal string that must appear and make it the
8025         * regmust.  Resolve ties in favor of later strings, since
8026         * the regstart check works with the beginning of the r.e.
8027         * and avoiding duplication strengthens checking.  Not a
8028         * strong reason, but sufficient in the absence of others.
8029         * [Now we resolve ties in favor of the earlier string if
8030         * it happens that c_offset_min has been invalidated, since the
8031         * earlier string may buy us something the later one won't.]
8032         */
8033
8034         data.substrs[0].str = newSVpvs("");
8035         data.substrs[1].str = newSVpvs("");
8036         data.last_found = newSVpvs("");
8037         data.cur_is_floating = 0; /* initially any found substring is fixed */
8038         ENTER_with_name("study_chunk");
8039         SAVEFREESV(data.substrs[0].str);
8040         SAVEFREESV(data.substrs[1].str);
8041         SAVEFREESV(data.last_found);
8042         first = scan;
8043         if (!RExC_rxi->regstclass) {
8044             ssc_init(pRExC_state, &ch_class);
8045             data.start_class = &ch_class;
8046             stclass_flag = SCF_DO_STCLASS_AND;
8047         } else                          /* XXXX Check for BOUND? */
8048             stclass_flag = 0;
8049         data.last_closep = &last_close;
8050
8051         DEBUG_RExC_seen();
8052         /*
8053          * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
8054          * (NO top level branches)
8055          */
8056         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
8057                              scan + RExC_size, /* Up to end */
8058             &data, -1, 0, NULL,
8059             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
8060                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
8061             0);
8062
8063
8064         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
8065
8066
8067         if ( RExC_total_parens == 1 && !data.cur_is_floating
8068              && data.last_start_min == 0 && data.last_end > 0
8069              && !RExC_seen_zerolen
8070              && !(RExC_seen & REG_VERBARG_SEEN)
8071              && !(RExC_seen & REG_GPOS_SEEN)
8072         ){
8073             RExC_rx->extflags |= RXf_CHECK_ALL;
8074         }
8075         scan_commit(pRExC_state, &data,&minlen, 0);
8076
8077
8078         /* XXX this is done in reverse order because that's the way the
8079          * code was before it was parameterised. Don't know whether it
8080          * actually needs doing in reverse order. DAPM */
8081         for (i = 1; i >= 0; i--) {
8082             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
8083
8084             if (   !(   i
8085                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
8086                      &&    data.substrs[0].min_offset
8087                         == data.substrs[1].min_offset
8088                      &&    SvCUR(data.substrs[0].str)
8089                         == SvCUR(data.substrs[1].str)
8090                     )
8091                 && S_setup_longest (aTHX_ pRExC_state,
8092                                         &(RExC_rx->substrs->data[i]),
8093                                         &(data.substrs[i]),
8094                                         longest_length[i]))
8095             {
8096                 RExC_rx->substrs->data[i].min_offset =
8097                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
8098
8099                 RExC_rx->substrs->data[i].max_offset = data.substrs[i].max_offset;
8100                 /* Don't offset infinity */
8101                 if (data.substrs[i].max_offset < SSize_t_MAX)
8102                     RExC_rx->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
8103                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
8104             }
8105             else {
8106                 RExC_rx->substrs->data[i].substr      = NULL;
8107                 RExC_rx->substrs->data[i].utf8_substr = NULL;
8108                 longest_length[i] = 0;
8109             }
8110         }
8111
8112         LEAVE_with_name("study_chunk");
8113
8114         if (RExC_rxi->regstclass
8115             && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY))
8116             RExC_rxi->regstclass = NULL;
8117
8118         if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr)
8119               || RExC_rx->substrs->data[0].min_offset)
8120             && stclass_flag
8121             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8122             && is_ssc_worth_it(pRExC_state, data.start_class))
8123         {
8124             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8125
8126             ssc_finalize(pRExC_state, data.start_class);
8127
8128             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8129             StructCopy(data.start_class,
8130                        (regnode_ssc*)RExC_rxi->data->data[n],
8131                        regnode_ssc);
8132             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8133             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8134             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
8135                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8136                       Perl_re_printf( aTHX_
8137                                     "synthetic stclass \"%s\".\n",
8138                                     SvPVX_const(sv));});
8139             data.start_class = NULL;
8140         }
8141
8142         /* A temporary algorithm prefers floated substr to fixed one of
8143          * same length to dig more info. */
8144         i = (longest_length[0] <= longest_length[1]);
8145         RExC_rx->substrs->check_ix = i;
8146         RExC_rx->check_end_shift  = RExC_rx->substrs->data[i].end_shift;
8147         RExC_rx->check_substr     = RExC_rx->substrs->data[i].substr;
8148         RExC_rx->check_utf8       = RExC_rx->substrs->data[i].utf8_substr;
8149         RExC_rx->check_offset_min = RExC_rx->substrs->data[i].min_offset;
8150         RExC_rx->check_offset_max = RExC_rx->substrs->data[i].max_offset;
8151         if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
8152             RExC_rx->intflags |= PREGf_NOSCAN;
8153
8154         if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) {
8155             RExC_rx->extflags |= RXf_USE_INTUIT;
8156             if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8))
8157                 RExC_rx->extflags |= RXf_INTUIT_TAIL;
8158         }
8159
8160         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
8161         if ( (STRLEN)minlen < longest_length[1] )
8162             minlen= longest_length[1];
8163         if ( (STRLEN)minlen < longest_length[0] )
8164             minlen= longest_length[0];
8165         */
8166     }
8167     else {
8168         /* Several toplevels. Best we can is to set minlen. */
8169         SSize_t fake;
8170         regnode_ssc ch_class;
8171         SSize_t last_close = 0;
8172
8173         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
8174
8175         scan = RExC_rxi->program + 1;
8176         ssc_init(pRExC_state, &ch_class);
8177         data.start_class = &ch_class;
8178         data.last_closep = &last_close;
8179
8180         DEBUG_RExC_seen();
8181         /*
8182          * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
8183          * (patterns WITH top level branches)
8184          */
8185         minlen = study_chunk(pRExC_state,
8186             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
8187             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
8188                                                       ? SCF_TRIE_DOING_RESTUDY
8189                                                       : 0),
8190             0);
8191
8192         CHECK_RESTUDY_GOTO_butfirst(NOOP);
8193
8194         RExC_rx->check_substr = NULL;
8195         RExC_rx->check_utf8 = NULL;
8196         RExC_rx->substrs->data[0].substr      = NULL;
8197         RExC_rx->substrs->data[0].utf8_substr = NULL;
8198         RExC_rx->substrs->data[1].substr      = NULL;
8199         RExC_rx->substrs->data[1].utf8_substr = NULL;
8200
8201         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8202             && is_ssc_worth_it(pRExC_state, data.start_class))
8203         {
8204             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8205
8206             ssc_finalize(pRExC_state, data.start_class);
8207
8208             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8209             StructCopy(data.start_class,
8210                        (regnode_ssc*)RExC_rxi->data->data[n],
8211                        regnode_ssc);
8212             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8213             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8214             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
8215                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8216                       Perl_re_printf( aTHX_
8217                                     "synthetic stclass \"%s\".\n",
8218                                     SvPVX_const(sv));});
8219             data.start_class = NULL;
8220         }
8221     }
8222
8223     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
8224         RExC_rx->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
8225         RExC_rx->maxlen = REG_INFTY;
8226     }
8227     else {
8228         RExC_rx->maxlen = RExC_maxlen;
8229     }
8230
8231     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
8232        the "real" pattern. */
8233     DEBUG_OPTIMISE_r({
8234         Perl_re_printf( aTHX_ "minlen: %" IVdf " RExC_rx->minlen:%" IVdf " maxlen:%" IVdf "\n",
8235                       (IV)minlen, (IV)RExC_rx->minlen, (IV)RExC_maxlen);
8236     });
8237     RExC_rx->minlenret = minlen;
8238     if (RExC_rx->minlen < minlen)
8239         RExC_rx->minlen = minlen;
8240
8241     if (RExC_seen & REG_RECURSE_SEEN ) {
8242         RExC_rx->intflags |= PREGf_RECURSE_SEEN;
8243         Newx(RExC_rx->recurse_locinput, RExC_rx->nparens + 1, char *);
8244     }
8245     if (RExC_seen & REG_GPOS_SEEN)
8246         RExC_rx->intflags |= PREGf_GPOS_SEEN;
8247     if (RExC_seen & REG_LOOKBEHIND_SEEN)
8248         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
8249                                                 lookbehind */
8250     if (pRExC_state->code_blocks)
8251         RExC_rx->extflags |= RXf_EVAL_SEEN;
8252     if (RExC_seen & REG_VERBARG_SEEN)
8253     {
8254         RExC_rx->intflags |= PREGf_VERBARG_SEEN;
8255         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
8256     }
8257     if (RExC_seen & REG_CUTGROUP_SEEN)
8258         RExC_rx->intflags |= PREGf_CUTGROUP_SEEN;
8259     if (pm_flags & PMf_USE_RE_EVAL)
8260         RExC_rx->intflags |= PREGf_USE_RE_EVAL;
8261     if (RExC_paren_names)
8262         RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
8263     else
8264         RXp_PAREN_NAMES(RExC_rx) = NULL;
8265
8266     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
8267      * so it can be used in pp.c */
8268     if (RExC_rx->intflags & PREGf_ANCH)
8269         RExC_rx->extflags |= RXf_IS_ANCHORED;
8270
8271
8272     {
8273         /* this is used to identify "special" patterns that might result
8274          * in Perl NOT calling the regex engine and instead doing the match "itself",
8275          * particularly special cases in split//. By having the regex compiler
8276          * do this pattern matching at a regop level (instead of by inspecting the pattern)
8277          * we avoid weird issues with equivalent patterns resulting in different behavior,
8278          * AND we allow non Perl engines to get the same optimizations by the setting the
8279          * flags appropriately - Yves */
8280         regnode *first = RExC_rxi->program + 1;
8281         U8 fop = OP(first);
8282         regnode *next = regnext(first);
8283         U8 nop = OP(next);
8284
8285         if (PL_regkind[fop] == NOTHING && nop == END)
8286             RExC_rx->extflags |= RXf_NULL;
8287         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
8288             /* when fop is SBOL first->flags will be true only when it was
8289              * produced by parsing /\A/, and not when parsing /^/. This is
8290              * very important for the split code as there we want to
8291              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
8292              * See rt #122761 for more details. -- Yves */
8293             RExC_rx->extflags |= RXf_START_ONLY;
8294         else if (fop == PLUS
8295                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
8296                  && nop == END)
8297             RExC_rx->extflags |= RXf_WHITE;
8298         else if ( RExC_rx->extflags & RXf_SPLIT
8299                   && (fop == EXACT || fop == EXACT_ONLY8 || fop == EXACTL)
8300                   && STR_LEN(first) == 1
8301                   && *(STRING(first)) == ' '
8302                   && nop == END )
8303             RExC_rx->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
8304
8305     }
8306
8307     if (RExC_contains_locale) {
8308         RXp_EXTFLAGS(RExC_rx) |= RXf_TAINTED;
8309     }
8310
8311 #ifdef DEBUGGING
8312     if (RExC_paren_names) {
8313         RExC_rxi->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
8314         RExC_rxi->data->data[RExC_rxi->name_list_idx]
8315                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
8316     } else
8317 #endif
8318     RExC_rxi->name_list_idx = 0;
8319
8320     while ( RExC_recurse_count > 0 ) {
8321         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
8322         /*
8323          * This data structure is set up in study_chunk() and is used
8324          * to calculate the distance between a GOSUB regopcode and
8325          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
8326          * it refers to.
8327          *
8328          * If for some reason someone writes code that optimises
8329          * away a GOSUB opcode then the assert should be changed to
8330          * an if(scan) to guard the ARG2L_SET() - Yves
8331          *
8332          */
8333         assert(scan && OP(scan) == GOSUB);
8334         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - REGNODE_OFFSET(scan));
8335     }
8336
8337     Newxz(RExC_rx->offs, RExC_total_parens, regexp_paren_pair);
8338     /* assume we don't need to swap parens around before we match */
8339     DEBUG_TEST_r({
8340         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
8341             (unsigned long)RExC_study_chunk_recursed_count);
8342     });
8343     DEBUG_DUMP_r({
8344         DEBUG_RExC_seen();
8345         Perl_re_printf( aTHX_ "Final program:\n");
8346         regdump(RExC_rx);
8347     });
8348
8349     if (RExC_open_parens) {
8350         Safefree(RExC_open_parens);
8351         RExC_open_parens = NULL;
8352     }
8353     if (RExC_close_parens) {
8354         Safefree(RExC_close_parens);
8355         RExC_close_parens = NULL;
8356     }
8357
8358 #ifdef USE_ITHREADS
8359     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
8360      * by setting the regexp SV to readonly-only instead. If the
8361      * pattern's been recompiled, the USEDness should remain. */
8362     if (old_re && SvREADONLY(old_re))
8363         SvREADONLY_on(Rx);
8364 #endif
8365     return Rx;
8366 }
8367
8368
8369 SV*
8370 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
8371                     const U32 flags)
8372 {
8373     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
8374
8375     PERL_UNUSED_ARG(value);
8376
8377     if (flags & RXapif_FETCH) {
8378         return reg_named_buff_fetch(rx, key, flags);
8379     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
8380         Perl_croak_no_modify();
8381         return NULL;
8382     } else if (flags & RXapif_EXISTS) {
8383         return reg_named_buff_exists(rx, key, flags)
8384             ? &PL_sv_yes
8385             : &PL_sv_no;
8386     } else if (flags & RXapif_REGNAMES) {
8387         return reg_named_buff_all(rx, flags);
8388     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
8389         return reg_named_buff_scalar(rx, flags);
8390     } else {
8391         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
8392         return NULL;
8393     }
8394 }
8395
8396 SV*
8397 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
8398                          const U32 flags)
8399 {
8400     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
8401     PERL_UNUSED_ARG(lastkey);
8402
8403     if (flags & RXapif_FIRSTKEY)
8404         return reg_named_buff_firstkey(rx, flags);
8405     else if (flags & RXapif_NEXTKEY)
8406         return reg_named_buff_nextkey(rx, flags);
8407     else {
8408         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
8409                                             (int)flags);
8410         return NULL;
8411     }
8412 }
8413
8414 SV*
8415 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
8416                           const U32 flags)
8417 {
8418     SV *ret;
8419     struct regexp *const rx = ReANY(r);
8420
8421     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
8422
8423     if (rx && RXp_PAREN_NAMES(rx)) {
8424         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
8425         if (he_str) {
8426             IV i;
8427             SV* sv_dat=HeVAL(he_str);
8428             I32 *nums=(I32*)SvPVX(sv_dat);
8429             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
8430             for ( i=0; i<SvIVX(sv_dat); i++ ) {
8431                 if ((I32)(rx->nparens) >= nums[i]
8432                     && rx->offs[nums[i]].start != -1
8433                     && rx->offs[nums[i]].end != -1)
8434                 {
8435                     ret = newSVpvs("");
8436                     CALLREG_NUMBUF_FETCH(r, nums[i], ret);
8437                     if (!retarray)
8438                         return ret;
8439                 } else {
8440                     if (retarray)
8441                         ret = newSVsv(&PL_sv_undef);
8442                 }
8443                 if (retarray)
8444                     av_push(retarray, ret);
8445             }
8446             if (retarray)
8447                 return newRV_noinc(MUTABLE_SV(retarray));
8448         }
8449     }
8450     return NULL;
8451 }
8452
8453 bool
8454 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
8455                            const U32 flags)
8456 {
8457     struct regexp *const rx = ReANY(r);
8458
8459     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
8460
8461     if (rx && RXp_PAREN_NAMES(rx)) {
8462         if (flags & RXapif_ALL) {
8463             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
8464         } else {
8465             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
8466             if (sv) {
8467                 SvREFCNT_dec_NN(sv);
8468                 return TRUE;
8469             } else {
8470                 return FALSE;
8471             }
8472         }
8473     } else {
8474         return FALSE;
8475     }
8476 }
8477
8478 SV*
8479 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8480 {
8481     struct regexp *const rx = ReANY(r);
8482
8483     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8484
8485     if ( rx && RXp_PAREN_NAMES(rx) ) {
8486         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8487
8488         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8489     } else {
8490         return FALSE;
8491     }
8492 }
8493
8494 SV*
8495 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8496 {
8497     struct regexp *const rx = ReANY(r);
8498     GET_RE_DEBUG_FLAGS_DECL;
8499
8500     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8501
8502     if (rx && RXp_PAREN_NAMES(rx)) {
8503         HV *hv = RXp_PAREN_NAMES(rx);
8504         HE *temphe;
8505         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8506             IV i;
8507             IV parno = 0;
8508             SV* sv_dat = HeVAL(temphe);
8509             I32 *nums = (I32*)SvPVX(sv_dat);
8510             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8511                 if ((I32)(rx->lastparen) >= nums[i] &&
8512                     rx->offs[nums[i]].start != -1 &&
8513                     rx->offs[nums[i]].end != -1)
8514                 {
8515                     parno = nums[i];
8516                     break;
8517                 }
8518             }
8519             if (parno || flags & RXapif_ALL) {
8520                 return newSVhek(HeKEY_hek(temphe));
8521             }
8522         }
8523     }
8524     return NULL;
8525 }
8526
8527 SV*
8528 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8529 {
8530     SV *ret;
8531     AV *av;
8532     SSize_t length;
8533     struct regexp *const rx = ReANY(r);
8534
8535     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8536
8537     if (rx && RXp_PAREN_NAMES(rx)) {
8538         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8539             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8540         } else if (flags & RXapif_ONE) {
8541             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8542             av = MUTABLE_AV(SvRV(ret));
8543             length = av_tindex(av);
8544             SvREFCNT_dec_NN(ret);
8545             return newSViv(length + 1);
8546         } else {
8547             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8548                                                 (int)flags);
8549             return NULL;
8550         }
8551     }
8552     return &PL_sv_undef;
8553 }
8554
8555 SV*
8556 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8557 {
8558     struct regexp *const rx = ReANY(r);
8559     AV *av = newAV();
8560
8561     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8562
8563     if (rx && RXp_PAREN_NAMES(rx)) {
8564         HV *hv= RXp_PAREN_NAMES(rx);
8565         HE *temphe;
8566         (void)hv_iterinit(hv);
8567         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8568             IV i;
8569             IV parno = 0;
8570             SV* sv_dat = HeVAL(temphe);
8571             I32 *nums = (I32*)SvPVX(sv_dat);
8572             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8573                 if ((I32)(rx->lastparen) >= nums[i] &&
8574                     rx->offs[nums[i]].start != -1 &&
8575                     rx->offs[nums[i]].end != -1)
8576                 {
8577                     parno = nums[i];
8578                     break;
8579                 }
8580             }
8581             if (parno || flags & RXapif_ALL) {
8582                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8583             }
8584         }
8585     }
8586
8587     return newRV_noinc(MUTABLE_SV(av));
8588 }
8589
8590 void
8591 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8592                              SV * const sv)
8593 {
8594     struct regexp *const rx = ReANY(r);
8595     char *s = NULL;
8596     SSize_t i = 0;
8597     SSize_t s1, t1;
8598     I32 n = paren;
8599
8600     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8601
8602     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8603            || n == RX_BUFF_IDX_CARET_FULLMATCH
8604            || n == RX_BUFF_IDX_CARET_POSTMATCH
8605        )
8606     {
8607         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8608         if (!keepcopy) {
8609             /* on something like
8610              *    $r = qr/.../;
8611              *    /$qr/p;
8612              * the KEEPCOPY is set on the PMOP rather than the regex */
8613             if (PL_curpm && r == PM_GETRE(PL_curpm))
8614                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8615         }
8616         if (!keepcopy)
8617             goto ret_undef;
8618     }
8619
8620     if (!rx->subbeg)
8621         goto ret_undef;
8622
8623     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8624         /* no need to distinguish between them any more */
8625         n = RX_BUFF_IDX_FULLMATCH;
8626
8627     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8628         && rx->offs[0].start != -1)
8629     {
8630         /* $`, ${^PREMATCH} */
8631         i = rx->offs[0].start;
8632         s = rx->subbeg;
8633     }
8634     else
8635     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8636         && rx->offs[0].end != -1)
8637     {
8638         /* $', ${^POSTMATCH} */
8639         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8640         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8641     }
8642     else
8643     if ( 0 <= n && n <= (I32)rx->nparens &&
8644         (s1 = rx->offs[n].start) != -1 &&
8645         (t1 = rx->offs[n].end) != -1)
8646     {
8647         /* $&, ${^MATCH},  $1 ... */
8648         i = t1 - s1;
8649         s = rx->subbeg + s1 - rx->suboffset;
8650     } else {
8651         goto ret_undef;
8652     }
8653
8654     assert(s >= rx->subbeg);
8655     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8656     if (i >= 0) {
8657 #ifdef NO_TAINT_SUPPORT
8658         sv_setpvn(sv, s, i);
8659 #else
8660         const int oldtainted = TAINT_get;
8661         TAINT_NOT;
8662         sv_setpvn(sv, s, i);
8663         TAINT_set(oldtainted);
8664 #endif
8665         if (RXp_MATCH_UTF8(rx))
8666             SvUTF8_on(sv);
8667         else
8668             SvUTF8_off(sv);
8669         if (TAINTING_get) {
8670             if (RXp_MATCH_TAINTED(rx)) {
8671                 if (SvTYPE(sv) >= SVt_PVMG) {
8672                     MAGIC* const mg = SvMAGIC(sv);
8673                     MAGIC* mgt;
8674                     TAINT;
8675                     SvMAGIC_set(sv, mg->mg_moremagic);
8676                     SvTAINT(sv);
8677                     if ((mgt = SvMAGIC(sv))) {
8678                         mg->mg_moremagic = mgt;
8679                         SvMAGIC_set(sv, mg);
8680                     }
8681                 } else {
8682                     TAINT;
8683                     SvTAINT(sv);
8684                 }
8685             } else
8686                 SvTAINTED_off(sv);
8687         }
8688     } else {
8689       ret_undef:
8690         sv_set_undef(sv);
8691         return;
8692     }
8693 }
8694
8695 void
8696 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8697                                                          SV const * const value)
8698 {
8699     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8700
8701     PERL_UNUSED_ARG(rx);
8702     PERL_UNUSED_ARG(paren);
8703     PERL_UNUSED_ARG(value);
8704
8705     if (!PL_localizing)
8706         Perl_croak_no_modify();
8707 }
8708
8709 I32
8710 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8711                               const I32 paren)
8712 {
8713     struct regexp *const rx = ReANY(r);
8714     I32 i;
8715     I32 s1, t1;
8716
8717     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8718
8719     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8720         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8721         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8722     )
8723     {
8724         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8725         if (!keepcopy) {
8726             /* on something like
8727              *    $r = qr/.../;
8728              *    /$qr/p;
8729              * the KEEPCOPY is set on the PMOP rather than the regex */
8730             if (PL_curpm && r == PM_GETRE(PL_curpm))
8731                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8732         }
8733         if (!keepcopy)
8734             goto warn_undef;
8735     }
8736
8737     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8738     switch (paren) {
8739       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8740       case RX_BUFF_IDX_PREMATCH:       /* $` */
8741         if (rx->offs[0].start != -1) {
8742                         i = rx->offs[0].start;
8743                         if (i > 0) {
8744                                 s1 = 0;
8745                                 t1 = i;
8746                                 goto getlen;
8747                         }
8748             }
8749         return 0;
8750
8751       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8752       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8753             if (rx->offs[0].end != -1) {
8754                         i = rx->sublen - rx->offs[0].end;
8755                         if (i > 0) {
8756                                 s1 = rx->offs[0].end;
8757                                 t1 = rx->sublen;
8758                                 goto getlen;
8759                         }
8760             }
8761         return 0;
8762
8763       default: /* $& / ${^MATCH}, $1, $2, ... */
8764             if (paren <= (I32)rx->nparens &&
8765             (s1 = rx->offs[paren].start) != -1 &&
8766             (t1 = rx->offs[paren].end) != -1)
8767             {
8768             i = t1 - s1;
8769             goto getlen;
8770         } else {
8771           warn_undef:
8772             if (ckWARN(WARN_UNINITIALIZED))
8773                 report_uninit((const SV *)sv);
8774             return 0;
8775         }
8776     }
8777   getlen:
8778     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8779         const char * const s = rx->subbeg - rx->suboffset + s1;
8780         const U8 *ep;
8781         STRLEN el;
8782
8783         i = t1 - s1;
8784         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8785                         i = el;
8786     }
8787     return i;
8788 }
8789
8790 SV*
8791 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8792 {
8793     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8794         PERL_UNUSED_ARG(rx);
8795         if (0)
8796             return NULL;
8797         else
8798             return newSVpvs("Regexp");
8799 }
8800
8801 /* Scans the name of a named buffer from the pattern.
8802  * If flags is REG_RSN_RETURN_NULL returns null.
8803  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8804  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8805  * to the parsed name as looked up in the RExC_paren_names hash.
8806  * If there is an error throws a vFAIL().. type exception.
8807  */
8808
8809 #define REG_RSN_RETURN_NULL    0
8810 #define REG_RSN_RETURN_NAME    1
8811 #define REG_RSN_RETURN_DATA    2
8812
8813 STATIC SV*
8814 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8815 {
8816     char *name_start = RExC_parse;
8817     SV* sv_name;
8818
8819     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8820
8821     assert (RExC_parse <= RExC_end);
8822     if (RExC_parse == RExC_end) NOOP;
8823     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8824          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8825           * using do...while */
8826         if (UTF)
8827             do {
8828                 RExC_parse += UTF8SKIP(RExC_parse);
8829             } while (   RExC_parse < RExC_end
8830                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8831         else
8832             do {
8833                 RExC_parse++;
8834             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8835     } else {
8836         RExC_parse++; /* so the <- from the vFAIL is after the offending
8837                          character */
8838         vFAIL("Group name must start with a non-digit word character");
8839     }
8840     sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8841                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8842     if ( flags == REG_RSN_RETURN_NAME)
8843         return sv_name;
8844     else if (flags==REG_RSN_RETURN_DATA) {
8845         HE *he_str = NULL;
8846         SV *sv_dat = NULL;
8847         if ( ! sv_name )      /* should not happen*/
8848             Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8849         if (RExC_paren_names)
8850             he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8851         if ( he_str )
8852             sv_dat = HeVAL(he_str);
8853         if ( ! sv_dat ) {   /* Didn't find group */
8854
8855             /* It might be a forward reference; we can't fail until we
8856                 * know, by completing the parse to get all the groups, and
8857                 * then reparsing */
8858             if (ALL_PARENS_COUNTED)  {
8859                 vFAIL("Reference to nonexistent named group");
8860             }
8861             else {
8862                 REQUIRE_PARENS_PASS;
8863             }
8864         }
8865         return sv_dat;
8866     }
8867
8868     Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8869                      (unsigned long) flags);
8870 }
8871
8872 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8873     if (RExC_lastparse!=RExC_parse) {                           \
8874         Perl_re_printf( aTHX_  "%s",                            \
8875             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8876                 RExC_end - RExC_parse, 16,                      \
8877                 "", "",                                         \
8878                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8879                 PERL_PV_PRETTY_ELLIPSES   |                     \
8880                 PERL_PV_PRETTY_LTGT       |                     \
8881                 PERL_PV_ESCAPE_RE         |                     \
8882                 PERL_PV_PRETTY_EXACTSIZE                        \
8883             )                                                   \
8884         );                                                      \
8885     } else                                                      \
8886         Perl_re_printf( aTHX_ "%16s","");                       \
8887                                                                 \
8888     if (RExC_lastnum!=RExC_emit)                                \
8889        Perl_re_printf( aTHX_ "|%4d", RExC_emit);                \
8890     else                                                        \
8891        Perl_re_printf( aTHX_ "|%4s","");                        \
8892     Perl_re_printf( aTHX_ "|%*s%-4s",                           \
8893         (int)((depth*2)), "",                                   \
8894         (funcname)                                              \
8895     );                                                          \
8896     RExC_lastnum=RExC_emit;                                     \
8897     RExC_lastparse=RExC_parse;                                  \
8898 })
8899
8900
8901
8902 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8903     DEBUG_PARSE_MSG((funcname));                            \
8904     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8905 })
8906 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8907     DEBUG_PARSE_MSG((funcname));                            \
8908     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8909 })
8910
8911 /* This section of code defines the inversion list object and its methods.  The
8912  * interfaces are highly subject to change, so as much as possible is static to
8913  * this file.  An inversion list is here implemented as a malloc'd C UV array
8914  * as an SVt_INVLIST scalar.
8915  *
8916  * An inversion list for Unicode is an array of code points, sorted by ordinal
8917  * number.  Each element gives the code point that begins a range that extends
8918  * up-to but not including the code point given by the next element.  The final
8919  * element gives the first code point of a range that extends to the platform's
8920  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8921  * ...) give ranges whose code points are all in the inversion list.  We say
8922  * that those ranges are in the set.  The odd-numbered elements give ranges
8923  * whose code points are not in the inversion list, and hence not in the set.
8924  * Thus, element [0] is the first code point in the list.  Element [1]
8925  * is the first code point beyond that not in the list; and element [2] is the
8926  * first code point beyond that that is in the list.  In other words, the first
8927  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8928  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8929  * all code points in that range are not in the inversion list.  The third
8930  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8931  * list, and so forth.  Thus every element whose index is divisible by two
8932  * gives the beginning of a range that is in the list, and every element whose
8933  * index is not divisible by two gives the beginning of a range not in the
8934  * list.  If the final element's index is divisible by two, the inversion list
8935  * extends to the platform's infinity; otherwise the highest code point in the
8936  * inversion list is the contents of that element minus 1.
8937  *
8938  * A range that contains just a single code point N will look like
8939  *  invlist[i]   == N
8940  *  invlist[i+1] == N+1
8941  *
8942  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8943  * impossible to represent, so element [i+1] is omitted.  The single element
8944  * inversion list
8945  *  invlist[0] == UV_MAX
8946  * contains just UV_MAX, but is interpreted as matching to infinity.
8947  *
8948  * Taking the complement (inverting) an inversion list is quite simple, if the
8949  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8950  * This implementation reserves an element at the beginning of each inversion
8951  * list to always contain 0; there is an additional flag in the header which
8952  * indicates if the list begins at the 0, or is offset to begin at the next
8953  * element.  This means that the inversion list can be inverted without any
8954  * copying; just flip the flag.
8955  *
8956  * More about inversion lists can be found in "Unicode Demystified"
8957  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8958  *
8959  * The inversion list data structure is currently implemented as an SV pointing
8960  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8961  * array of UV whose memory management is automatically handled by the existing
8962  * facilities for SV's.
8963  *
8964  * Some of the methods should always be private to the implementation, and some
8965  * should eventually be made public */
8966
8967 /* The header definitions are in F<invlist_inline.h> */
8968
8969 #ifndef PERL_IN_XSUB_RE
8970
8971 PERL_STATIC_INLINE UV*
8972 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8973 {
8974     /* Returns a pointer to the first element in the inversion list's array.
8975      * This is called upon initialization of an inversion list.  Where the
8976      * array begins depends on whether the list has the code point U+0000 in it
8977      * or not.  The other parameter tells it whether the code that follows this
8978      * call is about to put a 0 in the inversion list or not.  The first
8979      * element is either the element reserved for 0, if TRUE, or the element
8980      * after it, if FALSE */
8981
8982     bool* offset = get_invlist_offset_addr(invlist);
8983     UV* zero_addr = (UV *) SvPVX(invlist);
8984
8985     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8986
8987     /* Must be empty */
8988     assert(! _invlist_len(invlist));
8989
8990     *zero_addr = 0;
8991
8992     /* 1^1 = 0; 1^0 = 1 */
8993     *offset = 1 ^ will_have_0;
8994     return zero_addr + *offset;
8995 }
8996
8997 PERL_STATIC_INLINE void
8998 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8999 {
9000     /* Sets the current number of elements stored in the inversion list.
9001      * Updates SvCUR correspondingly */
9002     PERL_UNUSED_CONTEXT;
9003     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
9004
9005     assert(is_invlist(invlist));
9006
9007     SvCUR_set(invlist,
9008               (len == 0)
9009                ? 0
9010                : TO_INTERNAL_SIZE(len + offset));
9011     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
9012 }
9013
9014 STATIC void
9015 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
9016 {
9017     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
9018      * steals the list from 'src', so 'src' is made to have a NULL list.  This
9019      * is similar to what SvSetMagicSV() would do, if it were implemented on
9020      * inversion lists, though this routine avoids a copy */
9021
9022     const UV src_len          = _invlist_len(src);
9023     const bool src_offset     = *get_invlist_offset_addr(src);
9024     const STRLEN src_byte_len = SvLEN(src);
9025     char * array              = SvPVX(src);
9026
9027     const int oldtainted = TAINT_get;
9028
9029     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
9030
9031     assert(is_invlist(src));
9032     assert(is_invlist(dest));
9033     assert(! invlist_is_iterating(src));
9034     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
9035
9036     /* Make sure it ends in the right place with a NUL, as our inversion list
9037      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
9038      * asserts it */
9039     array[src_byte_len - 1] = '\0';
9040
9041     TAINT_NOT;      /* Otherwise it breaks */
9042     sv_usepvn_flags(dest,
9043                     (char *) array,
9044                     src_byte_len - 1,
9045
9046                     /* This flag is documented to cause a copy to be avoided */
9047                     SV_HAS_TRAILING_NUL);
9048     TAINT_set(oldtainted);
9049     SvPV_set(src, 0);
9050     SvLEN_set(src, 0);
9051     SvCUR_set(src, 0);
9052
9053     /* Finish up copying over the other fields in an inversion list */
9054     *get_invlist_offset_addr(dest) = src_offset;
9055     invlist_set_len(dest, src_len, src_offset);
9056     *get_invlist_previous_index_addr(dest) = 0;
9057     invlist_iterfinish(dest);
9058 }
9059
9060 PERL_STATIC_INLINE IV*
9061 S_get_invlist_previous_index_addr(SV* invlist)
9062 {
9063     /* Return the address of the IV that is reserved to hold the cached index
9064      * */
9065     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
9066
9067     assert(is_invlist(invlist));
9068
9069     return &(((XINVLIST*) SvANY(invlist))->prev_index);
9070 }
9071
9072 PERL_STATIC_INLINE IV
9073 S_invlist_previous_index(SV* const invlist)
9074 {
9075     /* Returns cached index of previous search */
9076
9077     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
9078
9079     return *get_invlist_previous_index_addr(invlist);
9080 }
9081
9082 PERL_STATIC_INLINE void
9083 S_invlist_set_previous_index(SV* const invlist, const IV index)
9084 {
9085     /* Caches <index> for later retrieval */
9086
9087     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
9088
9089     assert(index == 0 || index < (int) _invlist_len(invlist));
9090
9091     *get_invlist_previous_index_addr(invlist) = index;
9092 }
9093
9094 PERL_STATIC_INLINE void
9095 S_invlist_trim(SV* invlist)
9096 {
9097     /* Free the not currently-being-used space in an inversion list */
9098
9099     /* But don't free up the space needed for the 0 UV that is always at the
9100      * beginning of the list, nor the trailing NUL */
9101     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
9102
9103     PERL_ARGS_ASSERT_INVLIST_TRIM;
9104
9105     assert(is_invlist(invlist));
9106
9107     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
9108 }
9109
9110 PERL_STATIC_INLINE void
9111 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
9112 {
9113     PERL_ARGS_ASSERT_INVLIST_CLEAR;
9114
9115     assert(is_invlist(invlist));
9116
9117     invlist_set_len(invlist, 0, 0);
9118     invlist_trim(invlist);
9119 }
9120
9121 #endif /* ifndef PERL_IN_XSUB_RE */
9122
9123 PERL_STATIC_INLINE bool
9124 S_invlist_is_iterating(SV* const invlist)
9125 {
9126     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
9127
9128     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
9129 }
9130
9131 #ifndef PERL_IN_XSUB_RE
9132
9133 PERL_STATIC_INLINE UV
9134 S_invlist_max(SV* const invlist)
9135 {
9136     /* Returns the maximum number of elements storable in the inversion list's
9137      * array, without having to realloc() */
9138
9139     PERL_ARGS_ASSERT_INVLIST_MAX;
9140
9141     assert(is_invlist(invlist));
9142
9143     /* Assumes worst case, in which the 0 element is not counted in the
9144      * inversion list, so subtracts 1 for that */
9145     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
9146            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
9147            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
9148 }
9149
9150 STATIC void
9151 S_initialize_invlist_guts(pTHX_ SV* invlist, const Size_t initial_size)
9152 {
9153     PERL_ARGS_ASSERT_INITIALIZE_INVLIST_GUTS;
9154
9155     /* First 1 is in case the zero element isn't in the list; second 1 is for
9156      * trailing NUL */
9157     SvGROW(invlist, TO_INTERNAL_SIZE(initial_size + 1) + 1);
9158     invlist_set_len(invlist, 0, 0);
9159
9160     /* Force iterinit() to be used to get iteration to work */
9161     invlist_iterfinish(invlist);
9162
9163     *get_invlist_previous_index_addr(invlist) = 0;
9164 }
9165
9166 SV*
9167 Perl__new_invlist(pTHX_ IV initial_size)
9168 {
9169
9170     /* Return a pointer to a newly constructed inversion list, with enough
9171      * space to store 'initial_size' elements.  If that number is negative, a
9172      * system default is used instead */
9173
9174     SV* new_list;
9175
9176     if (initial_size < 0) {
9177         initial_size = 10;
9178     }
9179
9180     new_list = newSV_type(SVt_INVLIST);
9181     initialize_invlist_guts(new_list, initial_size);
9182
9183     return new_list;
9184 }
9185
9186 SV*
9187 Perl__new_invlist_C_array(pTHX_ const UV* const list)
9188 {
9189     /* Return a pointer to a newly constructed inversion list, initialized to
9190      * point to <list>, which has to be in the exact correct inversion list
9191      * form, including internal fields.  Thus this is a dangerous routine that
9192      * should not be used in the wrong hands.  The passed in 'list' contains
9193      * several header fields at the beginning that are not part of the
9194      * inversion list body proper */
9195
9196     const STRLEN length = (STRLEN) list[0];
9197     const UV version_id =          list[1];
9198     const bool offset   =    cBOOL(list[2]);
9199 #define HEADER_LENGTH 3
9200     /* If any of the above changes in any way, you must change HEADER_LENGTH
9201      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
9202      *      perl -E 'say int(rand 2**31-1)'
9203      */
9204 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
9205                                         data structure type, so that one being
9206                                         passed in can be validated to be an
9207                                         inversion list of the correct vintage.
9208                                        */
9209
9210     SV* invlist = newSV_type(SVt_INVLIST);
9211
9212     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
9213
9214     if (version_id != INVLIST_VERSION_ID) {
9215         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
9216     }
9217
9218     /* The generated array passed in includes header elements that aren't part
9219      * of the list proper, so start it just after them */
9220     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
9221
9222     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
9223                                shouldn't touch it */
9224
9225     *(get_invlist_offset_addr(invlist)) = offset;
9226
9227     /* The 'length' passed to us is the physical number of elements in the
9228      * inversion list.  But if there is an offset the logical number is one
9229      * less than that */
9230     invlist_set_len(invlist, length  - offset, offset);
9231
9232     invlist_set_previous_index(invlist, 0);
9233
9234     /* Initialize the iteration pointer. */
9235     invlist_iterfinish(invlist);
9236
9237     SvREADONLY_on(invlist);
9238
9239     return invlist;
9240 }
9241
9242 STATIC void
9243 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
9244 {
9245     /* Grow the maximum size of an inversion list */
9246
9247     PERL_ARGS_ASSERT_INVLIST_EXTEND;
9248
9249     assert(is_invlist(invlist));
9250
9251     /* Add one to account for the zero element at the beginning which may not
9252      * be counted by the calling parameters */
9253     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
9254 }
9255
9256 STATIC void
9257 S__append_range_to_invlist(pTHX_ SV* const invlist,
9258                                  const UV start, const UV end)
9259 {
9260    /* Subject to change or removal.  Append the range from 'start' to 'end' at
9261     * the end of the inversion list.  The range must be above any existing
9262     * ones. */
9263
9264     UV* array;
9265     UV max = invlist_max(invlist);
9266     UV len = _invlist_len(invlist);
9267     bool offset;
9268
9269     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
9270
9271     if (len == 0) { /* Empty lists must be initialized */
9272         offset = start != 0;
9273         array = _invlist_array_init(invlist, ! offset);
9274     }
9275     else {
9276         /* Here, the existing list is non-empty. The current max entry in the
9277          * list is generally the first value not in the set, except when the
9278          * set extends to the end of permissible values, in which case it is
9279          * the first entry in that final set, and so this call is an attempt to
9280          * append out-of-order */
9281
9282         UV final_element = len - 1;
9283         array = invlist_array(invlist);
9284         if (   array[final_element] > start
9285             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
9286         {
9287             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",
9288                      array[final_element], start,
9289                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
9290         }
9291
9292         /* Here, it is a legal append.  If the new range begins 1 above the end
9293          * of the range below it, it is extending the range below it, so the
9294          * new first value not in the set is one greater than the newly
9295          * extended range.  */
9296         offset = *get_invlist_offset_addr(invlist);
9297         if (array[final_element] == start) {
9298             if (end != UV_MAX) {
9299                 array[final_element] = end + 1;
9300             }
9301             else {
9302                 /* But if the end is the maximum representable on the machine,
9303                  * assume that infinity was actually what was meant.  Just let
9304                  * the range that this would extend to have no end */
9305                 invlist_set_len(invlist, len - 1, offset);
9306             }
9307             return;
9308         }
9309     }
9310
9311     /* Here the new range doesn't extend any existing set.  Add it */
9312
9313     len += 2;   /* Includes an element each for the start and end of range */
9314
9315     /* If wll overflow the existing space, extend, which may cause the array to
9316      * be moved */
9317     if (max < len) {
9318         invlist_extend(invlist, len);
9319
9320         /* Have to set len here to avoid assert failure in invlist_array() */
9321         invlist_set_len(invlist, len, offset);
9322
9323         array = invlist_array(invlist);
9324     }
9325     else {
9326         invlist_set_len(invlist, len, offset);
9327     }
9328
9329     /* The next item on the list starts the range, the one after that is
9330      * one past the new range.  */
9331     array[len - 2] = start;
9332     if (end != UV_MAX) {
9333         array[len - 1] = end + 1;
9334     }
9335     else {
9336         /* But if the end is the maximum representable on the machine, just let
9337          * the range have no end */
9338         invlist_set_len(invlist, len - 1, offset);
9339     }
9340 }
9341
9342 SSize_t
9343 Perl__invlist_search(SV* const invlist, const UV cp)
9344 {
9345     /* Searches the inversion list for the entry that contains the input code
9346      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
9347      * return value is the index into the list's array of the range that
9348      * contains <cp>, that is, 'i' such that
9349      *  array[i] <= cp < array[i+1]
9350      */
9351
9352     IV low = 0;
9353     IV mid;
9354     IV high = _invlist_len(invlist);
9355     const IV highest_element = high - 1;
9356     const UV* array;
9357
9358     PERL_ARGS_ASSERT__INVLIST_SEARCH;
9359
9360     /* If list is empty, return failure. */
9361     if (high == 0) {
9362         return -1;
9363     }
9364
9365     /* (We can't get the array unless we know the list is non-empty) */
9366     array = invlist_array(invlist);
9367
9368     mid = invlist_previous_index(invlist);
9369     assert(mid >=0);
9370     if (mid > highest_element) {
9371         mid = highest_element;
9372     }
9373
9374     /* <mid> contains the cache of the result of the previous call to this
9375      * function (0 the first time).  See if this call is for the same result,
9376      * or if it is for mid-1.  This is under the theory that calls to this
9377      * function will often be for related code points that are near each other.
9378      * And benchmarks show that caching gives better results.  We also test
9379      * here if the code point is within the bounds of the list.  These tests
9380      * replace others that would have had to be made anyway to make sure that
9381      * the array bounds were not exceeded, and these give us extra information
9382      * at the same time */
9383     if (cp >= array[mid]) {
9384         if (cp >= array[highest_element]) {
9385             return highest_element;
9386         }
9387
9388         /* Here, array[mid] <= cp < array[highest_element].  This means that
9389          * the final element is not the answer, so can exclude it; it also
9390          * means that <mid> is not the final element, so can refer to 'mid + 1'
9391          * safely */
9392         if (cp < array[mid + 1]) {
9393             return mid;
9394         }
9395         high--;
9396         low = mid + 1;
9397     }
9398     else { /* cp < aray[mid] */
9399         if (cp < array[0]) { /* Fail if outside the array */
9400             return -1;
9401         }
9402         high = mid;
9403         if (cp >= array[mid - 1]) {
9404             goto found_entry;
9405         }
9406     }
9407
9408     /* Binary search.  What we are looking for is <i> such that
9409      *  array[i] <= cp < array[i+1]
9410      * The loop below converges on the i+1.  Note that there may not be an
9411      * (i+1)th element in the array, and things work nonetheless */
9412     while (low < high) {
9413         mid = (low + high) / 2;
9414         assert(mid <= highest_element);
9415         if (array[mid] <= cp) { /* cp >= array[mid] */
9416             low = mid + 1;
9417
9418             /* We could do this extra test to exit the loop early.
9419             if (cp < array[low]) {
9420                 return mid;
9421             }
9422             */
9423         }
9424         else { /* cp < array[mid] */
9425             high = mid;
9426         }
9427     }
9428
9429   found_entry:
9430     high--;
9431     invlist_set_previous_index(invlist, high);
9432     return high;
9433 }
9434
9435 void
9436 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9437                                          const bool complement_b, SV** output)
9438 {
9439     /* Take the union of two inversion lists and point '*output' to it.  On
9440      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9441      * even 'a' or 'b').  If to an inversion list, the contents of the original
9442      * list will be replaced by the union.  The first list, 'a', may be
9443      * NULL, in which case a copy of the second list is placed in '*output'.
9444      * If 'complement_b' is TRUE, the union is taken of the complement
9445      * (inversion) of 'b' instead of b itself.
9446      *
9447      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9448      * Richard Gillam, published by Addison-Wesley, and explained at some
9449      * length there.  The preface says to incorporate its examples into your
9450      * code at your own risk.
9451      *
9452      * The algorithm is like a merge sort. */
9453
9454     const UV* array_a;    /* a's array */
9455     const UV* array_b;
9456     UV len_a;       /* length of a's array */
9457     UV len_b;
9458
9459     SV* u;                      /* the resulting union */
9460     UV* array_u;
9461     UV len_u = 0;
9462
9463     UV i_a = 0;             /* current index into a's array */
9464     UV i_b = 0;
9465     UV i_u = 0;
9466
9467     /* running count, as explained in the algorithm source book; items are
9468      * stopped accumulating and are output when the count changes to/from 0.
9469      * The count is incremented when we start a range that's in an input's set,
9470      * and decremented when we start a range that's not in a set.  So this
9471      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9472      * and hence nothing goes into the union; 1, just one of the inputs is in
9473      * its set (and its current range gets added to the union); and 2 when both
9474      * inputs are in their sets.  */
9475     UV count = 0;
9476
9477     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9478     assert(a != b);
9479     assert(*output == NULL || is_invlist(*output));
9480
9481     len_b = _invlist_len(b);
9482     if (len_b == 0) {
9483
9484         /* Here, 'b' is empty, hence it's complement is all possible code
9485          * points.  So if the union includes the complement of 'b', it includes
9486          * everything, and we need not even look at 'a'.  It's easiest to
9487          * create a new inversion list that matches everything.  */
9488         if (complement_b) {
9489             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9490
9491             if (*output == NULL) { /* If the output didn't exist, just point it
9492                                       at the new list */
9493                 *output = everything;
9494             }
9495             else { /* Otherwise, replace its contents with the new list */
9496                 invlist_replace_list_destroys_src(*output, everything);
9497                 SvREFCNT_dec_NN(everything);
9498             }
9499
9500             return;
9501         }
9502
9503         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9504          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9505          * output will be empty */
9506
9507         if (a == NULL || _invlist_len(a) == 0) {
9508             if (*output == NULL) {
9509                 *output = _new_invlist(0);
9510             }
9511             else {
9512                 invlist_clear(*output);
9513             }
9514             return;
9515         }
9516
9517         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9518          * union.  We can just return a copy of 'a' if '*output' doesn't point
9519          * to an existing list */
9520         if (*output == NULL) {
9521             *output = invlist_clone(a, NULL);
9522             return;
9523         }
9524
9525         /* If the output is to overwrite 'a', we have a no-op, as it's
9526          * already in 'a' */
9527         if (*output == a) {
9528             return;
9529         }
9530
9531         /* Here, '*output' is to be overwritten by 'a' */
9532         u = invlist_clone(a, NULL);
9533         invlist_replace_list_destroys_src(*output, u);
9534         SvREFCNT_dec_NN(u);
9535
9536         return;
9537     }
9538
9539     /* Here 'b' is not empty.  See about 'a' */
9540
9541     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9542
9543         /* Here, 'a' is empty (and b is not).  That means the union will come
9544          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9545          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9546          * the clone */
9547
9548         SV ** dest = (*output == NULL) ? output : &u;
9549         *dest = invlist_clone(b, NULL);
9550         if (complement_b) {
9551             _invlist_invert(*dest);
9552         }
9553
9554         if (dest == &u) {
9555             invlist_replace_list_destroys_src(*output, u);
9556             SvREFCNT_dec_NN(u);
9557         }
9558
9559         return;
9560     }
9561
9562     /* Here both lists exist and are non-empty */
9563     array_a = invlist_array(a);
9564     array_b = invlist_array(b);
9565
9566     /* If are to take the union of 'a' with the complement of b, set it
9567      * up so are looking at b's complement. */
9568     if (complement_b) {
9569
9570         /* To complement, we invert: if the first element is 0, remove it.  To
9571          * do this, we just pretend the array starts one later */
9572         if (array_b[0] == 0) {
9573             array_b++;
9574             len_b--;
9575         }
9576         else {
9577
9578             /* But if the first element is not zero, we pretend the list starts
9579              * at the 0 that is always stored immediately before the array. */
9580             array_b--;
9581             len_b++;
9582         }
9583     }
9584
9585     /* Size the union for the worst case: that the sets are completely
9586      * disjoint */
9587     u = _new_invlist(len_a + len_b);
9588
9589     /* Will contain U+0000 if either component does */
9590     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9591                                       || (len_b > 0 && array_b[0] == 0));
9592
9593     /* Go through each input list item by item, stopping when have exhausted
9594      * one of them */
9595     while (i_a < len_a && i_b < len_b) {
9596         UV cp;      /* The element to potentially add to the union's array */
9597         bool cp_in_set;   /* is it in the the input list's set or not */
9598
9599         /* We need to take one or the other of the two inputs for the union.
9600          * Since we are merging two sorted lists, we take the smaller of the
9601          * next items.  In case of a tie, we take first the one that is in its
9602          * set.  If we first took the one not in its set, it would decrement
9603          * the count, possibly to 0 which would cause it to be output as ending
9604          * the range, and the next time through we would take the same number,
9605          * and output it again as beginning the next range.  By doing it the
9606          * opposite way, there is no possibility that the count will be
9607          * momentarily decremented to 0, and thus the two adjoining ranges will
9608          * be seamlessly merged.  (In a tie and both are in the set or both not
9609          * in the set, it doesn't matter which we take first.) */
9610         if (       array_a[i_a] < array_b[i_b]
9611             || (   array_a[i_a] == array_b[i_b]
9612                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9613         {
9614             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9615             cp = array_a[i_a++];
9616         }
9617         else {
9618             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9619             cp = array_b[i_b++];
9620         }
9621
9622         /* Here, have chosen which of the two inputs to look at.  Only output
9623          * if the running count changes to/from 0, which marks the
9624          * beginning/end of a range that's in the set */
9625         if (cp_in_set) {
9626             if (count == 0) {
9627                 array_u[i_u++] = cp;
9628             }
9629             count++;
9630         }
9631         else {
9632             count--;
9633             if (count == 0) {
9634                 array_u[i_u++] = cp;
9635             }
9636         }
9637     }
9638
9639
9640     /* The loop above increments the index into exactly one of the input lists
9641      * each iteration, and ends when either index gets to its list end.  That
9642      * means the other index is lower than its end, and so something is
9643      * remaining in that one.  We decrement 'count', as explained below, if
9644      * that list is in its set.  (i_a and i_b each currently index the element
9645      * beyond the one we care about.) */
9646     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9647         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9648     {
9649         count--;
9650     }
9651
9652     /* Above we decremented 'count' if the list that had unexamined elements in
9653      * it was in its set.  This has made it so that 'count' being non-zero
9654      * means there isn't anything left to output; and 'count' equal to 0 means
9655      * that what is left to output is precisely that which is left in the
9656      * non-exhausted input list.
9657      *
9658      * To see why, note first that the exhausted input obviously has nothing
9659      * left to add to the union.  If it was in its set at its end, that means
9660      * the set extends from here to the platform's infinity, and hence so does
9661      * the union and the non-exhausted set is irrelevant.  The exhausted set
9662      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9663      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9664      * 'count' remains at 1.  This is consistent with the decremented 'count'
9665      * != 0 meaning there's nothing left to add to the union.
9666      *
9667      * But if the exhausted input wasn't in its set, it contributed 0 to
9668      * 'count', and the rest of the union will be whatever the other input is.
9669      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9670      * otherwise it gets decremented to 0.  This is consistent with 'count'
9671      * == 0 meaning the remainder of the union is whatever is left in the
9672      * non-exhausted list. */
9673     if (count != 0) {
9674         len_u = i_u;
9675     }
9676     else {
9677         IV copy_count = len_a - i_a;
9678         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9679             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9680         }
9681         else { /* The non-exhausted input is b */
9682             copy_count = len_b - i_b;
9683             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9684         }
9685         len_u = i_u + copy_count;
9686     }
9687
9688     /* Set the result to the final length, which can change the pointer to
9689      * array_u, so re-find it.  (Note that it is unlikely that this will
9690      * change, as we are shrinking the space, not enlarging it) */
9691     if (len_u != _invlist_len(u)) {
9692         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9693         invlist_trim(u);
9694         array_u = invlist_array(u);
9695     }
9696
9697     if (*output == NULL) {  /* Simply return the new inversion list */
9698         *output = u;
9699     }
9700     else {
9701         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9702          * could instead free '*output', and then set it to 'u', but experience
9703          * has shown [perl #127392] that if the input is a mortal, we can get a
9704          * huge build-up of these during regex compilation before they get
9705          * freed. */
9706         invlist_replace_list_destroys_src(*output, u);
9707         SvREFCNT_dec_NN(u);
9708     }
9709
9710     return;
9711 }
9712
9713 void
9714 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9715                                                const bool complement_b, SV** i)
9716 {
9717     /* Take the intersection of two inversion lists and point '*i' to it.  On
9718      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9719      * even 'a' or 'b').  If to an inversion list, the contents of the original
9720      * list will be replaced by the intersection.  The first list, 'a', may be
9721      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9722      * TRUE, the result will be the intersection of 'a' and the complement (or
9723      * inversion) of 'b' instead of 'b' directly.
9724      *
9725      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9726      * Richard Gillam, published by Addison-Wesley, and explained at some
9727      * length there.  The preface says to incorporate its examples into your
9728      * code at your own risk.  In fact, it had bugs
9729      *
9730      * The algorithm is like a merge sort, and is essentially the same as the
9731      * union above
9732      */
9733
9734     const UV* array_a;          /* a's array */
9735     const UV* array_b;
9736     UV len_a;   /* length of a's array */
9737     UV len_b;
9738
9739     SV* r;                   /* the resulting intersection */
9740     UV* array_r;
9741     UV len_r = 0;
9742
9743     UV i_a = 0;             /* current index into a's array */
9744     UV i_b = 0;
9745     UV i_r = 0;
9746
9747     /* running count of how many of the two inputs are postitioned at ranges
9748      * that are in their sets.  As explained in the algorithm source book,
9749      * items are stopped accumulating and are output when the count changes
9750      * to/from 2.  The count is incremented when we start a range that's in an
9751      * input's set, and decremented when we start a range that's not in a set.
9752      * Only when it is 2 are we in the intersection. */
9753     UV count = 0;
9754
9755     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9756     assert(a != b);
9757     assert(*i == NULL || is_invlist(*i));
9758
9759     /* Special case if either one is empty */
9760     len_a = (a == NULL) ? 0 : _invlist_len(a);
9761     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9762         if (len_a != 0 && complement_b) {
9763
9764             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9765              * must be empty.  Here, also we are using 'b's complement, which
9766              * hence must be every possible code point.  Thus the intersection
9767              * is simply 'a'. */
9768
9769             if (*i == a) {  /* No-op */
9770                 return;
9771             }
9772
9773             if (*i == NULL) {
9774                 *i = invlist_clone(a, NULL);
9775                 return;
9776             }
9777
9778             r = invlist_clone(a, NULL);
9779             invlist_replace_list_destroys_src(*i, r);
9780             SvREFCNT_dec_NN(r);
9781             return;
9782         }
9783
9784         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9785          * intersection must be empty */
9786         if (*i == NULL) {
9787             *i = _new_invlist(0);
9788             return;
9789         }
9790
9791         invlist_clear(*i);
9792         return;
9793     }
9794
9795     /* Here both lists exist and are non-empty */
9796     array_a = invlist_array(a);
9797     array_b = invlist_array(b);
9798
9799     /* If are to take the intersection of 'a' with the complement of b, set it
9800      * up so are looking at b's complement. */
9801     if (complement_b) {
9802
9803         /* To complement, we invert: if the first element is 0, remove it.  To
9804          * do this, we just pretend the array starts one later */
9805         if (array_b[0] == 0) {
9806             array_b++;
9807             len_b--;
9808         }
9809         else {
9810
9811             /* But if the first element is not zero, we pretend the list starts
9812              * at the 0 that is always stored immediately before the array. */
9813             array_b--;
9814             len_b++;
9815         }
9816     }
9817
9818     /* Size the intersection for the worst case: that the intersection ends up
9819      * fragmenting everything to be completely disjoint */
9820     r= _new_invlist(len_a + len_b);
9821
9822     /* Will contain U+0000 iff both components do */
9823     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9824                                      && len_b > 0 && array_b[0] == 0);
9825
9826     /* Go through each list item by item, stopping when have exhausted one of
9827      * them */
9828     while (i_a < len_a && i_b < len_b) {
9829         UV cp;      /* The element to potentially add to the intersection's
9830                        array */
9831         bool cp_in_set; /* Is it in the input list's set or not */
9832
9833         /* We need to take one or the other of the two inputs for the
9834          * intersection.  Since we are merging two sorted lists, we take the
9835          * smaller of the next items.  In case of a tie, we take first the one
9836          * that is not in its set (a difference from the union algorithm).  If
9837          * we first took the one in its set, it would increment the count,
9838          * possibly to 2 which would cause it to be output as starting a range
9839          * in the intersection, and the next time through we would take that
9840          * same number, and output it again as ending the set.  By doing the
9841          * opposite of this, there is no possibility that the count will be
9842          * momentarily incremented to 2.  (In a tie and both are in the set or
9843          * both not in the set, it doesn't matter which we take first.) */
9844         if (       array_a[i_a] < array_b[i_b]
9845             || (   array_a[i_a] == array_b[i_b]
9846                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9847         {
9848             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9849             cp = array_a[i_a++];
9850         }
9851         else {
9852             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9853             cp= array_b[i_b++];
9854         }
9855
9856         /* Here, have chosen which of the two inputs to look at.  Only output
9857          * if the running count changes to/from 2, which marks the
9858          * beginning/end of a range that's in the intersection */
9859         if (cp_in_set) {
9860             count++;
9861             if (count == 2) {
9862                 array_r[i_r++] = cp;
9863             }
9864         }
9865         else {
9866             if (count == 2) {
9867                 array_r[i_r++] = cp;
9868             }
9869             count--;
9870         }
9871
9872     }
9873
9874     /* The loop above increments the index into exactly one of the input lists
9875      * each iteration, and ends when either index gets to its list end.  That
9876      * means the other index is lower than its end, and so something is
9877      * remaining in that one.  We increment 'count', as explained below, if the
9878      * exhausted list was in its set.  (i_a and i_b each currently index the
9879      * element beyond the one we care about.) */
9880     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9881         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9882     {
9883         count++;
9884     }
9885
9886     /* Above we incremented 'count' if the exhausted list was in its set.  This
9887      * has made it so that 'count' being below 2 means there is nothing left to
9888      * output; otheriwse what's left to add to the intersection is precisely
9889      * that which is left in the non-exhausted input list.
9890      *
9891      * To see why, note first that the exhausted input obviously has nothing
9892      * left to affect the intersection.  If it was in its set at its end, that
9893      * means the set extends from here to the platform's infinity, and hence
9894      * anything in the non-exhausted's list will be in the intersection, and
9895      * anything not in it won't be.  Hence, the rest of the intersection is
9896      * precisely what's in the non-exhausted list  The exhausted set also
9897      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9898      * it means 'count' is now at least 2.  This is consistent with the
9899      * incremented 'count' being >= 2 means to add the non-exhausted list to
9900      * the intersection.
9901      *
9902      * But if the exhausted input wasn't in its set, it contributed 0 to
9903      * 'count', and the intersection can't include anything further; the
9904      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9905      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9906      * further to add to the intersection. */
9907     if (count < 2) { /* Nothing left to put in the intersection. */
9908         len_r = i_r;
9909     }
9910     else { /* copy the non-exhausted list, unchanged. */
9911         IV copy_count = len_a - i_a;
9912         if (copy_count > 0) {   /* a is the one with stuff left */
9913             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9914         }
9915         else {  /* b is the one with stuff left */
9916             copy_count = len_b - i_b;
9917             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9918         }
9919         len_r = i_r + copy_count;
9920     }
9921
9922     /* Set the result to the final length, which can change the pointer to
9923      * array_r, so re-find it.  (Note that it is unlikely that this will
9924      * change, as we are shrinking the space, not enlarging it) */
9925     if (len_r != _invlist_len(r)) {
9926         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9927         invlist_trim(r);
9928         array_r = invlist_array(r);
9929     }
9930
9931     if (*i == NULL) { /* Simply return the calculated intersection */
9932         *i = r;
9933     }
9934     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9935               instead free '*i', and then set it to 'r', but experience has
9936               shown [perl #127392] that if the input is a mortal, we can get a
9937               huge build-up of these during regex compilation before they get
9938               freed. */
9939         if (len_r) {
9940             invlist_replace_list_destroys_src(*i, r);
9941         }
9942         else {
9943             invlist_clear(*i);
9944         }
9945         SvREFCNT_dec_NN(r);
9946     }
9947
9948     return;
9949 }
9950
9951 SV*
9952 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9953 {
9954     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9955      * set.  A pointer to the inversion list is returned.  This may actually be
9956      * a new list, in which case the passed in one has been destroyed.  The
9957      * passed-in inversion list can be NULL, in which case a new one is created
9958      * with just the one range in it.  The new list is not necessarily
9959      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9960      * result of this function.  The gain would not be large, and in many
9961      * cases, this is called multiple times on a single inversion list, so
9962      * anything freed may almost immediately be needed again.
9963      *
9964      * This used to mostly call the 'union' routine, but that is much more
9965      * heavyweight than really needed for a single range addition */
9966
9967     UV* array;              /* The array implementing the inversion list */
9968     UV len;                 /* How many elements in 'array' */
9969     SSize_t i_s;            /* index into the invlist array where 'start'
9970                                should go */
9971     SSize_t i_e = 0;        /* And the index where 'end' should go */
9972     UV cur_highest;         /* The highest code point in the inversion list
9973                                upon entry to this function */
9974
9975     /* This range becomes the whole inversion list if none already existed */
9976     if (invlist == NULL) {
9977         invlist = _new_invlist(2);
9978         _append_range_to_invlist(invlist, start, end);
9979         return invlist;
9980     }
9981
9982     /* Likewise, if the inversion list is currently empty */
9983     len = _invlist_len(invlist);
9984     if (len == 0) {
9985         _append_range_to_invlist(invlist, start, end);
9986         return invlist;
9987     }
9988
9989     /* Starting here, we have to know the internals of the list */
9990     array = invlist_array(invlist);
9991
9992     /* If the new range ends higher than the current highest ... */
9993     cur_highest = invlist_highest(invlist);
9994     if (end > cur_highest) {
9995
9996         /* If the whole range is higher, we can just append it */
9997         if (start > cur_highest) {
9998             _append_range_to_invlist(invlist, start, end);
9999             return invlist;
10000         }
10001
10002         /* Otherwise, add the portion that is higher ... */
10003         _append_range_to_invlist(invlist, cur_highest + 1, end);
10004
10005         /* ... and continue on below to handle the rest.  As a result of the
10006          * above append, we know that the index of the end of the range is the
10007          * final even numbered one of the array.  Recall that the final element
10008          * always starts a range that extends to infinity.  If that range is in
10009          * the set (meaning the set goes from here to infinity), it will be an
10010          * even index, but if it isn't in the set, it's odd, and the final
10011          * range in the set is one less, which is even. */
10012         if (end == UV_MAX) {
10013             i_e = len;
10014         }
10015         else {
10016             i_e = len - 2;
10017         }
10018     }
10019
10020     /* We have dealt with appending, now see about prepending.  If the new
10021      * range starts lower than the current lowest ... */
10022     if (start < array[0]) {
10023
10024         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
10025          * Let the union code handle it, rather than having to know the
10026          * trickiness in two code places.  */
10027         if (UNLIKELY(start == 0)) {
10028             SV* range_invlist;
10029
10030             range_invlist = _new_invlist(2);
10031             _append_range_to_invlist(range_invlist, start, end);
10032
10033             _invlist_union(invlist, range_invlist, &invlist);
10034
10035             SvREFCNT_dec_NN(range_invlist);
10036
10037             return invlist;
10038         }
10039
10040         /* If the whole new range comes before the first entry, and doesn't
10041          * extend it, we have to insert it as an additional range */
10042         if (end < array[0] - 1) {
10043             i_s = i_e = -1;
10044             goto splice_in_new_range;
10045         }
10046
10047         /* Here the new range adjoins the existing first range, extending it
10048          * downwards. */
10049         array[0] = start;
10050
10051         /* And continue on below to handle the rest.  We know that the index of
10052          * the beginning of the range is the first one of the array */
10053         i_s = 0;
10054     }
10055     else { /* Not prepending any part of the new range to the existing list.
10056             * Find where in the list it should go.  This finds i_s, such that:
10057             *     invlist[i_s] <= start < array[i_s+1]
10058             */
10059         i_s = _invlist_search(invlist, start);
10060     }
10061
10062     /* At this point, any extending before the beginning of the inversion list
10063      * and/or after the end has been done.  This has made it so that, in the
10064      * code below, each endpoint of the new range is either in a range that is
10065      * in the set, or is in a gap between two ranges that are.  This means we
10066      * don't have to worry about exceeding the array bounds.
10067      *
10068      * Find where in the list the new range ends (but we can skip this if we
10069      * have already determined what it is, or if it will be the same as i_s,
10070      * which we already have computed) */
10071     if (i_e == 0) {
10072         i_e = (start == end)
10073               ? i_s
10074               : _invlist_search(invlist, end);
10075     }
10076
10077     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
10078      * is a range that goes to infinity there is no element at invlist[i_e+1],
10079      * so only the first relation holds. */
10080
10081     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10082
10083         /* Here, the ranges on either side of the beginning of the new range
10084          * are in the set, and this range starts in the gap between them.
10085          *
10086          * The new range extends the range above it downwards if the new range
10087          * ends at or above that range's start */
10088         const bool extends_the_range_above = (   end == UV_MAX
10089                                               || end + 1 >= array[i_s+1]);
10090
10091         /* The new range extends the range below it upwards if it begins just
10092          * after where that range ends */
10093         if (start == array[i_s]) {
10094
10095             /* If the new range fills the entire gap between the other ranges,
10096              * they will get merged together.  Other ranges may also get
10097              * merged, depending on how many of them the new range spans.  In
10098              * the general case, we do the merge later, just once, after we
10099              * figure out how many to merge.  But in the case where the new
10100              * range exactly spans just this one gap (possibly extending into
10101              * the one above), we do the merge here, and an early exit.  This
10102              * is done here to avoid having to special case later. */
10103             if (i_e - i_s <= 1) {
10104
10105                 /* If i_e - i_s == 1, it means that the new range terminates
10106                  * within the range above, and hence 'extends_the_range_above'
10107                  * must be true.  (If the range above it extends to infinity,
10108                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
10109                  * will be 0, so no harm done.) */
10110                 if (extends_the_range_above) {
10111                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
10112                     invlist_set_len(invlist,
10113                                     len - 2,
10114                                     *(get_invlist_offset_addr(invlist)));
10115                     return invlist;
10116                 }
10117
10118                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
10119                  * to the same range, and below we are about to decrement i_s
10120                  * */
10121                 i_e--;
10122             }
10123
10124             /* Here, the new range is adjacent to the one below.  (It may also
10125              * span beyond the range above, but that will get resolved later.)
10126              * Extend the range below to include this one. */
10127             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
10128             i_s--;
10129             start = array[i_s];
10130         }
10131         else if (extends_the_range_above) {
10132
10133             /* Here the new range only extends the range above it, but not the
10134              * one below.  It merges with the one above.  Again, we keep i_e
10135              * and i_s in sync if they point to the same range */
10136             if (i_e == i_s) {
10137                 i_e++;
10138             }
10139             i_s++;
10140             array[i_s] = start;
10141         }
10142     }
10143
10144     /* Here, we've dealt with the new range start extending any adjoining
10145      * existing ranges.
10146      *
10147      * If the new range extends to infinity, it is now the final one,
10148      * regardless of what was there before */
10149     if (UNLIKELY(end == UV_MAX)) {
10150         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
10151         return invlist;
10152     }
10153
10154     /* If i_e started as == i_s, it has also been dealt with,
10155      * and been updated to the new i_s, which will fail the following if */
10156     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
10157
10158         /* Here, the ranges on either side of the end of the new range are in
10159          * the set, and this range ends in the gap between them.
10160          *
10161          * If this range is adjacent to (hence extends) the range above it, it
10162          * becomes part of that range; likewise if it extends the range below,
10163          * it becomes part of that range */
10164         if (end + 1 == array[i_e+1]) {
10165             i_e++;
10166             array[i_e] = start;
10167         }
10168         else if (start <= array[i_e]) {
10169             array[i_e] = end + 1;
10170             i_e--;
10171         }
10172     }
10173
10174     if (i_s == i_e) {
10175
10176         /* If the range fits entirely in an existing range (as possibly already
10177          * extended above), it doesn't add anything new */
10178         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10179             return invlist;
10180         }
10181
10182         /* Here, no part of the range is in the list.  Must add it.  It will
10183          * occupy 2 more slots */
10184       splice_in_new_range:
10185
10186         invlist_extend(invlist, len + 2);
10187         array = invlist_array(invlist);
10188         /* Move the rest of the array down two slots. Don't include any
10189          * trailing NUL */
10190         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
10191
10192         /* Do the actual splice */
10193         array[i_e+1] = start;
10194         array[i_e+2] = end + 1;
10195         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
10196         return invlist;
10197     }
10198
10199     /* Here the new range crossed the boundaries of a pre-existing range.  The
10200      * code above has adjusted things so that both ends are in ranges that are
10201      * in the set.  This means everything in between must also be in the set.
10202      * Just squash things together */
10203     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
10204     invlist_set_len(invlist,
10205                     len - i_e + i_s,
10206                     *(get_invlist_offset_addr(invlist)));
10207
10208     return invlist;
10209 }
10210
10211 SV*
10212 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
10213                                  UV** other_elements_ptr)
10214 {
10215     /* Create and return an inversion list whose contents are to be populated
10216      * by the caller.  The caller gives the number of elements (in 'size') and
10217      * the very first element ('element0').  This function will set
10218      * '*other_elements_ptr' to an array of UVs, where the remaining elements
10219      * are to be placed.
10220      *
10221      * Obviously there is some trust involved that the caller will properly
10222      * fill in the other elements of the array.
10223      *
10224      * (The first element needs to be passed in, as the underlying code does
10225      * things differently depending on whether it is zero or non-zero) */
10226
10227     SV* invlist = _new_invlist(size);
10228     bool offset;
10229
10230     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
10231
10232     invlist = add_cp_to_invlist(invlist, element0);
10233     offset = *get_invlist_offset_addr(invlist);
10234
10235     invlist_set_len(invlist, size, offset);
10236     *other_elements_ptr = invlist_array(invlist) + 1;
10237     return invlist;
10238 }
10239
10240 #endif
10241
10242 PERL_STATIC_INLINE SV*
10243 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
10244     return _add_range_to_invlist(invlist, cp, cp);
10245 }
10246
10247 #ifndef PERL_IN_XSUB_RE
10248 void
10249 Perl__invlist_invert(pTHX_ SV* const invlist)
10250 {
10251     /* Complement the input inversion list.  This adds a 0 if the list didn't
10252      * have a zero; removes it otherwise.  As described above, the data
10253      * structure is set up so that this is very efficient */
10254
10255     PERL_ARGS_ASSERT__INVLIST_INVERT;
10256
10257     assert(! invlist_is_iterating(invlist));
10258
10259     /* The inverse of matching nothing is matching everything */
10260     if (_invlist_len(invlist) == 0) {
10261         _append_range_to_invlist(invlist, 0, UV_MAX);
10262         return;
10263     }
10264
10265     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
10266 }
10267
10268 SV*
10269 Perl_invlist_clone(pTHX_ SV* const invlist, SV* new_invlist)
10270 {
10271     /* Return a new inversion list that is a copy of the input one, which is
10272      * unchanged.  The new list will not be mortal even if the old one was. */
10273
10274     const STRLEN nominal_length = _invlist_len(invlist);
10275     const STRLEN physical_length = SvCUR(invlist);
10276     const bool offset = *(get_invlist_offset_addr(invlist));
10277
10278     PERL_ARGS_ASSERT_INVLIST_CLONE;
10279
10280     if (new_invlist == NULL) {
10281         new_invlist = _new_invlist(nominal_length);
10282     }
10283     else {
10284         sv_upgrade(new_invlist, SVt_INVLIST);
10285         initialize_invlist_guts(new_invlist, nominal_length);
10286     }
10287
10288     *(get_invlist_offset_addr(new_invlist)) = offset;
10289     invlist_set_len(new_invlist, nominal_length, offset);
10290     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
10291
10292     return new_invlist;
10293 }
10294
10295 #endif
10296
10297 PERL_STATIC_INLINE STRLEN*
10298 S_get_invlist_iter_addr(SV* invlist)
10299 {
10300     /* Return the address of the UV that contains the current iteration
10301      * position */
10302
10303     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
10304
10305     assert(is_invlist(invlist));
10306
10307     return &(((XINVLIST*) SvANY(invlist))->iterator);
10308 }
10309
10310 PERL_STATIC_INLINE void
10311 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
10312 {
10313     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
10314
10315     *get_invlist_iter_addr(invlist) = 0;
10316 }
10317
10318 PERL_STATIC_INLINE void
10319 S_invlist_iterfinish(SV* invlist)
10320 {
10321     /* Terminate iterator for invlist.  This is to catch development errors.
10322      * Any iteration that is interrupted before completed should call this
10323      * function.  Functions that add code points anywhere else but to the end
10324      * of an inversion list assert that they are not in the middle of an
10325      * iteration.  If they were, the addition would make the iteration
10326      * problematical: if the iteration hadn't reached the place where things
10327      * were being added, it would be ok */
10328
10329     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
10330
10331     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
10332 }
10333
10334 STATIC bool
10335 S_invlist_iternext(SV* invlist, UV* start, UV* end)
10336 {
10337     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
10338      * This call sets in <*start> and <*end>, the next range in <invlist>.
10339      * Returns <TRUE> if successful and the next call will return the next
10340      * range; <FALSE> if was already at the end of the list.  If the latter,
10341      * <*start> and <*end> are unchanged, and the next call to this function
10342      * will start over at the beginning of the list */
10343
10344     STRLEN* pos = get_invlist_iter_addr(invlist);
10345     UV len = _invlist_len(invlist);
10346     UV *array;
10347
10348     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
10349
10350     if (*pos >= len) {
10351         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
10352         return FALSE;
10353     }
10354
10355     array = invlist_array(invlist);
10356
10357     *start = array[(*pos)++];
10358
10359     if (*pos >= len) {
10360         *end = UV_MAX;
10361     }
10362     else {
10363         *end = array[(*pos)++] - 1;
10364     }
10365
10366     return TRUE;
10367 }
10368
10369 PERL_STATIC_INLINE UV
10370 S_invlist_highest(SV* const invlist)
10371 {
10372     /* Returns the highest code point that matches an inversion list.  This API
10373      * has an ambiguity, as it returns 0 under either the highest is actually
10374      * 0, or if the list is empty.  If this distinction matters to you, check
10375      * for emptiness before calling this function */
10376
10377     UV len = _invlist_len(invlist);
10378     UV *array;
10379
10380     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
10381
10382     if (len == 0) {
10383         return 0;
10384     }
10385
10386     array = invlist_array(invlist);
10387
10388     /* The last element in the array in the inversion list always starts a
10389      * range that goes to infinity.  That range may be for code points that are
10390      * matched in the inversion list, or it may be for ones that aren't
10391      * matched.  In the latter case, the highest code point in the set is one
10392      * less than the beginning of this range; otherwise it is the final element
10393      * of this range: infinity */
10394     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
10395            ? UV_MAX
10396            : array[len - 1] - 1;
10397 }
10398
10399 STATIC SV *
10400 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10401 {
10402     /* Get the contents of an inversion list into a string SV so that they can
10403      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10404      * traditionally done for debug tracing; otherwise it uses a format
10405      * suitable for just copying to the output, with blanks between ranges and
10406      * a dash between range components */
10407
10408     UV start, end;
10409     SV* output;
10410     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10411     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10412
10413     if (traditional_style) {
10414         output = newSVpvs("\n");
10415     }
10416     else {
10417         output = newSVpvs("");
10418     }
10419
10420     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10421
10422     assert(! invlist_is_iterating(invlist));
10423
10424     invlist_iterinit(invlist);
10425     while (invlist_iternext(invlist, &start, &end)) {
10426         if (end == UV_MAX) {
10427             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c",
10428                                           start, intra_range_delimiter,
10429                                                  inter_range_delimiter);
10430         }
10431         else if (end != start) {
10432             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10433                                           start,
10434                                                    intra_range_delimiter,
10435                                                   end, inter_range_delimiter);
10436         }
10437         else {
10438             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10439                                           start, inter_range_delimiter);
10440         }
10441     }
10442
10443     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10444         SvCUR_set(output, SvCUR(output) - 1);
10445     }
10446
10447     return output;
10448 }
10449
10450 #ifndef PERL_IN_XSUB_RE
10451 void
10452 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10453                          const char * const indent, SV* const invlist)
10454 {
10455     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10456      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10457      * the string 'indent'.  The output looks like this:
10458          [0] 0x000A .. 0x000D
10459          [2] 0x0085
10460          [4] 0x2028 .. 0x2029
10461          [6] 0x3104 .. INFTY
10462      * This means that the first range of code points matched by the list are
10463      * 0xA through 0xD; the second range contains only the single code point
10464      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10465      * are used to define each range (except if the final range extends to
10466      * infinity, only a single element is needed).  The array index of the
10467      * first element for the corresponding range is given in brackets. */
10468
10469     UV start, end;
10470     STRLEN count = 0;
10471
10472     PERL_ARGS_ASSERT__INVLIST_DUMP;
10473
10474     if (invlist_is_iterating(invlist)) {
10475         Perl_dump_indent(aTHX_ level, file,
10476              "%sCan't dump inversion list because is in middle of iterating\n",
10477              indent);
10478         return;
10479     }
10480
10481     invlist_iterinit(invlist);
10482     while (invlist_iternext(invlist, &start, &end)) {
10483         if (end == UV_MAX) {
10484             Perl_dump_indent(aTHX_ level, file,
10485                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n",
10486                                    indent, (UV)count, start);
10487         }
10488         else if (end != start) {
10489             Perl_dump_indent(aTHX_ level, file,
10490                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10491                                 indent, (UV)count, start,         end);
10492         }
10493         else {
10494             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10495                                             indent, (UV)count, start);
10496         }
10497         count += 2;
10498     }
10499 }
10500
10501 #endif
10502
10503 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10504 bool
10505 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10506 {
10507     /* Return a boolean as to if the two passed in inversion lists are
10508      * identical.  The final argument, if TRUE, says to take the complement of
10509      * the second inversion list before doing the comparison */
10510
10511     const UV len_a = _invlist_len(a);
10512     UV len_b = _invlist_len(b);
10513
10514     const UV* array_a = NULL;
10515     const UV* array_b = NULL;
10516
10517     PERL_ARGS_ASSERT__INVLISTEQ;
10518
10519     /* This code avoids accessing the arrays unless it knows the length is
10520      * non-zero */
10521
10522     if (len_a == 0) {
10523         if (len_b == 0) {
10524             return ! complement_b;
10525         }
10526     }
10527     else {
10528         array_a = invlist_array(a);
10529     }
10530
10531     if (len_b != 0) {
10532         array_b = invlist_array(b);
10533     }
10534
10535     /* If are to compare 'a' with the complement of b, set it
10536      * up so are looking at b's complement. */
10537     if (complement_b) {
10538
10539         /* The complement of nothing is everything, so <a> would have to have
10540          * just one element, starting at zero (ending at infinity) */
10541         if (len_b == 0) {
10542             return (len_a == 1 && array_a[0] == 0);
10543         }
10544         if (array_b[0] == 0) {
10545
10546             /* Otherwise, to complement, we invert.  Here, the first element is
10547              * 0, just remove it.  To do this, we just pretend the array starts
10548              * one later */
10549
10550             array_b++;
10551             len_b--;
10552         }
10553         else {
10554
10555             /* But if the first element is not zero, we pretend the list starts
10556              * at the 0 that is always stored immediately before the array. */
10557             array_b--;
10558             len_b++;
10559         }
10560     }
10561
10562     return    len_a == len_b
10563            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10564
10565 }
10566 #endif
10567
10568 /*
10569  * As best we can, determine the characters that can match the start of
10570  * the given EXACTF-ish node.  This is for use in creating ssc nodes, so there
10571  * can be false positive matches
10572  *
10573  * Returns the invlist as a new SV*; it is the caller's responsibility to
10574  * call SvREFCNT_dec() when done with it.
10575  */
10576 STATIC SV*
10577 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10578 {
10579     dVAR;
10580     const U8 * s = (U8*)STRING(node);
10581     SSize_t bytelen = STR_LEN(node);
10582     UV uc;
10583     /* Start out big enough for 2 separate code points */
10584     SV* invlist = _new_invlist(4);
10585
10586     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10587
10588     if (! UTF) {
10589         uc = *s;
10590
10591         /* We punt and assume can match anything if the node begins
10592          * with a multi-character fold.  Things are complicated.  For
10593          * example, /ffi/i could match any of:
10594          *  "\N{LATIN SMALL LIGATURE FFI}"
10595          *  "\N{LATIN SMALL LIGATURE FF}I"
10596          *  "F\N{LATIN SMALL LIGATURE FI}"
10597          *  plus several other things; and making sure we have all the
10598          *  possibilities is hard. */
10599         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10600             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10601         }
10602         else {
10603             /* Any Latin1 range character can potentially match any
10604              * other depending on the locale, and in Turkic locales, U+130 and
10605              * U+131 */
10606             if (OP(node) == EXACTFL) {
10607                 _invlist_union(invlist, PL_Latin1, &invlist);
10608                 invlist = add_cp_to_invlist(invlist,
10609                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10610                 invlist = add_cp_to_invlist(invlist,
10611                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10612             }
10613             else {
10614                 /* But otherwise, it matches at least itself.  We can
10615                  * quickly tell if it has a distinct fold, and if so,
10616                  * it matches that as well */
10617                 invlist = add_cp_to_invlist(invlist, uc);
10618                 if (IS_IN_SOME_FOLD_L1(uc))
10619                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10620             }
10621
10622             /* Some characters match above-Latin1 ones under /i.  This
10623              * is true of EXACTFL ones when the locale is UTF-8 */
10624             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10625                 && (! isASCII(uc) || (OP(node) != EXACTFAA
10626                                     && OP(node) != EXACTFAA_NO_TRIE)))
10627             {
10628                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10629             }
10630         }
10631     }
10632     else {  /* Pattern is UTF-8 */
10633         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10634         const U8* e = s + bytelen;
10635         IV fc;
10636
10637         fc = uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10638
10639         /* The only code points that aren't folded in a UTF EXACTFish
10640          * node are are the problematic ones in EXACTFL nodes */
10641         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10642             /* We need to check for the possibility that this EXACTFL
10643              * node begins with a multi-char fold.  Therefore we fold
10644              * the first few characters of it so that we can make that
10645              * check */
10646             U8 *d = folded;
10647             int i;
10648
10649             fc = -1;
10650             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10651                 if (isASCII(*s)) {
10652                     *(d++) = (U8) toFOLD(*s);
10653                     if (fc < 0) {       /* Save the first fold */
10654                         fc = *(d-1);
10655                     }
10656                     s++;
10657                 }
10658                 else {
10659                     STRLEN len;
10660                     UV fold = toFOLD_utf8_safe(s, e, d, &len);
10661                     if (fc < 0) {       /* Save the first fold */
10662                         fc = fold;
10663                     }
10664                     d += len;
10665                     s += UTF8SKIP(s);
10666                 }
10667             }
10668
10669             /* And set up so the code below that looks in this folded
10670              * buffer instead of the node's string */
10671             e = d;
10672             s = folded;
10673         }
10674
10675         /* When we reach here 's' points to the fold of the first
10676          * character(s) of the node; and 'e' points to far enough along
10677          * the folded string to be just past any possible multi-char
10678          * fold.
10679          *
10680          * Unlike the non-UTF-8 case, the macro for determining if a
10681          * string is a multi-char fold requires all the characters to
10682          * already be folded.  This is because of all the complications
10683          * if not.  Note that they are folded anyway, except in EXACTFL
10684          * nodes.  Like the non-UTF case above, we punt if the node
10685          * begins with a multi-char fold  */
10686
10687         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10688             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10689         }
10690         else {  /* Single char fold */
10691             unsigned int k;
10692             unsigned int first_fold;
10693             const unsigned int * remaining_folds;
10694             Size_t folds_count;
10695
10696             /* It matches itself */
10697             invlist = add_cp_to_invlist(invlist, fc);
10698
10699             /* ... plus all the things that fold to it, which are found in
10700              * PL_utf8_foldclosures */
10701             folds_count = _inverse_folds(fc, &first_fold,
10702                                                 &remaining_folds);
10703             for (k = 0; k < folds_count; k++) {
10704                 UV c = (k == 0) ? first_fold : remaining_folds[k-1];
10705
10706                 /* /aa doesn't allow folds between ASCII and non- */
10707                 if (   (OP(node) == EXACTFAA || OP(node) == EXACTFAA_NO_TRIE)
10708                     && isASCII(c) != isASCII(fc))
10709                 {
10710                     continue;
10711                 }
10712
10713                 invlist = add_cp_to_invlist(invlist, c);
10714             }
10715
10716             if (OP(node) == EXACTFL) {
10717
10718                 /* If either [iI] are present in an EXACTFL node the above code
10719                  * should have added its normal case pair, but under a Turkish
10720                  * locale they could match instead the case pairs from it.  Add
10721                  * those as potential matches as well */
10722                 if (isALPHA_FOLD_EQ(fc, 'I')) {
10723                     invlist = add_cp_to_invlist(invlist,
10724                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10725                     invlist = add_cp_to_invlist(invlist,
10726                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10727                 }
10728                 else if (fc == LATIN_SMALL_LETTER_DOTLESS_I) {
10729                     invlist = add_cp_to_invlist(invlist, 'I');
10730                 }
10731                 else if (fc == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
10732                     invlist = add_cp_to_invlist(invlist, 'i');
10733                 }
10734             }
10735         }
10736     }
10737
10738     return invlist;
10739 }
10740
10741 #undef HEADER_LENGTH
10742 #undef TO_INTERNAL_SIZE
10743 #undef FROM_INTERNAL_SIZE
10744 #undef INVLIST_VERSION_ID
10745
10746 /* End of inversion list object */
10747
10748 STATIC void
10749 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10750 {
10751     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10752      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10753      * should point to the first flag; it is updated on output to point to the
10754      * final ')' or ':'.  There needs to be at least one flag, or this will
10755      * abort */
10756
10757     /* for (?g), (?gc), and (?o) warnings; warning
10758        about (?c) will warn about (?g) -- japhy    */
10759
10760 #define WASTED_O  0x01
10761 #define WASTED_G  0x02
10762 #define WASTED_C  0x04
10763 #define WASTED_GC (WASTED_G|WASTED_C)
10764     I32 wastedflags = 0x00;
10765     U32 posflags = 0, negflags = 0;
10766     U32 *flagsp = &posflags;
10767     char has_charset_modifier = '\0';
10768     regex_charset cs;
10769     bool has_use_defaults = FALSE;
10770     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10771     int x_mod_count = 0;
10772
10773     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10774
10775     /* '^' as an initial flag sets certain defaults */
10776     if (UCHARAT(RExC_parse) == '^') {
10777         RExC_parse++;
10778         has_use_defaults = TRUE;
10779         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10780         cs = (RExC_uni_semantics)
10781              ? REGEX_UNICODE_CHARSET
10782              : REGEX_DEPENDS_CHARSET;
10783         set_regex_charset(&RExC_flags, cs);
10784     }
10785     else {
10786         cs = get_regex_charset(RExC_flags);
10787         if (   cs == REGEX_DEPENDS_CHARSET
10788             && RExC_uni_semantics)
10789         {
10790             cs = REGEX_UNICODE_CHARSET;
10791         }
10792     }
10793
10794     while (RExC_parse < RExC_end) {
10795         /* && strchr("iogcmsx", *RExC_parse) */
10796         /* (?g), (?gc) and (?o) are useless here
10797            and must be globally applied -- japhy */
10798         switch (*RExC_parse) {
10799
10800             /* Code for the imsxn flags */
10801             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10802
10803             case LOCALE_PAT_MOD:
10804                 if (has_charset_modifier) {
10805                     goto excess_modifier;
10806                 }
10807                 else if (flagsp == &negflags) {
10808                     goto neg_modifier;
10809                 }
10810                 cs = REGEX_LOCALE_CHARSET;
10811                 has_charset_modifier = LOCALE_PAT_MOD;
10812                 break;
10813             case UNICODE_PAT_MOD:
10814                 if (has_charset_modifier) {
10815                     goto excess_modifier;
10816                 }
10817                 else if (flagsp == &negflags) {
10818                     goto neg_modifier;
10819                 }
10820                 cs = REGEX_UNICODE_CHARSET;
10821                 has_charset_modifier = UNICODE_PAT_MOD;
10822                 break;
10823             case ASCII_RESTRICT_PAT_MOD:
10824                 if (flagsp == &negflags) {
10825                     goto neg_modifier;
10826                 }
10827                 if (has_charset_modifier) {
10828                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10829                         goto excess_modifier;
10830                     }
10831                     /* Doubled modifier implies more restricted */
10832                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10833                 }
10834                 else {
10835                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10836                 }
10837                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10838                 break;
10839             case DEPENDS_PAT_MOD:
10840                 if (has_use_defaults) {
10841                     goto fail_modifiers;
10842                 }
10843                 else if (flagsp == &negflags) {
10844                     goto neg_modifier;
10845                 }
10846                 else if (has_charset_modifier) {
10847                     goto excess_modifier;
10848                 }
10849
10850                 /* The dual charset means unicode semantics if the
10851                  * pattern (or target, not known until runtime) are
10852                  * utf8, or something in the pattern indicates unicode
10853                  * semantics */
10854                 cs = (RExC_uni_semantics)
10855                      ? REGEX_UNICODE_CHARSET
10856                      : REGEX_DEPENDS_CHARSET;
10857                 has_charset_modifier = DEPENDS_PAT_MOD;
10858                 break;
10859               excess_modifier:
10860                 RExC_parse++;
10861                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10862                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10863                 }
10864                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10865                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10866                                         *(RExC_parse - 1));
10867                 }
10868                 else {
10869                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10870                 }
10871                 NOT_REACHED; /*NOTREACHED*/
10872               neg_modifier:
10873                 RExC_parse++;
10874                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10875                                     *(RExC_parse - 1));
10876                 NOT_REACHED; /*NOTREACHED*/
10877             case ONCE_PAT_MOD: /* 'o' */
10878             case GLOBAL_PAT_MOD: /* 'g' */
10879                 if (ckWARN(WARN_REGEXP)) {
10880                     const I32 wflagbit = *RExC_parse == 'o'
10881                                          ? WASTED_O
10882                                          : WASTED_G;
10883                     if (! (wastedflags & wflagbit) ) {
10884                         wastedflags |= wflagbit;
10885                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10886                         vWARN5(
10887                             RExC_parse + 1,
10888                             "Useless (%s%c) - %suse /%c modifier",
10889                             flagsp == &negflags ? "?-" : "?",
10890                             *RExC_parse,
10891                             flagsp == &negflags ? "don't " : "",
10892                             *RExC_parse
10893                         );
10894                     }
10895                 }
10896                 break;
10897
10898             case CONTINUE_PAT_MOD: /* 'c' */
10899                 if (ckWARN(WARN_REGEXP)) {
10900                     if (! (wastedflags & WASTED_C) ) {
10901                         wastedflags |= WASTED_GC;
10902                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10903                         vWARN3(
10904                             RExC_parse + 1,
10905                             "Useless (%sc) - %suse /gc modifier",
10906                             flagsp == &negflags ? "?-" : "?",
10907                             flagsp == &negflags ? "don't " : ""
10908                         );
10909                     }
10910                 }
10911                 break;
10912             case KEEPCOPY_PAT_MOD: /* 'p' */
10913                 if (flagsp == &negflags) {
10914                     ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10915                 } else {
10916                     *flagsp |= RXf_PMf_KEEPCOPY;
10917                 }
10918                 break;
10919             case '-':
10920                 /* A flag is a default iff it is following a minus, so
10921                  * if there is a minus, it means will be trying to
10922                  * re-specify a default which is an error */
10923                 if (has_use_defaults || flagsp == &negflags) {
10924                     goto fail_modifiers;
10925                 }
10926                 flagsp = &negflags;
10927                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10928                 x_mod_count = 0;
10929                 break;
10930             case ':':
10931             case ')':
10932
10933                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10934                     negflags |= RXf_PMf_EXTENDED_MORE;
10935                 }
10936                 RExC_flags |= posflags;
10937
10938                 if (negflags & RXf_PMf_EXTENDED) {
10939                     negflags |= RXf_PMf_EXTENDED_MORE;
10940                 }
10941                 RExC_flags &= ~negflags;
10942                 set_regex_charset(&RExC_flags, cs);
10943
10944                 return;
10945             default:
10946               fail_modifiers:
10947                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
10948                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10949                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10950                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10951                 NOT_REACHED; /*NOTREACHED*/
10952         }
10953
10954         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10955     }
10956
10957     vFAIL("Sequence (?... not terminated");
10958 }
10959
10960 /*
10961  - reg - regular expression, i.e. main body or parenthesized thing
10962  *
10963  * Caller must absorb opening parenthesis.
10964  *
10965  * Combining parenthesis handling with the base level of regular expression
10966  * is a trifle forced, but the need to tie the tails of the branches to what
10967  * follows makes it hard to avoid.
10968  */
10969 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10970 #ifdef DEBUGGING
10971 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10972 #else
10973 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10974 #endif
10975
10976 PERL_STATIC_INLINE regnode_offset
10977 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10978                              I32 *flagp,
10979                              char * parse_start,
10980                              char ch
10981                       )
10982 {
10983     regnode_offset ret;
10984     char* name_start = RExC_parse;
10985     U32 num = 0;
10986     SV *sv_dat = reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
10987     GET_RE_DEBUG_FLAGS_DECL;
10988
10989     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10990
10991     if (RExC_parse == name_start || *RExC_parse != ch) {
10992         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10993         vFAIL2("Sequence %.3s... not terminated", parse_start);
10994     }
10995
10996     if (sv_dat) {
10997         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10998         RExC_rxi->data->data[num]=(void*)sv_dat;
10999         SvREFCNT_inc_simple_void_NN(sv_dat);
11000     }
11001     RExC_sawback = 1;
11002     ret = reganode(pRExC_state,
11003                    ((! FOLD)
11004                      ? REFN
11005                      : (ASCII_FOLD_RESTRICTED)
11006                        ? REFFAN
11007                        : (AT_LEAST_UNI_SEMANTICS)
11008                          ? REFFUN
11009                          : (LOC)
11010                            ? REFFLN
11011                            : REFFN),
11012                     num);
11013     *flagp |= HASWIDTH;
11014
11015     Set_Node_Offset(REGNODE_p(ret), parse_start+1);
11016     Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
11017
11018     nextchar(pRExC_state);
11019     return ret;
11020 }
11021
11022 /* On success, returns the offset at which any next node should be placed into
11023  * the regex engine program being compiled.
11024  *
11025  * Returns 0 otherwise, with *flagp set to indicate why:
11026  *  TRYAGAIN        at the end of (?) that only sets flags.
11027  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
11028  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
11029  *  Otherwise would only return 0 if regbranch() returns 0, which cannot
11030  *  happen.  */
11031 STATIC regnode_offset
11032 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
11033     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
11034      * 2 is like 1, but indicates that nextchar() has been called to advance
11035      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
11036      * this flag alerts us to the need to check for that */
11037 {
11038     regnode_offset ret = 0;    /* Will be the head of the group. */
11039     regnode_offset br;
11040     regnode_offset lastbr;
11041     regnode_offset ender = 0;
11042     I32 parno = 0;
11043     I32 flags;
11044     U32 oregflags = RExC_flags;
11045     bool have_branch = 0;
11046     bool is_open = 0;
11047     I32 freeze_paren = 0;
11048     I32 after_freeze = 0;
11049     I32 num; /* numeric backreferences */
11050     SV * max_open;  /* Max number of unclosed parens */
11051
11052     char * parse_start = RExC_parse; /* MJD */
11053     char * const oregcomp_parse = RExC_parse;
11054
11055     GET_RE_DEBUG_FLAGS_DECL;
11056
11057     PERL_ARGS_ASSERT_REG;
11058     DEBUG_PARSE("reg ");
11059
11060
11061     max_open = get_sv(RE_COMPILE_RECURSION_LIMIT, GV_ADD);
11062     assert(max_open);
11063     if (!SvIOK(max_open)) {
11064         sv_setiv(max_open, RE_COMPILE_RECURSION_INIT);
11065     }
11066     if (depth > 4 * (UV) SvIV(max_open)) { /* We increase depth by 4 for each
11067                                               open paren */
11068         vFAIL("Too many nested open parens");
11069     }
11070
11071     *flagp = 0;                         /* Tentatively. */
11072
11073     /* Having this true makes it feasible to have a lot fewer tests for the
11074      * parse pointer being in scope.  For example, we can write
11075      *      while(isFOO(*RExC_parse)) RExC_parse++;
11076      * instead of
11077      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
11078      */
11079     assert(*RExC_end == '\0');
11080
11081     /* Make an OPEN node, if parenthesized. */
11082     if (paren) {
11083
11084         /* Under /x, space and comments can be gobbled up between the '(' and
11085          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
11086          * intervening space, as the sequence is a token, and a token should be
11087          * indivisible */
11088         bool has_intervening_patws = (paren == 2)
11089                                   && *(RExC_parse - 1) != '(';
11090
11091         if (RExC_parse >= RExC_end) {
11092             vFAIL("Unmatched (");
11093         }
11094
11095         if (paren == 'r') {     /* Atomic script run */
11096             paren = '>';
11097             goto parse_rest;
11098         }
11099         else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
11100             char *start_verb = RExC_parse + 1;
11101             STRLEN verb_len;
11102             char *start_arg = NULL;
11103             unsigned char op = 0;
11104             int arg_required = 0;
11105             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
11106             bool has_upper = FALSE;
11107
11108             if (has_intervening_patws) {
11109                 RExC_parse++;   /* past the '*' */
11110
11111                 /* For strict backwards compatibility, don't change the message
11112                  * now that we also have lowercase operands */
11113                 if (isUPPER(*RExC_parse)) {
11114                     vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
11115                 }
11116                 else {
11117                     vFAIL("In '(*...)', the '(' and '*' must be adjacent");
11118                 }
11119             }
11120             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
11121                 if ( *RExC_parse == ':' ) {
11122                     start_arg = RExC_parse + 1;
11123                     break;
11124                 }
11125                 else if (! UTF) {
11126                     if (isUPPER(*RExC_parse)) {
11127                         has_upper = TRUE;
11128                     }
11129                     RExC_parse++;
11130                 }
11131                 else {
11132                     RExC_parse += UTF8SKIP(RExC_parse);
11133                 }
11134             }
11135             verb_len = RExC_parse - start_verb;
11136             if ( start_arg ) {
11137                 if (RExC_parse >= RExC_end) {
11138                     goto unterminated_verb_pattern;
11139                 }
11140
11141                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11142                 while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
11143                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11144                 }
11145                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11146                   unterminated_verb_pattern:
11147                     if (has_upper) {
11148                         vFAIL("Unterminated verb pattern argument");
11149                     }
11150                     else {
11151                         vFAIL("Unterminated '(*...' argument");
11152                     }
11153                 }
11154             } else {
11155                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11156                     if (has_upper) {
11157                         vFAIL("Unterminated verb pattern");
11158                     }
11159                     else {
11160                         vFAIL("Unterminated '(*...' construct");
11161                     }
11162                 }
11163             }
11164
11165             /* Here, we know that RExC_parse < RExC_end */
11166
11167             switch ( *start_verb ) {
11168             case 'A':  /* (*ACCEPT) */
11169                 if ( memEQs(start_verb, verb_len,"ACCEPT") ) {
11170                     op = ACCEPT;
11171                     internal_argval = RExC_nestroot;
11172                 }
11173                 break;
11174             case 'C':  /* (*COMMIT) */
11175                 if ( memEQs(start_verb, verb_len,"COMMIT") )
11176                     op = COMMIT;
11177                 break;
11178             case 'F':  /* (*FAIL) */
11179                 if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) {
11180                     op = OPFAIL;
11181                 }
11182                 break;
11183             case ':':  /* (*:NAME) */
11184             case 'M':  /* (*MARK:NAME) */
11185                 if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) {
11186                     op = MARKPOINT;
11187                     arg_required = 1;
11188                 }
11189                 break;
11190             case 'P':  /* (*PRUNE) */
11191                 if ( memEQs(start_verb, verb_len,"PRUNE") )
11192                     op = PRUNE;
11193                 break;
11194             case 'S':   /* (*SKIP) */
11195                 if ( memEQs(start_verb, verb_len,"SKIP") )
11196                     op = SKIP;
11197                 break;
11198             case 'T':  /* (*THEN) */
11199                 /* [19:06] <TimToady> :: is then */
11200                 if ( memEQs(start_verb, verb_len,"THEN") ) {
11201                     op = CUTGROUP;
11202                     RExC_seen |= REG_CUTGROUP_SEEN;
11203                 }
11204                 break;
11205             case 'a':
11206                 if (   memEQs(start_verb, verb_len, "asr")
11207                     || memEQs(start_verb, verb_len, "atomic_script_run"))
11208                 {
11209                     paren = 'r';        /* Mnemonic: recursed run */
11210                     goto script_run;
11211                 }
11212                 else if (memEQs(start_verb, verb_len, "atomic")) {
11213                     paren = 't';    /* AtOMIC */
11214                     goto alpha_assertions;
11215                 }
11216                 break;
11217             case 'p':
11218                 if (   memEQs(start_verb, verb_len, "plb")
11219                     || memEQs(start_verb, verb_len, "positive_lookbehind"))
11220                 {
11221                     paren = 'b';
11222                     goto lookbehind_alpha_assertions;
11223                 }
11224                 else if (   memEQs(start_verb, verb_len, "pla")
11225                          || memEQs(start_verb, verb_len, "positive_lookahead"))
11226                 {
11227                     paren = 'a';
11228                     goto alpha_assertions;
11229                 }
11230                 break;
11231             case 'n':
11232                 if (   memEQs(start_verb, verb_len, "nlb")
11233                     || memEQs(start_verb, verb_len, "negative_lookbehind"))
11234                 {
11235                     paren = 'B';
11236                     goto lookbehind_alpha_assertions;
11237                 }
11238                 else if (   memEQs(start_verb, verb_len, "nla")
11239                          || memEQs(start_verb, verb_len, "negative_lookahead"))
11240                 {
11241                     paren = 'A';
11242                     goto alpha_assertions;
11243                 }
11244                 break;
11245             case 's':
11246                 if (   memEQs(start_verb, verb_len, "sr")
11247                     || memEQs(start_verb, verb_len, "script_run"))
11248                 {
11249                     regnode_offset atomic;
11250
11251                     paren = 's';
11252
11253                    script_run:
11254
11255                     /* This indicates Unicode rules. */
11256                     REQUIRE_UNI_RULES(flagp, 0);
11257
11258                     if (! start_arg) {
11259                         goto no_colon;
11260                     }
11261
11262                     RExC_parse = start_arg;
11263
11264                     if (RExC_in_script_run) {
11265
11266                         /*  Nested script runs are treated as no-ops, because
11267                          *  if the nested one fails, the outer one must as
11268                          *  well.  It could fail sooner, and avoid (??{} with
11269                          *  side effects, but that is explicitly documented as
11270                          *  undefined behavior. */
11271
11272                         ret = 0;
11273
11274                         if (paren == 's') {
11275                             paren = ':';
11276                             goto parse_rest;
11277                         }
11278
11279                         /* But, the atomic part of a nested atomic script run
11280                          * isn't a no-op, but can be treated just like a '(?>'
11281                          * */
11282                         paren = '>';
11283                         goto parse_rest;
11284                     }
11285
11286                     /* By doing this here, we avoid extra warnings for nested
11287                      * script runs */
11288                     ckWARNexperimental(RExC_parse,
11289                         WARN_EXPERIMENTAL__SCRIPT_RUN,
11290                         "The script_run feature is experimental");
11291
11292                     if (paren == 's') {
11293                         /* Here, we're starting a new regular script run */
11294                         ret = reg_node(pRExC_state, SROPEN);
11295                         RExC_in_script_run = 1;
11296                         is_open = 1;
11297                         goto parse_rest;
11298                     }
11299
11300                     /* Here, we are starting an atomic script run.  This is
11301                      * handled by recursing to deal with the atomic portion
11302                      * separately, enclosed in SROPEN ... SRCLOSE nodes */
11303
11304                     ret = reg_node(pRExC_state, SROPEN);
11305
11306                     RExC_in_script_run = 1;
11307
11308                     atomic = reg(pRExC_state, 'r', &flags, depth);
11309                     if (flags & (RESTART_PARSE|NEED_UTF8)) {
11310                         *flagp = flags & (RESTART_PARSE|NEED_UTF8);
11311                         return 0;
11312                     }
11313
11314                     REGTAIL(pRExC_state, ret, atomic);
11315
11316                     REGTAIL(pRExC_state, atomic,
11317                            reg_node(pRExC_state, SRCLOSE));
11318
11319                     RExC_in_script_run = 0;
11320                     return ret;
11321                 }
11322
11323                 break;
11324
11325             lookbehind_alpha_assertions:
11326                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11327                 RExC_in_lookbehind++;
11328                 /*FALLTHROUGH*/
11329
11330             alpha_assertions:
11331                 ckWARNexperimental(RExC_parse,
11332                         WARN_EXPERIMENTAL__ALPHA_ASSERTIONS,
11333                         "The alpha_assertions feature is experimental");
11334
11335                 RExC_seen_zerolen++;
11336
11337                 if (! start_arg) {
11338                     goto no_colon;
11339                 }
11340
11341                 /* An empty negative lookahead assertion simply is failure */
11342                 if (paren == 'A' && RExC_parse == start_arg) {
11343                     ret=reganode(pRExC_state, OPFAIL, 0);
11344                     nextchar(pRExC_state);
11345                     return ret;
11346                 }
11347
11348                 RExC_parse = start_arg;
11349                 goto parse_rest;
11350
11351               no_colon:
11352                 vFAIL2utf8f(
11353                 "'(*%" UTF8f "' requires a terminating ':'",
11354                 UTF8fARG(UTF, verb_len, start_verb));
11355                 NOT_REACHED; /*NOTREACHED*/
11356
11357             } /* End of switch */
11358             if ( ! op ) {
11359                 RExC_parse += UTF
11360                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11361                               : 1;
11362                 if (has_upper || verb_len == 0) {
11363                     vFAIL2utf8f(
11364                     "Unknown verb pattern '%" UTF8f "'",
11365                     UTF8fARG(UTF, verb_len, start_verb));
11366                 }
11367                 else {
11368                     vFAIL2utf8f(
11369                     "Unknown '(*...)' construct '%" UTF8f "'",
11370                     UTF8fARG(UTF, verb_len, start_verb));
11371                 }
11372             }
11373             if ( RExC_parse == start_arg ) {
11374                 start_arg = NULL;
11375             }
11376             if ( arg_required && !start_arg ) {
11377                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
11378                     verb_len, start_verb);
11379             }
11380             if (internal_argval == -1) {
11381                 ret = reganode(pRExC_state, op, 0);
11382             } else {
11383                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
11384             }
11385             RExC_seen |= REG_VERBARG_SEEN;
11386             if (start_arg) {
11387                 SV *sv = newSVpvn( start_arg,
11388                                     RExC_parse - start_arg);
11389                 ARG(REGNODE_p(ret)) = add_data( pRExC_state,
11390                                         STR_WITH_LEN("S"));
11391                 RExC_rxi->data->data[ARG(REGNODE_p(ret))]=(void*)sv;
11392                 FLAGS(REGNODE_p(ret)) = 1;
11393             } else {
11394                 FLAGS(REGNODE_p(ret)) = 0;
11395             }
11396             if ( internal_argval != -1 )
11397                 ARG2L_SET(REGNODE_p(ret), internal_argval);
11398             nextchar(pRExC_state);
11399             return ret;
11400         }
11401         else if (*RExC_parse == '?') { /* (?...) */
11402             bool is_logical = 0;
11403             const char * const seqstart = RExC_parse;
11404             const char * endptr;
11405             if (has_intervening_patws) {
11406                 RExC_parse++;
11407                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
11408             }
11409
11410             RExC_parse++;           /* past the '?' */
11411             paren = *RExC_parse;    /* might be a trailing NUL, if not
11412                                        well-formed */
11413             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11414             if (RExC_parse > RExC_end) {
11415                 paren = '\0';
11416             }
11417             ret = 0;                    /* For look-ahead/behind. */
11418             switch (paren) {
11419
11420             case 'P':   /* (?P...) variants for those used to PCRE/Python */
11421                 paren = *RExC_parse;
11422                 if ( paren == '<') {    /* (?P<...>) named capture */
11423                     RExC_parse++;
11424                     if (RExC_parse >= RExC_end) {
11425                         vFAIL("Sequence (?P<... not terminated");
11426                     }
11427                     goto named_capture;
11428                 }
11429                 else if (paren == '>') {   /* (?P>name) named recursion */
11430                     RExC_parse++;
11431                     if (RExC_parse >= RExC_end) {
11432                         vFAIL("Sequence (?P>... not terminated");
11433                     }
11434                     goto named_recursion;
11435                 }
11436                 else if (paren == '=') {   /* (?P=...)  named backref */
11437                     RExC_parse++;
11438                     return handle_named_backref(pRExC_state, flagp,
11439                                                 parse_start, ')');
11440                 }
11441                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11442                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11443                 vFAIL3("Sequence (%.*s...) not recognized",
11444                                 RExC_parse-seqstart, seqstart);
11445                 NOT_REACHED; /*NOTREACHED*/
11446             case '<':           /* (?<...) */
11447                 if (*RExC_parse == '!')
11448                     paren = ',';
11449                 else if (*RExC_parse != '=')
11450               named_capture:
11451                 {               /* (?<...>) */
11452                     char *name_start;
11453                     SV *svname;
11454                     paren= '>';
11455                 /* FALLTHROUGH */
11456             case '\'':          /* (?'...') */
11457                     name_start = RExC_parse;
11458                     svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME);
11459                     if (   RExC_parse == name_start
11460                         || RExC_parse >= RExC_end
11461                         || *RExC_parse != paren)
11462                     {
11463                         vFAIL2("Sequence (?%c... not terminated",
11464                             paren=='>' ? '<' : paren);
11465                     }
11466                     {
11467                         HE *he_str;
11468                         SV *sv_dat = NULL;
11469                         if (!svname) /* shouldn't happen */
11470                             Perl_croak(aTHX_
11471                                 "panic: reg_scan_name returned NULL");
11472                         if (!RExC_paren_names) {
11473                             RExC_paren_names= newHV();
11474                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
11475 #ifdef DEBUGGING
11476                             RExC_paren_name_list= newAV();
11477                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
11478 #endif
11479                         }
11480                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
11481                         if ( he_str )
11482                             sv_dat = HeVAL(he_str);
11483                         if ( ! sv_dat ) {
11484                             /* croak baby croak */
11485                             Perl_croak(aTHX_
11486                                 "panic: paren_name hash element allocation failed");
11487                         } else if ( SvPOK(sv_dat) ) {
11488                             /* (?|...) can mean we have dupes so scan to check
11489                                its already been stored. Maybe a flag indicating
11490                                we are inside such a construct would be useful,
11491                                but the arrays are likely to be quite small, so
11492                                for now we punt -- dmq */
11493                             IV count = SvIV(sv_dat);
11494                             I32 *pv = (I32*)SvPVX(sv_dat);
11495                             IV i;
11496                             for ( i = 0 ; i < count ; i++ ) {
11497                                 if ( pv[i] == RExC_npar ) {
11498                                     count = 0;
11499                                     break;
11500                                 }
11501                             }
11502                             if ( count ) {
11503                                 pv = (I32*)SvGROW(sv_dat,
11504                                                 SvCUR(sv_dat) + sizeof(I32)+1);
11505                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
11506                                 pv[count] = RExC_npar;
11507                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
11508                             }
11509                         } else {
11510                             (void)SvUPGRADE(sv_dat, SVt_PVNV);
11511                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
11512                                                                 sizeof(I32));
11513                             SvIOK_on(sv_dat);
11514                             SvIV_set(sv_dat, 1);
11515                         }
11516 #ifdef DEBUGGING
11517                         /* Yes this does cause a memory leak in debugging Perls
11518                          * */
11519                         if (!av_store(RExC_paren_name_list,
11520                                       RExC_npar, SvREFCNT_inc_NN(svname)))
11521                             SvREFCNT_dec_NN(svname);
11522 #endif
11523
11524                         /*sv_dump(sv_dat);*/
11525                     }
11526                     nextchar(pRExC_state);
11527                     paren = 1;
11528                     goto capturing_parens;
11529                 }
11530
11531                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11532                 RExC_in_lookbehind++;
11533                 RExC_parse++;
11534                 if (RExC_parse >= RExC_end) {
11535                     vFAIL("Sequence (?... not terminated");
11536                 }
11537
11538                 /* FALLTHROUGH */
11539             case '=':           /* (?=...) */
11540                 RExC_seen_zerolen++;
11541                 break;
11542             case '!':           /* (?!...) */
11543                 RExC_seen_zerolen++;
11544                 /* check if we're really just a "FAIL" assertion */
11545                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11546                                         FALSE /* Don't force to /x */ );
11547                 if (*RExC_parse == ')') {
11548                     ret=reganode(pRExC_state, OPFAIL, 0);
11549                     nextchar(pRExC_state);
11550                     return ret;
11551                 }
11552                 break;
11553             case '|':           /* (?|...) */
11554                 /* branch reset, behave like a (?:...) except that
11555                    buffers in alternations share the same numbers */
11556                 paren = ':';
11557                 after_freeze = freeze_paren = RExC_npar;
11558
11559                 /* XXX This construct currently requires an extra pass.
11560                  * Investigation would be required to see if that could be
11561                  * changed */
11562                 REQUIRE_PARENS_PASS;
11563                 break;
11564             case ':':           /* (?:...) */
11565             case '>':           /* (?>...) */
11566                 break;
11567             case '$':           /* (?$...) */
11568             case '@':           /* (?@...) */
11569                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
11570                 break;
11571             case '0' :           /* (?0) */
11572             case 'R' :           /* (?R) */
11573                 if (RExC_parse == RExC_end || *RExC_parse != ')')
11574                     FAIL("Sequence (?R) not terminated");
11575                 num = 0;
11576                 RExC_seen |= REG_RECURSE_SEEN;
11577
11578                 /* XXX These constructs currently require an extra pass.
11579                  * It probably could be changed */
11580                 REQUIRE_PARENS_PASS;
11581
11582                 *flagp |= POSTPONED;
11583                 goto gen_recurse_regop;
11584                 /*notreached*/
11585             /* named and numeric backreferences */
11586             case '&':            /* (?&NAME) */
11587                 parse_start = RExC_parse - 1;
11588               named_recursion:
11589                 {
11590                     SV *sv_dat = reg_scan_name(pRExC_state,
11591                                                REG_RSN_RETURN_DATA);
11592                    num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
11593                 }
11594                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
11595                     vFAIL("Sequence (?&... not terminated");
11596                 goto gen_recurse_regop;
11597                 /* NOTREACHED */
11598             case '+':
11599                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11600                     RExC_parse++;
11601                     vFAIL("Illegal pattern");
11602                 }
11603                 goto parse_recursion;
11604                 /* NOTREACHED*/
11605             case '-': /* (?-1) */
11606                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11607                     RExC_parse--; /* rewind to let it be handled later */
11608                     goto parse_flags;
11609                 }
11610                 /* FALLTHROUGH */
11611             case '1': case '2': case '3': case '4': /* (?1) */
11612             case '5': case '6': case '7': case '8': case '9':
11613                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
11614               parse_recursion:
11615                 {
11616                     bool is_neg = FALSE;
11617                     UV unum;
11618                     parse_start = RExC_parse - 1; /* MJD */
11619                     if (*RExC_parse == '-') {
11620                         RExC_parse++;
11621                         is_neg = TRUE;
11622                     }
11623                     endptr = RExC_end;
11624                     if (grok_atoUV(RExC_parse, &unum, &endptr)
11625                         && unum <= I32_MAX
11626                     ) {
11627                         num = (I32)unum;
11628                         RExC_parse = (char*)endptr;
11629                     } else
11630                         num = I32_MAX;
11631                     if (is_neg) {
11632                         /* Some limit for num? */
11633                         num = -num;
11634                     }
11635                 }
11636                 if (*RExC_parse!=')')
11637                     vFAIL("Expecting close bracket");
11638
11639               gen_recurse_regop:
11640                 if ( paren == '-' ) {
11641                     /*
11642                     Diagram of capture buffer numbering.
11643                     Top line is the normal capture buffer numbers
11644                     Bottom line is the negative indexing as from
11645                     the X (the (?-2))
11646
11647                     +   1 2    3 4 5 X          6 7
11648                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11649                     -   5 4    3 2 1 X          x x
11650
11651                     */
11652                     num = RExC_npar + num;
11653                     if (num < 1)  {
11654
11655                         /* It might be a forward reference; we can't fail until
11656                          * we know, by completing the parse to get all the
11657                          * groups, and then reparsing */
11658                         if (ALL_PARENS_COUNTED)  {
11659                             RExC_parse++;
11660                             vFAIL("Reference to nonexistent group");
11661                         }
11662                         else {
11663                             REQUIRE_PARENS_PASS;
11664                         }
11665                     }
11666                 } else if ( paren == '+' ) {
11667                     num = RExC_npar + num - 1;
11668                 }
11669                 /* We keep track how many GOSUB items we have produced.
11670                    To start off the ARG2L() of the GOSUB holds its "id",
11671                    which is used later in conjunction with RExC_recurse
11672                    to calculate the offset we need to jump for the GOSUB,
11673                    which it will store in the final representation.
11674                    We have to defer the actual calculation until much later
11675                    as the regop may move.
11676                  */
11677
11678                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11679                 if (num >= RExC_npar) {
11680
11681                     /* It might be a forward reference; we can't fail until we
11682                      * know, by completing the parse to get all the groups, and
11683                      * then reparsing */
11684                     if (ALL_PARENS_COUNTED)  {
11685                         if (num >= RExC_total_parens) {
11686                             RExC_parse++;
11687                             vFAIL("Reference to nonexistent group");
11688                         }
11689                     }
11690                     else {
11691                         REQUIRE_PARENS_PASS;
11692                     }
11693                 }
11694                 RExC_recurse_count++;
11695                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11696                     "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11697                             22, "|    |", (int)(depth * 2 + 1), "",
11698                             (UV)ARG(REGNODE_p(ret)),
11699                             (IV)ARG2L(REGNODE_p(ret))));
11700                 RExC_seen |= REG_RECURSE_SEEN;
11701
11702                 Set_Node_Length(REGNODE_p(ret),
11703                                 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */
11704                 Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */
11705
11706                 *flagp |= POSTPONED;
11707                 assert(*RExC_parse == ')');
11708                 nextchar(pRExC_state);
11709                 return ret;
11710
11711             /* NOTREACHED */
11712
11713             case '?':           /* (??...) */
11714                 is_logical = 1;
11715                 if (*RExC_parse != '{') {
11716                     RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11717                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11718                     vFAIL2utf8f(
11719                         "Sequence (%" UTF8f "...) not recognized",
11720                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11721                     NOT_REACHED; /*NOTREACHED*/
11722                 }
11723                 *flagp |= POSTPONED;
11724                 paren = '{';
11725                 RExC_parse++;
11726                 /* FALLTHROUGH */
11727             case '{':           /* (?{...}) */
11728             {
11729                 U32 n = 0;
11730                 struct reg_code_block *cb;
11731                 OP * o;
11732
11733                 RExC_seen_zerolen++;
11734
11735                 if (   !pRExC_state->code_blocks
11736                     || pRExC_state->code_index
11737                                         >= pRExC_state->code_blocks->count
11738                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11739                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11740                             - RExC_start)
11741                 ) {
11742                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11743                         FAIL("panic: Sequence (?{...}): no code block found\n");
11744                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11745                 }
11746                 /* this is a pre-compiled code block (?{...}) */
11747                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11748                 RExC_parse = RExC_start + cb->end;
11749                 o = cb->block;
11750                 if (cb->src_regex) {
11751                     n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11752                     RExC_rxi->data->data[n] =
11753                         (void*)SvREFCNT_inc((SV*)cb->src_regex);
11754                     RExC_rxi->data->data[n+1] = (void*)o;
11755                 }
11756                 else {
11757                     n = add_data(pRExC_state,
11758                             (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11759                     RExC_rxi->data->data[n] = (void*)o;
11760                 }
11761                 pRExC_state->code_index++;
11762                 nextchar(pRExC_state);
11763
11764                 if (is_logical) {
11765                     regnode_offset eval;
11766                     ret = reg_node(pRExC_state, LOGICAL);
11767
11768                     eval = reg2Lanode(pRExC_state, EVAL,
11769                                        n,
11770
11771                                        /* for later propagation into (??{})
11772                                         * return value */
11773                                        RExC_flags & RXf_PMf_COMPILETIME
11774                                       );
11775                     FLAGS(REGNODE_p(ret)) = 2;
11776                     REGTAIL(pRExC_state, ret, eval);
11777                     /* deal with the length of this later - MJD */
11778                     return ret;
11779                 }
11780                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11781                 Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1);
11782                 Set_Node_Offset(REGNODE_p(ret), parse_start);
11783                 return ret;
11784             }
11785             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11786             {
11787                 int is_define= 0;
11788                 const int DEFINE_len = sizeof("DEFINE") - 1;
11789                 if (    RExC_parse < RExC_end - 1
11790                     && (   (       RExC_parse[0] == '?'        /* (?(?...)) */
11791                             && (   RExC_parse[1] == '='
11792                                 || RExC_parse[1] == '!'
11793                                 || RExC_parse[1] == '<'
11794                                 || RExC_parse[1] == '{'))
11795                         || (       RExC_parse[0] == '*'        /* (?(*...)) */
11796                             && (   memBEGINs(RExC_parse + 1,
11797                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11798                                          "pla:")
11799                                 || memBEGINs(RExC_parse + 1,
11800                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11801                                          "plb:")
11802                                 || memBEGINs(RExC_parse + 1,
11803                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11804                                          "nla:")
11805                                 || memBEGINs(RExC_parse + 1,
11806                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11807                                          "nlb:")
11808                                 || memBEGINs(RExC_parse + 1,
11809                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11810                                          "positive_lookahead:")
11811                                 || memBEGINs(RExC_parse + 1,
11812                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11813                                          "positive_lookbehind:")
11814                                 || memBEGINs(RExC_parse + 1,
11815                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11816                                          "negative_lookahead:")
11817                                 || memBEGINs(RExC_parse + 1,
11818                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11819                                          "negative_lookbehind:"))))
11820                 ) { /* Lookahead or eval. */
11821                     I32 flag;
11822                     regnode_offset tail;
11823
11824                     ret = reg_node(pRExC_state, LOGICAL);
11825                     FLAGS(REGNODE_p(ret)) = 1;
11826
11827                     tail = reg(pRExC_state, 1, &flag, depth+1);
11828                     RETURN_FAIL_ON_RESTART(flag, flagp);
11829                     REGTAIL(pRExC_state, ret, tail);
11830                     goto insert_if;
11831                 }
11832                 else if (   RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11833                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11834                 {
11835                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11836                     char *name_start= RExC_parse++;
11837                     U32 num = 0;
11838                     SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
11839                     if (   RExC_parse == name_start
11840                         || RExC_parse >= RExC_end
11841                         || *RExC_parse != ch)
11842                     {
11843                         vFAIL2("Sequence (?(%c... not terminated",
11844                             (ch == '>' ? '<' : ch));
11845                     }
11846                     RExC_parse++;
11847                     if (sv_dat) {
11848                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11849                         RExC_rxi->data->data[num]=(void*)sv_dat;
11850                         SvREFCNT_inc_simple_void_NN(sv_dat);
11851                     }
11852                     ret = reganode(pRExC_state, GROUPPN, num);
11853                     goto insert_if_check_paren;
11854                 }
11855                 else if (memBEGINs(RExC_parse,
11856                                    (STRLEN) (RExC_end - RExC_parse),
11857                                    "DEFINE"))
11858                 {
11859                     ret = reganode(pRExC_state, DEFINEP, 0);
11860                     RExC_parse += DEFINE_len;
11861                     is_define = 1;
11862                     goto insert_if_check_paren;
11863                 }
11864                 else if (RExC_parse[0] == 'R') {
11865                     RExC_parse++;
11866                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11867                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11868                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11869                      */
11870                     parno = 0;
11871                     if (RExC_parse[0] == '0') {
11872                         parno = 1;
11873                         RExC_parse++;
11874                     }
11875                     else if (inRANGE(RExC_parse[0], '1', '9')) {
11876                         UV uv;
11877                         endptr = RExC_end;
11878                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11879                             && uv <= I32_MAX
11880                         ) {
11881                             parno = (I32)uv + 1;
11882                             RExC_parse = (char*)endptr;
11883                         }
11884                         /* else "Switch condition not recognized" below */
11885                     } else if (RExC_parse[0] == '&') {
11886                         SV *sv_dat;
11887                         RExC_parse++;
11888                         sv_dat = reg_scan_name(pRExC_state,
11889                                                REG_RSN_RETURN_DATA);
11890                         if (sv_dat)
11891                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11892                     }
11893                     ret = reganode(pRExC_state, INSUBP, parno);
11894                     goto insert_if_check_paren;
11895                 }
11896                 else if (inRANGE(RExC_parse[0], '1', '9')) {
11897                     /* (?(1)...) */
11898                     char c;
11899                     UV uv;
11900                     endptr = RExC_end;
11901                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11902                         && uv <= I32_MAX
11903                     ) {
11904                         parno = (I32)uv;
11905                         RExC_parse = (char*)endptr;
11906                     }
11907                     else {
11908                         vFAIL("panic: grok_atoUV returned FALSE");
11909                     }
11910                     ret = reganode(pRExC_state, GROUPP, parno);
11911
11912                  insert_if_check_paren:
11913                     if (UCHARAT(RExC_parse) != ')') {
11914                         RExC_parse += UTF
11915                                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11916                                       : 1;
11917                         vFAIL("Switch condition not recognized");
11918                     }
11919                     nextchar(pRExC_state);
11920                   insert_if:
11921                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11922                     br = regbranch(pRExC_state, &flags, 1, depth+1);
11923                     if (br == 0) {
11924                         RETURN_FAIL_ON_RESTART(flags,flagp);
11925                         FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
11926                               (UV) flags);
11927                     } else
11928                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11929                                                           LONGJMP, 0));
11930                     c = UCHARAT(RExC_parse);
11931                     nextchar(pRExC_state);
11932                     if (flags&HASWIDTH)
11933                         *flagp |= HASWIDTH;
11934                     if (c == '|') {
11935                         if (is_define)
11936                             vFAIL("(?(DEFINE)....) does not allow branches");
11937
11938                         /* Fake one for optimizer.  */
11939                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11940
11941                         if (!regbranch(pRExC_state, &flags, 1, depth+1)) {
11942                             RETURN_FAIL_ON_RESTART(flags, flagp);
11943                             FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
11944                                   (UV) flags);
11945                         }
11946                         REGTAIL(pRExC_state, ret, lastbr);
11947                         if (flags&HASWIDTH)
11948                             *flagp |= HASWIDTH;
11949                         c = UCHARAT(RExC_parse);
11950                         nextchar(pRExC_state);
11951                     }
11952                     else
11953                         lastbr = 0;
11954                     if (c != ')') {
11955                         if (RExC_parse >= RExC_end)
11956                             vFAIL("Switch (?(condition)... not terminated");
11957                         else
11958                             vFAIL("Switch (?(condition)... contains too many branches");
11959                     }
11960                     ender = reg_node(pRExC_state, TAIL);
11961                     REGTAIL(pRExC_state, br, ender);
11962                     if (lastbr) {
11963                         REGTAIL(pRExC_state, lastbr, ender);
11964                         REGTAIL(pRExC_state, REGNODE_OFFSET(
11965                                                 NEXTOPER(
11966                                                 NEXTOPER(REGNODE_p(lastbr)))),
11967                                              ender);
11968                     }
11969                     else
11970                         REGTAIL(pRExC_state, ret, ender);
11971 #if 0  /* Removing this doesn't cause failures in the test suite -- khw */
11972                     RExC_size++; /* XXX WHY do we need this?!!
11973                                     For large programs it seems to be required
11974                                     but I can't figure out why. -- dmq*/
11975 #endif
11976                     return ret;
11977                 }
11978                 RExC_parse += UTF
11979                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11980                               : 1;
11981                 vFAIL("Unknown switch condition (?(...))");
11982             }
11983             case '[':           /* (?[ ... ]) */
11984                 return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
11985                                          oregcomp_parse);
11986             case 0: /* A NUL */
11987                 RExC_parse--; /* for vFAIL to print correctly */
11988                 vFAIL("Sequence (? incomplete");
11989                 break;
11990
11991             case ')':
11992                 if (RExC_strict) {  /* [perl #132851] */
11993                     ckWARNreg(RExC_parse, "Empty (?) without any modifiers");
11994                 }
11995                 /* FALLTHROUGH */
11996             default: /* e.g., (?i) */
11997                 RExC_parse = (char *) seqstart + 1;
11998               parse_flags:
11999                 parse_lparen_question_flags(pRExC_state);
12000                 if (UCHARAT(RExC_parse) != ':') {
12001                     if (RExC_parse < RExC_end)
12002                         nextchar(pRExC_state);
12003                     *flagp = TRYAGAIN;
12004                     return 0;
12005                 }
12006                 paren = ':';
12007                 nextchar(pRExC_state);
12008                 ret = 0;
12009                 goto parse_rest;
12010             } /* end switch */
12011         }
12012         else {
12013             if (*RExC_parse == '{') {
12014                 ckWARNregdep(RExC_parse + 1,
12015                             "Unescaped left brace in regex is "
12016                             "deprecated here (and will be fatal "
12017                             "in Perl 5.32), passed through");
12018             }
12019             /* Not bothering to indent here, as the above 'else' is temporary
12020              * */
12021         if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
12022           capturing_parens:
12023             parno = RExC_npar;
12024             RExC_npar++;
12025             if (! ALL_PARENS_COUNTED) {
12026                 /* If we are in our first pass through (and maybe only pass),
12027                  * we  need to allocate memory for the capturing parentheses
12028                  * data structures.
12029                  */
12030
12031                 if (!RExC_parens_buf_size) {
12032                     /* first guess at number of parens we might encounter */
12033                     RExC_parens_buf_size = 10;
12034
12035                     /* setup RExC_open_parens, which holds the address of each
12036                      * OPEN tag, and to make things simpler for the 0 index the
12037                      * start of the program - this is used later for offsets */
12038                     Newxz(RExC_open_parens, RExC_parens_buf_size,
12039                             regnode_offset);
12040                     RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
12041
12042                     /* setup RExC_close_parens, which holds the address of each
12043                      * CLOSE tag, and to make things simpler for the 0 index
12044                      * the end of the program - this is used later for offsets
12045                      * */
12046                     Newxz(RExC_close_parens, RExC_parens_buf_size,
12047                             regnode_offset);
12048                     /* we dont know where end op starts yet, so we dont need to
12049                      * set RExC_close_parens[0] like we do RExC_open_parens[0]
12050                      * above */
12051                 }
12052                 else if (RExC_npar > RExC_parens_buf_size) {
12053                     I32 old_size = RExC_parens_buf_size;
12054
12055                     RExC_parens_buf_size *= 2;
12056
12057                     Renew(RExC_open_parens, RExC_parens_buf_size,
12058                             regnode_offset);
12059                     Zero(RExC_open_parens + old_size,
12060                             RExC_parens_buf_size - old_size, regnode_offset);
12061
12062                     Renew(RExC_close_parens, RExC_parens_buf_size,
12063                             regnode_offset);
12064                     Zero(RExC_close_parens + old_size,
12065                             RExC_parens_buf_size - old_size, regnode_offset);
12066                 }
12067             }
12068
12069             ret = reganode(pRExC_state, OPEN, parno);
12070             if (!RExC_nestroot)
12071                 RExC_nestroot = parno;
12072             if (RExC_open_parens && !RExC_open_parens[parno])
12073             {
12074                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12075                     "%*s%*s Setting open paren #%" IVdf " to %d\n",
12076                     22, "|    |", (int)(depth * 2 + 1), "",
12077                     (IV)parno, ret));
12078                 RExC_open_parens[parno]= ret;
12079             }
12080
12081             Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
12082             Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */
12083             is_open = 1;
12084         } else {
12085             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
12086             paren = ':';
12087             ret = 0;
12088         }
12089         }
12090     }
12091     else                        /* ! paren */
12092         ret = 0;
12093
12094    parse_rest:
12095     /* Pick up the branches, linking them together. */
12096     parse_start = RExC_parse;   /* MJD */
12097     br = regbranch(pRExC_state, &flags, 1, depth+1);
12098
12099     /*     branch_len = (paren != 0); */
12100
12101     if (br == 0) {
12102         RETURN_FAIL_ON_RESTART(flags, flagp);
12103         FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12104     }
12105     if (*RExC_parse == '|') {
12106         if (RExC_use_BRANCHJ) {
12107             reginsert(pRExC_state, BRANCHJ, br, depth+1);
12108         }
12109         else {                  /* MJD */
12110             reginsert(pRExC_state, BRANCH, br, depth+1);
12111             Set_Node_Length(REGNODE_p(br), paren != 0);
12112             Set_Node_Offset_To_R(br, parse_start-RExC_start);
12113         }
12114         have_branch = 1;
12115     }
12116     else if (paren == ':') {
12117         *flagp |= flags&SIMPLE;
12118     }
12119     if (is_open) {                              /* Starts with OPEN. */
12120         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
12121     }
12122     else if (paren != '?')              /* Not Conditional */
12123         ret = br;
12124     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
12125     lastbr = br;
12126     while (*RExC_parse == '|') {
12127         if (RExC_use_BRANCHJ) {
12128             ender = reganode(pRExC_state, LONGJMP, 0);
12129
12130             /* Append to the previous. */
12131             REGTAIL(pRExC_state,
12132                     REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
12133                     ender);
12134         }
12135         nextchar(pRExC_state);
12136         if (freeze_paren) {
12137             if (RExC_npar > after_freeze)
12138                 after_freeze = RExC_npar;
12139             RExC_npar = freeze_paren;
12140         }
12141         br = regbranch(pRExC_state, &flags, 0, depth+1);
12142
12143         if (br == 0) {
12144             RETURN_FAIL_ON_RESTART(flags, flagp);
12145             FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12146         }
12147         if (!  REGTAIL(pRExC_state, lastbr, br)) {  /* BRANCH -> BRANCH. */
12148             REQUIRE_BRANCHJ(flagp, 0);
12149         }
12150         lastbr = br;
12151         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
12152     }
12153
12154     if (have_branch || paren != ':') {
12155         regnode * br;
12156
12157         /* Make a closing node, and hook it on the end. */
12158         switch (paren) {
12159         case ':':
12160             ender = reg_node(pRExC_state, TAIL);
12161             break;
12162         case 1: case 2:
12163             ender = reganode(pRExC_state, CLOSE, parno);
12164             if ( RExC_close_parens ) {
12165                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12166                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
12167                         22, "|    |", (int)(depth * 2 + 1), "",
12168                         (IV)parno, ender));
12169                 RExC_close_parens[parno]= ender;
12170                 if (RExC_nestroot == parno)
12171                     RExC_nestroot = 0;
12172             }
12173             Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */
12174             Set_Node_Length(REGNODE_p(ender), 1); /* MJD */
12175             break;
12176         case 's':
12177             ender = reg_node(pRExC_state, SRCLOSE);
12178             RExC_in_script_run = 0;
12179             break;
12180         case '<':
12181         case 'a':
12182         case 'A':
12183         case 'b':
12184         case 'B':
12185         case ',':
12186         case '=':
12187         case '!':
12188             *flagp &= ~HASWIDTH;
12189             /* FALLTHROUGH */
12190         case 't':   /* aTomic */
12191         case '>':
12192             ender = reg_node(pRExC_state, SUCCEED);
12193             break;
12194         case 0:
12195             ender = reg_node(pRExC_state, END);
12196             assert(!RExC_end_op); /* there can only be one! */
12197             RExC_end_op = REGNODE_p(ender);
12198             if (RExC_close_parens) {
12199                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12200                     "%*s%*s Setting close paren #0 (END) to %d\n",
12201                     22, "|    |", (int)(depth * 2 + 1), "",
12202                     ender));
12203
12204                 RExC_close_parens[0]= ender;
12205             }
12206             break;
12207         }
12208         DEBUG_PARSE_r(
12209             DEBUG_PARSE_MSG("lsbr");
12210             regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state);
12211             regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender), NULL, pRExC_state);
12212             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12213                           SvPV_nolen_const(RExC_mysv1),
12214                           (IV)lastbr,
12215                           SvPV_nolen_const(RExC_mysv2),
12216                           (IV)ender,
12217                           (IV)(ender - lastbr)
12218             );
12219         );
12220         if (! REGTAIL(pRExC_state, lastbr, ender)) {
12221             REQUIRE_BRANCHJ(flagp, 0);
12222         }
12223
12224         if (have_branch) {
12225             char is_nothing= 1;
12226             if (depth==1)
12227                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
12228
12229             /* Hook the tails of the branches to the closing node. */
12230             for (br = REGNODE_p(ret); br; br = regnext(br)) {
12231                 const U8 op = PL_regkind[OP(br)];
12232                 if (op == BRANCH) {
12233                     if (! REGTAIL_STUDY(pRExC_state,
12234                                         REGNODE_OFFSET(NEXTOPER(br)),
12235                                         ender))
12236                     {
12237                         REQUIRE_BRANCHJ(flagp, 0);
12238                     }
12239                     if ( OP(NEXTOPER(br)) != NOTHING
12240                          || regnext(NEXTOPER(br)) != REGNODE_p(ender))
12241                         is_nothing= 0;
12242                 }
12243                 else if (op == BRANCHJ) {
12244                     REGTAIL_STUDY(pRExC_state,
12245                                   REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
12246                                   ender);
12247                     /* for now we always disable this optimisation * /
12248                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
12249                          || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
12250                     */
12251                         is_nothing= 0;
12252                 }
12253             }
12254             if (is_nothing) {
12255                 regnode * ret_as_regnode = REGNODE_p(ret);
12256                 br= PL_regkind[OP(ret_as_regnode)] != BRANCH
12257                                ? regnext(ret_as_regnode)
12258                                : ret_as_regnode;
12259                 DEBUG_PARSE_r(
12260                     DEBUG_PARSE_MSG("NADA");
12261                     regprop(RExC_rx, RExC_mysv1, ret_as_regnode,
12262                                      NULL, pRExC_state);
12263                     regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender),
12264                                      NULL, pRExC_state);
12265                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12266                                   SvPV_nolen_const(RExC_mysv1),
12267                                   (IV)REG_NODE_NUM(ret_as_regnode),
12268                                   SvPV_nolen_const(RExC_mysv2),
12269                                   (IV)ender,
12270                                   (IV)(ender - ret)
12271                     );
12272                 );
12273                 OP(br)= NOTHING;
12274                 if (OP(REGNODE_p(ender)) == TAIL) {
12275                     NEXT_OFF(br)= 0;
12276                     RExC_emit= REGNODE_OFFSET(br) + 1;
12277                 } else {
12278                     regnode *opt;
12279                     for ( opt= br + 1; opt < REGNODE_p(ender) ; opt++ )
12280                         OP(opt)= OPTIMIZED;
12281                     NEXT_OFF(br)= REGNODE_p(ender) - br;
12282                 }
12283             }
12284         }
12285     }
12286
12287     {
12288         const char *p;
12289          /* Even/odd or x=don't care: 010101x10x */
12290         static const char parens[] = "=!aA<,>Bbt";
12291          /* flag below is set to 0 up through 'A'; 1 for larger */
12292
12293         if (paren && (p = strchr(parens, paren))) {
12294             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
12295             int flag = (p - parens) > 3;
12296
12297             if (paren == '>' || paren == 't') {
12298                 node = SUSPEND, flag = 0;
12299             }
12300
12301             reginsert(pRExC_state, node, ret, depth+1);
12302             Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12303             Set_Node_Offset(REGNODE_p(ret), parse_start + 1);
12304             FLAGS(REGNODE_p(ret)) = flag;
12305             if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL)))
12306             {
12307                 REQUIRE_BRANCHJ(flagp, 0);
12308             }
12309         }
12310     }
12311
12312     /* Check for proper termination. */
12313     if (paren) {
12314         /* restore original flags, but keep (?p) and, if we've encountered
12315          * something in the parse that changes /d rules into /u, keep the /u */
12316         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
12317         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
12318             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
12319         }
12320         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
12321             RExC_parse = oregcomp_parse;
12322             vFAIL("Unmatched (");
12323         }
12324         nextchar(pRExC_state);
12325     }
12326     else if (!paren && RExC_parse < RExC_end) {
12327         if (*RExC_parse == ')') {
12328             RExC_parse++;
12329             vFAIL("Unmatched )");
12330         }
12331         else
12332             FAIL("Junk on end of regexp");      /* "Can't happen". */
12333         NOT_REACHED; /* NOTREACHED */
12334     }
12335
12336     if (RExC_in_lookbehind) {
12337         RExC_in_lookbehind--;
12338     }
12339     if (after_freeze > RExC_npar)
12340         RExC_npar = after_freeze;
12341     return(ret);
12342 }
12343
12344 /*
12345  - regbranch - one alternative of an | operator
12346  *
12347  * Implements the concatenation operator.
12348  *
12349  * On success, returns the offset at which any next node should be placed into
12350  * the regex engine program being compiled.
12351  *
12352  * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
12353  * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
12354  * UTF-8
12355  */
12356 STATIC regnode_offset
12357 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
12358 {
12359     regnode_offset ret;
12360     regnode_offset chain = 0;
12361     regnode_offset latest;
12362     I32 flags = 0, c = 0;
12363     GET_RE_DEBUG_FLAGS_DECL;
12364
12365     PERL_ARGS_ASSERT_REGBRANCH;
12366
12367     DEBUG_PARSE("brnc");
12368
12369     if (first)
12370         ret = 0;
12371     else {
12372         if (RExC_use_BRANCHJ)
12373             ret = reganode(pRExC_state, BRANCHJ, 0);
12374         else {
12375             ret = reg_node(pRExC_state, BRANCH);
12376             Set_Node_Length(REGNODE_p(ret), 1);
12377         }
12378     }
12379
12380     *flagp = WORST;                     /* Tentatively. */
12381
12382     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
12383                             FALSE /* Don't force to /x */ );
12384     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
12385         flags &= ~TRYAGAIN;
12386         latest = regpiece(pRExC_state, &flags, depth+1);
12387         if (latest == 0) {
12388             if (flags & TRYAGAIN)
12389                 continue;
12390             RETURN_FAIL_ON_RESTART(flags, flagp);
12391             FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags);
12392         }
12393         else if (ret == 0)
12394             ret = latest;
12395         *flagp |= flags&(HASWIDTH|POSTPONED);
12396         if (chain == 0)         /* First piece. */
12397             *flagp |= flags&SPSTART;
12398         else {
12399             /* FIXME adding one for every branch after the first is probably
12400              * excessive now we have TRIE support. (hv) */
12401             MARK_NAUGHTY(1);
12402             if (! REGTAIL(pRExC_state, chain, latest)) {
12403                 /* XXX We could just redo this branch, but figuring out what
12404                  * bookkeeping needs to be reset is a pain, and it's likely
12405                  * that other branches that goto END will also be too large */
12406                 REQUIRE_BRANCHJ(flagp, 0);
12407             }
12408         }
12409         chain = latest;
12410         c++;
12411     }
12412     if (chain == 0) {   /* Loop ran zero times. */
12413         chain = reg_node(pRExC_state, NOTHING);
12414         if (ret == 0)
12415             ret = chain;
12416     }
12417     if (c == 1) {
12418         *flagp |= flags&SIMPLE;
12419     }
12420
12421     return ret;
12422 }
12423
12424 /*
12425  - regpiece - something followed by possible quantifier * + ? {n,m}
12426  *
12427  * Note that the branching code sequences used for ? and the general cases
12428  * of * and + are somewhat optimized:  they use the same NOTHING node as
12429  * both the endmarker for their branch list and the body of the last branch.
12430  * It might seem that this node could be dispensed with entirely, but the
12431  * endmarker role is not redundant.
12432  *
12433  * On success, returns the offset at which any next node should be placed into
12434  * the regex engine program being compiled.
12435  *
12436  * Returns 0 otherwise, with *flagp set to indicate why:
12437  *  TRYAGAIN        if regatom() returns 0 with TRYAGAIN.
12438  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
12439  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
12440  */
12441 STATIC regnode_offset
12442 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12443 {
12444     regnode_offset ret;
12445     char op;
12446     char *next;
12447     I32 flags;
12448     const char * const origparse = RExC_parse;
12449     I32 min;
12450     I32 max = REG_INFTY;
12451 #ifdef RE_TRACK_PATTERN_OFFSETS
12452     char *parse_start;
12453 #endif
12454     const char *maxpos = NULL;
12455     UV uv;
12456
12457     /* Save the original in case we change the emitted regop to a FAIL. */
12458     const regnode_offset orig_emit = RExC_emit;
12459
12460     GET_RE_DEBUG_FLAGS_DECL;
12461
12462     PERL_ARGS_ASSERT_REGPIECE;
12463
12464     DEBUG_PARSE("piec");
12465
12466     ret = regatom(pRExC_state, &flags, depth+1);
12467     if (ret == 0) {
12468         RETURN_FAIL_ON_RESTART_OR_FLAGS(flags, flagp, TRYAGAIN);
12469         FAIL2("panic: regatom returned failure, flags=%#" UVxf, (UV) flags);
12470     }
12471
12472     op = *RExC_parse;
12473
12474     if (op == '{' && regcurly(RExC_parse)) {
12475         maxpos = NULL;
12476 #ifdef RE_TRACK_PATTERN_OFFSETS
12477         parse_start = RExC_parse; /* MJD */
12478 #endif
12479         next = RExC_parse + 1;
12480         while (isDIGIT(*next) || *next == ',') {
12481             if (*next == ',') {
12482                 if (maxpos)
12483                     break;
12484                 else
12485                     maxpos = next;
12486             }
12487             next++;
12488         }
12489         if (*next == '}') {             /* got one */
12490             const char* endptr;
12491             if (!maxpos)
12492                 maxpos = next;
12493             RExC_parse++;
12494             if (isDIGIT(*RExC_parse)) {
12495                 endptr = RExC_end;
12496                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
12497                     vFAIL("Invalid quantifier in {,}");
12498                 if (uv >= REG_INFTY)
12499                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12500                 min = (I32)uv;
12501             } else {
12502                 min = 0;
12503             }
12504             if (*maxpos == ',')
12505                 maxpos++;
12506             else
12507                 maxpos = RExC_parse;
12508             if (isDIGIT(*maxpos)) {
12509                 endptr = RExC_end;
12510                 if (!grok_atoUV(maxpos, &uv, &endptr))
12511                     vFAIL("Invalid quantifier in {,}");
12512                 if (uv >= REG_INFTY)
12513                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12514                 max = (I32)uv;
12515             } else {
12516                 max = REG_INFTY;                /* meaning "infinity" */
12517             }
12518             RExC_parse = next;
12519             nextchar(pRExC_state);
12520             if (max < min) {    /* If can't match, warn and optimize to fail
12521                                    unconditionally */
12522                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
12523                 ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
12524                 NEXT_OFF(REGNODE_p(orig_emit)) =
12525                                     regarglen[OPFAIL] + NODE_STEP_REGNODE;
12526                 return ret;
12527             }
12528             else if (min == max && *RExC_parse == '?')
12529             {
12530                 ckWARN2reg(RExC_parse + 1,
12531                            "Useless use of greediness modifier '%c'",
12532                            *RExC_parse);
12533             }
12534
12535           do_curly:
12536             if ((flags&SIMPLE)) {
12537                 if (min == 0 && max == REG_INFTY) {
12538                     reginsert(pRExC_state, STAR, ret, depth+1);
12539                     MARK_NAUGHTY(4);
12540                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12541                     goto nest_check;
12542                 }
12543                 if (min == 1 && max == REG_INFTY) {
12544                     reginsert(pRExC_state, PLUS, ret, depth+1);
12545                     MARK_NAUGHTY(3);
12546                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12547                     goto nest_check;
12548                 }
12549                 MARK_NAUGHTY_EXP(2, 2);
12550                 reginsert(pRExC_state, CURLY, ret, depth+1);
12551                 Set_Node_Offset(REGNODE_p(ret), parse_start+1); /* MJD */
12552                 Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12553             }
12554             else {
12555                 const regnode_offset w = reg_node(pRExC_state, WHILEM);
12556
12557                 FLAGS(REGNODE_p(w)) = 0;
12558                 REGTAIL(pRExC_state, ret, w);
12559                 if (RExC_use_BRANCHJ) {
12560                     reginsert(pRExC_state, LONGJMP, ret, depth+1);
12561                     reginsert(pRExC_state, NOTHING, ret, depth+1);
12562                     NEXT_OFF(REGNODE_p(ret)) = 3;       /* Go over LONGJMP. */
12563                 }
12564                 reginsert(pRExC_state, CURLYX, ret, depth+1);
12565                                 /* MJD hk */
12566                 Set_Node_Offset(REGNODE_p(ret), parse_start+1);
12567                 Set_Node_Length(REGNODE_p(ret),
12568                                 op == '{' ? (RExC_parse - parse_start) : 1);
12569
12570                 if (RExC_use_BRANCHJ)
12571                     NEXT_OFF(REGNODE_p(ret)) = 3;   /* Go over NOTHING to
12572                                                        LONGJMP. */
12573                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
12574                 RExC_whilem_seen++;
12575                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
12576             }
12577             FLAGS(REGNODE_p(ret)) = 0;
12578
12579             if (min > 0)
12580                 *flagp = WORST;
12581             if (max > 0)
12582                 *flagp |= HASWIDTH;
12583             ARG1_SET(REGNODE_p(ret), (U16)min);
12584             ARG2_SET(REGNODE_p(ret), (U16)max);
12585             if (max == REG_INFTY)
12586                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12587
12588             goto nest_check;
12589         }
12590     }
12591
12592     if (!ISMULT1(op)) {
12593         *flagp = flags;
12594         return(ret);
12595     }
12596
12597 #if 0                           /* Now runtime fix should be reliable. */
12598
12599     /* if this is reinstated, don't forget to put this back into perldiag:
12600
12601             =item Regexp *+ operand could be empty at {#} in regex m/%s/
12602
12603            (F) The part of the regexp subject to either the * or + quantifier
12604            could match an empty string. The {#} shows in the regular
12605            expression about where the problem was discovered.
12606
12607     */
12608
12609     if (!(flags&HASWIDTH) && op != '?')
12610       vFAIL("Regexp *+ operand could be empty");
12611 #endif
12612
12613 #ifdef RE_TRACK_PATTERN_OFFSETS
12614     parse_start = RExC_parse;
12615 #endif
12616     nextchar(pRExC_state);
12617
12618     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
12619
12620     if (op == '*') {
12621         min = 0;
12622         goto do_curly;
12623     }
12624     else if (op == '+') {
12625         min = 1;
12626         goto do_curly;
12627     }
12628     else if (op == '?') {
12629         min = 0; max = 1;
12630         goto do_curly;
12631     }
12632   nest_check:
12633     if (!(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
12634         ckWARN2reg(RExC_parse,
12635                    "%" UTF8f " matches null string many times",
12636                    UTF8fARG(UTF, (RExC_parse >= origparse
12637                                  ? RExC_parse - origparse
12638                                  : 0),
12639                    origparse));
12640     }
12641
12642     if (*RExC_parse == '?') {
12643         nextchar(pRExC_state);
12644         reginsert(pRExC_state, MINMOD, ret, depth+1);
12645         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
12646     }
12647     else if (*RExC_parse == '+') {
12648         regnode_offset ender;
12649         nextchar(pRExC_state);
12650         ender = reg_node(pRExC_state, SUCCEED);
12651         REGTAIL(pRExC_state, ret, ender);
12652         reginsert(pRExC_state, SUSPEND, ret, depth+1);
12653         ender = reg_node(pRExC_state, TAIL);
12654         REGTAIL(pRExC_state, ret, ender);
12655     }
12656
12657     if (ISMULT2(RExC_parse)) {
12658         RExC_parse++;
12659         vFAIL("Nested quantifiers");
12660     }
12661
12662     return(ret);
12663 }
12664
12665 STATIC bool
12666 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
12667                 regnode_offset * node_p,
12668                 UV * code_point_p,
12669                 int * cp_count,
12670                 I32 * flagp,
12671                 const bool strict,
12672                 const U32 depth
12673     )
12674 {
12675  /* This routine teases apart the various meanings of \N and returns
12676   * accordingly.  The input parameters constrain which meaning(s) is/are valid
12677   * in the current context.
12678   *
12679   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
12680   *
12681   * If <code_point_p> is not NULL, the context is expecting the result to be a
12682   * single code point.  If this \N instance turns out to a single code point,
12683   * the function returns TRUE and sets *code_point_p to that code point.
12684   *
12685   * If <node_p> is not NULL, the context is expecting the result to be one of
12686   * the things representable by a regnode.  If this \N instance turns out to be
12687   * one such, the function generates the regnode, returns TRUE and sets *node_p
12688   * to point to the offset of that regnode into the regex engine program being
12689   * compiled.
12690   *
12691   * If this instance of \N isn't legal in any context, this function will
12692   * generate a fatal error and not return.
12693   *
12694   * On input, RExC_parse should point to the first char following the \N at the
12695   * time of the call.  On successful return, RExC_parse will have been updated
12696   * to point to just after the sequence identified by this routine.  Also
12697   * *flagp has been updated as needed.
12698   *
12699   * When there is some problem with the current context and this \N instance,
12700   * the function returns FALSE, without advancing RExC_parse, nor setting
12701   * *node_p, nor *code_point_p, nor *flagp.
12702   *
12703   * If <cp_count> is not NULL, the caller wants to know the length (in code
12704   * points) that this \N sequence matches.  This is set, and the input is
12705   * parsed for errors, even if the function returns FALSE, as detailed below.
12706   *
12707   * There are 6 possibilities here, as detailed in the next 6 paragraphs.
12708   *
12709   * Probably the most common case is for the \N to specify a single code point.
12710   * *cp_count will be set to 1, and *code_point_p will be set to that code
12711   * point.
12712   *
12713   * Another possibility is for the input to be an empty \N{}.  This is no
12714   * longer accepted, and will generate a fatal error.
12715   *
12716   * Another possibility is for a custom charnames handler to be in effect which
12717   * translates the input name to an empty string.  *cp_count will be set to 0.
12718   * *node_p will be set to a generated NOTHING node.
12719   *
12720   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
12721   * set to 0. *node_p will be set to a generated REG_ANY node.
12722   *
12723   * The fifth possibility is that \N resolves to a sequence of more than one
12724   * code points.  *cp_count will be set to the number of code points in the
12725   * sequence. *node_p will be set to a generated node returned by this
12726   * function calling S_reg().
12727   *
12728   * The final possibility is that it is premature to be calling this function;
12729   * the parse needs to be restarted.  This can happen when this changes from
12730   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
12731   * latter occurs only when the fifth possibility would otherwise be in
12732   * effect, and is because one of those code points requires the pattern to be
12733   * recompiled as UTF-8.  The function returns FALSE, and sets the
12734   * RESTART_PARSE and NEED_UTF8 flags in *flagp, as appropriate.  When this
12735   * happens, the caller needs to desist from continuing parsing, and return
12736   * this information to its caller.  This is not set for when there is only one
12737   * code point, as this can be called as part of an ANYOF node, and they can
12738   * store above-Latin1 code points without the pattern having to be in UTF-8.
12739   *
12740   * For non-single-quoted regexes, the tokenizer has resolved character and
12741   * sequence names inside \N{...} into their Unicode values, normalizing the
12742   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
12743   * hex-represented code points in the sequence.  This is done there because
12744   * the names can vary based on what charnames pragma is in scope at the time,
12745   * so we need a way to take a snapshot of what they resolve to at the time of
12746   * the original parse. [perl #56444].
12747   *
12748   * That parsing is skipped for single-quoted regexes, so here we may get
12749   * '\N{NAME}', which is parsed now.  If the single-quoted regex is something
12750   * like '\N{U+41}', that code point is Unicode, and has to be translated into
12751   * the native character set for non-ASCII platforms.  The other possibilities
12752   * are already native, so no translation is done. */
12753
12754     char * endbrace;    /* points to '}' following the name */
12755     char* p = RExC_parse; /* Temporary */
12756
12757     SV * substitute_parse = NULL;
12758     char *orig_end;
12759     char *save_start;
12760     I32 flags;
12761
12762     GET_RE_DEBUG_FLAGS_DECL;
12763
12764     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12765
12766     GET_RE_DEBUG_FLAGS;
12767
12768     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12769     assert(! (node_p && cp_count));               /* At most 1 should be set */
12770
12771     if (cp_count) {     /* Initialize return for the most common case */
12772         *cp_count = 1;
12773     }
12774
12775     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12776      * modifier.  The other meanings do not, so use a temporary until we find
12777      * out which we are being called with */
12778     skip_to_be_ignored_text(pRExC_state, &p,
12779                             FALSE /* Don't force to /x */ );
12780
12781     /* Disambiguate between \N meaning a named character versus \N meaning
12782      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12783      * quantifier, or if there is no '{' at all */
12784     if (*p != '{' || regcurly(p)) {
12785         RExC_parse = p;
12786         if (cp_count) {
12787             *cp_count = -1;
12788         }
12789
12790         if (! node_p) {
12791             return FALSE;
12792         }
12793
12794         *node_p = reg_node(pRExC_state, REG_ANY);
12795         *flagp |= HASWIDTH|SIMPLE;
12796         MARK_NAUGHTY(1);
12797         Set_Node_Length(REGNODE_p(*(node_p)), 1); /* MJD */
12798         return TRUE;
12799     }
12800
12801     /* The test above made sure that the next real character is a '{', but
12802      * under the /x modifier, it could be separated by space (or a comment and
12803      * \n) and this is not allowed (for consistency with \x{...} and the
12804      * tokenizer handling of \N{NAME}). */
12805     if (*RExC_parse != '{') {
12806         vFAIL("Missing braces on \\N{}");
12807     }
12808
12809     RExC_parse++;       /* Skip past the '{' */
12810
12811     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
12812     if (! endbrace) { /* no trailing brace */
12813         vFAIL2("Missing right brace on \\%c{}", 'N');
12814     }
12815
12816     /* Here, we have decided it should be a named character or sequence.  These
12817      * imply Unicode semantics */
12818     REQUIRE_UNI_RULES(flagp, FALSE);
12819
12820     /* \N{_} is what toke.c returns to us to indicate a name that evaluates to
12821      * nothing at all (not allowed under strict) */
12822     if (endbrace - RExC_parse == 1 && *RExC_parse == '_') {
12823         RExC_parse = endbrace;
12824         if (strict) {
12825             RExC_parse++;   /* Position after the "}" */
12826             vFAIL("Zero length \\N{}");
12827         }
12828
12829         if (cp_count) {
12830             *cp_count = 0;
12831         }
12832         nextchar(pRExC_state);
12833         if (! node_p) {
12834             return FALSE;
12835         }
12836
12837         *node_p = reg_node(pRExC_state, NOTHING);
12838         return TRUE;
12839     }
12840
12841     if (endbrace - RExC_parse < 2 || ! strBEGINs(RExC_parse, "U+")) {
12842
12843         /* Here, the name isn't of the form  U+....  This can happen if the
12844          * pattern is single-quoted, so didn't get evaluated in toke.c.  Now
12845          * is the time to find out what the name means */
12846
12847         const STRLEN name_len = endbrace - RExC_parse;
12848         SV *  value_sv;     /* What does this name evaluate to */
12849         SV ** value_svp;
12850         const U8 * value;   /* string of name's value */
12851         STRLEN value_len;   /* and its length */
12852
12853         /*  RExC_unlexed_names is a hash of names that weren't evaluated by
12854          *  toke.c, and their values. Make sure is initialized */
12855         if (! RExC_unlexed_names) {
12856             RExC_unlexed_names = newHV();
12857         }
12858
12859         /* If we have already seen this name in this pattern, use that.  This
12860          * allows us to only call the charnames handler once per name per
12861          * pattern.  A broken or malicious handler could return something
12862          * different each time, which could cause the results to vary depending
12863          * on if something gets added or subtracted from the pattern that
12864          * causes the number of passes to change, for example */
12865         if ((value_svp = hv_fetch(RExC_unlexed_names, RExC_parse,
12866                                                       name_len, 0)))
12867         {
12868             value_sv = *value_svp;
12869         }
12870         else { /* Otherwise we have to go out and get the name */
12871             const char * error_msg = NULL;
12872             value_sv = get_and_check_backslash_N_name(RExC_parse, endbrace,
12873                                                       UTF,
12874                                                       &error_msg);
12875             if (error_msg) {
12876                 RExC_parse = endbrace;
12877                 vFAIL(error_msg);
12878             }
12879
12880             /* If no error message, should have gotten a valid return */
12881             assert (value_sv);
12882
12883             /* Save the name's meaning for later use */
12884             if (! hv_store(RExC_unlexed_names, RExC_parse, name_len,
12885                            value_sv, 0))
12886             {
12887                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
12888             }
12889         }
12890
12891         /* Here, we have the value the name evaluates to in 'value_sv' */
12892         value = (U8 *) SvPV(value_sv, value_len);
12893
12894         /* See if the result is one code point vs 0 or multiple */
12895         if (value_len > 0 && value_len <= (UV) ((SvUTF8(value_sv))
12896                                                ? UTF8SKIP(value)
12897                                                : 1))
12898         {
12899             /* Here, exactly one code point.  If that isn't what is wanted,
12900              * fail */
12901             if (! code_point_p) {
12902                 RExC_parse = p;
12903                 return FALSE;
12904             }
12905
12906             /* Convert from string to numeric code point */
12907             *code_point_p = (SvUTF8(value_sv))
12908                             ? valid_utf8_to_uvchr(value, NULL)
12909                             : *value;
12910
12911             /* Have parsed this entire single code point \N{...}.  *cp_count
12912              * has already been set to 1, so don't do it again. */
12913             RExC_parse = endbrace;
12914             nextchar(pRExC_state);
12915             return TRUE;
12916         } /* End of is a single code point */
12917
12918         /* Count the code points, if caller desires.  The API says to do this
12919          * even if we will later return FALSE */
12920         if (cp_count) {
12921             *cp_count = 0;
12922
12923             *cp_count = (SvUTF8(value_sv))
12924                         ? utf8_length(value, value + value_len)
12925                         : value_len;
12926         }
12927
12928         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12929          * But don't back the pointer up if the caller wants to know how many
12930          * code points there are (they need to handle it themselves in this
12931          * case).  */
12932         if (! node_p) {
12933             if (! cp_count) {
12934                 RExC_parse = p;
12935             }
12936             return FALSE;
12937         }
12938
12939         /* Convert this to a sub-pattern of the form "(?: ... )", and then call
12940          * reg recursively to parse it.  That way, it retains its atomicness,
12941          * while not having to worry about any special handling that some code
12942          * points may have. */
12943
12944         substitute_parse = newSVpvs("?:");
12945         sv_catsv(substitute_parse, value_sv);
12946         sv_catpv(substitute_parse, ")");
12947
12948 #ifdef EBCDIC
12949         /* The value should already be native, so no need to convert on EBCDIC
12950          * platforms.*/
12951         assert(! RExC_recode_x_to_native);
12952 #endif
12953
12954     }
12955     else {   /* \N{U+...} */
12956         Size_t count = 0;   /* code point count kept internally */
12957
12958         /* We can get to here when the input is \N{U+...} or when toke.c has
12959          * converted a name to the \N{U+...} form.  This include changing a
12960          * name that evaluates to multiple code points to \N{U+c1.c2.c3 ...} */
12961
12962         RExC_parse += 2;    /* Skip past the 'U+' */
12963
12964         /* Code points are separated by dots.  The '}' terminates the whole
12965          * thing. */
12966
12967         do {    /* Loop until the ending brace */
12968             UV cp = 0;
12969             char * start_digit;     /* The first of the current code point */
12970             if (! isXDIGIT(*RExC_parse)) {
12971                 RExC_parse++;
12972                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
12973             }
12974
12975             start_digit = RExC_parse;
12976             count++;
12977
12978             /* Loop through the hex digits of the current code point */
12979             do {
12980                 /* Adding this digit will shift the result 4 bits.  If that
12981                  * result would be above the legal max, it's overflow */
12982                 if (cp > MAX_LEGAL_CP >> 4) {
12983
12984                     /* Find the end of the code point */
12985                     do {
12986                         RExC_parse ++;
12987                     } while (isXDIGIT(*RExC_parse) || *RExC_parse == '_');
12988
12989                     /* Be sure to synchronize this message with the similar one
12990                      * in utf8.c */
12991                     vFAIL4("Use of code point 0x%.*s is not allowed; the"
12992                         " permissible max is 0x%" UVxf,
12993                         (int) (RExC_parse - start_digit), start_digit,
12994                         MAX_LEGAL_CP);
12995                 }
12996
12997                 /* Accumulate this (valid) digit into the running total */
12998                 cp  = (cp << 4) + READ_XDIGIT(RExC_parse);
12999
13000                 /* READ_XDIGIT advanced the input pointer.  Ignore a single
13001                  * underscore separator */
13002                 if (*RExC_parse == '_' && isXDIGIT(RExC_parse[1])) {
13003                     RExC_parse++;
13004                 }
13005             } while (isXDIGIT(*RExC_parse));
13006
13007             /* Here, have accumulated the next code point */
13008             if (RExC_parse >= endbrace) {   /* If done ... */
13009                 if (count != 1) {
13010                     goto do_concat;
13011                 }
13012
13013                 /* Here, is a single code point; fail if doesn't want that */
13014                 if (! code_point_p) {
13015                     RExC_parse = p;
13016                     return FALSE;
13017                 }
13018
13019                 /* A single code point is easy to handle; just return it */
13020                 *code_point_p = UNI_TO_NATIVE(cp);
13021                 RExC_parse = endbrace;
13022                 nextchar(pRExC_state);
13023                 return TRUE;
13024             }
13025
13026             /* Here, the only legal thing would be a multiple character
13027              * sequence (of the form "\N{U+c1.c2. ... }".   So the next
13028              * character must be a dot (and the one after that can't be the
13029              * endbrace, or we'd have something like \N{U+100.} ) */
13030             if (*RExC_parse != '.' || RExC_parse + 1 >= endbrace) {
13031                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
13032                                 ? UTF8SKIP(RExC_parse)
13033                                 : 1;
13034                 if (RExC_parse >= endbrace) { /* Guard against malformed utf8 */
13035                     RExC_parse = endbrace;
13036                 }
13037                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
13038             }
13039
13040             /* Here, looks like its really a multiple character sequence.  Fail
13041              * if that's not what the caller wants.  But continue with counting
13042              * and error checking if they still want a count */
13043             if (! node_p && ! cp_count) {
13044                 return FALSE;
13045             }
13046
13047             /* What is done here is to convert this to a sub-pattern of the
13048              * form \x{char1}\x{char2}...  and then call reg recursively to
13049              * parse it (enclosing in "(?: ... )" ).  That way, it retains its
13050              * atomicness, while not having to worry about special handling
13051              * that some code points may have.  We don't create a subpattern,
13052              * but go through the motions of code point counting and error
13053              * checking, if the caller doesn't want a node returned. */
13054
13055             if (node_p && count == 1) {
13056                 substitute_parse = newSVpvs("?:");
13057             }
13058
13059           do_concat:
13060
13061             if (node_p) {
13062                 /* Convert to notation the rest of the code understands */
13063                 sv_catpvs(substitute_parse, "\\x{");
13064                 sv_catpvn(substitute_parse, start_digit,
13065                                             RExC_parse - start_digit);
13066                 sv_catpvs(substitute_parse, "}");
13067             }
13068
13069             /* Move to after the dot (or ending brace the final time through.)
13070              * */
13071             RExC_parse++;
13072             count++;
13073
13074         } while (RExC_parse < endbrace);
13075
13076         if (! node_p) { /* Doesn't want the node */
13077             assert (cp_count);
13078
13079             *cp_count = count;
13080             return FALSE;
13081         }
13082
13083         sv_catpvs(substitute_parse, ")");
13084
13085 #ifdef EBCDIC
13086         /* The values are Unicode, and therefore have to be converted to native
13087          * on a non-Unicode (meaning non-ASCII) platform. */
13088         RExC_recode_x_to_native = 1;
13089 #endif
13090
13091     }
13092
13093     /* Here, we have the string the name evaluates to, ready to be parsed,
13094      * stored in 'substitute_parse' as a series of valid "\x{...}\x{...}"
13095      * constructs.  This can be called from within a substitute parse already.
13096      * The error reporting mechanism doesn't work for 2 levels of this, but the
13097      * code above has validated this new construct, so there should be no
13098      * errors generated by the below.  And this isn' an exact copy, so the
13099      * mechanism to seamlessly deal with this won't work, so turn off warnings
13100      * during it */
13101     save_start = RExC_start;
13102     orig_end = RExC_end;
13103
13104     RExC_parse = RExC_start = SvPVX(substitute_parse);
13105     RExC_end = RExC_parse + SvCUR(substitute_parse);
13106     TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
13107
13108     *node_p = reg(pRExC_state, 1, &flags, depth+1);
13109
13110     /* Restore the saved values */
13111     RESTORE_WARNINGS;
13112     RExC_start = save_start;
13113     RExC_parse = endbrace;
13114     RExC_end = orig_end;
13115 #ifdef EBCDIC
13116     RExC_recode_x_to_native = 0;
13117 #endif
13118
13119     SvREFCNT_dec_NN(substitute_parse);
13120
13121     if (! *node_p) {
13122         RETURN_FAIL_ON_RESTART(flags, flagp);
13123         FAIL2("panic: reg returned failure to grok_bslash_N, flags=%#" UVxf,
13124             (UV) flags);
13125     }
13126     *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
13127
13128     nextchar(pRExC_state);
13129
13130     return TRUE;
13131 }
13132
13133
13134 PERL_STATIC_INLINE U8
13135 S_compute_EXACTish(RExC_state_t *pRExC_state)
13136 {
13137     U8 op;
13138
13139     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
13140
13141     if (! FOLD) {
13142         return (LOC)
13143                 ? EXACTL
13144                 : EXACT;
13145     }
13146
13147     op = get_regex_charset(RExC_flags);
13148     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
13149         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
13150                  been, so there is no hole */
13151     }
13152
13153     return op + EXACTF;
13154 }
13155
13156 STATIC bool
13157 S_new_regcurly(const char *s, const char *e)
13158 {
13159     /* This is a temporary function designed to match the most lenient form of
13160      * a {m,n} quantifier we ever envision, with either number omitted, and
13161      * spaces anywhere between/before/after them.
13162      *
13163      * If this function fails, then the string it matches is very unlikely to
13164      * ever be considered a valid quantifier, so we can allow the '{' that
13165      * begins it to be considered as a literal */
13166
13167     bool has_min = FALSE;
13168     bool has_max = FALSE;
13169
13170     PERL_ARGS_ASSERT_NEW_REGCURLY;
13171
13172     if (s >= e || *s++ != '{')
13173         return FALSE;
13174
13175     while (s < e && isSPACE(*s)) {
13176         s++;
13177     }
13178     while (s < e && isDIGIT(*s)) {
13179         has_min = TRUE;
13180         s++;
13181     }
13182     while (s < e && isSPACE(*s)) {
13183         s++;
13184     }
13185
13186     if (*s == ',') {
13187         s++;
13188         while (s < e && isSPACE(*s)) {
13189             s++;
13190         }
13191         while (s < e && isDIGIT(*s)) {
13192             has_max = TRUE;
13193             s++;
13194         }
13195         while (s < e && isSPACE(*s)) {
13196             s++;
13197         }
13198     }
13199
13200     return s < e && *s == '}' && (has_min || has_max);
13201 }
13202
13203 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
13204  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
13205
13206 static I32
13207 S_backref_value(char *p, char *e)
13208 {
13209     const char* endptr = e;
13210     UV val;
13211     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
13212         return (I32)val;
13213     return I32_MAX;
13214 }
13215
13216
13217 /*
13218  - regatom - the lowest level
13219
13220    Try to identify anything special at the start of the current parse position.
13221    If there is, then handle it as required. This may involve generating a
13222    single regop, such as for an assertion; or it may involve recursing, such as
13223    to handle a () structure.
13224
13225    If the string doesn't start with something special then we gobble up
13226    as much literal text as we can.  If we encounter a quantifier, we have to
13227    back off the final literal character, as that quantifier applies to just it
13228    and not to the whole string of literals.
13229
13230    Once we have been able to handle whatever type of thing started the
13231    sequence, we return the offset into the regex engine program being compiled
13232    at which any  next regnode should be placed.
13233
13234    Returns 0, setting *flagp to TRYAGAIN if reg() returns 0 with TRYAGAIN.
13235    Returns 0, setting *flagp to RESTART_PARSE if the parse needs to be
13236    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
13237    Otherwise does not return 0.
13238
13239    Note: we have to be careful with escapes, as they can be both literal
13240    and special, and in the case of \10 and friends, context determines which.
13241
13242    A summary of the code structure is:
13243
13244    switch (first_byte) {
13245         cases for each special:
13246             handle this special;
13247             break;
13248         case '\\':
13249             switch (2nd byte) {
13250                 cases for each unambiguous special:
13251                     handle this special;
13252                     break;
13253                 cases for each ambigous special/literal:
13254                     disambiguate;
13255                     if (special)  handle here
13256                     else goto defchar;
13257                 default: // unambiguously literal:
13258                     goto defchar;
13259             }
13260         default:  // is a literal char
13261             // FALL THROUGH
13262         defchar:
13263             create EXACTish node for literal;
13264             while (more input and node isn't full) {
13265                 switch (input_byte) {
13266                    cases for each special;
13267                        make sure parse pointer is set so that the next call to
13268                            regatom will see this special first
13269                        goto loopdone; // EXACTish node terminated by prev. char
13270                    default:
13271                        append char to EXACTISH node;
13272                 }
13273                 get next input byte;
13274             }
13275         loopdone:
13276    }
13277    return the generated node;
13278
13279    Specifically there are two separate switches for handling
13280    escape sequences, with the one for handling literal escapes requiring
13281    a dummy entry for all of the special escapes that are actually handled
13282    by the other.
13283
13284 */
13285
13286 STATIC regnode_offset
13287 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
13288 {
13289     dVAR;
13290     regnode_offset ret = 0;
13291     I32 flags = 0;
13292     char *parse_start;
13293     U8 op;
13294     int invert = 0;
13295     U8 arg;
13296
13297     GET_RE_DEBUG_FLAGS_DECL;
13298
13299     *flagp = WORST;             /* Tentatively. */
13300
13301     DEBUG_PARSE("atom");
13302
13303     PERL_ARGS_ASSERT_REGATOM;
13304
13305   tryagain:
13306     parse_start = RExC_parse;
13307     assert(RExC_parse < RExC_end);
13308     switch ((U8)*RExC_parse) {
13309     case '^':
13310         RExC_seen_zerolen++;
13311         nextchar(pRExC_state);
13312         if (RExC_flags & RXf_PMf_MULTILINE)
13313             ret = reg_node(pRExC_state, MBOL);
13314         else
13315             ret = reg_node(pRExC_state, SBOL);
13316         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13317         break;
13318     case '$':
13319         nextchar(pRExC_state);
13320         if (*RExC_parse)
13321             RExC_seen_zerolen++;
13322         if (RExC_flags & RXf_PMf_MULTILINE)
13323             ret = reg_node(pRExC_state, MEOL);
13324         else
13325             ret = reg_node(pRExC_state, SEOL);
13326         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13327         break;
13328     case '.':
13329         nextchar(pRExC_state);
13330         if (RExC_flags & RXf_PMf_SINGLELINE)
13331             ret = reg_node(pRExC_state, SANY);
13332         else
13333             ret = reg_node(pRExC_state, REG_ANY);
13334         *flagp |= HASWIDTH|SIMPLE;
13335         MARK_NAUGHTY(1);
13336         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13337         break;
13338     case '[':
13339     {
13340         char * const oregcomp_parse = ++RExC_parse;
13341         ret = regclass(pRExC_state, flagp, depth+1,
13342                        FALSE, /* means parse the whole char class */
13343                        TRUE, /* allow multi-char folds */
13344                        FALSE, /* don't silence non-portable warnings. */
13345                        (bool) RExC_strict,
13346                        TRUE, /* Allow an optimized regnode result */
13347                        NULL);
13348         if (ret == 0) {
13349             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13350             FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13351                   (UV) *flagp);
13352         }
13353         if (*RExC_parse != ']') {
13354             RExC_parse = oregcomp_parse;
13355             vFAIL("Unmatched [");
13356         }
13357         nextchar(pRExC_state);
13358         Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */
13359         break;
13360     }
13361     case '(':
13362         nextchar(pRExC_state);
13363         ret = reg(pRExC_state, 2, &flags, depth+1);
13364         if (ret == 0) {
13365                 if (flags & TRYAGAIN) {
13366                     if (RExC_parse >= RExC_end) {
13367                          /* Make parent create an empty node if needed. */
13368                         *flagp |= TRYAGAIN;
13369                         return(0);
13370                     }
13371                     goto tryagain;
13372                 }
13373                 RETURN_FAIL_ON_RESTART(flags, flagp);
13374                 FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf,
13375                                                                  (UV) flags);
13376         }
13377         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
13378         break;
13379     case '|':
13380     case ')':
13381         if (flags & TRYAGAIN) {
13382             *flagp |= TRYAGAIN;
13383             return 0;
13384         }
13385         vFAIL("Internal urp");
13386                                 /* Supposed to be caught earlier. */
13387         break;
13388     case '?':
13389     case '+':
13390     case '*':
13391         RExC_parse++;
13392         vFAIL("Quantifier follows nothing");
13393         break;
13394     case '\\':
13395         /* Special Escapes
13396
13397            This switch handles escape sequences that resolve to some kind
13398            of special regop and not to literal text. Escape sequences that
13399            resolve to literal text are handled below in the switch marked
13400            "Literal Escapes".
13401
13402            Every entry in this switch *must* have a corresponding entry
13403            in the literal escape switch. However, the opposite is not
13404            required, as the default for this switch is to jump to the
13405            literal text handling code.
13406         */
13407         RExC_parse++;
13408         switch ((U8)*RExC_parse) {
13409         /* Special Escapes */
13410         case 'A':
13411             RExC_seen_zerolen++;
13412             ret = reg_node(pRExC_state, SBOL);
13413             /* SBOL is shared with /^/ so we set the flags so we can tell
13414              * /\A/ from /^/ in split. */
13415             FLAGS(REGNODE_p(ret)) = 1;
13416             *flagp |= SIMPLE;
13417             goto finish_meta_pat;
13418         case 'G':
13419             ret = reg_node(pRExC_state, GPOS);
13420             RExC_seen |= REG_GPOS_SEEN;
13421             *flagp |= SIMPLE;
13422             goto finish_meta_pat;
13423         case 'K':
13424             RExC_seen_zerolen++;
13425             ret = reg_node(pRExC_state, KEEPS);
13426             *flagp |= SIMPLE;
13427             /* XXX:dmq : disabling in-place substitution seems to
13428              * be necessary here to avoid cases of memory corruption, as
13429              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
13430              */
13431             RExC_seen |= REG_LOOKBEHIND_SEEN;
13432             goto finish_meta_pat;
13433         case 'Z':
13434             ret = reg_node(pRExC_state, SEOL);
13435             *flagp |= SIMPLE;
13436             RExC_seen_zerolen++;                /* Do not optimize RE away */
13437             goto finish_meta_pat;
13438         case 'z':
13439             ret = reg_node(pRExC_state, EOS);
13440             *flagp |= SIMPLE;
13441             RExC_seen_zerolen++;                /* Do not optimize RE away */
13442             goto finish_meta_pat;
13443         case 'C':
13444             vFAIL("\\C no longer supported");
13445         case 'X':
13446             ret = reg_node(pRExC_state, CLUMP);
13447             *flagp |= HASWIDTH;
13448             goto finish_meta_pat;
13449
13450         case 'W':
13451             invert = 1;
13452             /* FALLTHROUGH */
13453         case 'w':
13454             arg = ANYOF_WORDCHAR;
13455             goto join_posix;
13456
13457         case 'B':
13458             invert = 1;
13459             /* FALLTHROUGH */
13460         case 'b':
13461           {
13462             U8 flags = 0;
13463             regex_charset charset = get_regex_charset(RExC_flags);
13464
13465             RExC_seen_zerolen++;
13466             RExC_seen |= REG_LOOKBEHIND_SEEN;
13467             op = BOUND + charset;
13468
13469             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
13470                 flags = TRADITIONAL_BOUND;
13471                 if (op > BOUNDA) {  /* /aa is same as /a */
13472                     op = BOUNDA;
13473                 }
13474             }
13475             else {
13476                 STRLEN length;
13477                 char name = *RExC_parse;
13478                 char * endbrace = NULL;
13479                 RExC_parse += 2;
13480                 endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13481
13482                 if (! endbrace) {
13483                     vFAIL2("Missing right brace on \\%c{}", name);
13484                 }
13485                 /* XXX Need to decide whether to take spaces or not.  Should be
13486                  * consistent with \p{}, but that currently is SPACE, which
13487                  * means vertical too, which seems wrong
13488                  * while (isBLANK(*RExC_parse)) {
13489                     RExC_parse++;
13490                 }*/
13491                 if (endbrace == RExC_parse) {
13492                     RExC_parse++;  /* After the '}' */
13493                     vFAIL2("Empty \\%c{}", name);
13494                 }
13495                 length = endbrace - RExC_parse;
13496                 /*while (isBLANK(*(RExC_parse + length - 1))) {
13497                     length--;
13498                 }*/
13499                 switch (*RExC_parse) {
13500                     case 'g':
13501                         if (    length != 1
13502                             && (memNEs(RExC_parse + 1, length - 1, "cb")))
13503                         {
13504                             goto bad_bound_type;
13505                         }
13506                         flags = GCB_BOUND;
13507                         break;
13508                     case 'l':
13509                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13510                             goto bad_bound_type;
13511                         }
13512                         flags = LB_BOUND;
13513                         break;
13514                     case 's':
13515                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13516                             goto bad_bound_type;
13517                         }
13518                         flags = SB_BOUND;
13519                         break;
13520                     case 'w':
13521                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13522                             goto bad_bound_type;
13523                         }
13524                         flags = WB_BOUND;
13525                         break;
13526                     default:
13527                       bad_bound_type:
13528                         RExC_parse = endbrace;
13529                         vFAIL2utf8f(
13530                             "'%" UTF8f "' is an unknown bound type",
13531                             UTF8fARG(UTF, length, endbrace - length));
13532                         NOT_REACHED; /*NOTREACHED*/
13533                 }
13534                 RExC_parse = endbrace;
13535                 REQUIRE_UNI_RULES(flagp, 0);
13536
13537                 if (op == BOUND) {
13538                     op = BOUNDU;
13539                 }
13540                 else if (op >= BOUNDA) {  /* /aa is same as /a */
13541                     op = BOUNDU;
13542                     length += 4;
13543
13544                     /* Don't have to worry about UTF-8, in this message because
13545                      * to get here the contents of the \b must be ASCII */
13546                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
13547                               "Using /u for '%.*s' instead of /%s",
13548                               (unsigned) length,
13549                               endbrace - length + 1,
13550                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
13551                               ? ASCII_RESTRICT_PAT_MODS
13552                               : ASCII_MORE_RESTRICT_PAT_MODS);
13553                 }
13554             }
13555
13556             if (op == BOUND) {
13557                 RExC_seen_d_op = TRUE;
13558             }
13559             else if (op == BOUNDL) {
13560                 RExC_contains_locale = 1;
13561             }
13562
13563             if (invert) {
13564                 op += NBOUND - BOUND;
13565             }
13566
13567             ret = reg_node(pRExC_state, op);
13568             FLAGS(REGNODE_p(ret)) = flags;
13569
13570             *flagp |= SIMPLE;
13571
13572             goto finish_meta_pat;
13573           }
13574
13575         case 'D':
13576             invert = 1;
13577             /* FALLTHROUGH */
13578         case 'd':
13579             arg = ANYOF_DIGIT;
13580             if (! DEPENDS_SEMANTICS) {
13581                 goto join_posix;
13582             }
13583
13584             /* \d doesn't have any matches in the upper Latin1 range, hence /d
13585              * is equivalent to /u.  Changing to /u saves some branches at
13586              * runtime */
13587             op = POSIXU;
13588             goto join_posix_op_known;
13589
13590         case 'R':
13591             ret = reg_node(pRExC_state, LNBREAK);
13592             *flagp |= HASWIDTH|SIMPLE;
13593             goto finish_meta_pat;
13594
13595         case 'H':
13596             invert = 1;
13597             /* FALLTHROUGH */
13598         case 'h':
13599             arg = ANYOF_BLANK;
13600             op = POSIXU;
13601             goto join_posix_op_known;
13602
13603         case 'V':
13604             invert = 1;
13605             /* FALLTHROUGH */
13606         case 'v':
13607             arg = ANYOF_VERTWS;
13608             op = POSIXU;
13609             goto join_posix_op_known;
13610
13611         case 'S':
13612             invert = 1;
13613             /* FALLTHROUGH */
13614         case 's':
13615             arg = ANYOF_SPACE;
13616
13617           join_posix:
13618
13619             op = POSIXD + get_regex_charset(RExC_flags);
13620             if (op > POSIXA) {  /* /aa is same as /a */
13621                 op = POSIXA;
13622             }
13623             else if (op == POSIXL) {
13624                 RExC_contains_locale = 1;
13625             }
13626             else if (op == POSIXD) {
13627                 RExC_seen_d_op = TRUE;
13628             }
13629
13630           join_posix_op_known:
13631
13632             if (invert) {
13633                 op += NPOSIXD - POSIXD;
13634             }
13635
13636             ret = reg_node(pRExC_state, op);
13637             FLAGS(REGNODE_p(ret)) = namedclass_to_classnum(arg);
13638
13639             *flagp |= HASWIDTH|SIMPLE;
13640             /* FALLTHROUGH */
13641
13642           finish_meta_pat:
13643             if (   UCHARAT(RExC_parse + 1) == '{'
13644                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
13645             {
13646                 RExC_parse += 2;
13647                 vFAIL("Unescaped left brace in regex is illegal here");
13648             }
13649             nextchar(pRExC_state);
13650             Set_Node_Length(REGNODE_p(ret), 2); /* MJD */
13651             break;
13652         case 'p':
13653         case 'P':
13654             RExC_parse--;
13655
13656             ret = regclass(pRExC_state, flagp, depth+1,
13657                            TRUE, /* means just parse this element */
13658                            FALSE, /* don't allow multi-char folds */
13659                            FALSE, /* don't silence non-portable warnings.  It
13660                                      would be a bug if these returned
13661                                      non-portables */
13662                            (bool) RExC_strict,
13663                            TRUE, /* Allow an optimized regnode result */
13664                            NULL);
13665             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13666             /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
13667              * multi-char folds are allowed.  */
13668             if (!ret)
13669                 FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13670                       (UV) *flagp);
13671
13672             RExC_parse--;
13673
13674             Set_Node_Offset(REGNODE_p(ret), parse_start);
13675             Set_Node_Cur_Length(REGNODE_p(ret), parse_start - 2);
13676             nextchar(pRExC_state);
13677             break;
13678         case 'N':
13679             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
13680              * \N{...} evaluates to a sequence of more than one code points).
13681              * The function call below returns a regnode, which is our result.
13682              * The parameters cause it to fail if the \N{} evaluates to a
13683              * single code point; we handle those like any other literal.  The
13684              * reason that the multicharacter case is handled here and not as
13685              * part of the EXACtish code is because of quantifiers.  In
13686              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
13687              * this way makes that Just Happen. dmq.
13688              * join_exact() will join this up with adjacent EXACTish nodes
13689              * later on, if appropriate. */
13690             ++RExC_parse;
13691             if (grok_bslash_N(pRExC_state,
13692                               &ret,     /* Want a regnode returned */
13693                               NULL,     /* Fail if evaluates to a single code
13694                                            point */
13695                               NULL,     /* Don't need a count of how many code
13696                                            points */
13697                               flagp,
13698                               RExC_strict,
13699                               depth)
13700             ) {
13701                 break;
13702             }
13703
13704             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13705
13706             /* Here, evaluates to a single code point.  Go get that */
13707             RExC_parse = parse_start;
13708             goto defchar;
13709
13710         case 'k':    /* Handle \k<NAME> and \k'NAME' */
13711       parse_named_seq:
13712         {
13713             char ch;
13714             if (   RExC_parse >= RExC_end - 1
13715                 || ((   ch = RExC_parse[1]) != '<'
13716                                       && ch != '\''
13717                                       && ch != '{'))
13718             {
13719                 RExC_parse++;
13720                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13721                 vFAIL2("Sequence %.2s... not terminated", parse_start);
13722             } else {
13723                 RExC_parse += 2;
13724                 ret = handle_named_backref(pRExC_state,
13725                                            flagp,
13726                                            parse_start,
13727                                            (ch == '<')
13728                                            ? '>'
13729                                            : (ch == '{')
13730                                              ? '}'
13731                                              : '\'');
13732             }
13733             break;
13734         }
13735         case 'g':
13736         case '1': case '2': case '3': case '4':
13737         case '5': case '6': case '7': case '8': case '9':
13738             {
13739                 I32 num;
13740                 bool hasbrace = 0;
13741
13742                 if (*RExC_parse == 'g') {
13743                     bool isrel = 0;
13744
13745                     RExC_parse++;
13746                     if (*RExC_parse == '{') {
13747                         RExC_parse++;
13748                         hasbrace = 1;
13749                     }
13750                     if (*RExC_parse == '-') {
13751                         RExC_parse++;
13752                         isrel = 1;
13753                     }
13754                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13755                         if (isrel) RExC_parse--;
13756                         RExC_parse -= 2;
13757                         goto parse_named_seq;
13758                     }
13759
13760                     if (RExC_parse >= RExC_end) {
13761                         goto unterminated_g;
13762                     }
13763                     num = S_backref_value(RExC_parse, RExC_end);
13764                     if (num == 0)
13765                         vFAIL("Reference to invalid group 0");
13766                     else if (num == I32_MAX) {
13767                          if (isDIGIT(*RExC_parse))
13768                             vFAIL("Reference to nonexistent group");
13769                         else
13770                           unterminated_g:
13771                             vFAIL("Unterminated \\g... pattern");
13772                     }
13773
13774                     if (isrel) {
13775                         num = RExC_npar - num;
13776                         if (num < 1)
13777                             vFAIL("Reference to nonexistent or unclosed group");
13778                     }
13779                 }
13780                 else {
13781                     num = S_backref_value(RExC_parse, RExC_end);
13782                     /* bare \NNN might be backref or octal - if it is larger
13783                      * than or equal RExC_npar then it is assumed to be an
13784                      * octal escape. Note RExC_npar is +1 from the actual
13785                      * number of parens. */
13786                     /* Note we do NOT check if num == I32_MAX here, as that is
13787                      * handled by the RExC_npar check */
13788
13789                     if (
13790                         /* any numeric escape < 10 is always a backref */
13791                         num > 9
13792                         /* any numeric escape < RExC_npar is a backref */
13793                         && num >= RExC_npar
13794                         /* cannot be an octal escape if it starts with 8 */
13795                         && *RExC_parse != '8'
13796                         /* cannot be an octal escape it it starts with 9 */
13797                         && *RExC_parse != '9'
13798                     ) {
13799                         /* Probably not meant to be a backref, instead likely
13800                          * to be an octal character escape, e.g. \35 or \777.
13801                          * The above logic should make it obvious why using
13802                          * octal escapes in patterns is problematic. - Yves */
13803                         RExC_parse = parse_start;
13804                         goto defchar;
13805                     }
13806                 }
13807
13808                 /* At this point RExC_parse points at a numeric escape like
13809                  * \12 or \88 or something similar, which we should NOT treat
13810                  * as an octal escape. It may or may not be a valid backref
13811                  * escape. For instance \88888888 is unlikely to be a valid
13812                  * backref. */
13813                 while (isDIGIT(*RExC_parse))
13814                     RExC_parse++;
13815                 if (hasbrace) {
13816                     if (*RExC_parse != '}')
13817                         vFAIL("Unterminated \\g{...} pattern");
13818                     RExC_parse++;
13819                 }
13820                 if (num >= (I32)RExC_npar) {
13821
13822                     /* It might be a forward reference; we can't fail until we
13823                      * know, by completing the parse to get all the groups, and
13824                      * then reparsing */
13825                     if (ALL_PARENS_COUNTED)  {
13826                         if (num >= RExC_total_parens)  {
13827                             vFAIL("Reference to nonexistent group");
13828                         }
13829                     }
13830                     else {
13831                         REQUIRE_PARENS_PASS;
13832                     }
13833                 }
13834                 RExC_sawback = 1;
13835                 ret = reganode(pRExC_state,
13836                                ((! FOLD)
13837                                  ? REF
13838                                  : (ASCII_FOLD_RESTRICTED)
13839                                    ? REFFA
13840                                    : (AT_LEAST_UNI_SEMANTICS)
13841                                      ? REFFU
13842                                      : (LOC)
13843                                        ? REFFL
13844                                        : REFF),
13845                                 num);
13846                 if (OP(REGNODE_p(ret)) == REFF) {
13847                     RExC_seen_d_op = TRUE;
13848                 }
13849                 *flagp |= HASWIDTH;
13850
13851                 /* override incorrect value set in reganode MJD */
13852                 Set_Node_Offset(REGNODE_p(ret), parse_start);
13853                 Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1);
13854                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13855                                         FALSE /* Don't force to /x */ );
13856             }
13857             break;
13858         case '\0':
13859             if (RExC_parse >= RExC_end)
13860                 FAIL("Trailing \\");
13861             /* FALLTHROUGH */
13862         default:
13863             /* Do not generate "unrecognized" warnings here, we fall
13864                back into the quick-grab loop below */
13865             RExC_parse = parse_start;
13866             goto defchar;
13867         } /* end of switch on a \foo sequence */
13868         break;
13869
13870     case '#':
13871
13872         /* '#' comments should have been spaced over before this function was
13873          * called */
13874         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13875         /*
13876         if (RExC_flags & RXf_PMf_EXTENDED) {
13877             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13878             if (RExC_parse < RExC_end)
13879                 goto tryagain;
13880         }
13881         */
13882
13883         /* FALLTHROUGH */
13884
13885     default:
13886           defchar: {
13887
13888             /* Here, we have determined that the next thing is probably a
13889              * literal character.  RExC_parse points to the first byte of its
13890              * definition.  (It still may be an escape sequence that evaluates
13891              * to a single character) */
13892
13893             STRLEN len = 0;
13894             UV ender = 0;
13895             char *p;
13896             char *s;
13897
13898 /* This allows us to fill a node with just enough spare so that if the final
13899  * character folds, its expansion is guaranteed to fit */
13900 #define MAX_NODE_STRING_SIZE (255-UTF8_MAXBYTES_CASE)
13901
13902             char *s0;
13903             U8 upper_parse = MAX_NODE_STRING_SIZE;
13904
13905             /* We start out as an EXACT node, even if under /i, until we find a
13906              * character which is in a fold.  The algorithm now segregates into
13907              * separate nodes, characters that fold from those that don't under
13908              * /i.  (This hopefully will create nodes that are fixed strings
13909              * even under /i, giving the optimizer something to grab on to.)
13910              * So, if a node has something in it and the next character is in
13911              * the opposite category, that node is closed up, and the function
13912              * returns.  Then regatom is called again, and a new node is
13913              * created for the new category. */
13914             U8 node_type = EXACT;
13915
13916             /* Assume the node will be fully used; the excess is given back at
13917              * the end.  We can't make any other length assumptions, as a byte
13918              * input sequence could shrink down. */
13919             Ptrdiff_t initial_size = STR_SZ(256);
13920
13921             bool next_is_quantifier;
13922             char * oldp = NULL;
13923
13924             /* We can convert EXACTF nodes to EXACTFU if they contain only
13925              * characters that match identically regardless of the target
13926              * string's UTF8ness.  The reason to do this is that EXACTF is not
13927              * trie-able, EXACTFU is, and EXACTFU requires fewer operations at
13928              * runtime.
13929              *
13930              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13931              * contain only above-Latin1 characters (hence must be in UTF8),
13932              * which don't participate in folds with Latin1-range characters,
13933              * as the latter's folds aren't known until runtime. */
13934             bool maybe_exactfu = FOLD && (DEPENDS_SEMANTICS || LOC);
13935
13936             /* Single-character EXACTish nodes are almost always SIMPLE.  This
13937              * allows us to override this as encountered */
13938             U8 maybe_SIMPLE = SIMPLE;
13939
13940             /* Does this node contain something that can't match unless the
13941              * target string is (also) in UTF-8 */
13942             bool requires_utf8_target = FALSE;
13943
13944             /* The sequence 'ss' is problematic in non-UTF-8 patterns. */
13945             bool has_ss = FALSE;
13946
13947             /* So is the MICRO SIGN */
13948             bool has_micro_sign = FALSE;
13949
13950             /* Allocate an EXACT node.  The node_type may change below to
13951              * another EXACTish node, but since the size of the node doesn't
13952              * change, it works */
13953             ret = regnode_guts(pRExC_state, node_type, initial_size, "exact");
13954             FILL_NODE(ret, node_type);
13955             RExC_emit++;
13956
13957             s = STRING(REGNODE_p(ret));
13958
13959             s0 = s;
13960
13961           reparse:
13962
13963             /* This breaks under rare circumstances.  If folding, we do not
13964              * want to split a node at a character that is a non-final in a
13965              * multi-char fold, as an input string could just happen to want to
13966              * match across the node boundary.  The code at the end of the loop
13967              * looks for this, and backs off until it finds not such a
13968              * character, but it is possible (though extremely, extremely
13969              * unlikely) for all characters in the node to be non-final fold
13970              * ones, in which case we just leave the node fully filled, and
13971              * hope that it doesn't match the string in just the wrong place */
13972
13973             assert( ! UTF     /* Is at the beginning of a character */
13974                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13975                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13976
13977             /* Here, we have a literal character.  Find the maximal string of
13978              * them in the input that we can fit into a single EXACTish node.
13979              * We quit at the first non-literal or when the node gets full, or
13980              * under /i the categorization of folding/non-folding character
13981              * changes */
13982             for (p = RExC_parse; len < upper_parse && p < RExC_end; ) {
13983
13984                 /* In most cases each iteration adds one byte to the output.
13985                  * The exceptions override this */
13986                 Size_t added_len = 1;
13987
13988                 oldp = p;
13989
13990                 /* White space has already been ignored */
13991                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13992                        || ! is_PATWS_safe((p), RExC_end, UTF));
13993
13994                 switch ((U8)*p) {
13995                 case '^':
13996                 case '$':
13997                 case '.':
13998                 case '[':
13999                 case '(':
14000                 case ')':
14001                 case '|':
14002                     goto loopdone;
14003                 case '\\':
14004                     /* Literal Escapes Switch
14005
14006                        This switch is meant to handle escape sequences that
14007                        resolve to a literal character.
14008
14009                        Every escape sequence that represents something
14010                        else, like an assertion or a char class, is handled
14011                        in the switch marked 'Special Escapes' above in this
14012                        routine, but also has an entry here as anything that
14013                        isn't explicitly mentioned here will be treated as
14014                        an unescaped equivalent literal.
14015                     */
14016
14017                     switch ((U8)*++p) {
14018
14019                     /* These are all the special escapes. */
14020                     case 'A':             /* Start assertion */
14021                     case 'b': case 'B':   /* Word-boundary assertion*/
14022                     case 'C':             /* Single char !DANGEROUS! */
14023                     case 'd': case 'D':   /* digit class */
14024                     case 'g': case 'G':   /* generic-backref, pos assertion */
14025                     case 'h': case 'H':   /* HORIZWS */
14026                     case 'k': case 'K':   /* named backref, keep marker */
14027                     case 'p': case 'P':   /* Unicode property */
14028                               case 'R':   /* LNBREAK */
14029                     case 's': case 'S':   /* space class */
14030                     case 'v': case 'V':   /* VERTWS */
14031                     case 'w': case 'W':   /* word class */
14032                     case 'X':             /* eXtended Unicode "combining
14033                                              character sequence" */
14034                     case 'z': case 'Z':   /* End of line/string assertion */
14035                         --p;
14036                         goto loopdone;
14037
14038                     /* Anything after here is an escape that resolves to a
14039                        literal. (Except digits, which may or may not)
14040                      */
14041                     case 'n':
14042                         ender = '\n';
14043                         p++;
14044                         break;
14045                     case 'N': /* Handle a single-code point named character. */
14046                         RExC_parse = p + 1;
14047                         if (! grok_bslash_N(pRExC_state,
14048                                             NULL,   /* Fail if evaluates to
14049                                                        anything other than a
14050                                                        single code point */
14051                                             &ender, /* The returned single code
14052                                                        point */
14053                                             NULL,   /* Don't need a count of
14054                                                        how many code points */
14055                                             flagp,
14056                                             RExC_strict,
14057                                             depth)
14058                         ) {
14059                             if (*flagp & NEED_UTF8)
14060                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
14061                             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
14062
14063                             /* Here, it wasn't a single code point.  Go close
14064                              * up this EXACTish node.  The switch() prior to
14065                              * this switch handles the other cases */
14066                             RExC_parse = p = oldp;
14067                             goto loopdone;
14068                         }
14069                         p = RExC_parse;
14070                         RExC_parse = parse_start;
14071
14072                         /* The \N{} means the pattern, if previously /d,
14073                          * becomes /u.  That means it can't be an EXACTF node,
14074                          * but an EXACTFU */
14075                         if (node_type == EXACTF) {
14076                             node_type = EXACTFU;
14077
14078                             /* If the node already contains something that
14079                              * differs between EXACTF and EXACTFU, reparse it
14080                              * as EXACTFU */
14081                             if (! maybe_exactfu) {
14082                                 len = 0;
14083                                 s = s0;
14084                                 goto reparse;
14085                             }
14086                         }
14087
14088                         break;
14089                     case 'r':
14090                         ender = '\r';
14091                         p++;
14092                         break;
14093                     case 't':
14094                         ender = '\t';
14095                         p++;
14096                         break;
14097                     case 'f':
14098                         ender = '\f';
14099                         p++;
14100                         break;
14101                     case 'e':
14102                         ender = ESC_NATIVE;
14103                         p++;
14104                         break;
14105                     case 'a':
14106                         ender = '\a';
14107                         p++;
14108                         break;
14109                     case 'o':
14110                         {
14111                             UV result;
14112                             const char* error_msg;
14113
14114                             bool valid = grok_bslash_o(&p,
14115                                                        RExC_end,
14116                                                        &result,
14117                                                        &error_msg,
14118                                                        TO_OUTPUT_WARNINGS(p),
14119                                                        (bool) RExC_strict,
14120                                                        TRUE, /* Output warnings
14121                                                                 for non-
14122                                                                 portables */
14123                                                        UTF);
14124                             if (! valid) {
14125                                 RExC_parse = p; /* going to die anyway; point
14126                                                    to exact spot of failure */
14127                                 vFAIL(error_msg);
14128                             }
14129                             UPDATE_WARNINGS_LOC(p - 1);
14130                             ender = result;
14131                             break;
14132                         }
14133                     case 'x':
14134                         {
14135                             UV result = UV_MAX; /* initialize to erroneous
14136                                                    value */
14137                             const char* error_msg;
14138
14139                             bool valid = grok_bslash_x(&p,
14140                                                        RExC_end,
14141                                                        &result,
14142                                                        &error_msg,
14143                                                        TO_OUTPUT_WARNINGS(p),
14144                                                        (bool) RExC_strict,
14145                                                        TRUE, /* Silence warnings
14146                                                                 for non-
14147                                                                 portables */
14148                                                        UTF);
14149                             if (! valid) {
14150                                 RExC_parse = p; /* going to die anyway; point
14151                                                    to exact spot of failure */
14152                                 vFAIL(error_msg);
14153                             }
14154                             UPDATE_WARNINGS_LOC(p - 1);
14155                             ender = result;
14156
14157                             if (ender < 0x100) {
14158 #ifdef EBCDIC
14159                                 if (RExC_recode_x_to_native) {
14160                                     ender = LATIN1_TO_NATIVE(ender);
14161                                 }
14162 #endif
14163                             }
14164                             break;
14165                         }
14166                     case 'c':
14167                         p++;
14168                         ender = grok_bslash_c(*p, TO_OUTPUT_WARNINGS(p));
14169                         UPDATE_WARNINGS_LOC(p);
14170                         p++;
14171                         break;
14172                     case '8': case '9': /* must be a backreference */
14173                         --p;
14174                         /* we have an escape like \8 which cannot be an octal escape
14175                          * so we exit the loop, and let the outer loop handle this
14176                          * escape which may or may not be a legitimate backref. */
14177                         goto loopdone;
14178                     case '1': case '2': case '3':case '4':
14179                     case '5': case '6': case '7':
14180                         /* When we parse backslash escapes there is ambiguity
14181                          * between backreferences and octal escapes. Any escape
14182                          * from \1 - \9 is a backreference, any multi-digit
14183                          * escape which does not start with 0 and which when
14184                          * evaluated as decimal could refer to an already
14185                          * parsed capture buffer is a back reference. Anything
14186                          * else is octal.
14187                          *
14188                          * Note this implies that \118 could be interpreted as
14189                          * 118 OR as "\11" . "8" depending on whether there
14190                          * were 118 capture buffers defined already in the
14191                          * pattern.  */
14192
14193                         /* NOTE, RExC_npar is 1 more than the actual number of
14194                          * parens we have seen so far, hence the "<" as opposed
14195                          * to "<=" */
14196                         if ( !isDIGIT(p[1]) || S_backref_value(p, RExC_end) < RExC_npar)
14197                         {  /* Not to be treated as an octal constant, go
14198                                    find backref */
14199                             --p;
14200                             goto loopdone;
14201                         }
14202                         /* FALLTHROUGH */
14203                     case '0':
14204                         {
14205                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
14206                             STRLEN numlen = 3;
14207                             ender = grok_oct(p, &numlen, &flags, NULL);
14208                             p += numlen;
14209                             if (   isDIGIT(*p)  /* like \08, \178 */
14210                                 && ckWARN(WARN_REGEXP)
14211                                 && numlen < 3)
14212                             {
14213                                 reg_warn_non_literal_string(
14214                                          p + 1,
14215                                          form_short_octal_warning(p, numlen));
14216                             }
14217                         }
14218                         break;
14219                     case '\0':
14220                         if (p >= RExC_end)
14221                             FAIL("Trailing \\");
14222                         /* FALLTHROUGH */
14223                     default:
14224                         if (isALPHANUMERIC(*p)) {
14225                             /* An alpha followed by '{' is going to fail next
14226                              * iteration, so don't output this warning in that
14227                              * case */
14228                             if (! isALPHA(*p) || *(p + 1) != '{') {
14229                                 ckWARN2reg(p + 1, "Unrecognized escape \\%.1s"
14230                                                   " passed through", p);
14231                             }
14232                         }
14233                         goto normal_default;
14234                     } /* End of switch on '\' */
14235                     break;
14236                 case '{':
14237                     /* Trying to gain new uses for '{' without breaking too
14238                      * much existing code is hard.  The solution currently
14239                      * adopted is:
14240                      *  1)  If there is no ambiguity that a '{' should always
14241                      *      be taken literally, at the start of a construct, we
14242                      *      just do so.
14243                      *  2)  If the literal '{' conflicts with our desired use
14244                      *      of it as a metacharacter, we die.  The deprecation
14245                      *      cycles for this have come and gone.
14246                      *  3)  If there is ambiguity, we raise a simple warning.
14247                      *      This could happen, for example, if the user
14248                      *      intended it to introduce a quantifier, but slightly
14249                      *      misspelled the quantifier.  Without this warning,
14250                      *      the quantifier would silently be taken as a literal
14251                      *      string of characters instead of a meta construct */
14252                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
14253                         if (      RExC_strict
14254                             || (  p > parse_start + 1
14255                                 && isALPHA_A(*(p - 1))
14256                                 && *(p - 2) == '\\')
14257                             || new_regcurly(p, RExC_end))
14258                         {
14259                             RExC_parse = p + 1;
14260                             vFAIL("Unescaped left brace in regex is "
14261                                   "illegal here");
14262                         }
14263                         ckWARNreg(p + 1, "Unescaped left brace in regex is"
14264                                          " passed through");
14265                     }
14266                     goto normal_default;
14267                 case '}':
14268                 case ']':
14269                     if (p > RExC_parse && RExC_strict) {
14270                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
14271                     }
14272                     /*FALLTHROUGH*/
14273                 default:    /* A literal character */
14274                   normal_default:
14275                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
14276                         STRLEN numlen;
14277                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
14278                                                &numlen, UTF8_ALLOW_DEFAULT);
14279                         p += numlen;
14280                     }
14281                     else
14282                         ender = (U8) *p++;
14283                     break;
14284                 } /* End of switch on the literal */
14285
14286                 /* Here, have looked at the literal character, and <ender>
14287                  * contains its ordinal; <p> points to the character after it.
14288                  * */
14289
14290                 if (ender > 255) {
14291                     REQUIRE_UTF8(flagp);
14292                 }
14293
14294                 /* We need to check if the next non-ignored thing is a
14295                  * quantifier.  Move <p> to after anything that should be
14296                  * ignored, which, as a side effect, positions <p> for the next
14297                  * loop iteration */
14298                 skip_to_be_ignored_text(pRExC_state, &p,
14299                                         FALSE /* Don't force to /x */ );
14300
14301                 /* If the next thing is a quantifier, it applies to this
14302                  * character only, which means that this character has to be in
14303                  * its own node and can't just be appended to the string in an
14304                  * existing node, so if there are already other characters in
14305                  * the node, close the node with just them, and set up to do
14306                  * this character again next time through, when it will be the
14307                  * only thing in its new node */
14308
14309                 next_is_quantifier =    LIKELY(p < RExC_end)
14310                                      && UNLIKELY(ISMULT2(p));
14311
14312                 if (next_is_quantifier && LIKELY(len)) {
14313                     p = oldp;
14314                     goto loopdone;
14315                 }
14316
14317                 /* Ready to add 'ender' to the node */
14318
14319                 if (! FOLD) {  /* The simple case, just append the literal */
14320
14321                       not_fold_common:
14322                         if (UVCHR_IS_INVARIANT(ender) || ! UTF) {
14323                             *(s++) = (char) ender;
14324                         }
14325                         else {
14326                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
14327                             added_len = (char *) new_s - s;
14328                             s = (char *) new_s;
14329
14330                             if (ender > 255)  {
14331                                 requires_utf8_target = TRUE;
14332                             }
14333                         }
14334                 }
14335                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
14336
14337                     /* Here are folding under /l, and the code point is
14338                      * problematic.  If this is the first character in the
14339                      * node, change the node type to folding.   Otherwise, if
14340                      * this is the first problematic character, close up the
14341                      * existing node, so can start a new node with this one */
14342                     if (! len) {
14343                         node_type = EXACTFL;
14344                         RExC_contains_locale = 1;
14345                     }
14346                     else if (node_type == EXACT) {
14347                         p = oldp;
14348                         goto loopdone;
14349                     }
14350
14351                     /* This problematic code point means we can't simplify
14352                      * things */
14353                     maybe_exactfu = FALSE;
14354
14355                     /* Here, we are adding a problematic fold character.
14356                      * "Problematic" in this context means that its fold isn't
14357                      * known until runtime.  (The non-problematic code points
14358                      * are the above-Latin1 ones that fold to also all
14359                      * above-Latin1.  Their folds don't vary no matter what the
14360                      * locale is.) But here we have characters whose fold
14361                      * depends on the locale.  We just add in the unfolded
14362                      * character, and wait until runtime to fold it */
14363                     goto not_fold_common;
14364                 }
14365                 else /* regular fold; see if actually is in a fold */
14366                      if (   (ender < 256 && ! IS_IN_SOME_FOLD_L1(ender))
14367                          || (ender > 255
14368                             && ! _invlist_contains_cp(PL_in_some_fold, ender)))
14369                 {
14370                     /* Here, folding, but the character isn't in a fold.
14371                      *
14372                      * Start a new node if previous characters in the node were
14373                      * folded */
14374                     if (len && node_type != EXACT) {
14375                         p = oldp;
14376                         goto loopdone;
14377                     }
14378
14379                     /* Here, continuing a node with non-folded characters.  Add
14380                      * this one */
14381                     goto not_fold_common;
14382                 }
14383                 else {  /* Here, does participate in some fold */
14384
14385                     /* If this is the first character in the node, change its
14386                      * type to folding.  Otherwise, if this is the first
14387                      * folding character in the node, close up the existing
14388                      * node, so can start a new node with this one.  */
14389                     if (! len) {
14390                         node_type = compute_EXACTish(pRExC_state);
14391                     }
14392                     else if (node_type == EXACT) {
14393                         p = oldp;
14394                         goto loopdone;
14395                     }
14396
14397                     if (UTF) {  /* Use the folded value */
14398                         if (UVCHR_IS_INVARIANT(ender)) {
14399                             *(s)++ = (U8) toFOLD(ender);
14400                         }
14401                         else {
14402                             ender = _to_uni_fold_flags(
14403                                     ender,
14404                                     (U8 *) s,
14405                                     &added_len,
14406                                     FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
14407                                                     ? FOLD_FLAGS_NOMIX_ASCII
14408                                                     : 0));
14409                             s += added_len;
14410
14411                             if (   ender > 255
14412                                 && LIKELY(ender != GREEK_SMALL_LETTER_MU))
14413                             {
14414                                 /* U+B5 folds to the MU, so its possible for a
14415                                  * non-UTF-8 target to match it */
14416                                 requires_utf8_target = TRUE;
14417                             }
14418                         }
14419                     }
14420                     else {
14421
14422                         /* Here is non-UTF8.  First, see if the character's
14423                          * fold differs between /d and /u. */
14424                         if (PL_fold[ender] != PL_fold_latin1[ender]) {
14425                             maybe_exactfu = FALSE;
14426                         }
14427
14428 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
14429    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
14430                                       || UNICODE_DOT_DOT_VERSION > 0)
14431
14432                         /* On non-ancient Unicode versions, this includes the
14433                          * multi-char fold SHARP S to 'ss' */
14434
14435                         if (   UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)
14436                                  || (   isALPHA_FOLD_EQ(ender, 's')
14437                                      && len > 0
14438                                      && isALPHA_FOLD_EQ(*(s-1), 's')))
14439                         {
14440                             /* Here, we have one of the following:
14441                              *  a)  a SHARP S.  This folds to 'ss' only under
14442                              *      /u rules.  If we are in that situation,
14443                              *      fold the SHARP S to 'ss'.  See the comments
14444                              *      for join_exact() as to why we fold this
14445                              *      non-UTF at compile time, and no others.
14446                              *  b)  'ss'.  When under /u, there's nothing
14447                              *      special needed to be done here.  The
14448                              *      previous iteration handled the first 's',
14449                              *      and this iteration will handle the second.
14450                              *      If, on the otherhand it's not /u, we have
14451                              *      to exclude the possibility of moving to /u,
14452                              *      so that we won't generate an unwanted
14453                              *      match, unless, at runtime, the target
14454                              *      string is in UTF-8.
14455                              * */
14456
14457                             has_ss = TRUE;
14458                             maybe_exactfu = FALSE;  /* Can't generate an
14459                                                        EXACTFU node (unless we
14460                                                        already are in one) */
14461                             if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
14462                                 maybe_SIMPLE = 0;
14463                                 if (node_type == EXACTFU) {
14464                                     *(s++) = 's';
14465
14466                                     /* Let the code below add in the extra 's' */
14467                                     ender = 's';
14468                                     added_len = 2;
14469                                 }
14470                             }
14471                         }
14472 #endif
14473
14474                         else if (UNLIKELY(ender == MICRO_SIGN)) {
14475                             has_micro_sign = TRUE;
14476                         }
14477
14478                         *(s++) = (DEPENDS_SEMANTICS)
14479                                  ? (char) toFOLD(ender)
14480
14481                                    /* Under /u, the fold of any character in
14482                                     * the 0-255 range happens to be its
14483                                     * lowercase equivalent, except for LATIN
14484                                     * SMALL LETTER SHARP S, which was handled
14485                                     * above, and the MICRO SIGN, whose fold
14486                                     * requires UTF-8 to represent.  */
14487                                  : (char) toLOWER_L1(ender);
14488                     }
14489                 } /* End of adding current character to the node */
14490
14491                 len += added_len;
14492
14493                 if (next_is_quantifier) {
14494
14495                     /* Here, the next input is a quantifier, and to get here,
14496                      * the current character is the only one in the node. */
14497                     goto loopdone;
14498                 }
14499
14500             } /* End of loop through literal characters */
14501
14502             /* Here we have either exhausted the input or ran out of room in
14503              * the node.  (If we encountered a character that can't be in the
14504              * node, transfer is made directly to <loopdone>, and so we
14505              * wouldn't have fallen off the end of the loop.)  In the latter
14506              * case, we artificially have to split the node into two, because
14507              * we just don't have enough space to hold everything.  This
14508              * creates a problem if the final character participates in a
14509              * multi-character fold in the non-final position, as a match that
14510              * should have occurred won't, due to the way nodes are matched,
14511              * and our artificial boundary.  So back off until we find a non-
14512              * problematic character -- one that isn't at the beginning or
14513              * middle of such a fold.  (Either it doesn't participate in any
14514              * folds, or appears only in the final position of all the folds it
14515              * does participate in.)  A better solution with far fewer false
14516              * positives, and that would fill the nodes more completely, would
14517              * be to actually have available all the multi-character folds to
14518              * test against, and to back-off only far enough to be sure that
14519              * this node isn't ending with a partial one.  <upper_parse> is set
14520              * further below (if we need to reparse the node) to include just
14521              * up through that final non-problematic character that this code
14522              * identifies, so when it is set to less than the full node, we can
14523              * skip the rest of this */
14524             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
14525                 PERL_UINT_FAST8_T backup_count = 0;
14526
14527                 const STRLEN full_len = len;
14528
14529                 assert(len >= MAX_NODE_STRING_SIZE);
14530
14531                 /* Here, <s> points to just beyond where we have output the
14532                  * final character of the node.  Look backwards through the
14533                  * string until find a non- problematic character */
14534
14535                 if (! UTF) {
14536
14537                     /* This has no multi-char folds to non-UTF characters */
14538                     if (ASCII_FOLD_RESTRICTED) {
14539                         goto loopdone;
14540                     }
14541
14542                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) {
14543                         backup_count++;
14544                     }
14545                     len = s - s0 + 1;
14546                 }
14547                 else {
14548
14549                     /* Point to the first byte of the final character */
14550                     s = (char *) utf8_hop_back((U8 *) s, -1, (U8 *) s0);
14551
14552                     while (s >= s0) {   /* Search backwards until find
14553                                            a non-problematic char */
14554                         if (UTF8_IS_INVARIANT(*s)) {
14555
14556                             /* There are no ascii characters that participate
14557                              * in multi-char folds under /aa.  In EBCDIC, the
14558                              * non-ascii invariants are all control characters,
14559                              * so don't ever participate in any folds. */
14560                             if (ASCII_FOLD_RESTRICTED
14561                                 || ! IS_NON_FINAL_FOLD(*s))
14562                             {
14563                                 break;
14564                             }
14565                         }
14566                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
14567                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
14568                                                                   *s, *(s+1))))
14569                             {
14570                                 break;
14571                             }
14572                         }
14573                         else if (! _invlist_contains_cp(
14574                                         PL_NonFinalFold,
14575                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
14576                         {
14577                             break;
14578                         }
14579
14580                         /* Here, the current character is problematic in that
14581                          * it does occur in the non-final position of some
14582                          * fold, so try the character before it, but have to
14583                          * special case the very first byte in the string, so
14584                          * we don't read outside the string */
14585                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
14586                         backup_count++;
14587                     } /* End of loop backwards through the string */
14588
14589                     /* If there were only problematic characters in the string,
14590                      * <s> will point to before s0, in which case the length
14591                      * should be 0, otherwise include the length of the
14592                      * non-problematic character just found */
14593                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
14594                 }
14595
14596                 /* Here, have found the final character, if any, that is
14597                  * non-problematic as far as ending the node without splitting
14598                  * it across a potential multi-char fold.  <len> contains the
14599                  * number of bytes in the node up-to and including that
14600                  * character, or is 0 if there is no such character, meaning
14601                  * the whole node contains only problematic characters.  In
14602                  * this case, give up and just take the node as-is.  We can't
14603                  * do any better */
14604                 if (len == 0) {
14605                     len = full_len;
14606
14607                 } else {
14608
14609                     /* Here, the node does contain some characters that aren't
14610                      * problematic.  If we didn't have to backup any, then the
14611                      * final character in the node is non-problematic, and we
14612                      * can take the node as-is */
14613                     if (backup_count == 0) {
14614                         goto loopdone;
14615                     }
14616                     else if (backup_count == 1) {
14617
14618                         /* If the final character is problematic, but the
14619                          * penultimate is not, back-off that last character to
14620                          * later start a new node with it */
14621                         p = oldp;
14622                         goto loopdone;
14623                     }
14624
14625                     /* Here, the final non-problematic character is earlier
14626                      * in the input than the penultimate character.  What we do
14627                      * is reparse from the beginning, going up only as far as
14628                      * this final ok one, thus guaranteeing that the node ends
14629                      * in an acceptable character.  The reason we reparse is
14630                      * that we know how far in the character is, but we don't
14631                      * know how to correlate its position with the input parse.
14632                      * An alternate implementation would be to build that
14633                      * correlation as we go along during the original parse,
14634                      * but that would entail extra work for every node, whereas
14635                      * this code gets executed only when the string is too
14636                      * large for the node, and the final two characters are
14637                      * problematic, an infrequent occurrence.  Yet another
14638                      * possible strategy would be to save the tail of the
14639                      * string, and the next time regatom is called, initialize
14640                      * with that.  The problem with this is that unless you
14641                      * back off one more character, you won't be guaranteed
14642                      * regatom will get called again, unless regbranch,
14643                      * regpiece ... are also changed.  If you do back off that
14644                      * extra character, so that there is input guaranteed to
14645                      * force calling regatom, you can't handle the case where
14646                      * just the first character in the node is acceptable.  I
14647                      * (khw) decided to try this method which doesn't have that
14648                      * pitfall; if performance issues are found, we can do a
14649                      * combination of the current approach plus that one */
14650                     upper_parse = len;
14651                     len = 0;
14652                     s = s0;
14653                     goto reparse;
14654                 }
14655             }   /* End of verifying node ends with an appropriate char */
14656
14657           loopdone:   /* Jumped to when encounters something that shouldn't be
14658                          in the node */
14659
14660             /* Free up any over-allocated space; cast is to silence bogus
14661              * warning in MS VC */
14662             change_engine_size(pRExC_state,
14663                                 - (Ptrdiff_t) (initial_size - STR_SZ(len)));
14664
14665             /* I (khw) don't know if you can get here with zero length, but the
14666              * old code handled this situation by creating a zero-length EXACT
14667              * node.  Might as well be NOTHING instead */
14668             if (len == 0) {
14669                 OP(REGNODE_p(ret)) = NOTHING;
14670             }
14671             else {
14672
14673                 /* If the node type is EXACT here, check to see if it
14674                  * should be EXACTL, or EXACT_ONLY8. */
14675                 if (node_type == EXACT) {
14676                     if (LOC) {
14677                         node_type = EXACTL;
14678                     }
14679                     else if (requires_utf8_target) {
14680                         node_type = EXACT_ONLY8;
14681                     }
14682                 } else if (FOLD) {
14683                     if (    UNLIKELY(has_micro_sign || has_ss)
14684                         && (node_type == EXACTFU || (   node_type == EXACTF
14685                                                      && maybe_exactfu)))
14686                     {   /* These two conditions are problematic in non-UTF-8
14687                            EXACTFU nodes. */
14688                         assert(! UTF);
14689                         node_type = EXACTFUP;
14690                     }
14691                     else if (node_type == EXACTFL) {
14692
14693                         /* 'maybe_exactfu' is deliberately set above to
14694                          * indicate this node type, where all code points in it
14695                          * are above 255 */
14696                         if (maybe_exactfu) {
14697                             node_type = EXACTFLU8;
14698                         }
14699                     }
14700                     else if (node_type == EXACTF) {  /* Means is /di */
14701
14702                         /* If 'maybe_exactfu' is clear, then we need to stay
14703                          * /di.  If it is set, it means there are no code
14704                          * points that match differently depending on UTF8ness
14705                          * of the target string, so it can become an EXACTFU
14706                          * node */
14707                         if (! maybe_exactfu) {
14708                             RExC_seen_d_op = TRUE;
14709                         }
14710                         else if (   isALPHA_FOLD_EQ(* STRING(REGNODE_p(ret)), 's')
14711                                  || isALPHA_FOLD_EQ(ender, 's'))
14712                         {
14713                             /* But, if the node begins or ends in an 's' we
14714                              * have to defer changing it into an EXACTFU, as
14715                              * the node could later get joined with another one
14716                              * that ends or begins with 's' creating an 'ss'
14717                              * sequence which would then wrongly match the
14718                              * sharp s without the target being UTF-8.  We
14719                              * create a special node that we resolve later when
14720                              * we join nodes together */
14721
14722                             node_type = EXACTFU_S_EDGE;
14723                         }
14724                         else {
14725                             node_type = EXACTFU;
14726                         }
14727                     }
14728
14729                     if (requires_utf8_target && node_type == EXACTFU) {
14730                         node_type = EXACTFU_ONLY8;
14731                     }
14732                 }
14733
14734                 OP(REGNODE_p(ret)) = node_type;
14735                 STR_LEN(REGNODE_p(ret)) = len;
14736                 RExC_emit += STR_SZ(len);
14737
14738                 /* If the node isn't a single character, it can't be SIMPLE */
14739                 if (len > (Size_t) ((UTF) ? UVCHR_SKIP(ender) : 1)) {
14740                     maybe_SIMPLE = 0;
14741                 }
14742
14743                 *flagp |= HASWIDTH | maybe_SIMPLE;
14744             }
14745
14746             Set_Node_Length(REGNODE_p(ret), p - parse_start - 1);
14747             RExC_parse = p;
14748
14749             {
14750                 /* len is STRLEN which is unsigned, need to copy to signed */
14751                 IV iv = len;
14752                 if (iv < 0)
14753                     vFAIL("Internal disaster");
14754             }
14755
14756         } /* End of label 'defchar:' */
14757         break;
14758     } /* End of giant switch on input character */
14759
14760     /* Position parse to next real character */
14761     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14762                                             FALSE /* Don't force to /x */ );
14763     if (   *RExC_parse == '{'
14764         && OP(REGNODE_p(ret)) != SBOL && ! regcurly(RExC_parse))
14765     {
14766         if (RExC_strict || new_regcurly(RExC_parse, RExC_end)) {
14767             RExC_parse++;
14768             vFAIL("Unescaped left brace in regex is illegal here");
14769         }
14770         ckWARNreg(RExC_parse + 1, "Unescaped left brace in regex is"
14771                                   " passed through");
14772     }
14773
14774     return(ret);
14775 }
14776
14777
14778 STATIC void
14779 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
14780 {
14781     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
14782      * sets up the bitmap and any flags, removing those code points from the
14783      * inversion list, setting it to NULL should it become completely empty */
14784
14785     dVAR;
14786
14787     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
14788     assert(PL_regkind[OP(node)] == ANYOF);
14789
14790     /* There is no bitmap for this node type */
14791     if (OP(node) == ANYOFH || OP(node) == ANYOFHb) {
14792         return;
14793     }
14794
14795     ANYOF_BITMAP_ZERO(node);
14796     if (*invlist_ptr) {
14797
14798         /* This gets set if we actually need to modify things */
14799         bool change_invlist = FALSE;
14800
14801         UV start, end;
14802
14803         /* Start looking through *invlist_ptr */
14804         invlist_iterinit(*invlist_ptr);
14805         while (invlist_iternext(*invlist_ptr, &start, &end)) {
14806             UV high;
14807             int i;
14808
14809             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
14810                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
14811             }
14812
14813             /* Quit if are above what we should change */
14814             if (start >= NUM_ANYOF_CODE_POINTS) {
14815                 break;
14816             }
14817
14818             change_invlist = TRUE;
14819
14820             /* Set all the bits in the range, up to the max that we are doing */
14821             high = (end < NUM_ANYOF_CODE_POINTS - 1)
14822                    ? end
14823                    : NUM_ANYOF_CODE_POINTS - 1;
14824             for (i = start; i <= (int) high; i++) {
14825                 if (! ANYOF_BITMAP_TEST(node, i)) {
14826                     ANYOF_BITMAP_SET(node, i);
14827                 }
14828             }
14829         }
14830         invlist_iterfinish(*invlist_ptr);
14831
14832         /* Done with loop; remove any code points that are in the bitmap from
14833          * *invlist_ptr; similarly for code points above the bitmap if we have
14834          * a flag to match all of them anyways */
14835         if (change_invlist) {
14836             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
14837         }
14838         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
14839             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
14840         }
14841
14842         /* If have completely emptied it, remove it completely */
14843         if (_invlist_len(*invlist_ptr) == 0) {
14844             SvREFCNT_dec_NN(*invlist_ptr);
14845             *invlist_ptr = NULL;
14846         }
14847     }
14848 }
14849
14850 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
14851    Character classes ([:foo:]) can also be negated ([:^foo:]).
14852    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
14853    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
14854    but trigger failures because they are currently unimplemented. */
14855
14856 #define POSIXCC_DONE(c)   ((c) == ':')
14857 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
14858 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
14859 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
14860
14861 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
14862 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
14863 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
14864
14865 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
14866
14867 /* 'posix_warnings' and 'warn_text' are names of variables in the following
14868  * routine. q.v. */
14869 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
14870         if (posix_warnings) {                                               \
14871             if (! RExC_warn_text ) RExC_warn_text =                         \
14872                                          (AV *) sv_2mortal((SV *) newAV()); \
14873             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                     \
14874                                              WARNING_PREFIX                 \
14875                                              text                           \
14876                                              REPORT_LOCATION,               \
14877                                              REPORT_LOCATION_ARGS(p)));     \
14878         }                                                                   \
14879     } STMT_END
14880 #define CLEAR_POSIX_WARNINGS()                                              \
14881     STMT_START {                                                            \
14882         if (posix_warnings && RExC_warn_text)                               \
14883             av_clear(RExC_warn_text);                                       \
14884     } STMT_END
14885
14886 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
14887     STMT_START {                                                            \
14888         CLEAR_POSIX_WARNINGS();                                             \
14889         return ret;                                                         \
14890     } STMT_END
14891
14892 STATIC int
14893 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
14894
14895     const char * const s,      /* Where the putative posix class begins.
14896                                   Normally, this is one past the '['.  This
14897                                   parameter exists so it can be somewhere
14898                                   besides RExC_parse. */
14899     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
14900                                   NULL */
14901     AV ** posix_warnings,      /* Where to place any generated warnings, or
14902                                   NULL */
14903     const bool check_only      /* Don't die if error */
14904 )
14905 {
14906     /* This parses what the caller thinks may be one of the three POSIX
14907      * constructs:
14908      *  1) a character class, like [:blank:]
14909      *  2) a collating symbol, like [. .]
14910      *  3) an equivalence class, like [= =]
14911      * In the latter two cases, it croaks if it finds a syntactically legal
14912      * one, as these are not handled by Perl.
14913      *
14914      * The main purpose is to look for a POSIX character class.  It returns:
14915      *  a) the class number
14916      *      if it is a completely syntactically and semantically legal class.
14917      *      'updated_parse_ptr', if not NULL, is set to point to just after the
14918      *      closing ']' of the class
14919      *  b) OOB_NAMEDCLASS
14920      *      if it appears that one of the three POSIX constructs was meant, but
14921      *      its specification was somehow defective.  'updated_parse_ptr', if
14922      *      not NULL, is set to point to the character just after the end
14923      *      character of the class.  See below for handling of warnings.
14924      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
14925      *      if it  doesn't appear that a POSIX construct was intended.
14926      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
14927      *      raised.
14928      *
14929      * In b) there may be errors or warnings generated.  If 'check_only' is
14930      * TRUE, then any errors are discarded.  Warnings are returned to the
14931      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
14932      * instead it is NULL, warnings are suppressed.
14933      *
14934      * The reason for this function, and its complexity is that a bracketed
14935      * character class can contain just about anything.  But it's easy to
14936      * mistype the very specific posix class syntax but yielding a valid
14937      * regular bracketed class, so it silently gets compiled into something
14938      * quite unintended.
14939      *
14940      * The solution adopted here maintains backward compatibility except that
14941      * it adds a warning if it looks like a posix class was intended but
14942      * improperly specified.  The warning is not raised unless what is input
14943      * very closely resembles one of the 14 legal posix classes.  To do this,
14944      * it uses fuzzy parsing.  It calculates how many single-character edits it
14945      * would take to transform what was input into a legal posix class.  Only
14946      * if that number is quite small does it think that the intention was a
14947      * posix class.  Obviously these are heuristics, and there will be cases
14948      * where it errs on one side or another, and they can be tweaked as
14949      * experience informs.
14950      *
14951      * The syntax for a legal posix class is:
14952      *
14953      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
14954      *
14955      * What this routine considers syntactically to be an intended posix class
14956      * is this (the comments indicate some restrictions that the pattern
14957      * doesn't show):
14958      *
14959      *  qr/(?x: \[?                         # The left bracket, possibly
14960      *                                      # omitted
14961      *          \h*                         # possibly followed by blanks
14962      *          (?: \^ \h* )?               # possibly a misplaced caret
14963      *          [:;]?                       # The opening class character,
14964      *                                      # possibly omitted.  A typo
14965      *                                      # semi-colon can also be used.
14966      *          \h*
14967      *          \^?                         # possibly a correctly placed
14968      *                                      # caret, but not if there was also
14969      *                                      # a misplaced one
14970      *          \h*
14971      *          .{3,15}                     # The class name.  If there are
14972      *                                      # deviations from the legal syntax,
14973      *                                      # its edit distance must be close
14974      *                                      # to a real class name in order
14975      *                                      # for it to be considered to be
14976      *                                      # an intended posix class.
14977      *          \h*
14978      *          [[:punct:]]?                # The closing class character,
14979      *                                      # possibly omitted.  If not a colon
14980      *                                      # nor semi colon, the class name
14981      *                                      # must be even closer to a valid
14982      *                                      # one
14983      *          \h*
14984      *          \]?                         # The right bracket, possibly
14985      *                                      # omitted.
14986      *     )/
14987      *
14988      * In the above, \h must be ASCII-only.
14989      *
14990      * These are heuristics, and can be tweaked as field experience dictates.
14991      * There will be cases when someone didn't intend to specify a posix class
14992      * that this warns as being so.  The goal is to minimize these, while
14993      * maximizing the catching of things intended to be a posix class that
14994      * aren't parsed as such.
14995      */
14996
14997     const char* p             = s;
14998     const char * const e      = RExC_end;
14999     unsigned complement       = 0;      /* If to complement the class */
15000     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
15001     bool has_opening_bracket  = FALSE;
15002     bool has_opening_colon    = FALSE;
15003     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
15004                                                    valid class */
15005     const char * possible_end = NULL;   /* used for a 2nd parse pass */
15006     const char* name_start;             /* ptr to class name first char */
15007
15008     /* If the number of single-character typos the input name is away from a
15009      * legal name is no more than this number, it is considered to have meant
15010      * the legal name */
15011     int max_distance          = 2;
15012
15013     /* to store the name.  The size determines the maximum length before we
15014      * decide that no posix class was intended.  Should be at least
15015      * sizeof("alphanumeric") */
15016     UV input_text[15];
15017     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
15018
15019     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
15020
15021     CLEAR_POSIX_WARNINGS();
15022
15023     if (p >= e) {
15024         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
15025     }
15026
15027     if (*(p - 1) != '[') {
15028         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
15029         found_problem = TRUE;
15030     }
15031     else {
15032         has_opening_bracket = TRUE;
15033     }
15034
15035     /* They could be confused and think you can put spaces between the
15036      * components */
15037     if (isBLANK(*p)) {
15038         found_problem = TRUE;
15039
15040         do {
15041             p++;
15042         } while (p < e && isBLANK(*p));
15043
15044         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15045     }
15046
15047     /* For [. .] and [= =].  These are quite different internally from [: :],
15048      * so they are handled separately.  */
15049     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
15050                                             and 1 for at least one char in it
15051                                           */
15052     {
15053         const char open_char  = *p;
15054         const char * temp_ptr = p + 1;
15055
15056         /* These two constructs are not handled by perl, and if we find a
15057          * syntactically valid one, we croak.  khw, who wrote this code, finds
15058          * this explanation of them very unclear:
15059          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
15060          * And searching the rest of the internet wasn't very helpful either.
15061          * It looks like just about any byte can be in these constructs,
15062          * depending on the locale.  But unless the pattern is being compiled
15063          * under /l, which is very rare, Perl runs under the C or POSIX locale.
15064          * In that case, it looks like [= =] isn't allowed at all, and that
15065          * [. .] could be any single code point, but for longer strings the
15066          * constituent characters would have to be the ASCII alphabetics plus
15067          * the minus-hyphen.  Any sensible locale definition would limit itself
15068          * to these.  And any portable one definitely should.  Trying to parse
15069          * the general case is a nightmare (see [perl #127604]).  So, this code
15070          * looks only for interiors of these constructs that match:
15071          *      qr/.|[-\w]{2,}/
15072          * Using \w relaxes the apparent rules a little, without adding much
15073          * danger of mistaking something else for one of these constructs.
15074          *
15075          * [. .] in some implementations described on the internet is usable to
15076          * escape a character that otherwise is special in bracketed character
15077          * classes.  For example [.].] means a literal right bracket instead of
15078          * the ending of the class
15079          *
15080          * [= =] can legitimately contain a [. .] construct, but we don't
15081          * handle this case, as that [. .] construct will later get parsed
15082          * itself and croak then.  And [= =] is checked for even when not under
15083          * /l, as Perl has long done so.
15084          *
15085          * The code below relies on there being a trailing NUL, so it doesn't
15086          * have to keep checking if the parse ptr < e.
15087          */
15088         if (temp_ptr[1] == open_char) {
15089             temp_ptr++;
15090         }
15091         else while (    temp_ptr < e
15092                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
15093         {
15094             temp_ptr++;
15095         }
15096
15097         if (*temp_ptr == open_char) {
15098             temp_ptr++;
15099             if (*temp_ptr == ']') {
15100                 temp_ptr++;
15101                 if (! found_problem && ! check_only) {
15102                     RExC_parse = (char *) temp_ptr;
15103                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
15104                             "extensions", open_char, open_char);
15105                 }
15106
15107                 /* Here, the syntax wasn't completely valid, or else the call
15108                  * is to check-only */
15109                 if (updated_parse_ptr) {
15110                     *updated_parse_ptr = (char *) temp_ptr;
15111                 }
15112
15113                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
15114             }
15115         }
15116
15117         /* If we find something that started out to look like one of these
15118          * constructs, but isn't, we continue below so that it can be checked
15119          * for being a class name with a typo of '.' or '=' instead of a colon.
15120          * */
15121     }
15122
15123     /* Here, we think there is a possibility that a [: :] class was meant, and
15124      * we have the first real character.  It could be they think the '^' comes
15125      * first */
15126     if (*p == '^') {
15127         found_problem = TRUE;
15128         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
15129         complement = 1;
15130         p++;
15131
15132         if (isBLANK(*p)) {
15133             found_problem = TRUE;
15134
15135             do {
15136                 p++;
15137             } while (p < e && isBLANK(*p));
15138
15139             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15140         }
15141     }
15142
15143     /* But the first character should be a colon, which they could have easily
15144      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
15145      * distinguish from a colon, so treat that as a colon).  */
15146     if (*p == ':') {
15147         p++;
15148         has_opening_colon = TRUE;
15149     }
15150     else if (*p == ';') {
15151         found_problem = TRUE;
15152         p++;
15153         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15154         has_opening_colon = TRUE;
15155     }
15156     else {
15157         found_problem = TRUE;
15158         ADD_POSIX_WARNING(p, "there must be a starting ':'");
15159
15160         /* Consider an initial punctuation (not one of the recognized ones) to
15161          * be a left terminator */
15162         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
15163             p++;
15164         }
15165     }
15166
15167     /* They may think that you can put spaces between the components */
15168     if (isBLANK(*p)) {
15169         found_problem = TRUE;
15170
15171         do {
15172             p++;
15173         } while (p < e && isBLANK(*p));
15174
15175         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15176     }
15177
15178     if (*p == '^') {
15179
15180         /* We consider something like [^:^alnum:]] to not have been intended to
15181          * be a posix class, but XXX maybe we should */
15182         if (complement) {
15183             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15184         }
15185
15186         complement = 1;
15187         p++;
15188     }
15189
15190     /* Again, they may think that you can put spaces between the components */
15191     if (isBLANK(*p)) {
15192         found_problem = TRUE;
15193
15194         do {
15195             p++;
15196         } while (p < e && isBLANK(*p));
15197
15198         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15199     }
15200
15201     if (*p == ']') {
15202
15203         /* XXX This ']' may be a typo, and something else was meant.  But
15204          * treating it as such creates enough complications, that that
15205          * possibility isn't currently considered here.  So we assume that the
15206          * ']' is what is intended, and if we've already found an initial '[',
15207          * this leaves this construct looking like [:] or [:^], which almost
15208          * certainly weren't intended to be posix classes */
15209         if (has_opening_bracket) {
15210             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15211         }
15212
15213         /* But this function can be called when we parse the colon for
15214          * something like qr/[alpha:]]/, so we back up to look for the
15215          * beginning */
15216         p--;
15217
15218         if (*p == ';') {
15219             found_problem = TRUE;
15220             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15221         }
15222         else if (*p != ':') {
15223
15224             /* XXX We are currently very restrictive here, so this code doesn't
15225              * consider the possibility that, say, /[alpha.]]/ was intended to
15226              * be a posix class. */
15227             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15228         }
15229
15230         /* Here we have something like 'foo:]'.  There was no initial colon,
15231          * and we back up over 'foo.  XXX Unlike the going forward case, we
15232          * don't handle typos of non-word chars in the middle */
15233         has_opening_colon = FALSE;
15234         p--;
15235
15236         while (p > RExC_start && isWORDCHAR(*p)) {
15237             p--;
15238         }
15239         p++;
15240
15241         /* Here, we have positioned ourselves to where we think the first
15242          * character in the potential class is */
15243     }
15244
15245     /* Now the interior really starts.  There are certain key characters that
15246      * can end the interior, or these could just be typos.  To catch both
15247      * cases, we may have to do two passes.  In the first pass, we keep on
15248      * going unless we come to a sequence that matches
15249      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
15250      * This means it takes a sequence to end the pass, so two typos in a row if
15251      * that wasn't what was intended.  If the class is perfectly formed, just
15252      * this one pass is needed.  We also stop if there are too many characters
15253      * being accumulated, but this number is deliberately set higher than any
15254      * real class.  It is set high enough so that someone who thinks that
15255      * 'alphanumeric' is a correct name would get warned that it wasn't.
15256      * While doing the pass, we keep track of where the key characters were in
15257      * it.  If we don't find an end to the class, and one of the key characters
15258      * was found, we redo the pass, but stop when we get to that character.
15259      * Thus the key character was considered a typo in the first pass, but a
15260      * terminator in the second.  If two key characters are found, we stop at
15261      * the second one in the first pass.  Again this can miss two typos, but
15262      * catches a single one
15263      *
15264      * In the first pass, 'possible_end' starts as NULL, and then gets set to
15265      * point to the first key character.  For the second pass, it starts as -1.
15266      * */
15267
15268     name_start = p;
15269   parse_name:
15270     {
15271         bool has_blank               = FALSE;
15272         bool has_upper               = FALSE;
15273         bool has_terminating_colon   = FALSE;
15274         bool has_terminating_bracket = FALSE;
15275         bool has_semi_colon          = FALSE;
15276         unsigned int name_len        = 0;
15277         int punct_count              = 0;
15278
15279         while (p < e) {
15280
15281             /* Squeeze out blanks when looking up the class name below */
15282             if (isBLANK(*p) ) {
15283                 has_blank = TRUE;
15284                 found_problem = TRUE;
15285                 p++;
15286                 continue;
15287             }
15288
15289             /* The name will end with a punctuation */
15290             if (isPUNCT(*p)) {
15291                 const char * peek = p + 1;
15292
15293                 /* Treat any non-']' punctuation followed by a ']' (possibly
15294                  * with intervening blanks) as trying to terminate the class.
15295                  * ']]' is very likely to mean a class was intended (but
15296                  * missing the colon), but the warning message that gets
15297                  * generated shows the error position better if we exit the
15298                  * loop at the bottom (eventually), so skip it here. */
15299                 if (*p != ']') {
15300                     if (peek < e && isBLANK(*peek)) {
15301                         has_blank = TRUE;
15302                         found_problem = TRUE;
15303                         do {
15304                             peek++;
15305                         } while (peek < e && isBLANK(*peek));
15306                     }
15307
15308                     if (peek < e && *peek == ']') {
15309                         has_terminating_bracket = TRUE;
15310                         if (*p == ':') {
15311                             has_terminating_colon = TRUE;
15312                         }
15313                         else if (*p == ';') {
15314                             has_semi_colon = TRUE;
15315                             has_terminating_colon = TRUE;
15316                         }
15317                         else {
15318                             found_problem = TRUE;
15319                         }
15320                         p = peek + 1;
15321                         goto try_posix;
15322                     }
15323                 }
15324
15325                 /* Here we have punctuation we thought didn't end the class.
15326                  * Keep track of the position of the key characters that are
15327                  * more likely to have been class-enders */
15328                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
15329
15330                     /* Allow just one such possible class-ender not actually
15331                      * ending the class. */
15332                     if (possible_end) {
15333                         break;
15334                     }
15335                     possible_end = p;
15336                 }
15337
15338                 /* If we have too many punctuation characters, no use in
15339                  * keeping going */
15340                 if (++punct_count > max_distance) {
15341                     break;
15342                 }
15343
15344                 /* Treat the punctuation as a typo. */
15345                 input_text[name_len++] = *p;
15346                 p++;
15347             }
15348             else if (isUPPER(*p)) { /* Use lowercase for lookup */
15349                 input_text[name_len++] = toLOWER(*p);
15350                 has_upper = TRUE;
15351                 found_problem = TRUE;
15352                 p++;
15353             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
15354                 input_text[name_len++] = *p;
15355                 p++;
15356             }
15357             else {
15358                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
15359                 p+= UTF8SKIP(p);
15360             }
15361
15362             /* The declaration of 'input_text' is how long we allow a potential
15363              * class name to be, before saying they didn't mean a class name at
15364              * all */
15365             if (name_len >= C_ARRAY_LENGTH(input_text)) {
15366                 break;
15367             }
15368         }
15369
15370         /* We get to here when the possible class name hasn't been properly
15371          * terminated before:
15372          *   1) we ran off the end of the pattern; or
15373          *   2) found two characters, each of which might have been intended to
15374          *      be the name's terminator
15375          *   3) found so many punctuation characters in the purported name,
15376          *      that the edit distance to a valid one is exceeded
15377          *   4) we decided it was more characters than anyone could have
15378          *      intended to be one. */
15379
15380         found_problem = TRUE;
15381
15382         /* In the final two cases, we know that looking up what we've
15383          * accumulated won't lead to a match, even a fuzzy one. */
15384         if (   name_len >= C_ARRAY_LENGTH(input_text)
15385             || punct_count > max_distance)
15386         {
15387             /* If there was an intermediate key character that could have been
15388              * an intended end, redo the parse, but stop there */
15389             if (possible_end && possible_end != (char *) -1) {
15390                 possible_end = (char *) -1; /* Special signal value to say
15391                                                we've done a first pass */
15392                 p = name_start;
15393                 goto parse_name;
15394             }
15395
15396             /* Otherwise, it can't have meant to have been a class */
15397             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15398         }
15399
15400         /* If we ran off the end, and the final character was a punctuation
15401          * one, back up one, to look at that final one just below.  Later, we
15402          * will restore the parse pointer if appropriate */
15403         if (name_len && p == e && isPUNCT(*(p-1))) {
15404             p--;
15405             name_len--;
15406         }
15407
15408         if (p < e && isPUNCT(*p)) {
15409             if (*p == ']') {
15410                 has_terminating_bracket = TRUE;
15411
15412                 /* If this is a 2nd ']', and the first one is just below this
15413                  * one, consider that to be the real terminator.  This gives a
15414                  * uniform and better positioning for the warning message  */
15415                 if (   possible_end
15416                     && possible_end != (char *) -1
15417                     && *possible_end == ']'
15418                     && name_len && input_text[name_len - 1] == ']')
15419                 {
15420                     name_len--;
15421                     p = possible_end;
15422
15423                     /* And this is actually equivalent to having done the 2nd
15424                      * pass now, so set it to not try again */
15425                     possible_end = (char *) -1;
15426                 }
15427             }
15428             else {
15429                 if (*p == ':') {
15430                     has_terminating_colon = TRUE;
15431                 }
15432                 else if (*p == ';') {
15433                     has_semi_colon = TRUE;
15434                     has_terminating_colon = TRUE;
15435                 }
15436                 p++;
15437             }
15438         }
15439
15440     try_posix:
15441
15442         /* Here, we have a class name to look up.  We can short circuit the
15443          * stuff below for short names that can't possibly be meant to be a
15444          * class name.  (We can do this on the first pass, as any second pass
15445          * will yield an even shorter name) */
15446         if (name_len < 3) {
15447             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15448         }
15449
15450         /* Find which class it is.  Initially switch on the length of the name.
15451          * */
15452         switch (name_len) {
15453             case 4:
15454                 if (memEQs(name_start, 4, "word")) {
15455                     /* this is not POSIX, this is the Perl \w */
15456                     class_number = ANYOF_WORDCHAR;
15457                 }
15458                 break;
15459             case 5:
15460                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
15461                  *                        graph lower print punct space upper
15462                  * Offset 4 gives the best switch position.  */
15463                 switch (name_start[4]) {
15464                     case 'a':
15465                         if (memBEGINs(name_start, 5, "alph")) /* alpha */
15466                             class_number = ANYOF_ALPHA;
15467                         break;
15468                     case 'e':
15469                         if (memBEGINs(name_start, 5, "spac")) /* space */
15470                             class_number = ANYOF_SPACE;
15471                         break;
15472                     case 'h':
15473                         if (memBEGINs(name_start, 5, "grap")) /* graph */
15474                             class_number = ANYOF_GRAPH;
15475                         break;
15476                     case 'i':
15477                         if (memBEGINs(name_start, 5, "asci")) /* ascii */
15478                             class_number = ANYOF_ASCII;
15479                         break;
15480                     case 'k':
15481                         if (memBEGINs(name_start, 5, "blan")) /* blank */
15482                             class_number = ANYOF_BLANK;
15483                         break;
15484                     case 'l':
15485                         if (memBEGINs(name_start, 5, "cntr")) /* cntrl */
15486                             class_number = ANYOF_CNTRL;
15487                         break;
15488                     case 'm':
15489                         if (memBEGINs(name_start, 5, "alnu")) /* alnum */
15490                             class_number = ANYOF_ALPHANUMERIC;
15491                         break;
15492                     case 'r':
15493                         if (memBEGINs(name_start, 5, "lowe")) /* lower */
15494                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
15495                         else if (memBEGINs(name_start, 5, "uppe")) /* upper */
15496                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
15497                         break;
15498                     case 't':
15499                         if (memBEGINs(name_start, 5, "digi")) /* digit */
15500                             class_number = ANYOF_DIGIT;
15501                         else if (memBEGINs(name_start, 5, "prin")) /* print */
15502                             class_number = ANYOF_PRINT;
15503                         else if (memBEGINs(name_start, 5, "punc")) /* punct */
15504                             class_number = ANYOF_PUNCT;
15505                         break;
15506                 }
15507                 break;
15508             case 6:
15509                 if (memEQs(name_start, 6, "xdigit"))
15510                     class_number = ANYOF_XDIGIT;
15511                 break;
15512         }
15513
15514         /* If the name exactly matches a posix class name the class number will
15515          * here be set to it, and the input almost certainly was meant to be a
15516          * posix class, so we can skip further checking.  If instead the syntax
15517          * is exactly correct, but the name isn't one of the legal ones, we
15518          * will return that as an error below.  But if neither of these apply,
15519          * it could be that no posix class was intended at all, or that one
15520          * was, but there was a typo.  We tease these apart by doing fuzzy
15521          * matching on the name */
15522         if (class_number == OOB_NAMEDCLASS && found_problem) {
15523             const UV posix_names[][6] = {
15524                                                 { 'a', 'l', 'n', 'u', 'm' },
15525                                                 { 'a', 'l', 'p', 'h', 'a' },
15526                                                 { 'a', 's', 'c', 'i', 'i' },
15527                                                 { 'b', 'l', 'a', 'n', 'k' },
15528                                                 { 'c', 'n', 't', 'r', 'l' },
15529                                                 { 'd', 'i', 'g', 'i', 't' },
15530                                                 { 'g', 'r', 'a', 'p', 'h' },
15531                                                 { 'l', 'o', 'w', 'e', 'r' },
15532                                                 { 'p', 'r', 'i', 'n', 't' },
15533                                                 { 'p', 'u', 'n', 'c', 't' },
15534                                                 { 's', 'p', 'a', 'c', 'e' },
15535                                                 { 'u', 'p', 'p', 'e', 'r' },
15536                                                 { 'w', 'o', 'r', 'd' },
15537                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
15538                                             };
15539             /* The names of the above all have added NULs to make them the same
15540              * size, so we need to also have the real lengths */
15541             const UV posix_name_lengths[] = {
15542                                                 sizeof("alnum") - 1,
15543                                                 sizeof("alpha") - 1,
15544                                                 sizeof("ascii") - 1,
15545                                                 sizeof("blank") - 1,
15546                                                 sizeof("cntrl") - 1,
15547                                                 sizeof("digit") - 1,
15548                                                 sizeof("graph") - 1,
15549                                                 sizeof("lower") - 1,
15550                                                 sizeof("print") - 1,
15551                                                 sizeof("punct") - 1,
15552                                                 sizeof("space") - 1,
15553                                                 sizeof("upper") - 1,
15554                                                 sizeof("word")  - 1,
15555                                                 sizeof("xdigit")- 1
15556                                             };
15557             unsigned int i;
15558             int temp_max = max_distance;    /* Use a temporary, so if we
15559                                                reparse, we haven't changed the
15560                                                outer one */
15561
15562             /* Use a smaller max edit distance if we are missing one of the
15563              * delimiters */
15564             if (   has_opening_bracket + has_opening_colon < 2
15565                 || has_terminating_bracket + has_terminating_colon < 2)
15566             {
15567                 temp_max--;
15568             }
15569
15570             /* See if the input name is close to a legal one */
15571             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
15572
15573                 /* Short circuit call if the lengths are too far apart to be
15574                  * able to match */
15575                 if (abs( (int) (name_len - posix_name_lengths[i]))
15576                     > temp_max)
15577                 {
15578                     continue;
15579                 }
15580
15581                 if (edit_distance(input_text,
15582                                   posix_names[i],
15583                                   name_len,
15584                                   posix_name_lengths[i],
15585                                   temp_max
15586                                  )
15587                     > -1)
15588                 { /* If it is close, it probably was intended to be a class */
15589                     goto probably_meant_to_be;
15590                 }
15591             }
15592
15593             /* Here the input name is not close enough to a valid class name
15594              * for us to consider it to be intended to be a posix class.  If
15595              * we haven't already done so, and the parse found a character that
15596              * could have been terminators for the name, but which we absorbed
15597              * as typos during the first pass, repeat the parse, signalling it
15598              * to stop at that character */
15599             if (possible_end && possible_end != (char *) -1) {
15600                 possible_end = (char *) -1;
15601                 p = name_start;
15602                 goto parse_name;
15603             }
15604
15605             /* Here neither pass found a close-enough class name */
15606             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15607         }
15608
15609     probably_meant_to_be:
15610
15611         /* Here we think that a posix specification was intended.  Update any
15612          * parse pointer */
15613         if (updated_parse_ptr) {
15614             *updated_parse_ptr = (char *) p;
15615         }
15616
15617         /* If a posix class name was intended but incorrectly specified, we
15618          * output or return the warnings */
15619         if (found_problem) {
15620
15621             /* We set flags for these issues in the parse loop above instead of
15622              * adding them to the list of warnings, because we can parse it
15623              * twice, and we only want one warning instance */
15624             if (has_upper) {
15625                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
15626             }
15627             if (has_blank) {
15628                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15629             }
15630             if (has_semi_colon) {
15631                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15632             }
15633             else if (! has_terminating_colon) {
15634                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
15635             }
15636             if (! has_terminating_bracket) {
15637                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
15638             }
15639
15640             if (   posix_warnings
15641                 && RExC_warn_text
15642                 && av_top_index(RExC_warn_text) > -1)
15643             {
15644                 *posix_warnings = RExC_warn_text;
15645             }
15646         }
15647         else if (class_number != OOB_NAMEDCLASS) {
15648             /* If it is a known class, return the class.  The class number
15649              * #defines are structured so each complement is +1 to the normal
15650              * one */
15651             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
15652         }
15653         else if (! check_only) {
15654
15655             /* Here, it is an unrecognized class.  This is an error (unless the
15656             * call is to check only, which we've already handled above) */
15657             const char * const complement_string = (complement)
15658                                                    ? "^"
15659                                                    : "";
15660             RExC_parse = (char *) p;
15661             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
15662                         complement_string,
15663                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
15664         }
15665     }
15666
15667     return OOB_NAMEDCLASS;
15668 }
15669 #undef ADD_POSIX_WARNING
15670
15671 STATIC unsigned  int
15672 S_regex_set_precedence(const U8 my_operator) {
15673
15674     /* Returns the precedence in the (?[...]) construct of the input operator,
15675      * specified by its character representation.  The precedence follows
15676      * general Perl rules, but it extends this so that ')' and ']' have (low)
15677      * precedence even though they aren't really operators */
15678
15679     switch (my_operator) {
15680         case '!':
15681             return 5;
15682         case '&':
15683             return 4;
15684         case '^':
15685         case '|':
15686         case '+':
15687         case '-':
15688             return 3;
15689         case ')':
15690             return 2;
15691         case ']':
15692             return 1;
15693     }
15694
15695     NOT_REACHED; /* NOTREACHED */
15696     return 0;   /* Silence compiler warning */
15697 }
15698
15699 STATIC regnode_offset
15700 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
15701                     I32 *flagp, U32 depth,
15702                     char * const oregcomp_parse)
15703 {
15704     /* Handle the (?[...]) construct to do set operations */
15705
15706     U8 curchar;                     /* Current character being parsed */
15707     UV start, end;                  /* End points of code point ranges */
15708     SV* final = NULL;               /* The end result inversion list */
15709     SV* result_string;              /* 'final' stringified */
15710     AV* stack;                      /* stack of operators and operands not yet
15711                                        resolved */
15712     AV* fence_stack = NULL;         /* A stack containing the positions in
15713                                        'stack' of where the undealt-with left
15714                                        parens would be if they were actually
15715                                        put there */
15716     /* The 'volatile' is a workaround for an optimiser bug
15717      * in Solaris Studio 12.3. See RT #127455 */
15718     volatile IV fence = 0;          /* Position of where most recent undealt-
15719                                        with left paren in stack is; -1 if none.
15720                                      */
15721     STRLEN len;                     /* Temporary */
15722     regnode_offset node;                  /* Temporary, and final regnode returned by
15723                                        this function */
15724     const bool save_fold = FOLD;    /* Temporary */
15725     char *save_end, *save_parse;    /* Temporaries */
15726     const bool in_locale = LOC;     /* we turn off /l during processing */
15727
15728     GET_RE_DEBUG_FLAGS_DECL;
15729
15730     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
15731
15732     DEBUG_PARSE("xcls");
15733
15734     if (in_locale) {
15735         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
15736     }
15737
15738     /* The use of this operator implies /u.  This is required so that the
15739      * compile time values are valid in all runtime cases */
15740     REQUIRE_UNI_RULES(flagp, 0);
15741
15742     ckWARNexperimental(RExC_parse,
15743                        WARN_EXPERIMENTAL__REGEX_SETS,
15744                        "The regex_sets feature is experimental");
15745
15746     /* Everything in this construct is a metacharacter.  Operands begin with
15747      * either a '\' (for an escape sequence), or a '[' for a bracketed
15748      * character class.  Any other character should be an operator, or
15749      * parenthesis for grouping.  Both types of operands are handled by calling
15750      * regclass() to parse them.  It is called with a parameter to indicate to
15751      * return the computed inversion list.  The parsing here is implemented via
15752      * a stack.  Each entry on the stack is a single character representing one
15753      * of the operators; or else a pointer to an operand inversion list. */
15754
15755 #define IS_OPERATOR(a) SvIOK(a)
15756 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
15757
15758     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
15759      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
15760      * with pronouncing it called it Reverse Polish instead, but now that YOU
15761      * know how to pronounce it you can use the correct term, thus giving due
15762      * credit to the person who invented it, and impressing your geek friends.
15763      * Wikipedia says that the pronounciation of "Ł" has been changing so that
15764      * it is now more like an English initial W (as in wonk) than an L.)
15765      *
15766      * This means that, for example, 'a | b & c' is stored on the stack as
15767      *
15768      * c  [4]
15769      * b  [3]
15770      * &  [2]
15771      * a  [1]
15772      * |  [0]
15773      *
15774      * where the numbers in brackets give the stack [array] element number.
15775      * In this implementation, parentheses are not stored on the stack.
15776      * Instead a '(' creates a "fence" so that the part of the stack below the
15777      * fence is invisible except to the corresponding ')' (this allows us to
15778      * replace testing for parens, by using instead subtraction of the fence
15779      * position).  As new operands are processed they are pushed onto the stack
15780      * (except as noted in the next paragraph).  New operators of higher
15781      * precedence than the current final one are inserted on the stack before
15782      * the lhs operand (so that when the rhs is pushed next, everything will be
15783      * in the correct positions shown above.  When an operator of equal or
15784      * lower precedence is encountered in parsing, all the stacked operations
15785      * of equal or higher precedence are evaluated, leaving the result as the
15786      * top entry on the stack.  This makes higher precedence operations
15787      * evaluate before lower precedence ones, and causes operations of equal
15788      * precedence to left associate.
15789      *
15790      * The only unary operator '!' is immediately pushed onto the stack when
15791      * encountered.  When an operand is encountered, if the top of the stack is
15792      * a '!", the complement is immediately performed, and the '!' popped.  The
15793      * resulting value is treated as a new operand, and the logic in the
15794      * previous paragraph is executed.  Thus in the expression
15795      *      [a] + ! [b]
15796      * the stack looks like
15797      *
15798      * !
15799      * a
15800      * +
15801      *
15802      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
15803      * becomes
15804      *
15805      * !b
15806      * a
15807      * +
15808      *
15809      * A ')' is treated as an operator with lower precedence than all the
15810      * aforementioned ones, which causes all operations on the stack above the
15811      * corresponding '(' to be evaluated down to a single resultant operand.
15812      * Then the fence for the '(' is removed, and the operand goes through the
15813      * algorithm above, without the fence.
15814      *
15815      * A separate stack is kept of the fence positions, so that the position of
15816      * the latest so-far unbalanced '(' is at the top of it.
15817      *
15818      * The ']' ending the construct is treated as the lowest operator of all,
15819      * so that everything gets evaluated down to a single operand, which is the
15820      * result */
15821
15822     sv_2mortal((SV *)(stack = newAV()));
15823     sv_2mortal((SV *)(fence_stack = newAV()));
15824
15825     while (RExC_parse < RExC_end) {
15826         I32 top_index;              /* Index of top-most element in 'stack' */
15827         SV** top_ptr;               /* Pointer to top 'stack' element */
15828         SV* current = NULL;         /* To contain the current inversion list
15829                                        operand */
15830         SV* only_to_avoid_leaks;
15831
15832         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15833                                 TRUE /* Force /x */ );
15834         if (RExC_parse >= RExC_end) {   /* Fail */
15835             break;
15836         }
15837
15838         curchar = UCHARAT(RExC_parse);
15839
15840 redo_curchar:
15841
15842 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15843                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
15844         DEBUG_U(dump_regex_sets_structures(pRExC_state,
15845                                            stack, fence, fence_stack));
15846 #endif
15847
15848         top_index = av_tindex_skip_len_mg(stack);
15849
15850         switch (curchar) {
15851             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
15852             char stacked_operator;  /* The topmost operator on the 'stack'. */
15853             SV* lhs;                /* Operand to the left of the operator */
15854             SV* rhs;                /* Operand to the right of the operator */
15855             SV* fence_ptr;          /* Pointer to top element of the fence
15856                                        stack */
15857
15858             case '(':
15859
15860                 if (   RExC_parse < RExC_end - 2
15861                     && UCHARAT(RExC_parse + 1) == '?'
15862                     && UCHARAT(RExC_parse + 2) == '^')
15863                 {
15864                     /* If is a '(?', could be an embedded '(?^flags:(?[...])'.
15865                      * This happens when we have some thing like
15866                      *
15867                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15868                      *   ...
15869                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15870                      *
15871                      * Here we would be handling the interpolated
15872                      * '$thai_or_lao'.  We handle this by a recursive call to
15873                      * ourselves which returns the inversion list the
15874                      * interpolated expression evaluates to.  We use the flags
15875                      * from the interpolated pattern. */
15876                     U32 save_flags = RExC_flags;
15877                     const char * save_parse;
15878
15879                     RExC_parse += 2;        /* Skip past the '(?' */
15880                     save_parse = RExC_parse;
15881
15882                     /* Parse the flags for the '(?'.  We already know the first
15883                      * flag to parse is a '^' */
15884                     parse_lparen_question_flags(pRExC_state);
15885
15886                     if (   RExC_parse >= RExC_end - 4
15887                         || UCHARAT(RExC_parse) != ':'
15888                         || UCHARAT(++RExC_parse) != '('
15889                         || UCHARAT(++RExC_parse) != '?'
15890                         || UCHARAT(++RExC_parse) != '[')
15891                     {
15892
15893                         /* In combination with the above, this moves the
15894                          * pointer to the point just after the first erroneous
15895                          * character. */
15896                         if (RExC_parse >= RExC_end - 4) {
15897                             RExC_parse = RExC_end;
15898                         }
15899                         else if (RExC_parse != save_parse) {
15900                             RExC_parse += (UTF)
15901                                           ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
15902                                           : 1;
15903                         }
15904                         vFAIL("Expecting '(?flags:(?[...'");
15905                     }
15906
15907                     /* Recurse, with the meat of the embedded expression */
15908                     RExC_parse++;
15909                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15910                                                     depth+1, oregcomp_parse);
15911
15912                     /* Here, 'current' contains the embedded expression's
15913                      * inversion list, and RExC_parse points to the trailing
15914                      * ']'; the next character should be the ')' */
15915                     RExC_parse++;
15916                     if (UCHARAT(RExC_parse) != ')')
15917                         vFAIL("Expecting close paren for nested extended charclass");
15918
15919                     /* Then the ')' matching the original '(' handled by this
15920                      * case: statement */
15921                     RExC_parse++;
15922                     if (UCHARAT(RExC_parse) != ')')
15923                         vFAIL("Expecting close paren for wrapper for nested extended charclass");
15924
15925                     RExC_flags = save_flags;
15926                     goto handle_operand;
15927                 }
15928
15929                 /* A regular '('.  Look behind for illegal syntax */
15930                 if (top_index - fence >= 0) {
15931                     /* If the top entry on the stack is an operator, it had
15932                      * better be a '!', otherwise the entry below the top
15933                      * operand should be an operator */
15934                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15935                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15936                         || (   IS_OPERAND(*top_ptr)
15937                             && (   top_index - fence < 1
15938                                 || ! (stacked_ptr = av_fetch(stack,
15939                                                              top_index - 1,
15940                                                              FALSE))
15941                                 || ! IS_OPERATOR(*stacked_ptr))))
15942                     {
15943                         RExC_parse++;
15944                         vFAIL("Unexpected '(' with no preceding operator");
15945                     }
15946                 }
15947
15948                 /* Stack the position of this undealt-with left paren */
15949                 av_push(fence_stack, newSViv(fence));
15950                 fence = top_index + 1;
15951                 break;
15952
15953             case '\\':
15954                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
15955                  * multi-char folds are allowed.  */
15956                 if (!regclass(pRExC_state, flagp, depth+1,
15957                               TRUE, /* means parse just the next thing */
15958                               FALSE, /* don't allow multi-char folds */
15959                               FALSE, /* don't silence non-portable warnings.  */
15960                               TRUE,  /* strict */
15961                               FALSE, /* Require return to be an ANYOF */
15962                               &current))
15963                 {
15964                     goto regclass_failed;
15965                 }
15966
15967                 /* regclass() will return with parsing just the \ sequence,
15968                  * leaving the parse pointer at the next thing to parse */
15969                 RExC_parse--;
15970                 goto handle_operand;
15971
15972             case '[':   /* Is a bracketed character class */
15973             {
15974                 /* See if this is a [:posix:] class. */
15975                 bool is_posix_class = (OOB_NAMEDCLASS
15976                             < handle_possible_posix(pRExC_state,
15977                                                 RExC_parse + 1,
15978                                                 NULL,
15979                                                 NULL,
15980                                                 TRUE /* checking only */));
15981                 /* If it is a posix class, leave the parse pointer at the '['
15982                  * to fool regclass() into thinking it is part of a
15983                  * '[[:posix:]]'. */
15984                 if (! is_posix_class) {
15985                     RExC_parse++;
15986                 }
15987
15988                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
15989                  * multi-char folds are allowed.  */
15990                 if (!regclass(pRExC_state, flagp, depth+1,
15991                                 is_posix_class, /* parse the whole char
15992                                                     class only if not a
15993                                                     posix class */
15994                                 FALSE, /* don't allow multi-char folds */
15995                                 TRUE, /* silence non-portable warnings. */
15996                                 TRUE, /* strict */
15997                                 FALSE, /* Require return to be an ANYOF */
15998                                 &current))
15999                 {
16000                     goto regclass_failed;
16001                 }
16002
16003                 if (! current) {
16004                     break;
16005                 }
16006
16007                 /* function call leaves parse pointing to the ']', except if we
16008                  * faked it */
16009                 if (is_posix_class) {
16010                     RExC_parse--;
16011                 }
16012
16013                 goto handle_operand;
16014             }
16015
16016             case ']':
16017                 if (top_index >= 1) {
16018                     goto join_operators;
16019                 }
16020
16021                 /* Only a single operand on the stack: are done */
16022                 goto done;
16023
16024             case ')':
16025                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
16026                     if (UCHARAT(RExC_parse - 1) == ']')  {
16027                         break;
16028                     }
16029                     RExC_parse++;
16030                     vFAIL("Unexpected ')'");
16031                 }
16032
16033                 /* If nothing after the fence, is missing an operand */
16034                 if (top_index - fence < 0) {
16035                     RExC_parse++;
16036                     goto bad_syntax;
16037                 }
16038                 /* If at least two things on the stack, treat this as an
16039                   * operator */
16040                 if (top_index - fence >= 1) {
16041                     goto join_operators;
16042                 }
16043
16044                 /* Here only a single thing on the fenced stack, and there is a
16045                  * fence.  Get rid of it */
16046                 fence_ptr = av_pop(fence_stack);
16047                 assert(fence_ptr);
16048                 fence = SvIV(fence_ptr);
16049                 SvREFCNT_dec_NN(fence_ptr);
16050                 fence_ptr = NULL;
16051
16052                 if (fence < 0) {
16053                     fence = 0;
16054                 }
16055
16056                 /* Having gotten rid of the fence, we pop the operand at the
16057                  * stack top and process it as a newly encountered operand */
16058                 current = av_pop(stack);
16059                 if (IS_OPERAND(current)) {
16060                     goto handle_operand;
16061                 }
16062
16063                 RExC_parse++;
16064                 goto bad_syntax;
16065
16066             case '&':
16067             case '|':
16068             case '+':
16069             case '-':
16070             case '^':
16071
16072                 /* These binary operators should have a left operand already
16073                  * parsed */
16074                 if (   top_index - fence < 0
16075                     || top_index - fence == 1
16076                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
16077                     || ! IS_OPERAND(*top_ptr))
16078                 {
16079                     goto unexpected_binary;
16080                 }
16081
16082                 /* If only the one operand is on the part of the stack visible
16083                  * to us, we just place this operator in the proper position */
16084                 if (top_index - fence < 2) {
16085
16086                     /* Place the operator before the operand */
16087
16088                     SV* lhs = av_pop(stack);
16089                     av_push(stack, newSVuv(curchar));
16090                     av_push(stack, lhs);
16091                     break;
16092                 }
16093
16094                 /* But if there is something else on the stack, we need to
16095                  * process it before this new operator if and only if the
16096                  * stacked operation has equal or higher precedence than the
16097                  * new one */
16098
16099              join_operators:
16100
16101                 /* The operator on the stack is supposed to be below both its
16102                  * operands */
16103                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
16104                     || IS_OPERAND(*stacked_ptr))
16105                 {
16106                     /* But if not, it's legal and indicates we are completely
16107                      * done if and only if we're currently processing a ']',
16108                      * which should be the final thing in the expression */
16109                     if (curchar == ']') {
16110                         goto done;
16111                     }
16112
16113                   unexpected_binary:
16114                     RExC_parse++;
16115                     vFAIL2("Unexpected binary operator '%c' with no "
16116                            "preceding operand", curchar);
16117                 }
16118                 stacked_operator = (char) SvUV(*stacked_ptr);
16119
16120                 if (regex_set_precedence(curchar)
16121                     > regex_set_precedence(stacked_operator))
16122                 {
16123                     /* Here, the new operator has higher precedence than the
16124                      * stacked one.  This means we need to add the new one to
16125                      * the stack to await its rhs operand (and maybe more
16126                      * stuff).  We put it before the lhs operand, leaving
16127                      * untouched the stacked operator and everything below it
16128                      * */
16129                     lhs = av_pop(stack);
16130                     assert(IS_OPERAND(lhs));
16131
16132                     av_push(stack, newSVuv(curchar));
16133                     av_push(stack, lhs);
16134                     break;
16135                 }
16136
16137                 /* Here, the new operator has equal or lower precedence than
16138                  * what's already there.  This means the operation already
16139                  * there should be performed now, before the new one. */
16140
16141                 rhs = av_pop(stack);
16142                 if (! IS_OPERAND(rhs)) {
16143
16144                     /* This can happen when a ! is not followed by an operand,
16145                      * like in /(?[\t &!])/ */
16146                     goto bad_syntax;
16147                 }
16148
16149                 lhs = av_pop(stack);
16150
16151                 if (! IS_OPERAND(lhs)) {
16152
16153                     /* This can happen when there is an empty (), like in
16154                      * /(?[[0]+()+])/ */
16155                     goto bad_syntax;
16156                 }
16157
16158                 switch (stacked_operator) {
16159                     case '&':
16160                         _invlist_intersection(lhs, rhs, &rhs);
16161                         break;
16162
16163                     case '|':
16164                     case '+':
16165                         _invlist_union(lhs, rhs, &rhs);
16166                         break;
16167
16168                     case '-':
16169                         _invlist_subtract(lhs, rhs, &rhs);
16170                         break;
16171
16172                     case '^':   /* The union minus the intersection */
16173                     {
16174                         SV* i = NULL;
16175                         SV* u = NULL;
16176
16177                         _invlist_union(lhs, rhs, &u);
16178                         _invlist_intersection(lhs, rhs, &i);
16179                         _invlist_subtract(u, i, &rhs);
16180                         SvREFCNT_dec_NN(i);
16181                         SvREFCNT_dec_NN(u);
16182                         break;
16183                     }
16184                 }
16185                 SvREFCNT_dec(lhs);
16186
16187                 /* Here, the higher precedence operation has been done, and the
16188                  * result is in 'rhs'.  We overwrite the stacked operator with
16189                  * the result.  Then we redo this code to either push the new
16190                  * operator onto the stack or perform any higher precedence
16191                  * stacked operation */
16192                 only_to_avoid_leaks = av_pop(stack);
16193                 SvREFCNT_dec(only_to_avoid_leaks);
16194                 av_push(stack, rhs);
16195                 goto redo_curchar;
16196
16197             case '!':   /* Highest priority, right associative */
16198
16199                 /* If what's already at the top of the stack is another '!",
16200                  * they just cancel each other out */
16201                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
16202                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
16203                 {
16204                     only_to_avoid_leaks = av_pop(stack);
16205                     SvREFCNT_dec(only_to_avoid_leaks);
16206                 }
16207                 else { /* Otherwise, since it's right associative, just push
16208                           onto the stack */
16209                     av_push(stack, newSVuv(curchar));
16210                 }
16211                 break;
16212
16213             default:
16214                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16215                 if (RExC_parse >= RExC_end) {
16216                     break;
16217                 }
16218                 vFAIL("Unexpected character");
16219
16220           handle_operand:
16221
16222             /* Here 'current' is the operand.  If something is already on the
16223              * stack, we have to check if it is a !.  But first, the code above
16224              * may have altered the stack in the time since we earlier set
16225              * 'top_index'.  */
16226
16227             top_index = av_tindex_skip_len_mg(stack);
16228             if (top_index - fence >= 0) {
16229                 /* If the top entry on the stack is an operator, it had better
16230                  * be a '!', otherwise the entry below the top operand should
16231                  * be an operator */
16232                 top_ptr = av_fetch(stack, top_index, FALSE);
16233                 assert(top_ptr);
16234                 if (IS_OPERATOR(*top_ptr)) {
16235
16236                     /* The only permissible operator at the top of the stack is
16237                      * '!', which is applied immediately to this operand. */
16238                     curchar = (char) SvUV(*top_ptr);
16239                     if (curchar != '!') {
16240                         SvREFCNT_dec(current);
16241                         vFAIL2("Unexpected binary operator '%c' with no "
16242                                 "preceding operand", curchar);
16243                     }
16244
16245                     _invlist_invert(current);
16246
16247                     only_to_avoid_leaks = av_pop(stack);
16248                     SvREFCNT_dec(only_to_avoid_leaks);
16249
16250                     /* And we redo with the inverted operand.  This allows
16251                      * handling multiple ! in a row */
16252                     goto handle_operand;
16253                 }
16254                           /* Single operand is ok only for the non-binary ')'
16255                            * operator */
16256                 else if ((top_index - fence == 0 && curchar != ')')
16257                          || (top_index - fence > 0
16258                              && (! (stacked_ptr = av_fetch(stack,
16259                                                            top_index - 1,
16260                                                            FALSE))
16261                                  || IS_OPERAND(*stacked_ptr))))
16262                 {
16263                     SvREFCNT_dec(current);
16264                     vFAIL("Operand with no preceding operator");
16265                 }
16266             }
16267
16268             /* Here there was nothing on the stack or the top element was
16269              * another operand.  Just add this new one */
16270             av_push(stack, current);
16271
16272         } /* End of switch on next parse token */
16273
16274         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16275     } /* End of loop parsing through the construct */
16276
16277     vFAIL("Syntax error in (?[...])");
16278
16279   done:
16280
16281     if (RExC_parse >= RExC_end || RExC_parse[1] != ')') {
16282         if (RExC_parse < RExC_end) {
16283             RExC_parse++;
16284         }
16285
16286         vFAIL("Unexpected ']' with no following ')' in (?[...");
16287     }
16288
16289     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
16290         vFAIL("Unmatched (");
16291     }
16292
16293     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
16294         || ((final = av_pop(stack)) == NULL)
16295         || ! IS_OPERAND(final)
16296         || ! is_invlist(final)
16297         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
16298     {
16299       bad_syntax:
16300         SvREFCNT_dec(final);
16301         vFAIL("Incomplete expression within '(?[ ])'");
16302     }
16303
16304     /* Here, 'final' is the resultant inversion list from evaluating the
16305      * expression.  Return it if so requested */
16306     if (return_invlist) {
16307         *return_invlist = final;
16308         return END;
16309     }
16310
16311     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
16312      * expecting a string of ranges and individual code points */
16313     invlist_iterinit(final);
16314     result_string = newSVpvs("");
16315     while (invlist_iternext(final, &start, &end)) {
16316         if (start == end) {
16317             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
16318         }
16319         else {
16320             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
16321                                                      start,          end);
16322         }
16323     }
16324
16325     /* About to generate an ANYOF (or similar) node from the inversion list we
16326      * have calculated */
16327     save_parse = RExC_parse;
16328     RExC_parse = SvPV(result_string, len);
16329     save_end = RExC_end;
16330     RExC_end = RExC_parse + len;
16331     TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
16332
16333     /* We turn off folding around the call, as the class we have constructed
16334      * already has all folding taken into consideration, and we don't want
16335      * regclass() to add to that */
16336     RExC_flags &= ~RXf_PMf_FOLD;
16337     /* regclass() can only return RESTART_PARSE and NEED_UTF8 if multi-char
16338      * folds are allowed.  */
16339     node = regclass(pRExC_state, flagp, depth+1,
16340                     FALSE, /* means parse the whole char class */
16341                     FALSE, /* don't allow multi-char folds */
16342                     TRUE, /* silence non-portable warnings.  The above may very
16343                              well have generated non-portable code points, but
16344                              they're valid on this machine */
16345                     FALSE, /* similarly, no need for strict */
16346                     FALSE, /* Require return to be an ANYOF */
16347                     NULL
16348                 );
16349
16350     RESTORE_WARNINGS;
16351     RExC_parse = save_parse + 1;
16352     RExC_end = save_end;
16353     SvREFCNT_dec_NN(final);
16354     SvREFCNT_dec_NN(result_string);
16355
16356     if (save_fold) {
16357         RExC_flags |= RXf_PMf_FOLD;
16358     }
16359
16360     if (!node)
16361         goto regclass_failed;
16362
16363     /* Fix up the node type if we are in locale.  (We have pretended we are
16364      * under /u for the purposes of regclass(), as this construct will only
16365      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
16366      * as to cause any warnings about bad locales to be output in regexec.c),
16367      * and add the flag that indicates to check if not in a UTF-8 locale.  The
16368      * reason we above forbid optimization into something other than an ANYOF
16369      * node is simply to minimize the number of code changes in regexec.c.
16370      * Otherwise we would have to create new EXACTish node types and deal with
16371      * them.  This decision could be revisited should this construct become
16372      * popular.
16373      *
16374      * (One might think we could look at the resulting ANYOF node and suppress
16375      * the flag if everything is above 255, as those would be UTF-8 only,
16376      * but this isn't true, as the components that led to that result could
16377      * have been locale-affected, and just happen to cancel each other out
16378      * under UTF-8 locales.) */
16379     if (in_locale) {
16380         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
16381
16382         assert(OP(REGNODE_p(node)) == ANYOF);
16383
16384         OP(REGNODE_p(node)) = ANYOFL;
16385         ANYOF_FLAGS(REGNODE_p(node))
16386                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
16387     }
16388
16389     nextchar(pRExC_state);
16390     Set_Node_Length(REGNODE_p(node), RExC_parse - oregcomp_parse + 1); /* MJD */
16391     return node;
16392
16393   regclass_failed:
16394     FAIL2("panic: regclass returned failure to handle_sets, " "flags=%#" UVxf,
16395                                                                 (UV) *flagp);
16396 }
16397
16398 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16399
16400 STATIC void
16401 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
16402                              AV * stack, const IV fence, AV * fence_stack)
16403 {   /* Dumps the stacks in handle_regex_sets() */
16404
16405     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
16406     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
16407     SSize_t i;
16408
16409     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
16410
16411     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
16412
16413     if (stack_top < 0) {
16414         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
16415     }
16416     else {
16417         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
16418         for (i = stack_top; i >= 0; i--) {
16419             SV ** element_ptr = av_fetch(stack, i, FALSE);
16420             if (! element_ptr) {
16421             }
16422
16423             if (IS_OPERATOR(*element_ptr)) {
16424                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
16425                                             (int) i, (int) SvIV(*element_ptr));
16426             }
16427             else {
16428                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
16429                 sv_dump(*element_ptr);
16430             }
16431         }
16432     }
16433
16434     if (fence_stack_top < 0) {
16435         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
16436     }
16437     else {
16438         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
16439         for (i = fence_stack_top; i >= 0; i--) {
16440             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
16441             if (! element_ptr) {
16442             }
16443
16444             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
16445                                             (int) i, (int) SvIV(*element_ptr));
16446         }
16447     }
16448 }
16449
16450 #endif
16451
16452 #undef IS_OPERATOR
16453 #undef IS_OPERAND
16454
16455 STATIC void
16456 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
16457 {
16458     /* This adds the Latin1/above-Latin1 folding rules.
16459      *
16460      * This should be called only for a Latin1-range code points, cp, which is
16461      * known to be involved in a simple fold with other code points above
16462      * Latin1.  It would give false results if /aa has been specified.
16463      * Multi-char folds are outside the scope of this, and must be handled
16464      * specially. */
16465
16466     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
16467
16468     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
16469
16470     /* The rules that are valid for all Unicode versions are hard-coded in */
16471     switch (cp) {
16472         case 'k':
16473         case 'K':
16474           *invlist =
16475              add_cp_to_invlist(*invlist, KELVIN_SIGN);
16476             break;
16477         case 's':
16478         case 'S':
16479           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
16480             break;
16481         case MICRO_SIGN:
16482           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
16483           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
16484             break;
16485         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
16486         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
16487           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
16488             break;
16489         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
16490           *invlist = add_cp_to_invlist(*invlist,
16491                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
16492             break;
16493
16494         default:    /* Other code points are checked against the data for the
16495                        current Unicode version */
16496           {
16497             Size_t folds_count;
16498             unsigned int first_fold;
16499             const unsigned int * remaining_folds;
16500             UV folded_cp;
16501
16502             if (isASCII(cp)) {
16503                 folded_cp = toFOLD(cp);
16504             }
16505             else {
16506                 U8 dummy_fold[UTF8_MAXBYTES_CASE+1];
16507                 Size_t dummy_len;
16508                 folded_cp = _to_fold_latin1(cp, dummy_fold, &dummy_len, 0);
16509             }
16510
16511             if (folded_cp > 255) {
16512                 *invlist = add_cp_to_invlist(*invlist, folded_cp);
16513             }
16514
16515             folds_count = _inverse_folds(folded_cp, &first_fold,
16516                                                     &remaining_folds);
16517             if (folds_count == 0) {
16518
16519                 /* Use deprecated warning to increase the chances of this being
16520                  * output */
16521                 ckWARN2reg_d(RExC_parse,
16522                         "Perl folding rules are not up-to-date for 0x%02X;"
16523                         " please use the perlbug utility to report;", cp);
16524             }
16525             else {
16526                 unsigned int i;
16527
16528                 if (first_fold > 255) {
16529                     *invlist = add_cp_to_invlist(*invlist, first_fold);
16530                 }
16531                 for (i = 0; i < folds_count - 1; i++) {
16532                     if (remaining_folds[i] > 255) {
16533                         *invlist = add_cp_to_invlist(*invlist,
16534                                                     remaining_folds[i]);
16535                     }
16536                 }
16537             }
16538             break;
16539          }
16540     }
16541 }
16542
16543 STATIC void
16544 S_output_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings)
16545 {
16546     /* Output the elements of the array given by '*posix_warnings' as REGEXP
16547      * warnings. */
16548
16549     SV * msg;
16550     const bool first_is_fatal = ckDEAD(packWARN(WARN_REGEXP));
16551
16552     PERL_ARGS_ASSERT_OUTPUT_POSIX_WARNINGS;
16553
16554     if (! TO_OUTPUT_WARNINGS(RExC_parse)) {
16555         return;
16556     }
16557
16558     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
16559         if (first_is_fatal) {           /* Avoid leaking this */
16560             av_undef(posix_warnings);   /* This isn't necessary if the
16561                                             array is mortal, but is a
16562                                             fail-safe */
16563             (void) sv_2mortal(msg);
16564             PREPARE_TO_DIE;
16565         }
16566         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
16567         SvREFCNT_dec_NN(msg);
16568     }
16569
16570     UPDATE_WARNINGS_LOC(RExC_parse);
16571 }
16572
16573 STATIC AV *
16574 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
16575 {
16576     /* This adds the string scalar <multi_string> to the array
16577      * <multi_char_matches>.  <multi_string> is known to have exactly
16578      * <cp_count> code points in it.  This is used when constructing a
16579      * bracketed character class and we find something that needs to match more
16580      * than a single character.
16581      *
16582      * <multi_char_matches> is actually an array of arrays.  Each top-level
16583      * element is an array that contains all the strings known so far that are
16584      * the same length.  And that length (in number of code points) is the same
16585      * as the index of the top-level array.  Hence, the [2] element is an
16586      * array, each element thereof is a string containing TWO code points;
16587      * while element [3] is for strings of THREE characters, and so on.  Since
16588      * this is for multi-char strings there can never be a [0] nor [1] element.
16589      *
16590      * When we rewrite the character class below, we will do so such that the
16591      * longest strings are written first, so that it prefers the longest
16592      * matching strings first.  This is done even if it turns out that any
16593      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
16594      * Christiansen has agreed that this is ok.  This makes the test for the
16595      * ligature 'ffi' come before the test for 'ff', for example */
16596
16597     AV* this_array;
16598     AV** this_array_ptr;
16599
16600     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
16601
16602     if (! multi_char_matches) {
16603         multi_char_matches = newAV();
16604     }
16605
16606     if (av_exists(multi_char_matches, cp_count)) {
16607         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
16608         this_array = *this_array_ptr;
16609     }
16610     else {
16611         this_array = newAV();
16612         av_store(multi_char_matches, cp_count,
16613                  (SV*) this_array);
16614     }
16615     av_push(this_array, multi_string);
16616
16617     return multi_char_matches;
16618 }
16619
16620 /* The names of properties whose definitions are not known at compile time are
16621  * stored in this SV, after a constant heading.  So if the length has been
16622  * changed since initialization, then there is a run-time definition. */
16623 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
16624                                         (SvCUR(listsv) != initial_listsv_len)
16625
16626 /* There is a restricted set of white space characters that are legal when
16627  * ignoring white space in a bracketed character class.  This generates the
16628  * code to skip them.
16629  *
16630  * There is a line below that uses the same white space criteria but is outside
16631  * this macro.  Both here and there must use the same definition */
16632 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
16633     STMT_START {                                                        \
16634         if (do_skip) {                                                  \
16635             while (isBLANK_A(UCHARAT(p)))                               \
16636             {                                                           \
16637                 p++;                                                    \
16638             }                                                           \
16639         }                                                               \
16640     } STMT_END
16641
16642 STATIC regnode_offset
16643 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
16644                  const bool stop_at_1,  /* Just parse the next thing, don't
16645                                            look for a full character class */
16646                  bool allow_mutiple_chars,
16647                  const bool silence_non_portable,   /* Don't output warnings
16648                                                        about too large
16649                                                        characters */
16650                  const bool strict,
16651                  bool optimizable,                  /* ? Allow a non-ANYOF return
16652                                                        node */
16653                  SV** ret_invlist  /* Return an inversion list, not a node */
16654           )
16655 {
16656     /* parse a bracketed class specification.  Most of these will produce an
16657      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
16658      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
16659      * under /i with multi-character folds: it will be rewritten following the
16660      * paradigm of this example, where the <multi-fold>s are characters which
16661      * fold to multiple character sequences:
16662      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
16663      * gets effectively rewritten as:
16664      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
16665      * reg() gets called (recursively) on the rewritten version, and this
16666      * function will return what it constructs.  (Actually the <multi-fold>s
16667      * aren't physically removed from the [abcdefghi], it's just that they are
16668      * ignored in the recursion by means of a flag:
16669      * <RExC_in_multi_char_class>.)
16670      *
16671      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
16672      * characters, with the corresponding bit set if that character is in the
16673      * list.  For characters above this, an inversion list is used.  There
16674      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
16675      * determinable at compile time
16676      *
16677      * On success, returns the offset at which any next node should be placed
16678      * into the regex engine program being compiled.
16679      *
16680      * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
16681      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
16682      * UTF-8
16683      */
16684
16685     dVAR;
16686     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
16687     IV range = 0;
16688     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
16689     regnode_offset ret = -1;    /* Initialized to an illegal value */
16690     STRLEN numlen;
16691     int namedclass = OOB_NAMEDCLASS;
16692     char *rangebegin = NULL;
16693     SV *listsv = NULL;      /* List of \p{user-defined} whose definitions
16694                                aren't available at the time this was called */
16695     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
16696                                       than just initialized.  */
16697     SV* properties = NULL;    /* Code points that match \p{} \P{} */
16698     SV* posixes = NULL;     /* Code points that match classes like [:word:],
16699                                extended beyond the Latin1 range.  These have to
16700                                be kept separate from other code points for much
16701                                of this function because their handling  is
16702                                different under /i, and for most classes under
16703                                /d as well */
16704     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
16705                                separate for a while from the non-complemented
16706                                versions because of complications with /d
16707                                matching */
16708     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
16709                                   treated more simply than the general case,
16710                                   leading to less compilation and execution
16711                                   work */
16712     UV element_count = 0;   /* Number of distinct elements in the class.
16713                                Optimizations may be possible if this is tiny */
16714     AV * multi_char_matches = NULL; /* Code points that fold to more than one
16715                                        character; used under /i */
16716     UV n;
16717     char * stop_ptr = RExC_end;    /* where to stop parsing */
16718
16719     /* ignore unescaped whitespace? */
16720     const bool skip_white = cBOOL(   ret_invlist
16721                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
16722
16723     /* inversion list of code points this node matches only when the target
16724      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
16725      * /d) */
16726     SV* upper_latin1_only_utf8_matches = NULL;
16727
16728     /* Inversion list of code points this node matches regardless of things
16729      * like locale, folding, utf8ness of the target string */
16730     SV* cp_list = NULL;
16731
16732     /* Like cp_list, but code points on this list need to be checked for things
16733      * that fold to/from them under /i */
16734     SV* cp_foldable_list = NULL;
16735
16736     /* Like cp_list, but code points on this list are valid only when the
16737      * runtime locale is UTF-8 */
16738     SV* only_utf8_locale_list = NULL;
16739
16740     /* In a range, if one of the endpoints is non-character-set portable,
16741      * meaning that it hard-codes a code point that may mean a different
16742      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
16743      * mnemonic '\t' which each mean the same character no matter which
16744      * character set the platform is on. */
16745     unsigned int non_portable_endpoint = 0;
16746
16747     /* Is the range unicode? which means on a platform that isn't 1-1 native
16748      * to Unicode (i.e. non-ASCII), each code point in it should be considered
16749      * to be a Unicode value.  */
16750     bool unicode_range = FALSE;
16751     bool invert = FALSE;    /* Is this class to be complemented */
16752
16753     bool warn_super = ALWAYS_WARN_SUPER;
16754
16755     const char * orig_parse = RExC_parse;
16756
16757     /* This variable is used to mark where the end in the input is of something
16758      * that looks like a POSIX construct but isn't.  During the parse, when
16759      * something looks like it could be such a construct is encountered, it is
16760      * checked for being one, but not if we've already checked this area of the
16761      * input.  Only after this position is reached do we check again */
16762     char *not_posix_region_end = RExC_parse - 1;
16763
16764     AV* posix_warnings = NULL;
16765     const bool do_posix_warnings = ckWARN(WARN_REGEXP);
16766     U8 op = END;    /* The returned node-type, initialized to an impossible
16767                        one.  */
16768     U8 anyof_flags = 0;   /* flag bits if the node is an ANYOF-type */
16769     U32 posixl = 0;       /* bit field of posix classes matched under /l */
16770
16771
16772 /* Flags as to what things aren't knowable until runtime.  (Note that these are
16773  * mutually exclusive.) */
16774 #define HAS_USER_DEFINED_PROPERTY 0x01   /* /u any user-defined properties that
16775                                             haven't been defined as of yet */
16776 #define HAS_D_RUNTIME_DEPENDENCY  0x02   /* /d if the target being matched is
16777                                             UTF-8 or not */
16778 #define HAS_L_RUNTIME_DEPENDENCY   0x04 /* /l what the posix classes match and
16779                                             what gets folded */
16780     U32 has_runtime_dependency = 0;     /* OR of the above flags */
16781
16782     GET_RE_DEBUG_FLAGS_DECL;
16783
16784     PERL_ARGS_ASSERT_REGCLASS;
16785 #ifndef DEBUGGING
16786     PERL_UNUSED_ARG(depth);
16787 #endif
16788
16789
16790     /* If wants an inversion list returned, we can't optimize to something
16791      * else. */
16792     if (ret_invlist) {
16793         optimizable = FALSE;
16794     }
16795
16796     DEBUG_PARSE("clas");
16797
16798 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
16799     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
16800                                    && UNICODE_DOT_DOT_VERSION == 0)
16801     allow_mutiple_chars = FALSE;
16802 #endif
16803
16804     /* We include the /i status at the beginning of this so that we can
16805      * know it at runtime */
16806     listsv = sv_2mortal(Perl_newSVpvf(aTHX_ "#%d\n", cBOOL(FOLD)));
16807     initial_listsv_len = SvCUR(listsv);
16808     SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
16809
16810     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16811
16812     assert(RExC_parse <= RExC_end);
16813
16814     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
16815         RExC_parse++;
16816         invert = TRUE;
16817         allow_mutiple_chars = FALSE;
16818         MARK_NAUGHTY(1);
16819         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16820     }
16821
16822     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
16823     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
16824         int maybe_class = handle_possible_posix(pRExC_state,
16825                                                 RExC_parse,
16826                                                 &not_posix_region_end,
16827                                                 NULL,
16828                                                 TRUE /* checking only */);
16829         if (maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
16830             ckWARN4reg(not_posix_region_end,
16831                     "POSIX syntax [%c %c] belongs inside character classes%s",
16832                     *RExC_parse, *RExC_parse,
16833                     (maybe_class == OOB_NAMEDCLASS)
16834                     ? ((POSIXCC_NOTYET(*RExC_parse))
16835                         ? " (but this one isn't implemented)"
16836                         : " (but this one isn't fully valid)")
16837                     : ""
16838                     );
16839         }
16840     }
16841
16842     /* If the caller wants us to just parse a single element, accomplish this
16843      * by faking the loop ending condition */
16844     if (stop_at_1 && RExC_end > RExC_parse) {
16845         stop_ptr = RExC_parse + 1;
16846     }
16847
16848     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
16849     if (UCHARAT(RExC_parse) == ']')
16850         goto charclassloop;
16851
16852     while (1) {
16853
16854         if (   posix_warnings
16855             && av_tindex_skip_len_mg(posix_warnings) >= 0
16856             && RExC_parse > not_posix_region_end)
16857         {
16858             /* Warnings about posix class issues are considered tentative until
16859              * we are far enough along in the parse that we can no longer
16860              * change our mind, at which point we output them.  This is done
16861              * each time through the loop so that a later class won't zap them
16862              * before they have been dealt with. */
16863             output_posix_warnings(pRExC_state, posix_warnings);
16864         }
16865
16866         if  (RExC_parse >= stop_ptr) {
16867             break;
16868         }
16869
16870         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16871
16872         if  (UCHARAT(RExC_parse) == ']') {
16873             break;
16874         }
16875
16876       charclassloop:
16877
16878         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16879         save_value = value;
16880         save_prevvalue = prevvalue;
16881
16882         if (!range) {
16883             rangebegin = RExC_parse;
16884             element_count++;
16885             non_portable_endpoint = 0;
16886         }
16887         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16888             value = utf8n_to_uvchr((U8*)RExC_parse,
16889                                    RExC_end - RExC_parse,
16890                                    &numlen, UTF8_ALLOW_DEFAULT);
16891             RExC_parse += numlen;
16892         }
16893         else
16894             value = UCHARAT(RExC_parse++);
16895
16896         if (value == '[') {
16897             char * posix_class_end;
16898             namedclass = handle_possible_posix(pRExC_state,
16899                                                RExC_parse,
16900                                                &posix_class_end,
16901                                                do_posix_warnings ? &posix_warnings : NULL,
16902                                                FALSE    /* die if error */);
16903             if (namedclass > OOB_NAMEDCLASS) {
16904
16905                 /* If there was an earlier attempt to parse this particular
16906                  * posix class, and it failed, it was a false alarm, as this
16907                  * successful one proves */
16908                 if (   posix_warnings
16909                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16910                     && not_posix_region_end >= RExC_parse
16911                     && not_posix_region_end <= posix_class_end)
16912                 {
16913                     av_undef(posix_warnings);
16914                 }
16915
16916                 RExC_parse = posix_class_end;
16917             }
16918             else if (namedclass == OOB_NAMEDCLASS) {
16919                 not_posix_region_end = posix_class_end;
16920             }
16921             else {
16922                 namedclass = OOB_NAMEDCLASS;
16923             }
16924         }
16925         else if (   RExC_parse - 1 > not_posix_region_end
16926                  && MAYBE_POSIXCC(value))
16927         {
16928             (void) handle_possible_posix(
16929                         pRExC_state,
16930                         RExC_parse - 1,  /* -1 because parse has already been
16931                                             advanced */
16932                         &not_posix_region_end,
16933                         do_posix_warnings ? &posix_warnings : NULL,
16934                         TRUE /* checking only */);
16935         }
16936         else if (  strict && ! skip_white
16937                  && (   _generic_isCC(value, _CC_VERTSPACE)
16938                      || is_VERTWS_cp_high(value)))
16939         {
16940             vFAIL("Literal vertical space in [] is illegal except under /x");
16941         }
16942         else if (value == '\\') {
16943             /* Is a backslash; get the code point of the char after it */
16944
16945             if (RExC_parse >= RExC_end) {
16946                 vFAIL("Unmatched [");
16947             }
16948
16949             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16950                 value = utf8n_to_uvchr((U8*)RExC_parse,
16951                                    RExC_end - RExC_parse,
16952                                    &numlen, UTF8_ALLOW_DEFAULT);
16953                 RExC_parse += numlen;
16954             }
16955             else
16956                 value = UCHARAT(RExC_parse++);
16957
16958             /* Some compilers cannot handle switching on 64-bit integer
16959              * values, therefore value cannot be an UV.  Yes, this will
16960              * be a problem later if we want switch on Unicode.
16961              * A similar issue a little bit later when switching on
16962              * namedclass. --jhi */
16963
16964             /* If the \ is escaping white space when white space is being
16965              * skipped, it means that that white space is wanted literally, and
16966              * is already in 'value'.  Otherwise, need to translate the escape
16967              * into what it signifies. */
16968             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16969
16970             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16971             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16972             case 's':   namedclass = ANYOF_SPACE;       break;
16973             case 'S':   namedclass = ANYOF_NSPACE;      break;
16974             case 'd':   namedclass = ANYOF_DIGIT;       break;
16975             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16976             case 'v':   namedclass = ANYOF_VERTWS;      break;
16977             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16978             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16979             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16980             case 'N':  /* Handle \N{NAME} in class */
16981                 {
16982                     const char * const backslash_N_beg = RExC_parse - 2;
16983                     int cp_count;
16984
16985                     if (! grok_bslash_N(pRExC_state,
16986                                         NULL,      /* No regnode */
16987                                         &value,    /* Yes single value */
16988                                         &cp_count, /* Multiple code pt count */
16989                                         flagp,
16990                                         strict,
16991                                         depth)
16992                     ) {
16993
16994                         if (*flagp & NEED_UTF8)
16995                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16996
16997                         RETURN_FAIL_ON_RESTART_FLAGP(flagp);
16998
16999                         if (cp_count < 0) {
17000                             vFAIL("\\N in a character class must be a named character: \\N{...}");
17001                         }
17002                         else if (cp_count == 0) {
17003                             ckWARNreg(RExC_parse,
17004                               "Ignoring zero length \\N{} in character class");
17005                         }
17006                         else { /* cp_count > 1 */
17007                             assert(cp_count > 1);
17008                             if (! RExC_in_multi_char_class) {
17009                                 if ( ! allow_mutiple_chars
17010                                     || invert
17011                                     || range
17012                                     || *RExC_parse == '-')
17013                                 {
17014                                     if (strict) {
17015                                         RExC_parse--;
17016                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
17017                                     }
17018                                     ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
17019                                     break; /* <value> contains the first code
17020                                               point. Drop out of the switch to
17021                                               process it */
17022                                 }
17023                                 else {
17024                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
17025                                                  RExC_parse - backslash_N_beg);
17026                                     multi_char_matches
17027                                         = add_multi_match(multi_char_matches,
17028                                                           multi_char_N,
17029                                                           cp_count);
17030                                 }
17031                             }
17032                         } /* End of cp_count != 1 */
17033
17034                         /* This element should not be processed further in this
17035                          * class */
17036                         element_count--;
17037                         value = save_value;
17038                         prevvalue = save_prevvalue;
17039                         continue;   /* Back to top of loop to get next char */
17040                     }
17041
17042                     /* Here, is a single code point, and <value> contains it */
17043                     unicode_range = TRUE;   /* \N{} are Unicode */
17044                 }
17045                 break;
17046             case 'p':
17047             case 'P':
17048                 {
17049                 char *e;
17050
17051                 /* \p means they want Unicode semantics */
17052                 REQUIRE_UNI_RULES(flagp, 0);
17053
17054                 if (RExC_parse >= RExC_end)
17055                     vFAIL2("Empty \\%c", (U8)value);
17056                 if (*RExC_parse == '{') {
17057                     const U8 c = (U8)value;
17058                     e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
17059                     if (!e) {
17060                         RExC_parse++;
17061                         vFAIL2("Missing right brace on \\%c{}", c);
17062                     }
17063
17064                     RExC_parse++;
17065
17066                     /* White space is allowed adjacent to the braces and after
17067                      * any '^', even when not under /x */
17068                     while (isSPACE(*RExC_parse)) {
17069                          RExC_parse++;
17070                     }
17071
17072                     if (UCHARAT(RExC_parse) == '^') {
17073
17074                         /* toggle.  (The rhs xor gets the single bit that
17075                          * differs between P and p; the other xor inverts just
17076                          * that bit) */
17077                         value ^= 'P' ^ 'p';
17078
17079                         RExC_parse++;
17080                         while (isSPACE(*RExC_parse)) {
17081                             RExC_parse++;
17082                         }
17083                     }
17084
17085                     if (e == RExC_parse)
17086                         vFAIL2("Empty \\%c{}", c);
17087
17088                     n = e - RExC_parse;
17089                     while (isSPACE(*(RExC_parse + n - 1)))
17090                         n--;
17091
17092                 }   /* The \p isn't immediately followed by a '{' */
17093                 else if (! isALPHA(*RExC_parse)) {
17094                     RExC_parse += (UTF)
17095                                   ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17096                                   : 1;
17097                     vFAIL2("Character following \\%c must be '{' or a "
17098                            "single-character Unicode property name",
17099                            (U8) value);
17100                 }
17101                 else {
17102                     e = RExC_parse;
17103                     n = 1;
17104                 }
17105                 {
17106                     char* name = RExC_parse;
17107
17108                     /* Any message returned about expanding the definition */
17109                     SV* msg = newSVpvs_flags("", SVs_TEMP);
17110
17111                     /* If set TRUE, the property is user-defined as opposed to
17112                      * official Unicode */
17113                     bool user_defined = FALSE;
17114
17115                     SV * prop_definition = parse_uniprop_string(
17116                                             name, n, UTF, FOLD,
17117                                             FALSE, /* This is compile-time */
17118
17119                                             /* We can't defer this defn when
17120                                              * the full result is required in
17121                                              * this call */
17122                                             ! cBOOL(ret_invlist),
17123
17124                                             &user_defined,
17125                                             msg,
17126                                             0 /* Base level */
17127                                            );
17128                     if (SvCUR(msg)) {   /* Assumes any error causes a msg */
17129                         assert(prop_definition == NULL);
17130                         RExC_parse = e + 1;
17131                         if (SvUTF8(msg)) {  /* msg being UTF-8 makes the whole
17132                                                thing so, or else the display is
17133                                                mojibake */
17134                             RExC_utf8 = TRUE;
17135                         }
17136                         /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
17137                         vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg),
17138                                     SvCUR(msg), SvPVX(msg)));
17139                     }
17140
17141                     if (! is_invlist(prop_definition)) {
17142
17143                         /* Here, the definition isn't known, so we have gotten
17144                          * returned a string that will be evaluated if and when
17145                          * encountered at runtime.  We add it to the list of
17146                          * such properties, along with whether it should be
17147                          * complemented or not */
17148                         if (value == 'P') {
17149                             sv_catpvs(listsv, "!");
17150                         }
17151                         else {
17152                             sv_catpvs(listsv, "+");
17153                         }
17154                         sv_catsv(listsv, prop_definition);
17155
17156                         has_runtime_dependency |= HAS_USER_DEFINED_PROPERTY;
17157
17158                         /* We don't know yet what this matches, so have to flag
17159                          * it */
17160                         anyof_flags |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17161                     }
17162                     else {
17163                         assert (prop_definition && is_invlist(prop_definition));
17164
17165                         /* Here we do have the complete property definition
17166                          *
17167                          * Temporary workaround for [perl #133136].  For this
17168                          * precise input that is in the .t that is failing,
17169                          * load utf8.pm, which is what the test wants, so that
17170                          * that .t passes */
17171                         if (     memEQs(RExC_start, e + 1 - RExC_start,
17172                                         "foo\\p{Alnum}")
17173                             && ! hv_common(GvHVn(PL_incgv),
17174                                            NULL,
17175                                            "utf8.pm", sizeof("utf8.pm") - 1,
17176                                            0, HV_FETCH_ISEXISTS, NULL, 0))
17177                         {
17178                             require_pv("utf8.pm");
17179                         }
17180
17181                         if (! user_defined &&
17182                             /* We warn on matching an above-Unicode code point
17183                              * if the match would return true, except don't
17184                              * warn for \p{All}, which has exactly one element
17185                              * = 0 */
17186                             (_invlist_contains_cp(prop_definition, 0x110000)
17187                                 && (! (_invlist_len(prop_definition) == 1
17188                                        && *invlist_array(prop_definition) == 0))))
17189                         {
17190                             warn_super = TRUE;
17191                         }
17192
17193                         /* Invert if asking for the complement */
17194                         if (value == 'P') {
17195                             _invlist_union_complement_2nd(properties,
17196                                                           prop_definition,
17197                                                           &properties);
17198                         }
17199                         else {
17200                             _invlist_union(properties, prop_definition, &properties);
17201                         }
17202                     }
17203                 }
17204
17205                 RExC_parse = e + 1;
17206                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
17207                                                 named */
17208                 }
17209                 break;
17210             case 'n':   value = '\n';                   break;
17211             case 'r':   value = '\r';                   break;
17212             case 't':   value = '\t';                   break;
17213             case 'f':   value = '\f';                   break;
17214             case 'b':   value = '\b';                   break;
17215             case 'e':   value = ESC_NATIVE;             break;
17216             case 'a':   value = '\a';                   break;
17217             case 'o':
17218                 RExC_parse--;   /* function expects to be pointed at the 'o' */
17219                 {
17220                     const char* error_msg;
17221                     bool valid = grok_bslash_o(&RExC_parse,
17222                                                RExC_end,
17223                                                &value,
17224                                                &error_msg,
17225                                                TO_OUTPUT_WARNINGS(RExC_parse),
17226                                                strict,
17227                                                silence_non_portable,
17228                                                UTF);
17229                     if (! valid) {
17230                         vFAIL(error_msg);
17231                     }
17232                     UPDATE_WARNINGS_LOC(RExC_parse - 1);
17233                 }
17234                 non_portable_endpoint++;
17235                 break;
17236             case 'x':
17237                 RExC_parse--;   /* function expects to be pointed at the 'x' */
17238                 {
17239                     const char* error_msg;
17240                     bool valid = grok_bslash_x(&RExC_parse,
17241                                                RExC_end,
17242                                                &value,
17243                                                &error_msg,
17244                                                TO_OUTPUT_WARNINGS(RExC_parse),
17245                                                strict,
17246                                                silence_non_portable,
17247                                                UTF);
17248                     if (! valid) {
17249                         vFAIL(error_msg);
17250                     }
17251                     UPDATE_WARNINGS_LOC(RExC_parse - 1);
17252                 }
17253                 non_portable_endpoint++;
17254                 break;
17255             case 'c':
17256                 value = grok_bslash_c(*RExC_parse, TO_OUTPUT_WARNINGS(RExC_parse));
17257                 UPDATE_WARNINGS_LOC(RExC_parse);
17258                 RExC_parse++;
17259                 non_portable_endpoint++;
17260                 break;
17261             case '0': case '1': case '2': case '3': case '4':
17262             case '5': case '6': case '7':
17263                 {
17264                     /* Take 1-3 octal digits */
17265                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
17266                     numlen = (strict) ? 4 : 3;
17267                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
17268                     RExC_parse += numlen;
17269                     if (numlen != 3) {
17270                         if (strict) {
17271                             RExC_parse += (UTF)
17272                                           ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17273                                           : 1;
17274                             vFAIL("Need exactly 3 octal digits");
17275                         }
17276                         else if (   numlen < 3 /* like \08, \178 */
17277                                  && RExC_parse < RExC_end
17278                                  && isDIGIT(*RExC_parse)
17279                                  && ckWARN(WARN_REGEXP))
17280                         {
17281                             reg_warn_non_literal_string(
17282                                  RExC_parse + 1,
17283                                  form_short_octal_warning(RExC_parse, numlen));
17284                         }
17285                     }
17286                     non_portable_endpoint++;
17287                     break;
17288                 }
17289             default:
17290                 /* Allow \_ to not give an error */
17291                 if (isWORDCHAR(value) && value != '_') {
17292                     if (strict) {
17293                         vFAIL2("Unrecognized escape \\%c in character class",
17294                                (int)value);
17295                     }
17296                     else {
17297                         ckWARN2reg(RExC_parse,
17298                             "Unrecognized escape \\%c in character class passed through",
17299                             (int)value);
17300                     }
17301                 }
17302                 break;
17303             }   /* End of switch on char following backslash */
17304         } /* end of handling backslash escape sequences */
17305
17306         /* Here, we have the current token in 'value' */
17307
17308         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
17309             U8 classnum;
17310
17311             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
17312              * literal, as is the character that began the false range, i.e.
17313              * the 'a' in the examples */
17314             if (range) {
17315                 const int w = (RExC_parse >= rangebegin)
17316                                 ? RExC_parse - rangebegin
17317                                 : 0;
17318                 if (strict) {
17319                     vFAIL2utf8f(
17320                         "False [] range \"%" UTF8f "\"",
17321                         UTF8fARG(UTF, w, rangebegin));
17322                 }
17323                 else {
17324                     ckWARN2reg(RExC_parse,
17325                         "False [] range \"%" UTF8f "\"",
17326                         UTF8fARG(UTF, w, rangebegin));
17327                     cp_list = add_cp_to_invlist(cp_list, '-');
17328                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
17329                                                             prevvalue);
17330                 }
17331
17332                 range = 0; /* this was not a true range */
17333                 element_count += 2; /* So counts for three values */
17334             }
17335
17336             classnum = namedclass_to_classnum(namedclass);
17337
17338             if (LOC && namedclass < ANYOF_POSIXL_MAX
17339 #ifndef HAS_ISASCII
17340                 && classnum != _CC_ASCII
17341 #endif
17342             ) {
17343                 SV* scratch_list = NULL;
17344
17345                 /* What the Posix classes (like \w, [:space:]) match isn't
17346                  * generally knowable under locale until actual match time.  A
17347                  * special node is used for these which has extra space for a
17348                  * bitmap, with a bit reserved for each named class that is to
17349                  * be matched against.  (This isn't needed for \p{} and
17350                  * pseudo-classes, as they are not affected by locale, and
17351                  * hence are dealt with separately.)  However, if a named class
17352                  * and its complement are both present, then it matches
17353                  * everything, and there is no runtime dependency.  Odd numbers
17354                  * are the complements of the next lower number, so xor works.
17355                  * (Note that something like [\w\D] should match everything,
17356                  * because \d should be a proper subset of \w.  But rather than
17357                  * trust that the locale is well behaved, we leave this to
17358                  * runtime to sort out) */
17359                 if (POSIXL_TEST(posixl, namedclass ^ 1)) {
17360                     cp_list = _add_range_to_invlist(cp_list, 0, UV_MAX);
17361                     POSIXL_ZERO(posixl);
17362                     has_runtime_dependency &= ~HAS_L_RUNTIME_DEPENDENCY;
17363                     anyof_flags &= ~ANYOF_MATCHES_POSIXL;
17364                     continue;   /* We could ignore the rest of the class, but
17365                                    best to parse it for any errors */
17366                 }
17367                 else { /* Here, isn't the complement of any already parsed
17368                           class */
17369                     POSIXL_SET(posixl, namedclass);
17370                     has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
17371                     anyof_flags |= ANYOF_MATCHES_POSIXL;
17372
17373                     /* The above-Latin1 characters are not subject to locale
17374                      * rules.  Just add them to the unconditionally-matched
17375                      * list */
17376
17377                     /* Get the list of the above-Latin1 code points this
17378                      * matches */
17379                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
17380                                             PL_XPosix_ptrs[classnum],
17381
17382                                             /* Odd numbers are complements,
17383                                              * like NDIGIT, NASCII, ... */
17384                                             namedclass % 2 != 0,
17385                                             &scratch_list);
17386                     /* Checking if 'cp_list' is NULL first saves an extra
17387                      * clone.  Its reference count will be decremented at the
17388                      * next union, etc, or if this is the only instance, at the
17389                      * end of the routine */
17390                     if (! cp_list) {
17391                         cp_list = scratch_list;
17392                     }
17393                     else {
17394                         _invlist_union(cp_list, scratch_list, &cp_list);
17395                         SvREFCNT_dec_NN(scratch_list);
17396                     }
17397                     continue;   /* Go get next character */
17398                 }
17399             }
17400             else {
17401
17402                 /* Here, is not /l, or is a POSIX class for which /l doesn't
17403                  * matter (or is a Unicode property, which is skipped here). */
17404                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
17405                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
17406
17407                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
17408                          * nor /l make a difference in what these match,
17409                          * therefore we just add what they match to cp_list. */
17410                         if (classnum != _CC_VERTSPACE) {
17411                             assert(   namedclass == ANYOF_HORIZWS
17412                                    || namedclass == ANYOF_NHORIZWS);
17413
17414                             /* It turns out that \h is just a synonym for
17415                              * XPosixBlank */
17416                             classnum = _CC_BLANK;
17417                         }
17418
17419                         _invlist_union_maybe_complement_2nd(
17420                                 cp_list,
17421                                 PL_XPosix_ptrs[classnum],
17422                                 namedclass % 2 != 0,    /* Complement if odd
17423                                                           (NHORIZWS, NVERTWS)
17424                                                         */
17425                                 &cp_list);
17426                     }
17427                 }
17428                 else if (   AT_LEAST_UNI_SEMANTICS
17429                          || classnum == _CC_ASCII
17430                          || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
17431                                                    || classnum == _CC_XDIGIT)))
17432                 {
17433                     /* We usually have to worry about /d affecting what POSIX
17434                      * classes match, with special code needed because we won't
17435                      * know until runtime what all matches.  But there is no
17436                      * extra work needed under /u and /a; and [:ascii:] is
17437                      * unaffected by /d; and :digit: and :xdigit: don't have
17438                      * runtime differences under /d.  So we can special case
17439                      * these, and avoid some extra work below, and at runtime.
17440                      * */
17441                     _invlist_union_maybe_complement_2nd(
17442                                                      simple_posixes,
17443                                                       ((AT_LEAST_ASCII_RESTRICTED)
17444                                                        ? PL_Posix_ptrs[classnum]
17445                                                        : PL_XPosix_ptrs[classnum]),
17446                                                      namedclass % 2 != 0,
17447                                                      &simple_posixes);
17448                 }
17449                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
17450                            complement and use nposixes */
17451                     SV** posixes_ptr = namedclass % 2 == 0
17452                                        ? &posixes
17453                                        : &nposixes;
17454                     _invlist_union_maybe_complement_2nd(
17455                                                      *posixes_ptr,
17456                                                      PL_XPosix_ptrs[classnum],
17457                                                      namedclass % 2 != 0,
17458                                                      posixes_ptr);
17459                 }
17460             }
17461         } /* end of namedclass \blah */
17462
17463         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
17464
17465         /* If 'range' is set, 'value' is the ending of a range--check its
17466          * validity.  (If value isn't a single code point in the case of a
17467          * range, we should have figured that out above in the code that
17468          * catches false ranges).  Later, we will handle each individual code
17469          * point in the range.  If 'range' isn't set, this could be the
17470          * beginning of a range, so check for that by looking ahead to see if
17471          * the next real character to be processed is the range indicator--the
17472          * minus sign */
17473
17474         if (range) {
17475 #ifdef EBCDIC
17476             /* For unicode ranges, we have to test that the Unicode as opposed
17477              * to the native values are not decreasing.  (Above 255, there is
17478              * no difference between native and Unicode) */
17479             if (unicode_range && prevvalue < 255 && value < 255) {
17480                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
17481                     goto backwards_range;
17482                 }
17483             }
17484             else
17485 #endif
17486             if (prevvalue > value) /* b-a */ {
17487                 int w;
17488 #ifdef EBCDIC
17489               backwards_range:
17490 #endif
17491                 w = RExC_parse - rangebegin;
17492                 vFAIL2utf8f(
17493                     "Invalid [] range \"%" UTF8f "\"",
17494                     UTF8fARG(UTF, w, rangebegin));
17495                 NOT_REACHED; /* NOTREACHED */
17496             }
17497         }
17498         else {
17499             prevvalue = value; /* save the beginning of the potential range */
17500             if (! stop_at_1     /* Can't be a range if parsing just one thing */
17501                 && *RExC_parse == '-')
17502             {
17503                 char* next_char_ptr = RExC_parse + 1;
17504
17505                 /* Get the next real char after the '-' */
17506                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
17507
17508                 /* If the '-' is at the end of the class (just before the ']',
17509                  * it is a literal minus; otherwise it is a range */
17510                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
17511                     RExC_parse = next_char_ptr;
17512
17513                     /* a bad range like \w-, [:word:]- ? */
17514                     if (namedclass > OOB_NAMEDCLASS) {
17515                         if (strict || ckWARN(WARN_REGEXP)) {
17516                             const int w = RExC_parse >= rangebegin
17517                                           ?  RExC_parse - rangebegin
17518                                           : 0;
17519                             if (strict) {
17520                                 vFAIL4("False [] range \"%*.*s\"",
17521                                     w, w, rangebegin);
17522                             }
17523                             else {
17524                                 vWARN4(RExC_parse,
17525                                     "False [] range \"%*.*s\"",
17526                                     w, w, rangebegin);
17527                             }
17528                         }
17529                         cp_list = add_cp_to_invlist(cp_list, '-');
17530                         element_count++;
17531                     } else
17532                         range = 1;      /* yeah, it's a range! */
17533                     continue;   /* but do it the next time */
17534                 }
17535             }
17536         }
17537
17538         if (namedclass > OOB_NAMEDCLASS) {
17539             continue;
17540         }
17541
17542         /* Here, we have a single value this time through the loop, and
17543          * <prevvalue> is the beginning of the range, if any; or <value> if
17544          * not. */
17545
17546         /* non-Latin1 code point implies unicode semantics. */
17547         if (value > 255) {
17548             REQUIRE_UNI_RULES(flagp, 0);
17549         }
17550
17551         /* Ready to process either the single value, or the completed range.
17552          * For single-valued non-inverted ranges, we consider the possibility
17553          * of multi-char folds.  (We made a conscious decision to not do this
17554          * for the other cases because it can often lead to non-intuitive
17555          * results.  For example, you have the peculiar case that:
17556          *  "s s" =~ /^[^\xDF]+$/i => Y
17557          *  "ss"  =~ /^[^\xDF]+$/i => N
17558          *
17559          * See [perl #89750] */
17560         if (FOLD && allow_mutiple_chars && value == prevvalue) {
17561             if (    value == LATIN_SMALL_LETTER_SHARP_S
17562                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
17563                                                         value)))
17564             {
17565                 /* Here <value> is indeed a multi-char fold.  Get what it is */
17566
17567                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17568                 STRLEN foldlen;
17569
17570                 UV folded = _to_uni_fold_flags(
17571                                 value,
17572                                 foldbuf,
17573                                 &foldlen,
17574                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
17575                                                    ? FOLD_FLAGS_NOMIX_ASCII
17576                                                    : 0)
17577                                 );
17578
17579                 /* Here, <folded> should be the first character of the
17580                  * multi-char fold of <value>, with <foldbuf> containing the
17581                  * whole thing.  But, if this fold is not allowed (because of
17582                  * the flags), <fold> will be the same as <value>, and should
17583                  * be processed like any other character, so skip the special
17584                  * handling */
17585                 if (folded != value) {
17586
17587                     /* Skip if we are recursed, currently parsing the class
17588                      * again.  Otherwise add this character to the list of
17589                      * multi-char folds. */
17590                     if (! RExC_in_multi_char_class) {
17591                         STRLEN cp_count = utf8_length(foldbuf,
17592                                                       foldbuf + foldlen);
17593                         SV* multi_fold = sv_2mortal(newSVpvs(""));
17594
17595                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
17596
17597                         multi_char_matches
17598                                         = add_multi_match(multi_char_matches,
17599                                                           multi_fold,
17600                                                           cp_count);
17601
17602                     }
17603
17604                     /* This element should not be processed further in this
17605                      * class */
17606                     element_count--;
17607                     value = save_value;
17608                     prevvalue = save_prevvalue;
17609                     continue;
17610                 }
17611             }
17612         }
17613
17614         if (strict && ckWARN(WARN_REGEXP)) {
17615             if (range) {
17616
17617                 /* If the range starts above 255, everything is portable and
17618                  * likely to be so for any forseeable character set, so don't
17619                  * warn. */
17620                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
17621                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
17622                 }
17623                 else if (prevvalue != value) {
17624
17625                     /* Under strict, ranges that stop and/or end in an ASCII
17626                      * printable should have each end point be a portable value
17627                      * for it (preferably like 'A', but we don't warn if it is
17628                      * a (portable) Unicode name or code point), and the range
17629                      * must be be all digits or all letters of the same case.
17630                      * Otherwise, the range is non-portable and unclear as to
17631                      * what it contains */
17632                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
17633                         && (          non_portable_endpoint
17634                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
17635                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
17636                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
17637                     ))) {
17638                         vWARN(RExC_parse, "Ranges of ASCII printables should"
17639                                           " be some subset of \"0-9\","
17640                                           " \"A-Z\", or \"a-z\"");
17641                     }
17642                     else if (prevvalue >= FIRST_NON_ASCII_DECIMAL_DIGIT) {
17643                         SSize_t index_start;
17644                         SSize_t index_final;
17645
17646                         /* But the nature of Unicode and languages mean we
17647                          * can't do the same checks for above-ASCII ranges,
17648                          * except in the case of digit ones.  These should
17649                          * contain only digits from the same group of 10.  The
17650                          * ASCII case is handled just above.  Hence here, the
17651                          * range could be a range of digits.  First some
17652                          * unlikely special cases.  Grandfather in that a range
17653                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
17654                          * if its starting value is one of the 10 digits prior
17655                          * to it.  This is because it is an alternate way of
17656                          * writing 19D1, and some people may expect it to be in
17657                          * that group.  But it is bad, because it won't give
17658                          * the expected results.  In Unicode 5.2 it was
17659                          * considered to be in that group (of 11, hence), but
17660                          * this was fixed in the next version */
17661
17662                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
17663                             goto warn_bad_digit_range;
17664                         }
17665                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
17666                                           &&     value <= 0x1D7FF))
17667                         {
17668                             /* This is the only other case currently in Unicode
17669                              * where the algorithm below fails.  The code
17670                              * points just above are the end points of a single
17671                              * range containing only decimal digits.  It is 5
17672                              * different series of 0-9.  All other ranges of
17673                              * digits currently in Unicode are just a single
17674                              * series.  (And mktables will notify us if a later
17675                              * Unicode version breaks this.)
17676                              *
17677                              * If the range being checked is at most 9 long,
17678                              * and the digit values represented are in
17679                              * numerical order, they are from the same series.
17680                              * */
17681                             if (         value - prevvalue > 9
17682                                 ||    (((    value - 0x1D7CE) % 10)
17683                                      <= (prevvalue - 0x1D7CE) % 10))
17684                             {
17685                                 goto warn_bad_digit_range;
17686                             }
17687                         }
17688                         else {
17689
17690                             /* For all other ranges of digits in Unicode, the
17691                              * algorithm is just to check if both end points
17692                              * are in the same series, which is the same range.
17693                              * */
17694                             index_start = _invlist_search(
17695                                                     PL_XPosix_ptrs[_CC_DIGIT],
17696                                                     prevvalue);
17697
17698                             /* Warn if the range starts and ends with a digit,
17699                              * and they are not in the same group of 10. */
17700                             if (   index_start >= 0
17701                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
17702                                 && (index_final =
17703                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
17704                                                     value)) != index_start
17705                                 && index_final >= 0
17706                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
17707                             {
17708                               warn_bad_digit_range:
17709                                 vWARN(RExC_parse, "Ranges of digits should be"
17710                                                   " from the same group of"
17711                                                   " 10");
17712                             }
17713                         }
17714                     }
17715                 }
17716             }
17717             if ((! range || prevvalue == value) && non_portable_endpoint) {
17718                 if (isPRINT_A(value)) {
17719                     char literal[3];
17720                     unsigned d = 0;
17721                     if (isBACKSLASHED_PUNCT(value)) {
17722                         literal[d++] = '\\';
17723                     }
17724                     literal[d++] = (char) value;
17725                     literal[d++] = '\0';
17726
17727                     vWARN4(RExC_parse,
17728                            "\"%.*s\" is more clearly written simply as \"%s\"",
17729                            (int) (RExC_parse - rangebegin),
17730                            rangebegin,
17731                            literal
17732                         );
17733                 }
17734                 else if (isMNEMONIC_CNTRL(value)) {
17735                     vWARN4(RExC_parse,
17736                            "\"%.*s\" is more clearly written simply as \"%s\"",
17737                            (int) (RExC_parse - rangebegin),
17738                            rangebegin,
17739                            cntrl_to_mnemonic((U8) value)
17740                         );
17741                 }
17742             }
17743         }
17744
17745         /* Deal with this element of the class */
17746
17747 #ifndef EBCDIC
17748         cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17749                                                     prevvalue, value);
17750 #else
17751         /* On non-ASCII platforms, for ranges that span all of 0..255, and ones
17752          * that don't require special handling, we can just add the range like
17753          * we do for ASCII platforms */
17754         if ((UNLIKELY(prevvalue == 0) && value >= 255)
17755             || ! (prevvalue < 256
17756                     && (unicode_range
17757                         || (! non_portable_endpoint
17758                             && ((isLOWER_A(prevvalue) && isLOWER_A(value))
17759                                 || (isUPPER_A(prevvalue)
17760                                     && isUPPER_A(value)))))))
17761         {
17762             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17763                                                         prevvalue, value);
17764         }
17765         else {
17766             /* Here, requires special handling.  This can be because it is a
17767              * range whose code points are considered to be Unicode, and so
17768              * must be individually translated into native, or because its a
17769              * subrange of 'A-Z' or 'a-z' which each aren't contiguous in
17770              * EBCDIC, but we have defined them to include only the "expected"
17771              * upper or lower case ASCII alphabetics.  Subranges above 255 are
17772              * the same in native and Unicode, so can be added as a range */
17773             U8 start = NATIVE_TO_LATIN1(prevvalue);
17774             unsigned j;
17775             U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
17776             for (j = start; j <= end; j++) {
17777                 cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
17778             }
17779             if (value > 255) {
17780                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17781                                                             256, value);
17782             }
17783         }
17784 #endif
17785
17786         range = 0; /* this range (if it was one) is done now */
17787     } /* End of loop through all the text within the brackets */
17788
17789     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
17790         output_posix_warnings(pRExC_state, posix_warnings);
17791     }
17792
17793     /* If anything in the class expands to more than one character, we have to
17794      * deal with them by building up a substitute parse string, and recursively
17795      * calling reg() on it, instead of proceeding */
17796     if (multi_char_matches) {
17797         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17798         I32 cp_count;
17799         STRLEN len;
17800         char *save_end = RExC_end;
17801         char *save_parse = RExC_parse;
17802         char *save_start = RExC_start;
17803         Size_t constructed_prefix_len = 0; /* This gives the length of the
17804                                               constructed portion of the
17805                                               substitute parse. */
17806         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17807                                        a "|" */
17808         I32 reg_flags;
17809
17810         assert(! invert);
17811         /* Only one level of recursion allowed */
17812         assert(RExC_copy_start_in_constructed == RExC_precomp);
17813
17814 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17815            because too confusing */
17816         if (invert) {
17817             sv_catpvs(substitute_parse, "(?:");
17818         }
17819 #endif
17820
17821         /* Look at the longest folds first */
17822         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17823                         cp_count > 0;
17824                         cp_count--)
17825         {
17826
17827             if (av_exists(multi_char_matches, cp_count)) {
17828                 AV** this_array_ptr;
17829                 SV* this_sequence;
17830
17831                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17832                                                  cp_count, FALSE);
17833                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17834                                                                 &PL_sv_undef)
17835                 {
17836                     if (! first_time) {
17837                         sv_catpvs(substitute_parse, "|");
17838                     }
17839                     first_time = FALSE;
17840
17841                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17842                 }
17843             }
17844         }
17845
17846         /* If the character class contains anything else besides these
17847          * multi-character folds, have to include it in recursive parsing */
17848         if (element_count) {
17849             sv_catpvs(substitute_parse, "|[");
17850             constructed_prefix_len = SvCUR(substitute_parse);
17851             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17852
17853             /* Put in a closing ']' only if not going off the end, as otherwise
17854              * we are adding something that really isn't there */
17855             if (RExC_parse < RExC_end) {
17856                 sv_catpvs(substitute_parse, "]");
17857             }
17858         }
17859
17860         sv_catpvs(substitute_parse, ")");
17861 #if 0
17862         if (invert) {
17863             /* This is a way to get the parse to skip forward a whole named
17864              * sequence instead of matching the 2nd character when it fails the
17865              * first */
17866             sv_catpvs(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17867         }
17868 #endif
17869
17870         /* Set up the data structure so that any errors will be properly
17871          * reported.  See the comments at the definition of
17872          * REPORT_LOCATION_ARGS for details */
17873         RExC_copy_start_in_input = (char *) orig_parse;
17874         RExC_start = RExC_parse = SvPV(substitute_parse, len);
17875         RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len;
17876         RExC_end = RExC_parse + len;
17877         RExC_in_multi_char_class = 1;
17878
17879         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17880
17881         *flagp |= reg_flags & (HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PARSE|NEED_UTF8);
17882
17883         /* And restore so can parse the rest of the pattern */
17884         RExC_parse = save_parse;
17885         RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start;
17886         RExC_end = save_end;
17887         RExC_in_multi_char_class = 0;
17888         SvREFCNT_dec_NN(multi_char_matches);
17889         return ret;
17890     }
17891
17892     /* If folding, we calculate all characters that could fold to or from the
17893      * ones already on the list */
17894     if (cp_foldable_list) {
17895         if (FOLD) {
17896             UV start, end;      /* End points of code point ranges */
17897
17898             SV* fold_intersection = NULL;
17899             SV** use_list;
17900
17901             /* Our calculated list will be for Unicode rules.  For locale
17902              * matching, we have to keep a separate list that is consulted at
17903              * runtime only when the locale indicates Unicode rules (and we
17904              * don't include potential matches in the ASCII/Latin1 range, as
17905              * any code point could fold to any other, based on the run-time
17906              * locale).   For non-locale, we just use the general list */
17907             if (LOC) {
17908                 use_list = &only_utf8_locale_list;
17909             }
17910             else {
17911                 use_list = &cp_list;
17912             }
17913
17914             /* Only the characters in this class that participate in folds need
17915              * be checked.  Get the intersection of this class and all the
17916              * possible characters that are foldable.  This can quickly narrow
17917              * down a large class */
17918             _invlist_intersection(PL_in_some_fold, cp_foldable_list,
17919                                   &fold_intersection);
17920
17921             /* Now look at the foldable characters in this class individually */
17922             invlist_iterinit(fold_intersection);
17923             while (invlist_iternext(fold_intersection, &start, &end)) {
17924                 UV j;
17925                 UV folded;
17926
17927                 /* Look at every character in the range */
17928                 for (j = start; j <= end; j++) {
17929                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17930                     STRLEN foldlen;
17931                     unsigned int k;
17932                     Size_t folds_count;
17933                     unsigned int first_fold;
17934                     const unsigned int * remaining_folds;
17935
17936                     if (j < 256) {
17937
17938                         /* Under /l, we don't know what code points below 256
17939                          * fold to, except we do know the MICRO SIGN folds to
17940                          * an above-255 character if the locale is UTF-8, so we
17941                          * add it to the special list (in *use_list)  Otherwise
17942                          * we know now what things can match, though some folds
17943                          * are valid under /d only if the target is UTF-8.
17944                          * Those go in a separate list */
17945                         if (      IS_IN_SOME_FOLD_L1(j)
17946                             && ! (LOC && j != MICRO_SIGN))
17947                         {
17948
17949                             /* ASCII is always matched; non-ASCII is matched
17950                              * only under Unicode rules (which could happen
17951                              * under /l if the locale is a UTF-8 one */
17952                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17953                                 *use_list = add_cp_to_invlist(*use_list,
17954                                                             PL_fold_latin1[j]);
17955                             }
17956                             else if (j != PL_fold_latin1[j]) {
17957                                 upper_latin1_only_utf8_matches
17958                                         = add_cp_to_invlist(
17959                                                 upper_latin1_only_utf8_matches,
17960                                                 PL_fold_latin1[j]);
17961                             }
17962                         }
17963
17964                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17965                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17966                         {
17967                             add_above_Latin1_folds(pRExC_state,
17968                                                    (U8) j,
17969                                                    use_list);
17970                         }
17971                         continue;
17972                     }
17973
17974                     /* Here is an above Latin1 character.  We don't have the
17975                      * rules hard-coded for it.  First, get its fold.  This is
17976                      * the simple fold, as the multi-character folds have been
17977                      * handled earlier and separated out */
17978                     folded = _to_uni_fold_flags(j, foldbuf, &foldlen,
17979                                                         (ASCII_FOLD_RESTRICTED)
17980                                                         ? FOLD_FLAGS_NOMIX_ASCII
17981                                                         : 0);
17982
17983                     /* Single character fold of above Latin1.  Add everything
17984                      * in its fold closure to the list that this node should
17985                      * match. */
17986                     folds_count = _inverse_folds(folded, &first_fold,
17987                                                     &remaining_folds);
17988                     for (k = 0; k <= folds_count; k++) {
17989                         UV c = (k == 0)     /* First time through use itself */
17990                                 ? folded
17991                                 : (k == 1)  /* 2nd time use, the first fold */
17992                                    ? first_fold
17993
17994                                      /* Then the remaining ones */
17995                                    : remaining_folds[k-2];
17996
17997                         /* /aa doesn't allow folds between ASCII and non- */
17998                         if ((   ASCII_FOLD_RESTRICTED
17999                             && (isASCII(c) != isASCII(j))))
18000                         {
18001                             continue;
18002                         }
18003
18004                         /* Folds under /l which cross the 255/256 boundary are
18005                          * added to a separate list.  (These are valid only
18006                          * when the locale is UTF-8.) */
18007                         if (c < 256 && LOC) {
18008                             *use_list = add_cp_to_invlist(*use_list, c);
18009                             continue;
18010                         }
18011
18012                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
18013                         {
18014                             cp_list = add_cp_to_invlist(cp_list, c);
18015                         }
18016                         else {
18017                             /* Similarly folds involving non-ascii Latin1
18018                              * characters under /d are added to their list */
18019                             upper_latin1_only_utf8_matches
18020                                     = add_cp_to_invlist(
18021                                                 upper_latin1_only_utf8_matches,
18022                                                 c);
18023                         }
18024                     }
18025                 }
18026             }
18027             SvREFCNT_dec_NN(fold_intersection);
18028         }
18029
18030         /* Now that we have finished adding all the folds, there is no reason
18031          * to keep the foldable list separate */
18032         _invlist_union(cp_list, cp_foldable_list, &cp_list);
18033         SvREFCNT_dec_NN(cp_foldable_list);
18034     }
18035
18036     /* And combine the result (if any) with any inversion lists from posix
18037      * classes.  The lists are kept separate up to now because we don't want to
18038      * fold the classes */
18039     if (simple_posixes) {   /* These are the classes known to be unaffected by
18040                                /a, /aa, and /d */
18041         if (cp_list) {
18042             _invlist_union(cp_list, simple_posixes, &cp_list);
18043             SvREFCNT_dec_NN(simple_posixes);
18044         }
18045         else {
18046             cp_list = simple_posixes;
18047         }
18048     }
18049     if (posixes || nposixes) {
18050         if (! DEPENDS_SEMANTICS) {
18051
18052             /* For everything but /d, we can just add the current 'posixes' and
18053              * 'nposixes' to the main list */
18054             if (posixes) {
18055                 if (cp_list) {
18056                     _invlist_union(cp_list, posixes, &cp_list);
18057                     SvREFCNT_dec_NN(posixes);
18058                 }
18059                 else {
18060                     cp_list = posixes;
18061                 }
18062             }
18063             if (nposixes) {
18064                 if (cp_list) {
18065                     _invlist_union(cp_list, nposixes, &cp_list);
18066                     SvREFCNT_dec_NN(nposixes);
18067                 }
18068                 else {
18069                     cp_list = nposixes;
18070                 }
18071             }
18072         }
18073         else {
18074             /* Under /d, things like \w match upper Latin1 characters only if
18075              * the target string is in UTF-8.  But things like \W match all the
18076              * upper Latin1 characters if the target string is not in UTF-8.
18077              *
18078              * Handle the case with something like \W separately */
18079             if (nposixes) {
18080                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1, NULL);
18081
18082                 /* A complemented posix class matches all upper Latin1
18083                  * characters if not in UTF-8.  And it matches just certain
18084                  * ones when in UTF-8.  That means those certain ones are
18085                  * matched regardless, so can just be added to the
18086                  * unconditional list */
18087                 if (cp_list) {
18088                     _invlist_union(cp_list, nposixes, &cp_list);
18089                     SvREFCNT_dec_NN(nposixes);
18090                     nposixes = NULL;
18091                 }
18092                 else {
18093                     cp_list = nposixes;
18094                 }
18095
18096                 /* Likewise for 'posixes' */
18097                 _invlist_union(posixes, cp_list, &cp_list);
18098
18099                 /* Likewise for anything else in the range that matched only
18100                  * under UTF-8 */
18101                 if (upper_latin1_only_utf8_matches) {
18102                     _invlist_union(cp_list,
18103                                    upper_latin1_only_utf8_matches,
18104                                    &cp_list);
18105                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18106                     upper_latin1_only_utf8_matches = NULL;
18107                 }
18108
18109                 /* If we don't match all the upper Latin1 characters regardless
18110                  * of UTF-8ness, we have to set a flag to match the rest when
18111                  * not in UTF-8 */
18112                 _invlist_subtract(only_non_utf8_list, cp_list,
18113                                   &only_non_utf8_list);
18114                 if (_invlist_len(only_non_utf8_list) != 0) {
18115                     anyof_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18116                 }
18117                 SvREFCNT_dec_NN(only_non_utf8_list);
18118             }
18119             else {
18120                 /* Here there were no complemented posix classes.  That means
18121                  * the upper Latin1 characters in 'posixes' match only when the
18122                  * target string is in UTF-8.  So we have to add them to the
18123                  * list of those types of code points, while adding the
18124                  * remainder to the unconditional list.
18125                  *
18126                  * First calculate what they are */
18127                 SV* nonascii_but_latin1_properties = NULL;
18128                 _invlist_intersection(posixes, PL_UpperLatin1,
18129                                       &nonascii_but_latin1_properties);
18130
18131                 /* And add them to the final list of such characters. */
18132                 _invlist_union(upper_latin1_only_utf8_matches,
18133                                nonascii_but_latin1_properties,
18134                                &upper_latin1_only_utf8_matches);
18135
18136                 /* Remove them from what now becomes the unconditional list */
18137                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
18138                                   &posixes);
18139
18140                 /* And add those unconditional ones to the final list */
18141                 if (cp_list) {
18142                     _invlist_union(cp_list, posixes, &cp_list);
18143                     SvREFCNT_dec_NN(posixes);
18144                     posixes = NULL;
18145                 }
18146                 else {
18147                     cp_list = posixes;
18148                 }
18149
18150                 SvREFCNT_dec(nonascii_but_latin1_properties);
18151
18152                 /* Get rid of any characters from the conditional list that we
18153                  * now know are matched unconditionally, which may make that
18154                  * list empty */
18155                 _invlist_subtract(upper_latin1_only_utf8_matches,
18156                                   cp_list,
18157                                   &upper_latin1_only_utf8_matches);
18158                 if (_invlist_len(upper_latin1_only_utf8_matches) == 0) {
18159                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18160                     upper_latin1_only_utf8_matches = NULL;
18161                 }
18162             }
18163         }
18164     }
18165
18166     /* And combine the result (if any) with any inversion list from properties.
18167      * The lists are kept separate up to now so that we can distinguish the two
18168      * in regards to matching above-Unicode.  A run-time warning is generated
18169      * if a Unicode property is matched against a non-Unicode code point. But,
18170      * we allow user-defined properties to match anything, without any warning,
18171      * and we also suppress the warning if there is a portion of the character
18172      * class that isn't a Unicode property, and which matches above Unicode, \W
18173      * or [\x{110000}] for example.
18174      * (Note that in this case, unlike the Posix one above, there is no
18175      * <upper_latin1_only_utf8_matches>, because having a Unicode property
18176      * forces Unicode semantics */
18177     if (properties) {
18178         if (cp_list) {
18179
18180             /* If it matters to the final outcome, see if a non-property
18181              * component of the class matches above Unicode.  If so, the
18182              * warning gets suppressed.  This is true even if just a single
18183              * such code point is specified, as, though not strictly correct if
18184              * another such code point is matched against, the fact that they
18185              * are using above-Unicode code points indicates they should know
18186              * the issues involved */
18187             if (warn_super) {
18188                 warn_super = ! (invert
18189                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
18190             }
18191
18192             _invlist_union(properties, cp_list, &cp_list);
18193             SvREFCNT_dec_NN(properties);
18194         }
18195         else {
18196             cp_list = properties;
18197         }
18198
18199         if (warn_super) {
18200             anyof_flags
18201              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18202
18203             /* Because an ANYOF node is the only one that warns, this node
18204              * can't be optimized into something else */
18205             optimizable = FALSE;
18206         }
18207     }
18208
18209     /* Here, we have calculated what code points should be in the character
18210      * class.
18211      *
18212      * Now we can see about various optimizations.  Fold calculation (which we
18213      * did above) needs to take place before inversion.  Otherwise /[^k]/i
18214      * would invert to include K, which under /i would match k, which it
18215      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
18216      * folded until runtime */
18217
18218     /* If we didn't do folding, it's because some information isn't available
18219      * until runtime; set the run-time fold flag for these  We know to set the
18220      * flag if we have a non-NULL list for UTF-8 locales, or the class matches
18221      * at least one 0-255 range code point */
18222     if (LOC && FOLD) {
18223
18224         /* Some things on the list might be unconditionally included because of
18225          * other components.  Remove them, and clean up the list if it goes to
18226          * 0 elements */
18227         if (only_utf8_locale_list && cp_list) {
18228             _invlist_subtract(only_utf8_locale_list, cp_list,
18229                               &only_utf8_locale_list);
18230
18231             if (_invlist_len(only_utf8_locale_list) == 0) {
18232                 SvREFCNT_dec_NN(only_utf8_locale_list);
18233                 only_utf8_locale_list = NULL;
18234             }
18235         }
18236         if (    only_utf8_locale_list
18237             || (cp_list && (   _invlist_contains_cp(cp_list, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
18238                             || _invlist_contains_cp(cp_list, LATIN_SMALL_LETTER_DOTLESS_I))))
18239         {
18240             has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18241             anyof_flags
18242                  |= ANYOFL_FOLD
18243                  |  ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
18244         }
18245         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
18246             UV start, end;
18247             invlist_iterinit(cp_list);
18248             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
18249                 anyof_flags |= ANYOFL_FOLD;
18250                 has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18251             }
18252             invlist_iterfinish(cp_list);
18253         }
18254     }
18255     else if (   DEPENDS_SEMANTICS
18256              && (    upper_latin1_only_utf8_matches
18257                  || (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
18258     {
18259         RExC_seen_d_op = TRUE;
18260         has_runtime_dependency |= HAS_D_RUNTIME_DEPENDENCY;
18261     }
18262
18263     /* Optimize inverted patterns (e.g. [^a-z]) when everything is known at
18264      * compile time. */
18265     if (     cp_list
18266         &&   invert
18267         && ! has_runtime_dependency)
18268     {
18269         _invlist_invert(cp_list);
18270
18271         /* Clear the invert flag since have just done it here */
18272         invert = FALSE;
18273     }
18274
18275     if (ret_invlist) {
18276         *ret_invlist = cp_list;
18277
18278         return RExC_emit;
18279     }
18280
18281     /* All possible optimizations below still have these characteristics.
18282      * (Multi-char folds aren't SIMPLE, but they don't get this far in this
18283      * routine) */
18284     *flagp |= HASWIDTH|SIMPLE;
18285
18286     if (anyof_flags & ANYOF_LOCALE_FLAGS) {
18287         RExC_contains_locale = 1;
18288     }
18289
18290     /* Some character classes are equivalent to other nodes.  Such nodes take
18291      * up less room, and some nodes require fewer operations to execute, than
18292      * ANYOF nodes.  EXACTish nodes may be joinable with adjacent nodes to
18293      * improve efficiency. */
18294
18295     if (optimizable) {
18296         PERL_UINT_FAST8_T i;
18297         Size_t partial_cp_count = 0;
18298         UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
18299         UV   end[MAX_FOLD_FROMS+1] = { 0 };
18300
18301         if (cp_list) { /* Count the code points in enough ranges that we would
18302                           see all the ones possible in any fold in this version
18303                           of Unicode */
18304
18305             invlist_iterinit(cp_list);
18306             for (i = 0; i <= MAX_FOLD_FROMS; i++) {
18307                 if (! invlist_iternext(cp_list, &start[i], &end[i])) {
18308                     break;
18309                 }
18310                 partial_cp_count += end[i] - start[i] + 1;
18311             }
18312
18313             invlist_iterfinish(cp_list);
18314         }
18315
18316         /* If we know at compile time that this matches every possible code
18317          * point, any run-time dependencies don't matter */
18318         if (start[0] == 0 && end[0] == UV_MAX) {
18319             if (invert) {
18320                 ret = reganode(pRExC_state, OPFAIL, 0);
18321             }
18322             else {
18323                 ret = reg_node(pRExC_state, SANY);
18324                 MARK_NAUGHTY(1);
18325             }
18326             goto not_anyof;
18327         }
18328
18329         /* Similarly, for /l posix classes, if both a class and its
18330          * complement match, any run-time dependencies don't matter */
18331         if (posixl) {
18332             for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX;
18333                                                         namedclass += 2)
18334             {
18335                 if (   POSIXL_TEST(posixl, namedclass)      /* class */
18336                     && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
18337                 {
18338                     if (invert) {
18339                         ret = reganode(pRExC_state, OPFAIL, 0);
18340                     }
18341                     else {
18342                         ret = reg_node(pRExC_state, SANY);
18343                         MARK_NAUGHTY(1);
18344                     }
18345                     goto not_anyof;
18346                 }
18347             }
18348             /* For well-behaved locales, some classes are subsets of others,
18349              * so complementing the subset and including the non-complemented
18350              * superset should match everything, like [\D[:alnum:]], and
18351              * [[:^alpha:][:alnum:]], but some implementations of locales are
18352              * buggy, and khw thinks its a bad idea to have optimization change
18353              * behavior, even if it avoids an OS bug in a given case */
18354
18355 #define isSINGLE_BIT_SET(n) isPOWER_OF_2(n)
18356
18357             /* If is a single posix /l class, can optimize to just that op.
18358              * Such a node will not match anything in the Latin1 range, as that
18359              * is not determinable until runtime, but will match whatever the
18360              * class does outside that range.  (Note that some classes won't
18361              * match anything outside the range, like [:ascii:]) */
18362             if (    isSINGLE_BIT_SET(posixl)
18363                 && (partial_cp_count == 0 || start[0] > 255))
18364             {
18365                 U8 classnum;
18366                 SV * class_above_latin1 = NULL;
18367                 bool already_inverted;
18368                 bool are_equivalent;
18369
18370                 /* Compute which bit is set, which is the same thing as, e.g.,
18371                  * ANYOF_CNTRL.  From
18372                  * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn
18373                  * */
18374                 static const int MultiplyDeBruijnBitPosition2[32] =
18375                     {
18376                     0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
18377                     31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
18378                     };
18379
18380                 namedclass = MultiplyDeBruijnBitPosition2[(posixl
18381                                                           * 0x077CB531U) >> 27];
18382                 classnum = namedclass_to_classnum(namedclass);
18383
18384                 /* The named classes are such that the inverted number is one
18385                  * larger than the non-inverted one */
18386                 already_inverted = namedclass
18387                                  - classnum_to_namedclass(classnum);
18388
18389                 /* Create an inversion list of the official property, inverted
18390                  * if the constructed node list is inverted, and restricted to
18391                  * only the above latin1 code points, which are the only ones
18392                  * known at compile time */
18393                 _invlist_intersection_maybe_complement_2nd(
18394                                                     PL_AboveLatin1,
18395                                                     PL_XPosix_ptrs[classnum],
18396                                                     already_inverted,
18397                                                     &class_above_latin1);
18398                 are_equivalent = _invlistEQ(class_above_latin1, cp_list,
18399                                                                         FALSE);
18400                 SvREFCNT_dec_NN(class_above_latin1);
18401
18402                 if (are_equivalent) {
18403
18404                     /* Resolve the run-time inversion flag with this possibly
18405                      * inverted class */
18406                     invert = invert ^ already_inverted;
18407
18408                     ret = reg_node(pRExC_state,
18409                                    POSIXL + invert * (NPOSIXL - POSIXL));
18410                     FLAGS(REGNODE_p(ret)) = classnum;
18411                     goto not_anyof;
18412                 }
18413             }
18414         }
18415
18416         /* khw can't think of any other possible transformation involving
18417          * these. */
18418         if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
18419             goto is_anyof;
18420         }
18421
18422         if (! has_runtime_dependency) {
18423
18424             /* If the list is empty, nothing matches.  This happens, for
18425              * example, when a Unicode property that doesn't match anything is
18426              * the only element in the character class (perluniprops.pod notes
18427              * such properties). */
18428             if (partial_cp_count == 0) {
18429                 if (invert) {
18430                     ret = reg_node(pRExC_state, SANY);
18431                 }
18432                 else {
18433                     ret = reganode(pRExC_state, OPFAIL, 0);
18434                 }
18435
18436                 goto not_anyof;
18437             }
18438
18439             /* If matches everything but \n */
18440             if (   start[0] == 0 && end[0] == '\n' - 1
18441                 && start[1] == '\n' + 1 && end[1] == UV_MAX)
18442             {
18443                 assert (! invert);
18444                 ret = reg_node(pRExC_state, REG_ANY);
18445                 MARK_NAUGHTY(1);
18446                 goto not_anyof;
18447             }
18448         }
18449
18450         /* Next see if can optimize classes that contain just a few code points
18451          * into an EXACTish node.  The reason to do this is to let the
18452          * optimizer join this node with adjacent EXACTish ones.
18453          *
18454          * An EXACTFish node can be generated even if not under /i, and vice
18455          * versa.  But care must be taken.  An EXACTFish node has to be such
18456          * that it only matches precisely the code points in the class, but we
18457          * want to generate the least restrictive one that does that, to
18458          * increase the odds of being able to join with an adjacent node.  For
18459          * example, if the class contains [kK], we have to make it an EXACTFAA
18460          * node to prevent the KELVIN SIGN from matching.  Whether we are under
18461          * /i or not is irrelevant in this case.  Less obvious is the pattern
18462          * qr/[\x{02BC}]n/i.  U+02BC is MODIFIER LETTER APOSTROPHE. That is
18463          * supposed to match the single character U+0149 LATIN SMALL LETTER N
18464          * PRECEDED BY APOSTROPHE.  And so even though there is no simple fold
18465          * that includes \X{02BC}, there is a multi-char fold that does, and so
18466          * the node generated for it must be an EXACTFish one.  On the other
18467          * hand qr/:/i should generate a plain EXACT node since the colon
18468          * participates in no fold whatsoever, and having it EXACT tells the
18469          * optimizer the target string cannot match unless it has a colon in
18470          * it.
18471          *
18472          * We don't typically generate an EXACTish node if doing so would
18473          * require changing the pattern to UTF-8, as that affects /d and
18474          * otherwise is slower.  However, under /i, not changing to UTF-8 can
18475          * miss some potential multi-character folds.  We calculate the
18476          * EXACTish node, and then decide if something would be missed if we
18477          * don't upgrade */
18478         if (   ! posixl
18479             && ! invert
18480
18481                 /* Only try if there are no more code points in the class than
18482                  * in the max possible fold */
18483             &&   partial_cp_count > 0 && partial_cp_count <= MAX_FOLD_FROMS + 1
18484
18485             && (start[0] < 256 || UTF || FOLD))
18486         {
18487             if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches)
18488             {
18489                 /* We can always make a single code point class into an
18490                  * EXACTish node. */
18491
18492                 if (LOC) {
18493
18494                     /* Here is /l:  Use EXACTL, except /li indicates EXACTFL,
18495                      * as that means there is a fold not known until runtime so
18496                      * shows as only a single code point here. */
18497                     op = (FOLD) ? EXACTFL : EXACTL;
18498                 }
18499                 else if (! FOLD) { /* Not /l and not /i */
18500                     op = (start[0] < 256) ? EXACT : EXACT_ONLY8;
18501                 }
18502                 else if (start[0] < 256) { /* /i, not /l, and the code point is
18503                                               small */
18504
18505                     /* Under /i, it gets a little tricky.  A code point that
18506                      * doesn't participate in a fold should be an EXACT node.
18507                      * We know this one isn't the result of a simple fold, or
18508                      * there'd be more than one code point in the list, but it
18509                      * could be part of a multi- character fold.  In that case
18510                      * we better not create an EXACT node, as we would wrongly
18511                      * be telling the optimizer that this code point must be in
18512                      * the target string, and that is wrong.  This is because
18513                      * if the sequence around this code point forms a
18514                      * multi-char fold, what needs to be in the string could be
18515                      * the code point that folds to the sequence.
18516                      *
18517                      * This handles the case of below-255 code points, as we
18518                      * have an easy look up for those.  The next clause handles
18519                      * the above-256 one */
18520                     op = IS_IN_SOME_FOLD_L1(start[0])
18521                          ? EXACTFU
18522                          : EXACT;
18523                 }
18524                 else {  /* /i, larger code point.  Since we are under /i, and
18525                            have just this code point, we know that it can't
18526                            fold to something else, so PL_InMultiCharFold
18527                            applies to it */
18528                     op = _invlist_contains_cp(PL_InMultiCharFold,
18529                                               start[0])
18530                          ? EXACTFU_ONLY8
18531                          : EXACT_ONLY8;
18532                 }
18533
18534                 value = start[0];
18535             }
18536             else if (  ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
18537                      && _invlist_contains_cp(PL_in_some_fold, start[0]))
18538             {
18539                 /* Here, the only runtime dependency, if any, is from /d, and
18540                  * the class matches more than one code point, and the lowest
18541                  * code point participates in some fold.  It might be that the
18542                  * other code points are /i equivalent to this one, and hence
18543                  * they would representable by an EXACTFish node.  Above, we
18544                  * eliminated classes that contain too many code points to be
18545                  * EXACTFish, with the test for MAX_FOLD_FROMS
18546                  *
18547                  * First, special case the ASCII fold pairs, like 'B' and 'b'.
18548                  * We do this because we have EXACTFAA at our disposal for the
18549                  * ASCII range */
18550                 if (partial_cp_count == 2 && isASCII(start[0])) {
18551
18552                     /* The only ASCII characters that participate in folds are
18553                      * alphabetics */
18554                     assert(isALPHA(start[0]));
18555                     if (   end[0] == start[0]   /* First range is a single
18556                                                    character, so 2nd exists */
18557                         && isALPHA_FOLD_EQ(start[0], start[1]))
18558                     {
18559
18560                         /* Here, is part of an ASCII fold pair */
18561
18562                         if (   ASCII_FOLD_RESTRICTED
18563                             || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(start[0]))
18564                         {
18565                             /* If the second clause just above was true, it
18566                              * means we can't be under /i, or else the list
18567                              * would have included more than this fold pair.
18568                              * Therefore we have to exclude the possibility of
18569                              * whatever else it is that folds to these, by
18570                              * using EXACTFAA */
18571                             op = EXACTFAA;
18572                         }
18573                         else if (HAS_NONLATIN1_FOLD_CLOSURE(start[0])) {
18574
18575                             /* Here, there's no simple fold that start[0] is part
18576                              * of, but there is a multi-character one.  If we
18577                              * are not under /i, we want to exclude that
18578                              * possibility; if under /i, we want to include it
18579                              * */
18580                             op = (FOLD) ? EXACTFU : EXACTFAA;
18581                         }
18582                         else {
18583
18584                             /* Here, the only possible fold start[0] particpates in
18585                              * is with start[1].  /i or not isn't relevant */
18586                             op = EXACTFU;
18587                         }
18588
18589                         value = toFOLD(start[0]);
18590                     }
18591                 }
18592                 else if (  ! upper_latin1_only_utf8_matches
18593                          || (   _invlist_len(upper_latin1_only_utf8_matches)
18594                                                                           == 2
18595                              && PL_fold_latin1[
18596                                invlist_highest(upper_latin1_only_utf8_matches)]
18597                              == start[0]))
18598                 {
18599                     /* Here, the smallest character is non-ascii or there are
18600                      * more than 2 code points matched by this node.  Also, we
18601                      * either don't have /d UTF-8 dependent matches, or if we
18602                      * do, they look like they could be a single character that
18603                      * is the fold of the lowest one in the always-match list.
18604                      * This test quickly excludes most of the false positives
18605                      * when there are /d UTF-8 depdendent matches.  These are
18606                      * like LATIN CAPITAL LETTER A WITH GRAVE matching LATIN
18607                      * SMALL LETTER A WITH GRAVE iff the target string is
18608                      * UTF-8.  (We don't have to worry above about exceeding
18609                      * the array bounds of PL_fold_latin1[] because any code
18610                      * point in 'upper_latin1_only_utf8_matches' is below 256.)
18611                      *
18612                      * EXACTFAA would apply only to pairs (hence exactly 2 code
18613                      * points) in the ASCII range, so we can't use it here to
18614                      * artificially restrict the fold domain, so we check if
18615                      * the class does or does not match some EXACTFish node.
18616                      * Further, if we aren't under /i, and and the folded-to
18617                      * character is part of a multi-character fold, we can't do
18618                      * this optimization, as the sequence around it could be
18619                      * that multi-character fold, and we don't here know the
18620                      * context, so we have to assume it is that multi-char
18621                      * fold, to prevent potential bugs.
18622                      *
18623                      * To do the general case, we first find the fold of the
18624                      * lowest code point (which may be higher than the lowest
18625                      * one), then find everything that folds to it.  (The data
18626                      * structure we have only maps from the folded code points,
18627                      * so we have to do the earlier step.) */
18628
18629                     Size_t foldlen;
18630                     U8 foldbuf[UTF8_MAXBYTES_CASE];
18631                     UV folded = _to_uni_fold_flags(start[0],
18632                                                         foldbuf, &foldlen, 0);
18633                     unsigned int first_fold;
18634                     const unsigned int * remaining_folds;
18635                     Size_t folds_to_this_cp_count = _inverse_folds(
18636                                                             folded,
18637                                                             &first_fold,
18638                                                             &remaining_folds);
18639                     Size_t folds_count = folds_to_this_cp_count + 1;
18640                     SV * fold_list = _new_invlist(folds_count);
18641                     unsigned int i;
18642
18643                     /* If there are UTF-8 dependent matches, create a temporary
18644                      * list of what this node matches, including them. */
18645                     SV * all_cp_list = NULL;
18646                     SV ** use_this_list = &cp_list;
18647
18648                     if (upper_latin1_only_utf8_matches) {
18649                         all_cp_list = _new_invlist(0);
18650                         use_this_list = &all_cp_list;
18651                         _invlist_union(cp_list,
18652                                        upper_latin1_only_utf8_matches,
18653                                        use_this_list);
18654                     }
18655
18656                     /* Having gotten everything that participates in the fold
18657                      * containing the lowest code point, we turn that into an
18658                      * inversion list, making sure everything is included. */
18659                     fold_list = add_cp_to_invlist(fold_list, start[0]);
18660                     fold_list = add_cp_to_invlist(fold_list, folded);
18661                     if (folds_to_this_cp_count > 0) {
18662                         fold_list = add_cp_to_invlist(fold_list, first_fold);
18663                         for (i = 0; i + 1 < folds_to_this_cp_count; i++) {
18664                             fold_list = add_cp_to_invlist(fold_list,
18665                                                         remaining_folds[i]);
18666                         }
18667                     }
18668
18669                     /* If the fold list is identical to what's in this ANYOF
18670                      * node, the node can be represented by an EXACTFish one
18671                      * instead */
18672                     if (_invlistEQ(*use_this_list, fold_list,
18673                                    0 /* Don't complement */ )
18674                     ) {
18675
18676                         /* But, we have to be careful, as mentioned above.
18677                          * Just the right sequence of characters could match
18678                          * this if it is part of a multi-character fold.  That
18679                          * IS what we want if we are under /i.  But it ISN'T
18680                          * what we want if not under /i, as it could match when
18681                          * it shouldn't.  So, when we aren't under /i and this
18682                          * character participates in a multi-char fold, we
18683                          * don't optimize into an EXACTFish node.  So, for each
18684                          * case below we have to check if we are folding
18685                          * and if not, if it is not part of a multi-char fold.
18686                          * */
18687                         if (start[0] > 255) {    /* Highish code point */
18688                             if (FOLD || ! _invlist_contains_cp(
18689                                             PL_InMultiCharFold, folded))
18690                             {
18691                                 op = (LOC)
18692                                      ? EXACTFLU8
18693                                      : (ASCII_FOLD_RESTRICTED)
18694                                        ? EXACTFAA
18695                                        : EXACTFU_ONLY8;
18696                                 value = folded;
18697                             }
18698                         }   /* Below, the lowest code point < 256 */
18699                         else if (    FOLD
18700                                  &&  folded == 's'
18701                                  &&  DEPENDS_SEMANTICS)
18702                         {   /* An EXACTF node containing a single character
18703                                 's', can be an EXACTFU if it doesn't get
18704                                 joined with an adjacent 's' */
18705                             op = EXACTFU_S_EDGE;
18706                             value = folded;
18707                         }
18708                         else if (    FOLD
18709                                 || ! HAS_NONLATIN1_FOLD_CLOSURE(start[0]))
18710                         {
18711                             if (upper_latin1_only_utf8_matches) {
18712                                 op = EXACTF;
18713
18714                                 /* We can't use the fold, as that only matches
18715                                  * under UTF-8 */
18716                                 value = start[0];
18717                             }
18718                             else if (     UNLIKELY(start[0] == MICRO_SIGN)
18719                                      && ! UTF)
18720                             {   /* EXACTFUP is a special node for this
18721                                    character */
18722                                 op = (ASCII_FOLD_RESTRICTED)
18723                                      ? EXACTFAA
18724                                      : EXACTFUP;
18725                                 value = MICRO_SIGN;
18726                             }
18727                             else if (     ASCII_FOLD_RESTRICTED
18728                                      && ! isASCII(start[0]))
18729                             {   /* For ASCII under /iaa, we can use EXACTFU
18730                                    below */
18731                                 op = EXACTFAA;
18732                                 value = folded;
18733                             }
18734                             else {
18735                                 op = EXACTFU;
18736                                 value = folded;
18737                             }
18738                         }
18739                     }
18740
18741                     SvREFCNT_dec_NN(fold_list);
18742                     SvREFCNT_dec(all_cp_list);
18743                 }
18744             }
18745
18746             if (op != END) {
18747
18748                 /* Here, we have calculated what EXACTish node we would use.
18749                  * But we don't use it if it would require converting the
18750                  * pattern to UTF-8, unless not using it could cause us to miss
18751                  * some folds (hence be buggy) */
18752
18753                 if (! UTF && value > 255) {
18754                     SV * in_multis = NULL;
18755
18756                     assert(FOLD);
18757
18758                     /* If there is no code point that is part of a multi-char
18759                      * fold, then there aren't any matches, so we don't do this
18760                      * optimization.  Otherwise, it could match depending on
18761                      * the context around us, so we do upgrade */
18762                     _invlist_intersection(PL_InMultiCharFold, cp_list, &in_multis);
18763                     if (UNLIKELY(_invlist_len(in_multis) != 0)) {
18764                         REQUIRE_UTF8(flagp);
18765                     }
18766                     else {
18767                         op = END;
18768                     }
18769                 }
18770
18771                 if (op != END) {
18772                     U8 len = (UTF) ? UVCHR_SKIP(value) : 1;
18773
18774                     ret = regnode_guts(pRExC_state, op, len, "exact");
18775                     FILL_NODE(ret, op);
18776                     RExC_emit += 1 + STR_SZ(len);
18777                     STR_LEN(REGNODE_p(ret)) = len;
18778                     if (len == 1) {
18779                         *STRING(REGNODE_p(ret)) = (U8) value;
18780                     }
18781                     else {
18782                         uvchr_to_utf8((U8 *) STRING(REGNODE_p(ret)), value);
18783                     }
18784                     goto not_anyof;
18785                 }
18786             }
18787         }
18788
18789         if (! has_runtime_dependency) {
18790
18791             /* See if this can be turned into an ANYOFM node.  Think about the
18792              * bit patterns in two different bytes.  In some positions, the
18793              * bits in each will be 1; and in other positions both will be 0;
18794              * and in some positions the bit will be 1 in one byte, and 0 in
18795              * the other.  Let 'n' be the number of positions where the bits
18796              * differ.  We create a mask which has exactly 'n' 0 bits, each in
18797              * a position where the two bytes differ.  Now take the set of all
18798              * bytes that when ANDed with the mask yield the same result.  That
18799              * set has 2**n elements, and is representable by just two 8 bit
18800              * numbers: the result and the mask.  Importantly, matching the set
18801              * can be vectorized by creating a word full of the result bytes,
18802              * and a word full of the mask bytes, yielding a significant speed
18803              * up.  Here, see if this node matches such a set.  As a concrete
18804              * example consider [01], and the byte representing '0' which is
18805              * 0x30 on ASCII machines.  It has the bits 0011 0000.  Take the
18806              * mask 1111 1110.  If we AND 0x31 and 0x30 with that mask we get
18807              * 0x30.  Any other bytes ANDed yield something else.  So [01],
18808              * which is a common usage, is optimizable into ANYOFM, and can
18809              * benefit from the speed up.  We can only do this on UTF-8
18810              * invariant bytes, because they have the same bit patterns under
18811              * UTF-8 as not. */
18812             PERL_UINT_FAST8_T inverted = 0;
18813 #ifdef EBCDIC
18814             const PERL_UINT_FAST8_T max_permissible = 0xFF;
18815 #else
18816             const PERL_UINT_FAST8_T max_permissible = 0x7F;
18817 #endif
18818             /* If doesn't fit the criteria for ANYOFM, invert and try again.
18819              * If that works we will instead later generate an NANYOFM, and
18820              * invert back when through */
18821             if (invlist_highest(cp_list) > max_permissible) {
18822                 _invlist_invert(cp_list);
18823                 inverted = 1;
18824             }
18825
18826             if (invlist_highest(cp_list) <= max_permissible) {
18827                 UV this_start, this_end;
18828                 UV lowest_cp = UV_MAX;  /* inited to suppress compiler warn */
18829                 U8 bits_differing = 0;
18830                 Size_t full_cp_count = 0;
18831                 bool first_time = TRUE;
18832
18833                 /* Go through the bytes and find the bit positions that differ
18834                  * */
18835                 invlist_iterinit(cp_list);
18836                 while (invlist_iternext(cp_list, &this_start, &this_end)) {
18837                     unsigned int i = this_start;
18838
18839                     if (first_time) {
18840                         if (! UVCHR_IS_INVARIANT(i)) {
18841                             goto done_anyofm;
18842                         }
18843
18844                         first_time = FALSE;
18845                         lowest_cp = this_start;
18846
18847                         /* We have set up the code point to compare with.
18848                          * Don't compare it with itself */
18849                         i++;
18850                     }
18851
18852                     /* Find the bit positions that differ from the lowest code
18853                      * point in the node.  Keep track of all such positions by
18854                      * OR'ing */
18855                     for (; i <= this_end; i++) {
18856                         if (! UVCHR_IS_INVARIANT(i)) {
18857                             goto done_anyofm;
18858                         }
18859
18860                         bits_differing  |= i ^ lowest_cp;
18861                     }
18862
18863                     full_cp_count += this_end - this_start + 1;
18864                 }
18865                 invlist_iterfinish(cp_list);
18866
18867                 /* At the end of the loop, we count how many bits differ from
18868                  * the bits in lowest code point, call the count 'd'.  If the
18869                  * set we found contains 2**d elements, it is the closure of
18870                  * all code points that differ only in those bit positions.  To
18871                  * convince yourself of that, first note that the number in the
18872                  * closure must be a power of 2, which we test for.  The only
18873                  * way we could have that count and it be some differing set,
18874                  * is if we got some code points that don't differ from the
18875                  * lowest code point in any position, but do differ from each
18876                  * other in some other position.  That means one code point has
18877                  * a 1 in that position, and another has a 0.  But that would
18878                  * mean that one of them differs from the lowest code point in
18879                  * that position, which possibility we've already excluded.  */
18880                 if (  (inverted || full_cp_count > 1)
18881                     && full_cp_count == 1U << PL_bitcount[bits_differing])
18882                 {
18883                     U8 ANYOFM_mask;
18884
18885                     op = ANYOFM + inverted;;
18886
18887                     /* We need to make the bits that differ be 0's */
18888                     ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
18889
18890                     /* The argument is the lowest code point */
18891                     ret = reganode(pRExC_state, op, lowest_cp);
18892                     FLAGS(REGNODE_p(ret)) = ANYOFM_mask;
18893                 }
18894             }
18895           done_anyofm:
18896
18897             if (inverted) {
18898                 _invlist_invert(cp_list);
18899             }
18900
18901             if (op != END) {
18902                 goto not_anyof;
18903             }
18904         }
18905
18906         if (! (anyof_flags & ANYOF_LOCALE_FLAGS)) {
18907             PERL_UINT_FAST8_T type;
18908             SV * intersection = NULL;
18909             SV* d_invlist = NULL;
18910
18911             /* See if this matches any of the POSIX classes.  The POSIXA and
18912              * POSIXD ones are about the same speed as ANYOF ops, but take less
18913              * room; the ones that have above-Latin1 code point matches are
18914              * somewhat faster than ANYOF.  */
18915
18916             for (type = POSIXA; type >= POSIXD; type--) {
18917                 int posix_class;
18918
18919                 if (type == POSIXL) {   /* But not /l posix classes */
18920                     continue;
18921                 }
18922
18923                 for (posix_class = 0;
18924                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
18925                      posix_class++)
18926                 {
18927                     SV** our_code_points = &cp_list;
18928                     SV** official_code_points;
18929                     int try_inverted;
18930
18931                     if (type == POSIXA) {
18932                         official_code_points = &PL_Posix_ptrs[posix_class];
18933                     }
18934                     else {
18935                         official_code_points = &PL_XPosix_ptrs[posix_class];
18936                     }
18937
18938                     /* Skip non-existent classes of this type.  e.g. \v only
18939                      * has an entry in PL_XPosix_ptrs */
18940                     if (! *official_code_points) {
18941                         continue;
18942                     }
18943
18944                     /* Try both the regular class, and its inversion */
18945                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
18946                         bool this_inverted = invert ^ try_inverted;
18947
18948                         if (type != POSIXD) {
18949
18950                             /* This class that isn't /d can't match if we have
18951                              * /d dependencies */
18952                             if (has_runtime_dependency
18953                                                     & HAS_D_RUNTIME_DEPENDENCY)
18954                             {
18955                                 continue;
18956                             }
18957                         }
18958                         else /* is /d */ if (! this_inverted) {
18959
18960                             /* /d classes don't match anything non-ASCII below
18961                              * 256 unconditionally (which cp_list contains) */
18962                             _invlist_intersection(cp_list, PL_UpperLatin1,
18963                                                            &intersection);
18964                             if (_invlist_len(intersection) != 0) {
18965                                 continue;
18966                             }
18967
18968                             SvREFCNT_dec(d_invlist);
18969                             d_invlist = invlist_clone(cp_list, NULL);
18970
18971                             /* But under UTF-8 it turns into using /u rules.
18972                              * Add the things it matches under these conditions
18973                              * so that we check below that these are identical
18974                              * to what the tested class should match */
18975                             if (upper_latin1_only_utf8_matches) {
18976                                 _invlist_union(
18977                                             d_invlist,
18978                                             upper_latin1_only_utf8_matches,
18979                                             &d_invlist);
18980                             }
18981                             our_code_points = &d_invlist;
18982                         }
18983                         else {  /* POSIXD, inverted.  If this doesn't have this
18984                                    flag set, it isn't /d. */
18985                             if (! (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
18986                             {
18987                                 continue;
18988                             }
18989                             our_code_points = &cp_list;
18990                         }
18991
18992                         /* Here, have weeded out some things.  We want to see
18993                          * if the list of characters this node contains
18994                          * ('*our_code_points') precisely matches those of the
18995                          * class we are currently checking against
18996                          * ('*official_code_points'). */
18997                         if (_invlistEQ(*our_code_points,
18998                                        *official_code_points,
18999                                        try_inverted))
19000                         {
19001                             /* Here, they precisely match.  Optimize this ANYOF
19002                              * node into its equivalent POSIX one of the
19003                              * correct type, possibly inverted */
19004                             ret = reg_node(pRExC_state, (try_inverted)
19005                                                         ? type + NPOSIXA
19006                                                                 - POSIXA
19007                                                         : type);
19008                             FLAGS(REGNODE_p(ret)) = posix_class;
19009                             SvREFCNT_dec(d_invlist);
19010                             SvREFCNT_dec(intersection);
19011                             goto not_anyof;
19012                         }
19013                     }
19014                 }
19015             }
19016             SvREFCNT_dec(d_invlist);
19017             SvREFCNT_dec(intersection);
19018         }
19019
19020         /* If didn't find an optimization and there is no need for a
19021         * bitmap, optimize to indicate that */
19022         if (     start[0] >= NUM_ANYOF_CODE_POINTS
19023             && ! LOC
19024             && ! upper_latin1_only_utf8_matches
19025             &&   anyof_flags == 0)
19026         {
19027             UV highest_cp = invlist_highest(cp_list);
19028
19029             /* If the lowest and highest code point in the class have the same
19030              * UTF-8 first byte, then all do, and we can store that byte for
19031              * regexec.c to use so that it can more quickly scan the target
19032              * string for potential matches for this class.  We co-opt the
19033              * flags field for this, and make the node ANYOFb.  We do accept
19034              * here very large code points (for future use), but don't do
19035              * this optimization for them, as it would cause other
19036              * complications */
19037             op = ANYOFH;
19038             if (highest_cp <= IV_MAX) {
19039                 U8 low_utf8[UTF8_MAXBYTES+1];
19040                 U8 high_utf8[UTF8_MAXBYTES+1];
19041
19042                 (void) uvchr_to_utf8(low_utf8, start[0]);
19043                 (void) uvchr_to_utf8(high_utf8, invlist_highest(cp_list));
19044
19045                 if (low_utf8[0] == high_utf8[0]) {
19046                     anyof_flags = low_utf8[0];
19047                     op = ANYOFHb;
19048                 }
19049             }
19050
19051             goto done_finding_op;
19052         }
19053     }   /* End of seeing if can optimize it into a different node */
19054
19055   is_anyof: /* It's going to be an ANYOF node. */
19056     op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
19057          ? ANYOFD
19058          : ((posixl)
19059             ? ANYOFPOSIXL
19060             : ((LOC)
19061                ? ANYOFL
19062                : ANYOF));
19063
19064   done_finding_op:
19065
19066     ret = regnode_guts(pRExC_state, op, regarglen[op], "anyof");
19067     FILL_NODE(ret, op);        /* We set the argument later */
19068     RExC_emit += 1 + regarglen[op];
19069     ANYOF_FLAGS(REGNODE_p(ret)) = anyof_flags;
19070
19071     /* Here, <cp_list> contains all the code points we can determine at
19072      * compile time that match under all conditions.  Go through it, and
19073      * for things that belong in the bitmap, put them there, and delete from
19074      * <cp_list>.  While we are at it, see if everything above 255 is in the
19075      * list, and if so, set a flag to speed up execution */
19076
19077     populate_ANYOF_from_invlist(REGNODE_p(ret), &cp_list);
19078
19079     if (posixl) {
19080         ANYOF_POSIXL_SET_TO_BITMAP(REGNODE_p(ret), posixl);
19081     }
19082
19083     if (invert) {
19084         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_INVERT;
19085     }
19086
19087     /* Here, the bitmap has been populated with all the Latin1 code points that
19088      * always match.  Can now add to the overall list those that match only
19089      * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>).
19090      * */
19091     if (upper_latin1_only_utf8_matches) {
19092         if (cp_list) {
19093             _invlist_union(cp_list,
19094                            upper_latin1_only_utf8_matches,
19095                            &cp_list);
19096             SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
19097         }
19098         else {
19099             cp_list = upper_latin1_only_utf8_matches;
19100         }
19101         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
19102     }
19103
19104     set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
19105                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
19106                    ? listsv : NULL,
19107                   only_utf8_locale_list);
19108     return ret;
19109
19110   not_anyof:
19111
19112     /* Here, the node is getting optimized into something that's not an ANYOF
19113      * one.  Finish up. */
19114
19115     Set_Node_Offset_Length(REGNODE_p(ret), orig_parse - RExC_start,
19116                                            RExC_parse - orig_parse);;
19117     SvREFCNT_dec(cp_list);;
19118     return ret;
19119 }
19120
19121 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
19122
19123 STATIC void
19124 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
19125                 regnode* const node,
19126                 SV* const cp_list,
19127                 SV* const runtime_defns,
19128                 SV* const only_utf8_locale_list)
19129 {
19130     /* Sets the arg field of an ANYOF-type node 'node', using information about
19131      * the node passed-in.  If there is nothing outside the node's bitmap, the
19132      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
19133      * the count returned by add_data(), having allocated and stored an array,
19134      * av, as follows:
19135      *
19136      *  av[0] stores the inversion list defining this class as far as known at
19137      *        this time, or PL_sv_undef if nothing definite is now known.
19138      *  av[1] stores the inversion list of code points that match only if the
19139      *        current locale is UTF-8, or if none, PL_sv_undef if there is an
19140      *        av[2], or no entry otherwise.
19141      *  av[2] stores the list of user-defined properties whose subroutine
19142      *        definitions aren't known at this time, or no entry if none. */
19143
19144     UV n;
19145
19146     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
19147
19148     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
19149         assert(! (ANYOF_FLAGS(node)
19150                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
19151         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
19152     }
19153     else {
19154         AV * const av = newAV();
19155         SV *rv;
19156
19157         if (cp_list) {
19158             av_store(av, INVLIST_INDEX, cp_list);
19159         }
19160
19161         if (only_utf8_locale_list) {
19162             av_store(av, ONLY_LOCALE_MATCHES_INDEX, only_utf8_locale_list);
19163         }
19164
19165         if (runtime_defns) {
19166             av_store(av, DEFERRED_USER_DEFINED_INDEX, SvREFCNT_inc(runtime_defns));
19167         }
19168
19169         rv = newRV_noinc(MUTABLE_SV(av));
19170         n = add_data(pRExC_state, STR_WITH_LEN("s"));
19171         RExC_rxi->data->data[n] = (void*)rv;
19172         ARG_SET(node, n);
19173     }
19174 }
19175
19176 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
19177 SV *
19178 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
19179                                         const regnode* node,
19180                                         bool doinit,
19181                                         SV** listsvp,
19182                                         SV** only_utf8_locale_ptr,
19183                                         SV** output_invlist)
19184
19185 {
19186     /* For internal core use only.
19187      * Returns the inversion list for the input 'node' in the regex 'prog'.
19188      * If <doinit> is 'true', will attempt to create the inversion list if not
19189      *    already done.
19190      * If <listsvp> is non-null, will return the printable contents of the
19191      *    property definition.  This can be used to get debugging information
19192      *    even before the inversion list exists, by calling this function with
19193      *    'doinit' set to false, in which case the components that will be used
19194      *    to eventually create the inversion list are returned  (in a printable
19195      *    form).
19196      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
19197      *    store an inversion list of code points that should match only if the
19198      *    execution-time locale is a UTF-8 one.
19199      * If <output_invlist> is not NULL, it is where this routine is to store an
19200      *    inversion list of the code points that would be instead returned in
19201      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
19202      *    when this parameter is used, is just the non-code point data that
19203      *    will go into creating the inversion list.  This currently should be just
19204      *    user-defined properties whose definitions were not known at compile
19205      *    time.  Using this parameter allows for easier manipulation of the
19206      *    inversion list's data by the caller.  It is illegal to call this
19207      *    function with this parameter set, but not <listsvp>
19208      *
19209      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
19210      * that, in spite of this function's name, the inversion list it returns
19211      * may include the bitmap data as well */
19212
19213     SV *si  = NULL;         /* Input initialization string */
19214     SV* invlist = NULL;
19215
19216     RXi_GET_DECL(prog, progi);
19217     const struct reg_data * const data = prog ? progi->data : NULL;
19218
19219     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
19220     assert(! output_invlist || listsvp);
19221
19222     if (data && data->count) {
19223         const U32 n = ARG(node);
19224
19225         if (data->what[n] == 's') {
19226             SV * const rv = MUTABLE_SV(data->data[n]);
19227             AV * const av = MUTABLE_AV(SvRV(rv));
19228             SV **const ary = AvARRAY(av);
19229
19230             invlist = ary[INVLIST_INDEX];
19231
19232             if (av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX) {
19233                 *only_utf8_locale_ptr = ary[ONLY_LOCALE_MATCHES_INDEX];
19234             }
19235
19236             if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
19237                 si = ary[DEFERRED_USER_DEFINED_INDEX];
19238             }
19239
19240             if (doinit && (si || invlist)) {
19241                 if (si) {
19242                     bool user_defined;
19243                     SV * msg = newSVpvs_flags("", SVs_TEMP);
19244
19245                     SV * prop_definition = handle_user_defined_property(
19246                             "", 0, FALSE,   /* There is no \p{}, \P{} */
19247                             SvPVX_const(si)[1] - '0',   /* /i or not has been
19248                                                            stored here for just
19249                                                            this occasion */
19250                             TRUE,           /* run time */
19251                             FALSE,          /* This call must find the defn */
19252                             si,             /* The property definition  */
19253                             &user_defined,
19254                             msg,
19255                             0               /* base level call */
19256                            );
19257
19258                     if (SvCUR(msg)) {
19259                         assert(prop_definition == NULL);
19260
19261                         Perl_croak(aTHX_ "%" UTF8f,
19262                                 UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg)));
19263                     }
19264
19265                     if (invlist) {
19266                         _invlist_union(invlist, prop_definition, &invlist);
19267                         SvREFCNT_dec_NN(prop_definition);
19268                     }
19269                     else {
19270                         invlist = prop_definition;
19271                     }
19272
19273                     STATIC_ASSERT_STMT(ONLY_LOCALE_MATCHES_INDEX == 1 + INVLIST_INDEX);
19274                     STATIC_ASSERT_STMT(DEFERRED_USER_DEFINED_INDEX == 1 + ONLY_LOCALE_MATCHES_INDEX);
19275
19276                     av_store(av, INVLIST_INDEX, invlist);
19277                     av_fill(av, (ary[ONLY_LOCALE_MATCHES_INDEX])
19278                                  ? ONLY_LOCALE_MATCHES_INDEX:
19279                                  INVLIST_INDEX);
19280                     si = NULL;
19281                 }
19282             }
19283         }
19284     }
19285
19286     /* If requested, return a printable version of what this ANYOF node matches
19287      * */
19288     if (listsvp) {
19289         SV* matches_string = NULL;
19290
19291         /* This function can be called at compile-time, before everything gets
19292          * resolved, in which case we return the currently best available
19293          * information, which is the string that will eventually be used to do
19294          * that resolving, 'si' */
19295         if (si) {
19296             /* Here, we only have 'si' (and possibly some passed-in data in
19297              * 'invlist', which is handled below)  If the caller only wants
19298              * 'si', use that.  */
19299             if (! output_invlist) {
19300                 matches_string = newSVsv(si);
19301             }
19302             else {
19303                 /* But if the caller wants an inversion list of the node, we
19304                  * need to parse 'si' and place as much as possible in the
19305                  * desired output inversion list, making 'matches_string' only
19306                  * contain the currently unresolvable things */
19307                 const char *si_string = SvPVX(si);
19308                 STRLEN remaining = SvCUR(si);
19309                 UV prev_cp = 0;
19310                 U8 count = 0;
19311
19312                 /* Ignore everything before the first new-line */
19313                 while (*si_string != '\n' && remaining > 0) {
19314                     si_string++;
19315                     remaining--;
19316                 }
19317                 assert(remaining > 0);
19318
19319                 si_string++;
19320                 remaining--;
19321
19322                 while (remaining > 0) {
19323
19324                     /* The data consists of just strings defining user-defined
19325                      * property names, but in prior incarnations, and perhaps
19326                      * somehow from pluggable regex engines, it could still
19327                      * hold hex code point definitions.  Each component of a
19328                      * range would be separated by a tab, and each range by a
19329                      * new-line.  If these are found, instead add them to the
19330                      * inversion list */
19331                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
19332                                      |PERL_SCAN_SILENT_NON_PORTABLE;
19333                     STRLEN len = remaining;
19334                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
19335
19336                     /* If the hex decode routine found something, it should go
19337                      * up to the next \n */
19338                     if (   *(si_string + len) == '\n') {
19339                         if (count) {    /* 2nd code point on line */
19340                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
19341                         }
19342                         else {
19343                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
19344                         }
19345                         count = 0;
19346                         goto prepare_for_next_iteration;
19347                     }
19348
19349                     /* If the hex decode was instead for the lower range limit,
19350                      * save it, and go parse the upper range limit */
19351                     if (*(si_string + len) == '\t') {
19352                         assert(count == 0);
19353
19354                         prev_cp = cp;
19355                         count = 1;
19356                       prepare_for_next_iteration:
19357                         si_string += len + 1;
19358                         remaining -= len + 1;
19359                         continue;
19360                     }
19361
19362                     /* Here, didn't find a legal hex number.  Just add it from
19363                      * here to the next \n */
19364
19365                     remaining -= len;
19366                     while (*(si_string + len) != '\n' && remaining > 0) {
19367                         remaining--;
19368                         len++;
19369                     }
19370                     if (*(si_string + len) == '\n') {
19371                         len++;
19372                         remaining--;
19373                     }
19374                     if (matches_string) {
19375                         sv_catpvn(matches_string, si_string, len - 1);
19376                     }
19377                     else {
19378                         matches_string = newSVpvn(si_string, len - 1);
19379                     }
19380                     si_string += len;
19381                     sv_catpvs(matches_string, " ");
19382                 } /* end of loop through the text */
19383
19384                 assert(matches_string);
19385                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
19386                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
19387                 }
19388             } /* end of has an 'si' */
19389         }
19390
19391         /* Add the stuff that's already known */
19392         if (invlist) {
19393
19394             /* Again, if the caller doesn't want the output inversion list, put
19395              * everything in 'matches-string' */
19396             if (! output_invlist) {
19397                 if ( ! matches_string) {
19398                     matches_string = newSVpvs("\n");
19399                 }
19400                 sv_catsv(matches_string, invlist_contents(invlist,
19401                                                   TRUE /* traditional style */
19402                                                   ));
19403             }
19404             else if (! *output_invlist) {
19405                 *output_invlist = invlist_clone(invlist, NULL);
19406             }
19407             else {
19408                 _invlist_union(*output_invlist, invlist, output_invlist);
19409             }
19410         }
19411
19412         *listsvp = matches_string;
19413     }
19414
19415     return invlist;
19416 }
19417 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
19418
19419 /* reg_skipcomment()
19420
19421    Absorbs an /x style # comment from the input stream,
19422    returning a pointer to the first character beyond the comment, or if the
19423    comment terminates the pattern without anything following it, this returns
19424    one past the final character of the pattern (in other words, RExC_end) and
19425    sets the REG_RUN_ON_COMMENT_SEEN flag.
19426
19427    Note it's the callers responsibility to ensure that we are
19428    actually in /x mode
19429
19430 */
19431
19432 PERL_STATIC_INLINE char*
19433 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
19434 {
19435     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
19436
19437     assert(*p == '#');
19438
19439     while (p < RExC_end) {
19440         if (*(++p) == '\n') {
19441             return p+1;
19442         }
19443     }
19444
19445     /* we ran off the end of the pattern without ending the comment, so we have
19446      * to add an \n when wrapping */
19447     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
19448     return p;
19449 }
19450
19451 STATIC void
19452 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
19453                                 char ** p,
19454                                 const bool force_to_xmod
19455                          )
19456 {
19457     /* If the text at the current parse position '*p' is a '(?#...)' comment,
19458      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
19459      * is /x whitespace, advance '*p' so that on exit it points to the first
19460      * byte past all such white space and comments */
19461
19462     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
19463
19464     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
19465
19466     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
19467
19468     for (;;) {
19469         if (RExC_end - (*p) >= 3
19470             && *(*p)     == '('
19471             && *(*p + 1) == '?'
19472             && *(*p + 2) == '#')
19473         {
19474             while (*(*p) != ')') {
19475                 if ((*p) == RExC_end)
19476                     FAIL("Sequence (?#... not terminated");
19477                 (*p)++;
19478             }
19479             (*p)++;
19480             continue;
19481         }
19482
19483         if (use_xmod) {
19484             const char * save_p = *p;
19485             while ((*p) < RExC_end) {
19486                 STRLEN len;
19487                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
19488                     (*p) += len;
19489                 }
19490                 else if (*(*p) == '#') {
19491                     (*p) = reg_skipcomment(pRExC_state, (*p));
19492                 }
19493                 else {
19494                     break;
19495                 }
19496             }
19497             if (*p != save_p) {
19498                 continue;
19499             }
19500         }
19501
19502         break;
19503     }
19504
19505     return;
19506 }
19507
19508 /* nextchar()
19509
19510    Advances the parse position by one byte, unless that byte is the beginning
19511    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
19512    those two cases, the parse position is advanced beyond all such comments and
19513    white space.
19514
19515    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
19516 */
19517
19518 STATIC void
19519 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
19520 {
19521     PERL_ARGS_ASSERT_NEXTCHAR;
19522
19523     if (RExC_parse < RExC_end) {
19524         assert(   ! UTF
19525                || UTF8_IS_INVARIANT(*RExC_parse)
19526                || UTF8_IS_START(*RExC_parse));
19527
19528         RExC_parse += (UTF)
19529                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
19530                       : 1;
19531
19532         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
19533                                 FALSE /* Don't force /x */ );
19534     }
19535 }
19536
19537 STATIC void
19538 S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const Ptrdiff_t size)
19539 {
19540     /* 'size' is the delta to add or subtract from the current memory allocated
19541      * to the regex engine being constructed */
19542
19543     PERL_ARGS_ASSERT_CHANGE_ENGINE_SIZE;
19544
19545     RExC_size += size;
19546
19547     Renewc(RExC_rxi,
19548            sizeof(regexp_internal) + (RExC_size + 1) * sizeof(regnode),
19549                                                 /* +1 for REG_MAGIC */
19550            char,
19551            regexp_internal);
19552     if ( RExC_rxi == NULL )
19553         FAIL("Regexp out of space");
19554     RXi_SET(RExC_rx, RExC_rxi);
19555
19556     RExC_emit_start = RExC_rxi->program;
19557     if (size > 0) {
19558         Zero(REGNODE_p(RExC_emit), size, regnode);
19559     }
19560
19561 #ifdef RE_TRACK_PATTERN_OFFSETS
19562     Renew(RExC_offsets, 2*RExC_size+1, U32);
19563     if (size > 0) {
19564         Zero(RExC_offsets + 2*(RExC_size - size) + 1, 2 * size, U32);
19565     }
19566     RExC_offsets[0] = RExC_size;
19567 #endif
19568 }
19569
19570 STATIC regnode_offset
19571 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
19572 {
19573     /* Allocate a regnode for 'op', with 'extra_size' extra space.  It aligns
19574      * and increments RExC_size and RExC_emit
19575      *
19576      * It returns the regnode's offset into the regex engine program */
19577
19578     const regnode_offset ret = RExC_emit;
19579
19580     GET_RE_DEBUG_FLAGS_DECL;
19581
19582     PERL_ARGS_ASSERT_REGNODE_GUTS;
19583
19584     SIZE_ALIGN(RExC_size);
19585     change_engine_size(pRExC_state, (Ptrdiff_t) 1 + extra_size);
19586     NODE_ALIGN_FILL(REGNODE_p(ret));
19587 #ifndef RE_TRACK_PATTERN_OFFSETS
19588     PERL_UNUSED_ARG(name);
19589     PERL_UNUSED_ARG(op);
19590 #else
19591     assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF);
19592
19593     if (RExC_offsets) {         /* MJD */
19594         MJD_OFFSET_DEBUG(
19595               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
19596               name, __LINE__,
19597               PL_reg_name[op],
19598               (UV)(RExC_emit) > RExC_offsets[0]
19599                 ? "Overwriting end of array!\n" : "OK",
19600               (UV)(RExC_emit),
19601               (UV)(RExC_parse - RExC_start),
19602               (UV)RExC_offsets[0]));
19603         Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END));
19604     }
19605 #endif
19606     return(ret);
19607 }
19608
19609 /*
19610 - reg_node - emit a node
19611 */
19612 STATIC regnode_offset /* Location. */
19613 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
19614 {
19615     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
19616     regnode_offset ptr = ret;
19617
19618     PERL_ARGS_ASSERT_REG_NODE;
19619
19620     assert(regarglen[op] == 0);
19621
19622     FILL_ADVANCE_NODE(ptr, op);
19623     RExC_emit = ptr;
19624     return(ret);
19625 }
19626
19627 /*
19628 - reganode - emit a node with an argument
19629 */
19630 STATIC regnode_offset /* Location. */
19631 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
19632 {
19633     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
19634     regnode_offset ptr = ret;
19635
19636     PERL_ARGS_ASSERT_REGANODE;
19637
19638     /* ANYOF are special cased to allow non-length 1 args */
19639     assert(regarglen[op] == 1);
19640
19641     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
19642     RExC_emit = ptr;
19643     return(ret);
19644 }
19645
19646 STATIC regnode_offset
19647 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
19648 {
19649     /* emit a node with U32 and I32 arguments */
19650
19651     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
19652     regnode_offset ptr = ret;
19653
19654     PERL_ARGS_ASSERT_REG2LANODE;
19655
19656     assert(regarglen[op] == 2);
19657
19658     FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
19659     RExC_emit = ptr;
19660     return(ret);
19661 }
19662
19663 /*
19664 - reginsert - insert an operator in front of already-emitted operand
19665 *
19666 * That means that on exit 'operand' is the offset of the newly inserted
19667 * operator, and the original operand has been relocated.
19668 *
19669 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
19670 * set up NEXT_OFF() of the inserted node if needed. Something like this:
19671 *
19672 *   reginsert(pRExC, OPFAIL, orig_emit, depth+1);
19673 *   NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
19674 *
19675 * ALSO NOTE - FLAGS(newly-inserted-operator) will be set to 0 as well.
19676 */
19677 STATIC void
19678 S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op,
19679                   const regnode_offset operand, const U32 depth)
19680 {
19681     regnode *src;
19682     regnode *dst;
19683     regnode *place;
19684     const int offset = regarglen[(U8)op];
19685     const int size = NODE_STEP_REGNODE + offset;
19686     GET_RE_DEBUG_FLAGS_DECL;
19687
19688     PERL_ARGS_ASSERT_REGINSERT;
19689     PERL_UNUSED_CONTEXT;
19690     PERL_UNUSED_ARG(depth);
19691 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
19692     DEBUG_PARSE_FMT("inst"," - %s", PL_reg_name[op]);
19693     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
19694                                     studying. If this is wrong then we need to adjust RExC_recurse
19695                                     below like we do with RExC_open_parens/RExC_close_parens. */
19696     change_engine_size(pRExC_state, (Ptrdiff_t) size);
19697     src = REGNODE_p(RExC_emit);
19698     RExC_emit += size;
19699     dst = REGNODE_p(RExC_emit);
19700
19701     /* If we are in a "count the parentheses" pass, the numbers are unreliable,
19702      * and [perl #133871] shows this can lead to problems, so skip this
19703      * realignment of parens until a later pass when they are reliable */
19704     if (! IN_PARENS_PASS && RExC_open_parens) {
19705         int paren;
19706         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
19707         /* remember that RExC_npar is rex->nparens + 1,
19708          * iow it is 1 more than the number of parens seen in
19709          * the pattern so far. */
19710         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
19711             /* note, RExC_open_parens[0] is the start of the
19712              * regex, it can't move. RExC_close_parens[0] is the end
19713              * of the regex, it *can* move. */
19714             if ( paren && RExC_open_parens[paren] >= operand ) {
19715                 /*DEBUG_PARSE_FMT("open"," - %d", size);*/
19716                 RExC_open_parens[paren] += size;
19717             } else {
19718                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
19719             }
19720             if ( RExC_close_parens[paren] >= operand ) {
19721                 /*DEBUG_PARSE_FMT("close"," - %d", size);*/
19722                 RExC_close_parens[paren] += size;
19723             } else {
19724                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
19725             }
19726         }
19727     }
19728     if (RExC_end_op)
19729         RExC_end_op += size;
19730
19731     while (src > REGNODE_p(operand)) {
19732         StructCopy(--src, --dst, regnode);
19733 #ifdef RE_TRACK_PATTERN_OFFSETS
19734         if (RExC_offsets) {     /* MJD 20010112 */
19735             MJD_OFFSET_DEBUG(
19736                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
19737                   "reginsert",
19738                   __LINE__,
19739                   PL_reg_name[op],
19740                   (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0]
19741                     ? "Overwriting end of array!\n" : "OK",
19742                   (UV)REGNODE_OFFSET(src),
19743                   (UV)REGNODE_OFFSET(dst),
19744                   (UV)RExC_offsets[0]));
19745             Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src));
19746             Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src));
19747         }
19748 #endif
19749     }
19750
19751     place = REGNODE_p(operand); /* Op node, where operand used to be. */
19752 #ifdef RE_TRACK_PATTERN_OFFSETS
19753     if (RExC_offsets) {         /* MJD */
19754         MJD_OFFSET_DEBUG(
19755               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
19756               "reginsert",
19757               __LINE__,
19758               PL_reg_name[op],
19759               (UV)REGNODE_OFFSET(place) > RExC_offsets[0]
19760               ? "Overwriting end of array!\n" : "OK",
19761               (UV)REGNODE_OFFSET(place),
19762               (UV)(RExC_parse - RExC_start),
19763               (UV)RExC_offsets[0]));
19764         Set_Node_Offset(place, RExC_parse);
19765         Set_Node_Length(place, 1);
19766     }
19767 #endif
19768     src = NEXTOPER(place);
19769     FLAGS(place) = 0;
19770     FILL_NODE(operand, op);
19771
19772     /* Zero out any arguments in the new node */
19773     Zero(src, offset, regnode);
19774 }
19775
19776 /*
19777 - regtail - set the next-pointer at the end of a node chain of p to val.  If
19778             that value won't fit in the space available, instead returns FALSE.
19779             (Except asserts if we can't fit in the largest space the regex
19780             engine is designed for.)
19781 - SEE ALSO: regtail_study
19782 */
19783 STATIC bool
19784 S_regtail(pTHX_ RExC_state_t * pRExC_state,
19785                 const regnode_offset p,
19786                 const regnode_offset val,
19787                 const U32 depth)
19788 {
19789     regnode_offset scan;
19790     GET_RE_DEBUG_FLAGS_DECL;
19791
19792     PERL_ARGS_ASSERT_REGTAIL;
19793 #ifndef DEBUGGING
19794     PERL_UNUSED_ARG(depth);
19795 #endif
19796
19797     /* Find last node. */
19798     scan = (regnode_offset) p;
19799     for (;;) {
19800         regnode * const temp = regnext(REGNODE_p(scan));
19801         DEBUG_PARSE_r({
19802             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
19803             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
19804             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
19805                 SvPV_nolen_const(RExC_mysv), scan,
19806                     (temp == NULL ? "->" : ""),
19807                     (temp == NULL ? PL_reg_name[OP(REGNODE_p(val))] : "")
19808             );
19809         });
19810         if (temp == NULL)
19811             break;
19812         scan = REGNODE_OFFSET(temp);
19813     }
19814
19815     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
19816         assert((UV) (val - scan) <= U32_MAX);
19817         ARG_SET(REGNODE_p(scan), val - scan);
19818     }
19819     else {
19820         if (val - scan > U16_MAX) {
19821             /* Since not all callers check the return value, populate this with
19822              * something that won't loop and will likely lead to a crash if
19823              * execution continues */
19824             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
19825             return FALSE;
19826         }
19827         NEXT_OFF(REGNODE_p(scan)) = val - scan;
19828     }
19829
19830     return TRUE;
19831 }
19832
19833 #ifdef DEBUGGING
19834 /*
19835 - regtail_study - set the next-pointer at the end of a node chain of p to val.
19836 - Look for optimizable sequences at the same time.
19837 - currently only looks for EXACT chains.
19838
19839 This is experimental code. The idea is to use this routine to perform
19840 in place optimizations on branches and groups as they are constructed,
19841 with the long term intention of removing optimization from study_chunk so
19842 that it is purely analytical.
19843
19844 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
19845 to control which is which.
19846
19847 This used to return a value that was ignored.  It was a problem that it is
19848 #ifdef'd to be another function that didn't return a value.  khw has changed it
19849 so both currently return a pass/fail return.
19850
19851 */
19852 /* TODO: All four parms should be const */
19853
19854 STATIC bool
19855 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
19856                       const regnode_offset val, U32 depth)
19857 {
19858     regnode_offset scan;
19859     U8 exact = PSEUDO;
19860 #ifdef EXPERIMENTAL_INPLACESCAN
19861     I32 min = 0;
19862 #endif
19863     GET_RE_DEBUG_FLAGS_DECL;
19864
19865     PERL_ARGS_ASSERT_REGTAIL_STUDY;
19866
19867
19868     /* Find last node. */
19869
19870     scan = p;
19871     for (;;) {
19872         regnode * const temp = regnext(REGNODE_p(scan));
19873 #ifdef EXPERIMENTAL_INPLACESCAN
19874         if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
19875             bool unfolded_multi_char;   /* Unexamined in this routine */
19876             if (join_exact(pRExC_state, scan, &min,
19877                            &unfolded_multi_char, 1, REGNODE_p(val), depth+1))
19878                 return TRUE; /* Was return EXACT */
19879         }
19880 #endif
19881         if ( exact ) {
19882             switch (OP(REGNODE_p(scan))) {
19883                 case EXACT:
19884                 case EXACT_ONLY8:
19885                 case EXACTL:
19886                 case EXACTF:
19887                 case EXACTFU_S_EDGE:
19888                 case EXACTFAA_NO_TRIE:
19889                 case EXACTFAA:
19890                 case EXACTFU:
19891                 case EXACTFU_ONLY8:
19892                 case EXACTFLU8:
19893                 case EXACTFUP:
19894                 case EXACTFL:
19895                         if( exact == PSEUDO )
19896                             exact= OP(REGNODE_p(scan));
19897                         else if ( exact != OP(REGNODE_p(scan)) )
19898                             exact= 0;
19899                 case NOTHING:
19900                     break;
19901                 default:
19902                     exact= 0;
19903             }
19904         }
19905         DEBUG_PARSE_r({
19906             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
19907             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
19908             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
19909                 SvPV_nolen_const(RExC_mysv),
19910                 scan,
19911                 PL_reg_name[exact]);
19912         });
19913         if (temp == NULL)
19914             break;
19915         scan = REGNODE_OFFSET(temp);
19916     }
19917     DEBUG_PARSE_r({
19918         DEBUG_PARSE_MSG("");
19919         regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state);
19920         Perl_re_printf( aTHX_
19921                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
19922                       SvPV_nolen_const(RExC_mysv),
19923                       (IV)val,
19924                       (IV)(val - scan)
19925         );
19926     });
19927     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
19928         assert((UV) (val - scan) <= U32_MAX);
19929         ARG_SET(REGNODE_p(scan), val - scan);
19930     }
19931     else {
19932         if (val - scan > U16_MAX) {
19933             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
19934             return FALSE;
19935         }
19936         NEXT_OFF(REGNODE_p(scan)) = val - scan;
19937     }
19938
19939     return TRUE; /* Was 'return exact' */
19940 }
19941 #endif
19942
19943 STATIC SV*
19944 S_get_ANYOFM_contents(pTHX_ const regnode * n) {
19945
19946     /* Returns an inversion list of all the code points matched by the
19947      * ANYOFM/NANYOFM node 'n' */
19948
19949     SV * cp_list = _new_invlist(-1);
19950     const U8 lowest = (U8) ARG(n);
19951     unsigned int i;
19952     U8 count = 0;
19953     U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
19954
19955     PERL_ARGS_ASSERT_GET_ANYOFM_CONTENTS;
19956
19957     /* Starting with the lowest code point, any code point that ANDed with the
19958      * mask yields the lowest code point is in the set */
19959     for (i = lowest; i <= 0xFF; i++) {
19960         if ((i & FLAGS(n)) == ARG(n)) {
19961             cp_list = add_cp_to_invlist(cp_list, i);
19962             count++;
19963
19964             /* We know how many code points (a power of two) that are in the
19965              * set.  No use looking once we've got that number */
19966             if (count >= needed) break;
19967         }
19968     }
19969
19970     if (OP(n) == NANYOFM) {
19971         _invlist_invert(cp_list);
19972     }
19973     return cp_list;
19974 }
19975
19976 /*
19977  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
19978  */
19979 #ifdef DEBUGGING
19980
19981 static void
19982 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
19983 {
19984     int bit;
19985     int set=0;
19986
19987     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19988
19989     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
19990         if (flags & (1<<bit)) {
19991             if (!set++ && lead)
19992                 Perl_re_printf( aTHX_  "%s", lead);
19993             Perl_re_printf( aTHX_  "%s ", PL_reg_intflags_name[bit]);
19994         }
19995     }
19996     if (lead)  {
19997         if (set)
19998             Perl_re_printf( aTHX_  "\n");
19999         else
20000             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20001     }
20002 }
20003
20004 static void
20005 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
20006 {
20007     int bit;
20008     int set=0;
20009     regex_charset cs;
20010
20011     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
20012
20013     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
20014         if (flags & (1<<bit)) {
20015             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
20016                 continue;
20017             }
20018             if (!set++ && lead)
20019                 Perl_re_printf( aTHX_  "%s", lead);
20020             Perl_re_printf( aTHX_  "%s ", PL_reg_extflags_name[bit]);
20021         }
20022     }
20023     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
20024             if (!set++ && lead) {
20025                 Perl_re_printf( aTHX_  "%s", lead);
20026             }
20027             switch (cs) {
20028                 case REGEX_UNICODE_CHARSET:
20029                     Perl_re_printf( aTHX_  "UNICODE");
20030                     break;
20031                 case REGEX_LOCALE_CHARSET:
20032                     Perl_re_printf( aTHX_  "LOCALE");
20033                     break;
20034                 case REGEX_ASCII_RESTRICTED_CHARSET:
20035                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
20036                     break;
20037                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
20038                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
20039                     break;
20040                 default:
20041                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
20042                     break;
20043             }
20044     }
20045     if (lead)  {
20046         if (set)
20047             Perl_re_printf( aTHX_  "\n");
20048         else
20049             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20050     }
20051 }
20052 #endif
20053
20054 void
20055 Perl_regdump(pTHX_ const regexp *r)
20056 {
20057 #ifdef DEBUGGING
20058     int i;
20059     SV * const sv = sv_newmortal();
20060     SV *dsv= sv_newmortal();
20061     RXi_GET_DECL(r, ri);
20062     GET_RE_DEBUG_FLAGS_DECL;
20063
20064     PERL_ARGS_ASSERT_REGDUMP;
20065
20066     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
20067
20068     /* Header fields of interest. */
20069     for (i = 0; i < 2; i++) {
20070         if (r->substrs->data[i].substr) {
20071             RE_PV_QUOTED_DECL(s, 0, dsv,
20072                             SvPVX_const(r->substrs->data[i].substr),
20073                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
20074                             PL_dump_re_max_len);
20075             Perl_re_printf( aTHX_
20076                           "%s %s%s at %" IVdf "..%" UVuf " ",
20077                           i ? "floating" : "anchored",
20078                           s,
20079                           RE_SV_TAIL(r->substrs->data[i].substr),
20080                           (IV)r->substrs->data[i].min_offset,
20081                           (UV)r->substrs->data[i].max_offset);
20082         }
20083         else if (r->substrs->data[i].utf8_substr) {
20084             RE_PV_QUOTED_DECL(s, 1, dsv,
20085                             SvPVX_const(r->substrs->data[i].utf8_substr),
20086                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
20087                             30);
20088             Perl_re_printf( aTHX_
20089                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
20090                           i ? "floating" : "anchored",
20091                           s,
20092                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
20093                           (IV)r->substrs->data[i].min_offset,
20094                           (UV)r->substrs->data[i].max_offset);
20095         }
20096     }
20097
20098     if (r->check_substr || r->check_utf8)
20099         Perl_re_printf( aTHX_
20100                       (const char *)
20101                       (   r->check_substr == r->substrs->data[1].substr
20102                        && r->check_utf8   == r->substrs->data[1].utf8_substr
20103                        ? "(checking floating" : "(checking anchored"));
20104     if (r->intflags & PREGf_NOSCAN)
20105         Perl_re_printf( aTHX_  " noscan");
20106     if (r->extflags & RXf_CHECK_ALL)
20107         Perl_re_printf( aTHX_  " isall");
20108     if (r->check_substr || r->check_utf8)
20109         Perl_re_printf( aTHX_  ") ");
20110
20111     if (ri->regstclass) {
20112         regprop(r, sv, ri->regstclass, NULL, NULL);
20113         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
20114     }
20115     if (r->intflags & PREGf_ANCH) {
20116         Perl_re_printf( aTHX_  "anchored");
20117         if (r->intflags & PREGf_ANCH_MBOL)
20118             Perl_re_printf( aTHX_  "(MBOL)");
20119         if (r->intflags & PREGf_ANCH_SBOL)
20120             Perl_re_printf( aTHX_  "(SBOL)");
20121         if (r->intflags & PREGf_ANCH_GPOS)
20122             Perl_re_printf( aTHX_  "(GPOS)");
20123         Perl_re_printf( aTHX_ " ");
20124     }
20125     if (r->intflags & PREGf_GPOS_SEEN)
20126         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
20127     if (r->intflags & PREGf_SKIP)
20128         Perl_re_printf( aTHX_  "plus ");
20129     if (r->intflags & PREGf_IMPLICIT)
20130         Perl_re_printf( aTHX_  "implicit ");
20131     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
20132     if (r->extflags & RXf_EVAL_SEEN)
20133         Perl_re_printf( aTHX_  "with eval ");
20134     Perl_re_printf( aTHX_  "\n");
20135     DEBUG_FLAGS_r({
20136         regdump_extflags("r->extflags: ", r->extflags);
20137         regdump_intflags("r->intflags: ", r->intflags);
20138     });
20139 #else
20140     PERL_ARGS_ASSERT_REGDUMP;
20141     PERL_UNUSED_CONTEXT;
20142     PERL_UNUSED_ARG(r);
20143 #endif  /* DEBUGGING */
20144 }
20145
20146 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
20147 #ifdef DEBUGGING
20148
20149 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
20150      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
20151      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
20152      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
20153      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
20154      || _CC_VERTSPACE != 15
20155 #   error Need to adjust order of anyofs[]
20156 #  endif
20157 static const char * const anyofs[] = {
20158     "\\w",
20159     "\\W",
20160     "\\d",
20161     "\\D",
20162     "[:alpha:]",
20163     "[:^alpha:]",
20164     "[:lower:]",
20165     "[:^lower:]",
20166     "[:upper:]",
20167     "[:^upper:]",
20168     "[:punct:]",
20169     "[:^punct:]",
20170     "[:print:]",
20171     "[:^print:]",
20172     "[:alnum:]",
20173     "[:^alnum:]",
20174     "[:graph:]",
20175     "[:^graph:]",
20176     "[:cased:]",
20177     "[:^cased:]",
20178     "\\s",
20179     "\\S",
20180     "[:blank:]",
20181     "[:^blank:]",
20182     "[:xdigit:]",
20183     "[:^xdigit:]",
20184     "[:cntrl:]",
20185     "[:^cntrl:]",
20186     "[:ascii:]",
20187     "[:^ascii:]",
20188     "\\v",
20189     "\\V"
20190 };
20191 #endif
20192
20193 /*
20194 - regprop - printable representation of opcode, with run time support
20195 */
20196
20197 void
20198 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
20199 {
20200 #ifdef DEBUGGING
20201     dVAR;
20202     int k;
20203     RXi_GET_DECL(prog, progi);
20204     GET_RE_DEBUG_FLAGS_DECL;
20205
20206     PERL_ARGS_ASSERT_REGPROP;
20207
20208     SvPVCLEAR(sv);
20209
20210     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
20211         /* It would be nice to FAIL() here, but this may be called from
20212            regexec.c, and it would be hard to supply pRExC_state. */
20213         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
20214                                               (int)OP(o), (int)REGNODE_MAX);
20215     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
20216
20217     k = PL_regkind[OP(o)];
20218
20219     if (k == EXACT) {
20220         sv_catpvs(sv, " ");
20221         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
20222          * is a crude hack but it may be the best for now since
20223          * we have no flag "this EXACTish node was UTF-8"
20224          * --jhi */
20225         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
20226                   PL_colors[0], PL_colors[1],
20227                   PERL_PV_ESCAPE_UNI_DETECT |
20228                   PERL_PV_ESCAPE_NONASCII   |
20229                   PERL_PV_PRETTY_ELLIPSES   |
20230                   PERL_PV_PRETTY_LTGT       |
20231                   PERL_PV_PRETTY_NOCLEAR
20232                   );
20233     } else if (k == TRIE) {
20234         /* print the details of the trie in dumpuntil instead, as
20235          * progi->data isn't available here */
20236         const char op = OP(o);
20237         const U32 n = ARG(o);
20238         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
20239                (reg_ac_data *)progi->data->data[n] :
20240                NULL;
20241         const reg_trie_data * const trie
20242             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
20243
20244         Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]);
20245         DEBUG_TRIE_COMPILE_r({
20246           if (trie->jump)
20247             sv_catpvs(sv, "(JUMP)");
20248           Perl_sv_catpvf(aTHX_ sv,
20249             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
20250             (UV)trie->startstate,
20251             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
20252             (UV)trie->wordcount,
20253             (UV)trie->minlen,
20254             (UV)trie->maxlen,
20255             (UV)TRIE_CHARCOUNT(trie),
20256             (UV)trie->uniquecharcount
20257           );
20258         });
20259         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
20260             sv_catpvs(sv, "[");
20261             (void) put_charclass_bitmap_innards(sv,
20262                                                 ((IS_ANYOF_TRIE(op))
20263                                                  ? ANYOF_BITMAP(o)
20264                                                  : TRIE_BITMAP(trie)),
20265                                                 NULL,
20266                                                 NULL,
20267                                                 NULL,
20268                                                 FALSE
20269                                                );
20270             sv_catpvs(sv, "]");
20271         }
20272     } else if (k == CURLY) {
20273         U32 lo = ARG1(o), hi = ARG2(o);
20274         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
20275             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
20276         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
20277         if (hi == REG_INFTY)
20278             sv_catpvs(sv, "INFTY");
20279         else
20280             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
20281         sv_catpvs(sv, "}");
20282     }
20283     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
20284         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
20285     else if (k == REF || k == OPEN || k == CLOSE
20286              || k == GROUPP || OP(o)==ACCEPT)
20287     {
20288         AV *name_list= NULL;
20289         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
20290         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
20291         if ( RXp_PAREN_NAMES(prog) ) {
20292             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
20293         } else if ( pRExC_state ) {
20294             name_list= RExC_paren_name_list;
20295         }
20296         if (name_list) {
20297             if ( k != REF || (OP(o) < REFN)) {
20298                 SV **name= av_fetch(name_list, parno, 0 );
20299                 if (name)
20300                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20301             }
20302             else {
20303                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
20304                 I32 *nums=(I32*)SvPVX(sv_dat);
20305                 SV **name= av_fetch(name_list, nums[0], 0 );
20306                 I32 n;
20307                 if (name) {
20308                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
20309                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
20310                                     (n ? "," : ""), (IV)nums[n]);
20311                     }
20312                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20313                 }
20314             }
20315         }
20316         if ( k == REF && reginfo) {
20317             U32 n = ARG(o);  /* which paren pair */
20318             I32 ln = prog->offs[n].start;
20319             if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
20320                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
20321             else if (ln == prog->offs[n].end)
20322                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
20323             else {
20324                 const char *s = reginfo->strbeg + ln;
20325                 Perl_sv_catpvf(aTHX_ sv, ": ");
20326                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
20327                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
20328             }
20329         }
20330     } else if (k == GOSUB) {
20331         AV *name_list= NULL;
20332         if ( RXp_PAREN_NAMES(prog) ) {
20333             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
20334         } else if ( pRExC_state ) {
20335             name_list= RExC_paren_name_list;
20336         }
20337
20338         /* Paren and offset */
20339         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
20340                 (int)((o + (int)ARG2L(o)) - progi->program) );
20341         if (name_list) {
20342             SV **name= av_fetch(name_list, ARG(o), 0 );
20343             if (name)
20344                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20345         }
20346     }
20347     else if (k == LOGICAL)
20348         /* 2: embedded, otherwise 1 */
20349         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
20350     else if (k == ANYOF) {
20351         const U8 flags = (OP(o) == ANYOFHb) ? 0 : ANYOF_FLAGS(o);
20352         bool do_sep = FALSE;    /* Do we need to separate various components of
20353                                    the output? */
20354         /* Set if there is still an unresolved user-defined property */
20355         SV *unresolved                = NULL;
20356
20357         /* Things that are ignored except when the runtime locale is UTF-8 */
20358         SV *only_utf8_locale_invlist = NULL;
20359
20360         /* Code points that don't fit in the bitmap */
20361         SV *nonbitmap_invlist = NULL;
20362
20363         /* And things that aren't in the bitmap, but are small enough to be */
20364         SV* bitmap_range_not_in_bitmap = NULL;
20365
20366         const bool inverted = flags & ANYOF_INVERT;
20367
20368         if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) {
20369             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
20370                 sv_catpvs(sv, "{utf8-locale-reqd}");
20371             }
20372             if (flags & ANYOFL_FOLD) {
20373                 sv_catpvs(sv, "{i}");
20374             }
20375         }
20376
20377         /* If there is stuff outside the bitmap, get it */
20378         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
20379             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
20380                                                 &unresolved,
20381                                                 &only_utf8_locale_invlist,
20382                                                 &nonbitmap_invlist);
20383             /* The non-bitmap data may contain stuff that could fit in the
20384              * bitmap.  This could come from a user-defined property being
20385              * finally resolved when this call was done; or much more likely
20386              * because there are matches that require UTF-8 to be valid, and so
20387              * aren't in the bitmap.  This is teased apart later */
20388             _invlist_intersection(nonbitmap_invlist,
20389                                   PL_InBitmap,
20390                                   &bitmap_range_not_in_bitmap);
20391             /* Leave just the things that don't fit into the bitmap */
20392             _invlist_subtract(nonbitmap_invlist,
20393                               PL_InBitmap,
20394                               &nonbitmap_invlist);
20395         }
20396
20397         /* Obey this flag to add all above-the-bitmap code points */
20398         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
20399             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
20400                                                       NUM_ANYOF_CODE_POINTS,
20401                                                       UV_MAX);
20402         }
20403
20404         /* Ready to start outputting.  First, the initial left bracket */
20405         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
20406
20407         if (OP(o) != ANYOFH && OP(o) != ANYOFHb) {
20408             /* Then all the things that could fit in the bitmap */
20409             do_sep = put_charclass_bitmap_innards(sv,
20410                                                   ANYOF_BITMAP(o),
20411                                                   bitmap_range_not_in_bitmap,
20412                                                   only_utf8_locale_invlist,
20413                                                   o,
20414
20415                                                   /* Can't try inverting for a
20416                                                    * better display if there
20417                                                    * are things that haven't
20418                                                    * been resolved */
20419                                                   unresolved != NULL);
20420             SvREFCNT_dec(bitmap_range_not_in_bitmap);
20421
20422             /* If there are user-defined properties which haven't been defined
20423              * yet, output them.  If the result is not to be inverted, it is
20424              * clearest to output them in a separate [] from the bitmap range
20425              * stuff.  If the result is to be complemented, we have to show
20426              * everything in one [], as the inversion applies to the whole
20427              * thing.  Use {braces} to separate them from anything in the
20428              * bitmap and anything above the bitmap. */
20429             if (unresolved) {
20430                 if (inverted) {
20431                     if (! do_sep) { /* If didn't output anything in the bitmap
20432                                      */
20433                         sv_catpvs(sv, "^");
20434                     }
20435                     sv_catpvs(sv, "{");
20436                 }
20437                 else if (do_sep) {
20438                     Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
20439                                                       PL_colors[0]);
20440                 }
20441                 sv_catsv(sv, unresolved);
20442                 if (inverted) {
20443                     sv_catpvs(sv, "}");
20444                 }
20445                 do_sep = ! inverted;
20446             }
20447         }
20448
20449         /* And, finally, add the above-the-bitmap stuff */
20450         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
20451             SV* contents;
20452
20453             /* See if truncation size is overridden */
20454             const STRLEN dump_len = (PL_dump_re_max_len > 256)
20455                                     ? PL_dump_re_max_len
20456                                     : 256;
20457
20458             /* This is output in a separate [] */
20459             if (do_sep) {
20460                 Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
20461             }
20462
20463             /* And, for easy of understanding, it is shown in the
20464              * uncomplemented form if possible.  The one exception being if
20465              * there are unresolved items, where the inversion has to be
20466              * delayed until runtime */
20467             if (inverted && ! unresolved) {
20468                 _invlist_invert(nonbitmap_invlist);
20469                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
20470             }
20471
20472             contents = invlist_contents(nonbitmap_invlist,
20473                                         FALSE /* output suitable for catsv */
20474                                        );
20475
20476             /* If the output is shorter than the permissible maximum, just do it. */
20477             if (SvCUR(contents) <= dump_len) {
20478                 sv_catsv(sv, contents);
20479             }
20480             else {
20481                 const char * contents_string = SvPVX(contents);
20482                 STRLEN i = dump_len;
20483
20484                 /* Otherwise, start at the permissible max and work back to the
20485                  * first break possibility */
20486                 while (i > 0 && contents_string[i] != ' ') {
20487                     i--;
20488                 }
20489                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
20490                                        find a legal break */
20491                     i = dump_len;
20492                 }
20493
20494                 sv_catpvn(sv, contents_string, i);
20495                 sv_catpvs(sv, "...");
20496             }
20497
20498             SvREFCNT_dec_NN(contents);
20499             SvREFCNT_dec_NN(nonbitmap_invlist);
20500         }
20501
20502         /* And finally the matching, closing ']' */
20503         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
20504
20505         if (OP(o) == ANYOFHb) {
20506             Perl_sv_catpvf(aTHX_ sv, " (First UTF-8 byte=\\x%02x)", FLAGS(o));
20507         }
20508
20509
20510         SvREFCNT_dec(unresolved);
20511     }
20512     else if (k == ANYOFM) {
20513         SV * cp_list = get_ANYOFM_contents(o);
20514
20515         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
20516         if (OP(o) == NANYOFM) {
20517             _invlist_invert(cp_list);
20518         }
20519
20520         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, TRUE);
20521         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
20522
20523         SvREFCNT_dec(cp_list);
20524     }
20525     else if (k == POSIXD || k == NPOSIXD) {
20526         U8 index = FLAGS(o) * 2;
20527         if (index < C_ARRAY_LENGTH(anyofs)) {
20528             if (*anyofs[index] != '[')  {
20529                 sv_catpvs(sv, "[");
20530             }
20531             sv_catpv(sv, anyofs[index]);
20532             if (*anyofs[index] != '[')  {
20533                 sv_catpvs(sv, "]");
20534             }
20535         }
20536         else {
20537             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
20538         }
20539     }
20540     else if (k == BOUND || k == NBOUND) {
20541         /* Must be synced with order of 'bound_type' in regcomp.h */
20542         const char * const bounds[] = {
20543             "",      /* Traditional */
20544             "{gcb}",
20545             "{lb}",
20546             "{sb}",
20547             "{wb}"
20548         };
20549         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
20550         sv_catpv(sv, bounds[FLAGS(o)]);
20551     }
20552     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) {
20553         Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags));
20554         if (o->next_off) {
20555             Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off);
20556         }
20557         Perl_sv_catpvf(aTHX_ sv, "]");
20558     }
20559     else if (OP(o) == SBOL)
20560         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
20561
20562     /* add on the verb argument if there is one */
20563     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
20564         if ( ARG(o) )
20565             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
20566                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
20567         else
20568             sv_catpvs(sv, ":NULL");
20569     }
20570 #else
20571     PERL_UNUSED_CONTEXT;
20572     PERL_UNUSED_ARG(sv);
20573     PERL_UNUSED_ARG(o);
20574     PERL_UNUSED_ARG(prog);
20575     PERL_UNUSED_ARG(reginfo);
20576     PERL_UNUSED_ARG(pRExC_state);
20577 #endif  /* DEBUGGING */
20578 }
20579
20580
20581
20582 SV *
20583 Perl_re_intuit_string(pTHX_ REGEXP * const r)
20584 {                               /* Assume that RE_INTUIT is set */
20585     struct regexp *const prog = ReANY(r);
20586     GET_RE_DEBUG_FLAGS_DECL;
20587
20588     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
20589     PERL_UNUSED_CONTEXT;
20590
20591     DEBUG_COMPILE_r(
20592         {
20593             const char * const s = SvPV_nolen_const(RX_UTF8(r)
20594                       ? prog->check_utf8 : prog->check_substr);
20595
20596             if (!PL_colorset) reginitcolors();
20597             Perl_re_printf( aTHX_
20598                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
20599                       PL_colors[4],
20600                       RX_UTF8(r) ? "utf8 " : "",
20601                       PL_colors[5], PL_colors[0],
20602                       s,
20603                       PL_colors[1],
20604                       (strlen(s) > PL_dump_re_max_len ? "..." : ""));
20605         } );
20606
20607     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
20608     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
20609 }
20610
20611 /*
20612    pregfree()
20613
20614    handles refcounting and freeing the perl core regexp structure. When
20615    it is necessary to actually free the structure the first thing it
20616    does is call the 'free' method of the regexp_engine associated to
20617    the regexp, allowing the handling of the void *pprivate; member
20618    first. (This routine is not overridable by extensions, which is why
20619    the extensions free is called first.)
20620
20621    See regdupe and regdupe_internal if you change anything here.
20622 */
20623 #ifndef PERL_IN_XSUB_RE
20624 void
20625 Perl_pregfree(pTHX_ REGEXP *r)
20626 {
20627     SvREFCNT_dec(r);
20628 }
20629
20630 void
20631 Perl_pregfree2(pTHX_ REGEXP *rx)
20632 {
20633     struct regexp *const r = ReANY(rx);
20634     GET_RE_DEBUG_FLAGS_DECL;
20635
20636     PERL_ARGS_ASSERT_PREGFREE2;
20637
20638     if (! r)
20639         return;
20640
20641     if (r->mother_re) {
20642         ReREFCNT_dec(r->mother_re);
20643     } else {
20644         CALLREGFREE_PVT(rx); /* free the private data */
20645         SvREFCNT_dec(RXp_PAREN_NAMES(r));
20646     }
20647     if (r->substrs) {
20648         int i;
20649         for (i = 0; i < 2; i++) {
20650             SvREFCNT_dec(r->substrs->data[i].substr);
20651             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
20652         }
20653         Safefree(r->substrs);
20654     }
20655     RX_MATCH_COPY_FREE(rx);
20656 #ifdef PERL_ANY_COW
20657     SvREFCNT_dec(r->saved_copy);
20658 #endif
20659     Safefree(r->offs);
20660     SvREFCNT_dec(r->qr_anoncv);
20661     if (r->recurse_locinput)
20662         Safefree(r->recurse_locinput);
20663 }
20664
20665
20666 /*  reg_temp_copy()
20667
20668     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
20669     except that dsv will be created if NULL.
20670
20671     This function is used in two main ways. First to implement
20672         $r = qr/....; $s = $$r;
20673
20674     Secondly, it is used as a hacky workaround to the structural issue of
20675     match results
20676     being stored in the regexp structure which is in turn stored in
20677     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
20678     could be PL_curpm in multiple contexts, and could require multiple
20679     result sets being associated with the pattern simultaneously, such
20680     as when doing a recursive match with (??{$qr})
20681
20682     The solution is to make a lightweight copy of the regexp structure
20683     when a qr// is returned from the code executed by (??{$qr}) this
20684     lightweight copy doesn't actually own any of its data except for
20685     the starp/end and the actual regexp structure itself.
20686
20687 */
20688
20689
20690 REGEXP *
20691 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
20692 {
20693     struct regexp *drx;
20694     struct regexp *const srx = ReANY(ssv);
20695     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
20696
20697     PERL_ARGS_ASSERT_REG_TEMP_COPY;
20698
20699     if (!dsv)
20700         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
20701     else {
20702         assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV));
20703
20704         /* our only valid caller, sv_setsv_flags(), should have done
20705          * a SV_CHECK_THINKFIRST_COW_DROP() by now */
20706         assert(!SvOOK(dsv));
20707         assert(!SvIsCOW(dsv));
20708         assert(!SvROK(dsv));
20709
20710         if (SvPVX_const(dsv)) {
20711             if (SvLEN(dsv))
20712                 Safefree(SvPVX(dsv));
20713             SvPVX(dsv) = NULL;
20714         }
20715         SvLEN_set(dsv, 0);
20716         SvCUR_set(dsv, 0);
20717         SvOK_off((SV *)dsv);
20718
20719         if (islv) {
20720             /* For PVLVs, the head (sv_any) points to an XPVLV, while
20721              * the LV's xpvlenu_rx will point to a regexp body, which
20722              * we allocate here */
20723             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
20724             assert(!SvPVX(dsv));
20725             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
20726             temp->sv_any = NULL;
20727             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
20728             SvREFCNT_dec_NN(temp);
20729             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
20730                ing below will not set it. */
20731             SvCUR_set(dsv, SvCUR(ssv));
20732         }
20733     }
20734     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
20735        sv_force_normal(sv) is called.  */
20736     SvFAKE_on(dsv);
20737     drx = ReANY(dsv);
20738
20739     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
20740     SvPV_set(dsv, RX_WRAPPED(ssv));
20741     /* We share the same string buffer as the original regexp, on which we
20742        hold a reference count, incremented when mother_re is set below.
20743        The string pointer is copied here, being part of the regexp struct.
20744      */
20745     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
20746            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
20747     if (!islv)
20748         SvLEN_set(dsv, 0);
20749     if (srx->offs) {
20750         const I32 npar = srx->nparens+1;
20751         Newx(drx->offs, npar, regexp_paren_pair);
20752         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
20753     }
20754     if (srx->substrs) {
20755         int i;
20756         Newx(drx->substrs, 1, struct reg_substr_data);
20757         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
20758
20759         for (i = 0; i < 2; i++) {
20760             SvREFCNT_inc_void(drx->substrs->data[i].substr);
20761             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
20762         }
20763
20764         /* check_substr and check_utf8, if non-NULL, point to either their
20765            anchored or float namesakes, and don't hold a second reference.  */
20766     }
20767     RX_MATCH_COPIED_off(dsv);
20768 #ifdef PERL_ANY_COW
20769     drx->saved_copy = NULL;
20770 #endif
20771     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
20772     SvREFCNT_inc_void(drx->qr_anoncv);
20773     if (srx->recurse_locinput)
20774         Newx(drx->recurse_locinput, srx->nparens + 1, char *);
20775
20776     return dsv;
20777 }
20778 #endif
20779
20780
20781 /* regfree_internal()
20782
20783    Free the private data in a regexp. This is overloadable by
20784    extensions. Perl takes care of the regexp structure in pregfree(),
20785    this covers the *pprivate pointer which technically perl doesn't
20786    know about, however of course we have to handle the
20787    regexp_internal structure when no extension is in use.
20788
20789    Note this is called before freeing anything in the regexp
20790    structure.
20791  */
20792
20793 void
20794 Perl_regfree_internal(pTHX_ REGEXP * const rx)
20795 {
20796     struct regexp *const r = ReANY(rx);
20797     RXi_GET_DECL(r, ri);
20798     GET_RE_DEBUG_FLAGS_DECL;
20799
20800     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
20801
20802     if (! ri) {
20803         return;
20804     }
20805
20806     DEBUG_COMPILE_r({
20807         if (!PL_colorset)
20808             reginitcolors();
20809         {
20810             SV *dsv= sv_newmortal();
20811             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
20812                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
20813             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
20814                 PL_colors[4], PL_colors[5], s);
20815         }
20816     });
20817
20818 #ifdef RE_TRACK_PATTERN_OFFSETS
20819     if (ri->u.offsets)
20820         Safefree(ri->u.offsets);             /* 20010421 MJD */
20821 #endif
20822     if (ri->code_blocks)
20823         S_free_codeblocks(aTHX_ ri->code_blocks);
20824
20825     if (ri->data) {
20826         int n = ri->data->count;
20827
20828         while (--n >= 0) {
20829           /* If you add a ->what type here, update the comment in regcomp.h */
20830             switch (ri->data->what[n]) {
20831             case 'a':
20832             case 'r':
20833             case 's':
20834             case 'S':
20835             case 'u':
20836                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
20837                 break;
20838             case 'f':
20839                 Safefree(ri->data->data[n]);
20840                 break;
20841             case 'l':
20842             case 'L':
20843                 break;
20844             case 'T':
20845                 { /* Aho Corasick add-on structure for a trie node.
20846                      Used in stclass optimization only */
20847                     U32 refcount;
20848                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
20849 #ifdef USE_ITHREADS
20850                     dVAR;
20851 #endif
20852                     OP_REFCNT_LOCK;
20853                     refcount = --aho->refcount;
20854                     OP_REFCNT_UNLOCK;
20855                     if ( !refcount ) {
20856                         PerlMemShared_free(aho->states);
20857                         PerlMemShared_free(aho->fail);
20858                          /* do this last!!!! */
20859                         PerlMemShared_free(ri->data->data[n]);
20860                         /* we should only ever get called once, so
20861                          * assert as much, and also guard the free
20862                          * which /might/ happen twice. At the least
20863                          * it will make code anlyzers happy and it
20864                          * doesn't cost much. - Yves */
20865                         assert(ri->regstclass);
20866                         if (ri->regstclass) {
20867                             PerlMemShared_free(ri->regstclass);
20868                             ri->regstclass = 0;
20869                         }
20870                     }
20871                 }
20872                 break;
20873             case 't':
20874                 {
20875                     /* trie structure. */
20876                     U32 refcount;
20877                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
20878 #ifdef USE_ITHREADS
20879                     dVAR;
20880 #endif
20881                     OP_REFCNT_LOCK;
20882                     refcount = --trie->refcount;
20883                     OP_REFCNT_UNLOCK;
20884                     if ( !refcount ) {
20885                         PerlMemShared_free(trie->charmap);
20886                         PerlMemShared_free(trie->states);
20887                         PerlMemShared_free(trie->trans);
20888                         if (trie->bitmap)
20889                             PerlMemShared_free(trie->bitmap);
20890                         if (trie->jump)
20891                             PerlMemShared_free(trie->jump);
20892                         PerlMemShared_free(trie->wordinfo);
20893                         /* do this last!!!! */
20894                         PerlMemShared_free(ri->data->data[n]);
20895                     }
20896                 }
20897                 break;
20898             default:
20899                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
20900                                                     ri->data->what[n]);
20901             }
20902         }
20903         Safefree(ri->data->what);
20904         Safefree(ri->data);
20905     }
20906
20907     Safefree(ri);
20908 }
20909
20910 #define av_dup_inc(s, t)        MUTABLE_AV(sv_dup_inc((const SV *)s, t))
20911 #define hv_dup_inc(s, t)        MUTABLE_HV(sv_dup_inc((const SV *)s, t))
20912 #define SAVEPVN(p, n)   ((p) ? savepvn(p, n) : NULL)
20913
20914 /*
20915    re_dup_guts - duplicate a regexp.
20916
20917    This routine is expected to clone a given regexp structure. It is only
20918    compiled under USE_ITHREADS.
20919
20920    After all of the core data stored in struct regexp is duplicated
20921    the regexp_engine.dupe method is used to copy any private data
20922    stored in the *pprivate pointer. This allows extensions to handle
20923    any duplication it needs to do.
20924
20925    See pregfree() and regfree_internal() if you change anything here.
20926 */
20927 #if defined(USE_ITHREADS)
20928 #ifndef PERL_IN_XSUB_RE
20929 void
20930 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
20931 {
20932     dVAR;
20933     I32 npar;
20934     const struct regexp *r = ReANY(sstr);
20935     struct regexp *ret = ReANY(dstr);
20936
20937     PERL_ARGS_ASSERT_RE_DUP_GUTS;
20938
20939     npar = r->nparens+1;
20940     Newx(ret->offs, npar, regexp_paren_pair);
20941     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
20942
20943     if (ret->substrs) {
20944         /* Do it this way to avoid reading from *r after the StructCopy().
20945            That way, if any of the sv_dup_inc()s dislodge *r from the L1
20946            cache, it doesn't matter.  */
20947         int i;
20948         const bool anchored = r->check_substr
20949             ? r->check_substr == r->substrs->data[0].substr
20950             : r->check_utf8   == r->substrs->data[0].utf8_substr;
20951         Newx(ret->substrs, 1, struct reg_substr_data);
20952         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
20953
20954         for (i = 0; i < 2; i++) {
20955             ret->substrs->data[i].substr =
20956                         sv_dup_inc(ret->substrs->data[i].substr, param);
20957             ret->substrs->data[i].utf8_substr =
20958                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
20959         }
20960
20961         /* check_substr and check_utf8, if non-NULL, point to either their
20962            anchored or float namesakes, and don't hold a second reference.  */
20963
20964         if (ret->check_substr) {
20965             if (anchored) {
20966                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
20967
20968                 ret->check_substr = ret->substrs->data[0].substr;
20969                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
20970             } else {
20971                 assert(r->check_substr == r->substrs->data[1].substr);
20972                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
20973
20974                 ret->check_substr = ret->substrs->data[1].substr;
20975                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
20976             }
20977         } else if (ret->check_utf8) {
20978             if (anchored) {
20979                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
20980             } else {
20981                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
20982             }
20983         }
20984     }
20985
20986     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
20987     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
20988     if (r->recurse_locinput)
20989         Newx(ret->recurse_locinput, r->nparens + 1, char *);
20990
20991     if (ret->pprivate)
20992         RXi_SET(ret, CALLREGDUPE_PVT(dstr, param));
20993
20994     if (RX_MATCH_COPIED(dstr))
20995         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
20996     else
20997         ret->subbeg = NULL;
20998 #ifdef PERL_ANY_COW
20999     ret->saved_copy = NULL;
21000 #endif
21001
21002     /* Whether mother_re be set or no, we need to copy the string.  We
21003        cannot refrain from copying it when the storage points directly to
21004        our mother regexp, because that's
21005                1: a buffer in a different thread
21006                2: something we no longer hold a reference on
21007                so we need to copy it locally.  */
21008     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
21009     /* set malloced length to a non-zero value so it will be freed
21010      * (otherwise in combination with SVf_FAKE it looks like an alien
21011      * buffer). It doesn't have to be the actual malloced size, since it
21012      * should never be grown */
21013     SvLEN_set(dstr, SvCUR(sstr)+1);
21014     ret->mother_re   = NULL;
21015 }
21016 #endif /* PERL_IN_XSUB_RE */
21017
21018 /*
21019    regdupe_internal()
21020
21021    This is the internal complement to regdupe() which is used to copy
21022    the structure pointed to by the *pprivate pointer in the regexp.
21023    This is the core version of the extension overridable cloning hook.
21024    The regexp structure being duplicated will be copied by perl prior
21025    to this and will be provided as the regexp *r argument, however
21026    with the /old/ structures pprivate pointer value. Thus this routine
21027    may override any copying normally done by perl.
21028
21029    It returns a pointer to the new regexp_internal structure.
21030 */
21031
21032 void *
21033 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
21034 {
21035     dVAR;
21036     struct regexp *const r = ReANY(rx);
21037     regexp_internal *reti;
21038     int len;
21039     RXi_GET_DECL(r, ri);
21040
21041     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
21042
21043     len = ProgLen(ri);
21044
21045     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
21046           char, regexp_internal);
21047     Copy(ri->program, reti->program, len+1, regnode);
21048
21049
21050     if (ri->code_blocks) {
21051         int n;
21052         Newx(reti->code_blocks, 1, struct reg_code_blocks);
21053         Newx(reti->code_blocks->cb, ri->code_blocks->count,
21054                     struct reg_code_block);
21055         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
21056              ri->code_blocks->count, struct reg_code_block);
21057         for (n = 0; n < ri->code_blocks->count; n++)
21058              reti->code_blocks->cb[n].src_regex = (REGEXP*)
21059                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
21060         reti->code_blocks->count = ri->code_blocks->count;
21061         reti->code_blocks->refcnt = 1;
21062     }
21063     else
21064         reti->code_blocks = NULL;
21065
21066     reti->regstclass = NULL;
21067
21068     if (ri->data) {
21069         struct reg_data *d;
21070         const int count = ri->data->count;
21071         int i;
21072
21073         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
21074                 char, struct reg_data);
21075         Newx(d->what, count, U8);
21076
21077         d->count = count;
21078         for (i = 0; i < count; i++) {
21079             d->what[i] = ri->data->what[i];
21080             switch (d->what[i]) {
21081                 /* see also regcomp.h and regfree_internal() */
21082             case 'a': /* actually an AV, but the dup function is identical.
21083                          values seem to be "plain sv's" generally. */
21084             case 'r': /* a compiled regex (but still just another SV) */
21085             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
21086                          this use case should go away, the code could have used
21087                          'a' instead - see S_set_ANYOF_arg() for array contents. */
21088             case 'S': /* actually an SV, but the dup function is identical.  */
21089             case 'u': /* actually an HV, but the dup function is identical.
21090                          values are "plain sv's" */
21091                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
21092                 break;
21093             case 'f':
21094                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
21095                  * patterns which could start with several different things. Pre-TRIE
21096                  * this was more important than it is now, however this still helps
21097                  * in some places, for instance /x?a+/ might produce a SSC equivalent
21098                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
21099                  * in regexec.c
21100                  */
21101                 /* This is cheating. */
21102                 Newx(d->data[i], 1, regnode_ssc);
21103                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
21104                 reti->regstclass = (regnode*)d->data[i];
21105                 break;
21106             case 'T':
21107                 /* AHO-CORASICK fail table */
21108                 /* Trie stclasses are readonly and can thus be shared
21109                  * without duplication. We free the stclass in pregfree
21110                  * when the corresponding reg_ac_data struct is freed.
21111                  */
21112                 reti->regstclass= ri->regstclass;
21113                 /* FALLTHROUGH */
21114             case 't':
21115                 /* TRIE transition table */
21116                 OP_REFCNT_LOCK;
21117                 ((reg_trie_data*)ri->data->data[i])->refcount++;
21118                 OP_REFCNT_UNLOCK;
21119                 /* FALLTHROUGH */
21120             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
21121             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
21122                          is not from another regexp */
21123                 d->data[i] = ri->data->data[i];
21124                 break;
21125             default:
21126                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
21127                                                            ri->data->what[i]);
21128             }
21129         }
21130
21131         reti->data = d;
21132     }
21133     else
21134         reti->data = NULL;
21135
21136     reti->name_list_idx = ri->name_list_idx;
21137
21138 #ifdef RE_TRACK_PATTERN_OFFSETS
21139     if (ri->u.offsets) {
21140         Newx(reti->u.offsets, 2*len+1, U32);
21141         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
21142     }
21143 #else
21144     SetProgLen(reti, len);
21145 #endif
21146
21147     return (void*)reti;
21148 }
21149
21150 #endif    /* USE_ITHREADS */
21151
21152 #ifndef PERL_IN_XSUB_RE
21153
21154 /*
21155  - regnext - dig the "next" pointer out of a node
21156  */
21157 regnode *
21158 Perl_regnext(pTHX_ regnode *p)
21159 {
21160     I32 offset;
21161
21162     if (!p)
21163         return(NULL);
21164
21165     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
21166         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
21167                                                 (int)OP(p), (int)REGNODE_MAX);
21168     }
21169
21170     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
21171     if (offset == 0)
21172         return(NULL);
21173
21174     return(p+offset);
21175 }
21176
21177 #endif
21178
21179 STATIC void
21180 S_re_croak2(pTHX_ bool utf8, const char* pat1, const char* pat2,...)
21181 {
21182     va_list args;
21183     STRLEN l1 = strlen(pat1);
21184     STRLEN l2 = strlen(pat2);
21185     char buf[512];
21186     SV *msv;
21187     const char *message;
21188
21189     PERL_ARGS_ASSERT_RE_CROAK2;
21190
21191     if (l1 > 510)
21192         l1 = 510;
21193     if (l1 + l2 > 510)
21194         l2 = 510 - l1;
21195     Copy(pat1, buf, l1 , char);
21196     Copy(pat2, buf + l1, l2 , char);
21197     buf[l1 + l2] = '\n';
21198     buf[l1 + l2 + 1] = '\0';
21199     va_start(args, pat2);
21200     msv = vmess(buf, &args);
21201     va_end(args);
21202     message = SvPV_const(msv, l1);
21203     if (l1 > 512)
21204         l1 = 512;
21205     Copy(message, buf, l1 , char);
21206     /* l1-1 to avoid \n */
21207     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
21208 }
21209
21210 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
21211
21212 #ifndef PERL_IN_XSUB_RE
21213 void
21214 Perl_save_re_context(pTHX)
21215 {
21216     I32 nparens = -1;
21217     I32 i;
21218
21219     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
21220
21221     if (PL_curpm) {
21222         const REGEXP * const rx = PM_GETRE(PL_curpm);
21223         if (rx)
21224             nparens = RX_NPARENS(rx);
21225     }
21226
21227     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
21228      * that PL_curpm will be null, but that utf8.pm and the modules it
21229      * loads will only use $1..$3.
21230      * The t/porting/re_context.t test file checks this assumption.
21231      */
21232     if (nparens == -1)
21233         nparens = 3;
21234
21235     for (i = 1; i <= nparens; i++) {
21236         char digits[TYPE_CHARS(long)];
21237         const STRLEN len = my_snprintf(digits, sizeof(digits),
21238                                        "%lu", (long)i);
21239         GV *const *const gvp
21240             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
21241
21242         if (gvp) {
21243             GV * const gv = *gvp;
21244             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
21245                 save_scalar(gv);
21246         }
21247     }
21248 }
21249 #endif
21250
21251 #ifdef DEBUGGING
21252
21253 STATIC void
21254 S_put_code_point(pTHX_ SV *sv, UV c)
21255 {
21256     PERL_ARGS_ASSERT_PUT_CODE_POINT;
21257
21258     if (c > 255) {
21259         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
21260     }
21261     else if (isPRINT(c)) {
21262         const char string = (char) c;
21263
21264         /* We use {phrase} as metanotation in the class, so also escape literal
21265          * braces */
21266         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
21267             sv_catpvs(sv, "\\");
21268         sv_catpvn(sv, &string, 1);
21269     }
21270     else if (isMNEMONIC_CNTRL(c)) {
21271         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
21272     }
21273     else {
21274         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
21275     }
21276 }
21277
21278 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
21279
21280 STATIC void
21281 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
21282 {
21283     /* Appends to 'sv' a displayable version of the range of code points from
21284      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
21285      * that have them, when they occur at the beginning or end of the range.
21286      * It uses hex to output the remaining code points, unless 'allow_literals'
21287      * is true, in which case the printable ASCII ones are output as-is (though
21288      * some of these will be escaped by put_code_point()).
21289      *
21290      * NOTE:  This is designed only for printing ranges of code points that fit
21291      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
21292      */
21293
21294     const unsigned int min_range_count = 3;
21295
21296     assert(start <= end);
21297
21298     PERL_ARGS_ASSERT_PUT_RANGE;
21299
21300     while (start <= end) {
21301         UV this_end;
21302         const char * format;
21303
21304         if (end - start < min_range_count) {
21305
21306             /* Output chars individually when they occur in short ranges */
21307             for (; start <= end; start++) {
21308                 put_code_point(sv, start);
21309             }
21310             break;
21311         }
21312
21313         /* If permitted by the input options, and there is a possibility that
21314          * this range contains a printable literal, look to see if there is
21315          * one. */
21316         if (allow_literals && start <= MAX_PRINT_A) {
21317
21318             /* If the character at the beginning of the range isn't an ASCII
21319              * printable, effectively split the range into two parts:
21320              *  1) the portion before the first such printable,
21321              *  2) the rest
21322              * and output them separately. */
21323             if (! isPRINT_A(start)) {
21324                 UV temp_end = start + 1;
21325
21326                 /* There is no point looking beyond the final possible
21327                  * printable, in MAX_PRINT_A */
21328                 UV max = MIN(end, MAX_PRINT_A);
21329
21330                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
21331                     temp_end++;
21332                 }
21333
21334                 /* Here, temp_end points to one beyond the first printable if
21335                  * found, or to one beyond 'max' if not.  If none found, make
21336                  * sure that we use the entire range */
21337                 if (temp_end > MAX_PRINT_A) {
21338                     temp_end = end + 1;
21339                 }
21340
21341                 /* Output the first part of the split range: the part that
21342                  * doesn't have printables, with the parameter set to not look
21343                  * for literals (otherwise we would infinitely recurse) */
21344                 put_range(sv, start, temp_end - 1, FALSE);
21345
21346                 /* The 2nd part of the range (if any) starts here. */
21347                 start = temp_end;
21348
21349                 /* We do a continue, instead of dropping down, because even if
21350                  * the 2nd part is non-empty, it could be so short that we want
21351                  * to output it as individual characters, as tested for at the
21352                  * top of this loop.  */
21353                 continue;
21354             }
21355
21356             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
21357              * output a sub-range of just the digits or letters, then process
21358              * the remaining portion as usual. */
21359             if (isALPHANUMERIC_A(start)) {
21360                 UV mask = (isDIGIT_A(start))
21361                            ? _CC_DIGIT
21362                              : isUPPER_A(start)
21363                                ? _CC_UPPER
21364                                : _CC_LOWER;
21365                 UV temp_end = start + 1;
21366
21367                 /* Find the end of the sub-range that includes just the
21368                  * characters in the same class as the first character in it */
21369                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
21370                     temp_end++;
21371                 }
21372                 temp_end--;
21373
21374                 /* For short ranges, don't duplicate the code above to output
21375                  * them; just call recursively */
21376                 if (temp_end - start < min_range_count) {
21377                     put_range(sv, start, temp_end, FALSE);
21378                 }
21379                 else {  /* Output as a range */
21380                     put_code_point(sv, start);
21381                     sv_catpvs(sv, "-");
21382                     put_code_point(sv, temp_end);
21383                 }
21384                 start = temp_end + 1;
21385                 continue;
21386             }
21387
21388             /* We output any other printables as individual characters */
21389             if (isPUNCT_A(start) || isSPACE_A(start)) {
21390                 while (start <= end && (isPUNCT_A(start)
21391                                         || isSPACE_A(start)))
21392                 {
21393                     put_code_point(sv, start);
21394                     start++;
21395                 }
21396                 continue;
21397             }
21398         } /* End of looking for literals */
21399
21400         /* Here is not to output as a literal.  Some control characters have
21401          * mnemonic names.  Split off any of those at the beginning and end of
21402          * the range to print mnemonically.  It isn't possible for many of
21403          * these to be in a row, so this won't overwhelm with output */
21404         if (   start <= end
21405             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
21406         {
21407             while (isMNEMONIC_CNTRL(start) && start <= end) {
21408                 put_code_point(sv, start);
21409                 start++;
21410             }
21411
21412             /* If this didn't take care of the whole range ... */
21413             if (start <= end) {
21414
21415                 /* Look backwards from the end to find the final non-mnemonic
21416                  * */
21417                 UV temp_end = end;
21418                 while (isMNEMONIC_CNTRL(temp_end)) {
21419                     temp_end--;
21420                 }
21421
21422                 /* And separately output the interior range that doesn't start
21423                  * or end with mnemonics */
21424                 put_range(sv, start, temp_end, FALSE);
21425
21426                 /* Then output the mnemonic trailing controls */
21427                 start = temp_end + 1;
21428                 while (start <= end) {
21429                     put_code_point(sv, start);
21430                     start++;
21431                 }
21432                 break;
21433             }
21434         }
21435
21436         /* As a final resort, output the range or subrange as hex. */
21437
21438         this_end = (end < NUM_ANYOF_CODE_POINTS)
21439                     ? end
21440                     : NUM_ANYOF_CODE_POINTS - 1;
21441 #if NUM_ANYOF_CODE_POINTS > 256
21442         format = (this_end < 256)
21443                  ? "\\x%02" UVXf "-\\x%02" UVXf
21444                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
21445 #else
21446         format = "\\x%02" UVXf "-\\x%02" UVXf;
21447 #endif
21448         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
21449         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
21450         GCC_DIAG_RESTORE_STMT;
21451         break;
21452     }
21453 }
21454
21455 STATIC void
21456 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
21457 {
21458     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
21459      * 'invlist' */
21460
21461     UV start, end;
21462     bool allow_literals = TRUE;
21463
21464     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
21465
21466     /* Generally, it is more readable if printable characters are output as
21467      * literals, but if a range (nearly) spans all of them, it's best to output
21468      * it as a single range.  This code will use a single range if all but 2
21469      * ASCII printables are in it */
21470     invlist_iterinit(invlist);
21471     while (invlist_iternext(invlist, &start, &end)) {
21472
21473         /* If the range starts beyond the final printable, it doesn't have any
21474          * in it */
21475         if (start > MAX_PRINT_A) {
21476             break;
21477         }
21478
21479         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
21480          * all but two, the range must start and end no later than 2 from
21481          * either end */
21482         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
21483             if (end > MAX_PRINT_A) {
21484                 end = MAX_PRINT_A;
21485             }
21486             if (start < ' ') {
21487                 start = ' ';
21488             }
21489             if (end - start >= MAX_PRINT_A - ' ' - 2) {
21490                 allow_literals = FALSE;
21491             }
21492             break;
21493         }
21494     }
21495     invlist_iterfinish(invlist);
21496
21497     /* Here we have figured things out.  Output each range */
21498     invlist_iterinit(invlist);
21499     while (invlist_iternext(invlist, &start, &end)) {
21500         if (start >= NUM_ANYOF_CODE_POINTS) {
21501             break;
21502         }
21503         put_range(sv, start, end, allow_literals);
21504     }
21505     invlist_iterfinish(invlist);
21506
21507     return;
21508 }
21509
21510 STATIC SV*
21511 S_put_charclass_bitmap_innards_common(pTHX_
21512         SV* invlist,            /* The bitmap */
21513         SV* posixes,            /* Under /l, things like [:word:], \S */
21514         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
21515         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
21516         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
21517         const bool invert       /* Is the result to be inverted? */
21518 )
21519 {
21520     /* Create and return an SV containing a displayable version of the bitmap
21521      * and associated information determined by the input parameters.  If the
21522      * output would have been only the inversion indicator '^', NULL is instead
21523      * returned. */
21524
21525     dVAR;
21526     SV * output;
21527
21528     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
21529
21530     if (invert) {
21531         output = newSVpvs("^");
21532     }
21533     else {
21534         output = newSVpvs("");
21535     }
21536
21537     /* First, the code points in the bitmap that are unconditionally there */
21538     put_charclass_bitmap_innards_invlist(output, invlist);
21539
21540     /* Traditionally, these have been placed after the main code points */
21541     if (posixes) {
21542         sv_catsv(output, posixes);
21543     }
21544
21545     if (only_utf8 && _invlist_len(only_utf8)) {
21546         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
21547         put_charclass_bitmap_innards_invlist(output, only_utf8);
21548     }
21549
21550     if (not_utf8 && _invlist_len(not_utf8)) {
21551         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
21552         put_charclass_bitmap_innards_invlist(output, not_utf8);
21553     }
21554
21555     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
21556         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
21557         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
21558
21559         /* This is the only list in this routine that can legally contain code
21560          * points outside the bitmap range.  The call just above to
21561          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
21562          * output them here.  There's about a half-dozen possible, and none in
21563          * contiguous ranges longer than 2 */
21564         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21565             UV start, end;
21566             SV* above_bitmap = NULL;
21567
21568             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
21569
21570             invlist_iterinit(above_bitmap);
21571             while (invlist_iternext(above_bitmap, &start, &end)) {
21572                 UV i;
21573
21574                 for (i = start; i <= end; i++) {
21575                     put_code_point(output, i);
21576                 }
21577             }
21578             invlist_iterfinish(above_bitmap);
21579             SvREFCNT_dec_NN(above_bitmap);
21580         }
21581     }
21582
21583     if (invert && SvCUR(output) == 1) {
21584         return NULL;
21585     }
21586
21587     return output;
21588 }
21589
21590 STATIC bool
21591 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
21592                                      char *bitmap,
21593                                      SV *nonbitmap_invlist,
21594                                      SV *only_utf8_locale_invlist,
21595                                      const regnode * const node,
21596                                      const bool force_as_is_display)
21597 {
21598     /* Appends to 'sv' a displayable version of the innards of the bracketed
21599      * character class defined by the other arguments:
21600      *  'bitmap' points to the bitmap, or NULL if to ignore that.
21601      *  'nonbitmap_invlist' is an inversion list of the code points that are in
21602      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
21603      *      none.  The reasons for this could be that they require some
21604      *      condition such as the target string being or not being in UTF-8
21605      *      (under /d), or because they came from a user-defined property that
21606      *      was not resolved at the time of the regex compilation (under /u)
21607      *  'only_utf8_locale_invlist' is an inversion list of the code points that
21608      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
21609      *  'node' is the regex pattern ANYOF node.  It is needed only when the
21610      *      above two parameters are not null, and is passed so that this
21611      *      routine can tease apart the various reasons for them.
21612      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
21613      *      to invert things to see if that leads to a cleaner display.  If
21614      *      FALSE, this routine is free to use its judgment about doing this.
21615      *
21616      * It returns TRUE if there was actually something output.  (It may be that
21617      * the bitmap, etc is empty.)
21618      *
21619      * When called for outputting the bitmap of a non-ANYOF node, just pass the
21620      * bitmap, with the succeeding parameters set to NULL, and the final one to
21621      * FALSE.
21622      */
21623
21624     /* In general, it tries to display the 'cleanest' representation of the
21625      * innards, choosing whether to display them inverted or not, regardless of
21626      * whether the class itself is to be inverted.  However,  there are some
21627      * cases where it can't try inverting, as what actually matches isn't known
21628      * until runtime, and hence the inversion isn't either. */
21629
21630     dVAR;
21631     bool inverting_allowed = ! force_as_is_display;
21632
21633     int i;
21634     STRLEN orig_sv_cur = SvCUR(sv);
21635
21636     SV* invlist;            /* Inversion list we accumulate of code points that
21637                                are unconditionally matched */
21638     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
21639                                UTF-8 */
21640     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
21641                              */
21642     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
21643     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
21644                                        is UTF-8 */
21645
21646     SV* as_is_display;      /* The output string when we take the inputs
21647                                literally */
21648     SV* inverted_display;   /* The output string when we invert the inputs */
21649
21650     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
21651
21652     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
21653                                                    to match? */
21654     /* We are biased in favor of displaying things without them being inverted,
21655      * as that is generally easier to understand */
21656     const int bias = 5;
21657
21658     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
21659
21660     /* Start off with whatever code points are passed in.  (We clone, so we
21661      * don't change the caller's list) */
21662     if (nonbitmap_invlist) {
21663         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
21664         invlist = invlist_clone(nonbitmap_invlist, NULL);
21665     }
21666     else {  /* Worst case size is every other code point is matched */
21667         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
21668     }
21669
21670     if (flags) {
21671         if (OP(node) == ANYOFD) {
21672
21673             /* This flag indicates that the code points below 0x100 in the
21674              * nonbitmap list are precisely the ones that match only when the
21675              * target is UTF-8 (they should all be non-ASCII). */
21676             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
21677             {
21678                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
21679                 _invlist_subtract(invlist, only_utf8, &invlist);
21680             }
21681
21682             /* And this flag for matching all non-ASCII 0xFF and below */
21683             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
21684             {
21685                 not_utf8 = invlist_clone(PL_UpperLatin1, NULL);
21686             }
21687         }
21688         else if (OP(node) == ANYOFL || OP(node) == ANYOFPOSIXL) {
21689
21690             /* If either of these flags are set, what matches isn't
21691              * determinable except during execution, so don't know enough here
21692              * to invert */
21693             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
21694                 inverting_allowed = FALSE;
21695             }
21696
21697             /* What the posix classes match also varies at runtime, so these
21698              * will be output symbolically. */
21699             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
21700                 int i;
21701
21702                 posixes = newSVpvs("");
21703                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
21704                     if (ANYOF_POSIXL_TEST(node, i)) {
21705                         sv_catpv(posixes, anyofs[i]);
21706                     }
21707                 }
21708             }
21709         }
21710     }
21711
21712     /* Accumulate the bit map into the unconditional match list */
21713     if (bitmap) {
21714         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
21715             if (BITMAP_TEST(bitmap, i)) {
21716                 int start = i++;
21717                 for (;
21718                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
21719                      i++)
21720                 { /* empty */ }
21721                 invlist = _add_range_to_invlist(invlist, start, i-1);
21722             }
21723         }
21724     }
21725
21726     /* Make sure that the conditional match lists don't have anything in them
21727      * that match unconditionally; otherwise the output is quite confusing.
21728      * This could happen if the code that populates these misses some
21729      * duplication. */
21730     if (only_utf8) {
21731         _invlist_subtract(only_utf8, invlist, &only_utf8);
21732     }
21733     if (not_utf8) {
21734         _invlist_subtract(not_utf8, invlist, &not_utf8);
21735     }
21736
21737     if (only_utf8_locale_invlist) {
21738
21739         /* Since this list is passed in, we have to make a copy before
21740          * modifying it */
21741         only_utf8_locale = invlist_clone(only_utf8_locale_invlist, NULL);
21742
21743         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
21744
21745         /* And, it can get really weird for us to try outputting an inverted
21746          * form of this list when it has things above the bitmap, so don't even
21747          * try */
21748         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21749             inverting_allowed = FALSE;
21750         }
21751     }
21752
21753     /* Calculate what the output would be if we take the input as-is */
21754     as_is_display = put_charclass_bitmap_innards_common(invlist,
21755                                                     posixes,
21756                                                     only_utf8,
21757                                                     not_utf8,
21758                                                     only_utf8_locale,
21759                                                     invert);
21760
21761     /* If have to take the output as-is, just do that */
21762     if (! inverting_allowed) {
21763         if (as_is_display) {
21764             sv_catsv(sv, as_is_display);
21765             SvREFCNT_dec_NN(as_is_display);
21766         }
21767     }
21768     else { /* But otherwise, create the output again on the inverted input, and
21769               use whichever version is shorter */
21770
21771         int inverted_bias, as_is_bias;
21772
21773         /* We will apply our bias to whichever of the the results doesn't have
21774          * the '^' */
21775         if (invert) {
21776             invert = FALSE;
21777             as_is_bias = bias;
21778             inverted_bias = 0;
21779         }
21780         else {
21781             invert = TRUE;
21782             as_is_bias = 0;
21783             inverted_bias = bias;
21784         }
21785
21786         /* Now invert each of the lists that contribute to the output,
21787          * excluding from the result things outside the possible range */
21788
21789         /* For the unconditional inversion list, we have to add in all the
21790          * conditional code points, so that when inverted, they will be gone
21791          * from it */
21792         _invlist_union(only_utf8, invlist, &invlist);
21793         _invlist_union(not_utf8, invlist, &invlist);
21794         _invlist_union(only_utf8_locale, invlist, &invlist);
21795         _invlist_invert(invlist);
21796         _invlist_intersection(invlist, PL_InBitmap, &invlist);
21797
21798         if (only_utf8) {
21799             _invlist_invert(only_utf8);
21800             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
21801         }
21802         else if (not_utf8) {
21803
21804             /* If a code point matches iff the target string is not in UTF-8,
21805              * then complementing the result has it not match iff not in UTF-8,
21806              * which is the same thing as matching iff it is UTF-8. */
21807             only_utf8 = not_utf8;
21808             not_utf8 = NULL;
21809         }
21810
21811         if (only_utf8_locale) {
21812             _invlist_invert(only_utf8_locale);
21813             _invlist_intersection(only_utf8_locale,
21814                                   PL_InBitmap,
21815                                   &only_utf8_locale);
21816         }
21817
21818         inverted_display = put_charclass_bitmap_innards_common(
21819                                             invlist,
21820                                             posixes,
21821                                             only_utf8,
21822                                             not_utf8,
21823                                             only_utf8_locale, invert);
21824
21825         /* Use the shortest representation, taking into account our bias
21826          * against showing it inverted */
21827         if (   inverted_display
21828             && (   ! as_is_display
21829                 || (  SvCUR(inverted_display) + inverted_bias
21830                     < SvCUR(as_is_display)    + as_is_bias)))
21831         {
21832             sv_catsv(sv, inverted_display);
21833         }
21834         else if (as_is_display) {
21835             sv_catsv(sv, as_is_display);
21836         }
21837
21838         SvREFCNT_dec(as_is_display);
21839         SvREFCNT_dec(inverted_display);
21840     }
21841
21842     SvREFCNT_dec_NN(invlist);
21843     SvREFCNT_dec(only_utf8);
21844     SvREFCNT_dec(not_utf8);
21845     SvREFCNT_dec(posixes);
21846     SvREFCNT_dec(only_utf8_locale);
21847
21848     return SvCUR(sv) > orig_sv_cur;
21849 }
21850
21851 #define CLEAR_OPTSTART                                                       \
21852     if (optstart) STMT_START {                                               \
21853         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
21854                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
21855         optstart=NULL;                                                       \
21856     } STMT_END
21857
21858 #define DUMPUNTIL(b,e)                                                       \
21859                     CLEAR_OPTSTART;                                          \
21860                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
21861
21862 STATIC const regnode *
21863 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
21864             const regnode *last, const regnode *plast,
21865             SV* sv, I32 indent, U32 depth)
21866 {
21867     U8 op = PSEUDO;     /* Arbitrary non-END op. */
21868     const regnode *next;
21869     const regnode *optstart= NULL;
21870
21871     RXi_GET_DECL(r, ri);
21872     GET_RE_DEBUG_FLAGS_DECL;
21873
21874     PERL_ARGS_ASSERT_DUMPUNTIL;
21875
21876 #ifdef DEBUG_DUMPUNTIL
21877     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
21878         last ? last-start : 0, plast ? plast-start : 0);
21879 #endif
21880
21881     if (plast && plast < last)
21882         last= plast;
21883
21884     while (PL_regkind[op] != END && (!last || node < last)) {
21885         assert(node);
21886         /* While that wasn't END last time... */
21887         NODE_ALIGN(node);
21888         op = OP(node);
21889         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
21890             indent--;
21891         next = regnext((regnode *)node);
21892
21893         /* Where, what. */
21894         if (OP(node) == OPTIMIZED) {
21895             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
21896                 optstart = node;
21897             else
21898                 goto after_print;
21899         } else
21900             CLEAR_OPTSTART;
21901
21902         regprop(r, sv, node, NULL, NULL);
21903         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
21904                       (int)(2*indent + 1), "", SvPVX_const(sv));
21905
21906         if (OP(node) != OPTIMIZED) {
21907             if (next == NULL)           /* Next ptr. */
21908                 Perl_re_printf( aTHX_  " (0)");
21909             else if (PL_regkind[(U8)op] == BRANCH
21910                      && PL_regkind[OP(next)] != BRANCH )
21911                 Perl_re_printf( aTHX_  " (FAIL)");
21912             else
21913                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
21914             Perl_re_printf( aTHX_ "\n");
21915         }
21916
21917       after_print:
21918         if (PL_regkind[(U8)op] == BRANCHJ) {
21919             assert(next);
21920             {
21921                 const regnode *nnode = (OP(next) == LONGJMP
21922                                        ? regnext((regnode *)next)
21923                                        : next);
21924                 if (last && nnode > last)
21925                     nnode = last;
21926                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
21927             }
21928         }
21929         else if (PL_regkind[(U8)op] == BRANCH) {
21930             assert(next);
21931             DUMPUNTIL(NEXTOPER(node), next);
21932         }
21933         else if ( PL_regkind[(U8)op]  == TRIE ) {
21934             const regnode *this_trie = node;
21935             const char op = OP(node);
21936             const U32 n = ARG(node);
21937             const reg_ac_data * const ac = op>=AHOCORASICK ?
21938                (reg_ac_data *)ri->data->data[n] :
21939                NULL;
21940             const reg_trie_data * const trie =
21941                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
21942 #ifdef DEBUGGING
21943             AV *const trie_words
21944                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
21945 #endif
21946             const regnode *nextbranch= NULL;
21947             I32 word_idx;
21948             SvPVCLEAR(sv);
21949             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
21950                 SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0);
21951
21952                 Perl_re_indentf( aTHX_  "%s ",
21953                     indent+3,
21954                     elem_ptr
21955                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
21956                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
21957                                 PL_colors[0], PL_colors[1],
21958                                 (SvUTF8(*elem_ptr)
21959                                  ? PERL_PV_ESCAPE_UNI
21960                                  : 0)
21961                                 | PERL_PV_PRETTY_ELLIPSES
21962                                 | PERL_PV_PRETTY_LTGT
21963                             )
21964                     : "???"
21965                 );
21966                 if (trie->jump) {
21967                     U16 dist= trie->jump[word_idx+1];
21968                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
21969                                (UV)((dist ? this_trie + dist : next) - start));
21970                     if (dist) {
21971                         if (!nextbranch)
21972                             nextbranch= this_trie + trie->jump[0];
21973                         DUMPUNTIL(this_trie + dist, nextbranch);
21974                     }
21975                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
21976                         nextbranch= regnext((regnode *)nextbranch);
21977                 } else {
21978                     Perl_re_printf( aTHX_  "\n");
21979                 }
21980             }
21981             if (last && next > last)
21982                 node= last;
21983             else
21984                 node= next;
21985         }
21986         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
21987             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
21988                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
21989         }
21990         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
21991             assert(next);
21992             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
21993         }
21994         else if ( op == PLUS || op == STAR) {
21995             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
21996         }
21997         else if (PL_regkind[(U8)op] == EXACT) {
21998             /* Literal string, where present. */
21999             node += NODE_SZ_STR(node) - 1;
22000             node = NEXTOPER(node);
22001         }
22002         else {
22003             node = NEXTOPER(node);
22004             node += regarglen[(U8)op];
22005         }
22006         if (op == CURLYX || op == OPEN || op == SROPEN)
22007             indent++;
22008     }
22009     CLEAR_OPTSTART;
22010 #ifdef DEBUG_DUMPUNTIL
22011     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
22012 #endif
22013     return node;
22014 }
22015
22016 #endif  /* DEBUGGING */
22017
22018 #ifndef PERL_IN_XSUB_RE
22019
22020 #include "uni_keywords.h"
22021
22022 void
22023 Perl_init_uniprops(pTHX)
22024 {
22025     dVAR;
22026
22027     PL_user_def_props = newHV();
22028
22029 #ifdef USE_ITHREADS
22030
22031     HvSHAREKEYS_off(PL_user_def_props);
22032     PL_user_def_props_aTHX = aTHX;
22033
22034 #endif
22035
22036     /* Set up the inversion list global variables */
22037
22038     PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
22039     PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALNUM]);
22040     PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALPHA]);
22041     PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXBLANK]);
22042     PL_XPosix_ptrs[_CC_CASED] =  _new_invlist_C_array(uni_prop_ptrs[UNI_CASED]);
22043     PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXCNTRL]);
22044     PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXDIGIT]);
22045     PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXGRAPH]);
22046     PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXLOWER]);
22047     PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPRINT]);
22048     PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPUNCT]);
22049     PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXSPACE]);
22050     PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXUPPER]);
22051     PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_VERTSPACE]);
22052     PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXWORD]);
22053     PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXXDIGIT]);
22054
22055     PL_Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
22056     PL_Posix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALNUM]);
22057     PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALPHA]);
22058     PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXBLANK]);
22059     PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
22060     PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXCNTRL]);
22061     PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXDIGIT]);
22062     PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXGRAPH]);
22063     PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXLOWER]);
22064     PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPRINT]);
22065     PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPUNCT]);
22066     PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXSPACE]);
22067     PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXUPPER]);
22068     PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
22069     PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXWORD]);
22070     PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXXDIGIT]);
22071
22072     PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
22073     PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
22074     PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
22075     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
22076     PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
22077
22078     PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
22079     PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
22080     PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
22081
22082     PL_Assigned_invlist = _new_invlist_C_array(uni_prop_ptrs[UNI_ASSIGNED]);
22083
22084     PL_utf8_perl_idstart = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDSTART]);
22085     PL_utf8_perl_idcont = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDCONT]);
22086
22087     PL_utf8_charname_begin = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_BEGIN]);
22088     PL_utf8_charname_continue = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_CONTINUE]);
22089
22090     PL_in_some_fold = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_ANY_FOLDS]);
22091     PL_HasMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
22092                                             UNI__PERL_FOLDS_TO_MULTI_CHAR]);
22093     PL_InMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
22094                                             UNI__PERL_IS_IN_MULTI_CHAR_FOLD]);
22095     PL_NonFinalFold = _new_invlist_C_array(uni_prop_ptrs[
22096                                             UNI__PERL_NON_FINAL_FOLDS]);
22097
22098     PL_utf8_toupper = _new_invlist_C_array(Uppercase_Mapping_invlist);
22099     PL_utf8_tolower = _new_invlist_C_array(Lowercase_Mapping_invlist);
22100     PL_utf8_totitle = _new_invlist_C_array(Titlecase_Mapping_invlist);
22101     PL_utf8_tofold = _new_invlist_C_array(Case_Folding_invlist);
22102     PL_utf8_tosimplefold = _new_invlist_C_array(Simple_Case_Folding_invlist);
22103     PL_utf8_foldclosures = _new_invlist_C_array(_Perl_IVCF_invlist);
22104     PL_utf8_mark = _new_invlist_C_array(uni_prop_ptrs[UNI_M]);
22105     PL_CCC_non0_non230 = _new_invlist_C_array(_Perl_CCC_non0_non230_invlist);
22106     PL_Private_Use = _new_invlist_C_array(uni_prop_ptrs[UNI_CO]);
22107
22108 #ifdef UNI_XIDC
22109     /* The below are used only by deprecated functions.  They could be removed */
22110     PL_utf8_xidcont  = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDC]);
22111     PL_utf8_idcont   = _new_invlist_C_array(uni_prop_ptrs[UNI_IDC]);
22112     PL_utf8_xidstart = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDS]);
22113 #endif
22114 }
22115
22116 #if 0
22117
22118 This code was mainly added for backcompat to give a warning for non-portable
22119 code points in user-defined properties.  But experiments showed that the
22120 warning in earlier perls were only omitted on overflow, which should be an
22121 error, so there really isnt a backcompat issue, and actually adding the
22122 warning when none was present before might cause breakage, for little gain.  So
22123 khw left this code in, but not enabled.  Tests were never added.
22124
22125 embed.fnc entry:
22126 Ei      |const char *|get_extended_utf8_msg|const UV cp
22127
22128 PERL_STATIC_INLINE const char *
22129 S_get_extended_utf8_msg(pTHX_ const UV cp)
22130 {
22131     U8 dummy[UTF8_MAXBYTES + 1];
22132     HV *msgs;
22133     SV **msg;
22134
22135     uvchr_to_utf8_flags_msgs(dummy, cp, UNICODE_WARN_PERL_EXTENDED,
22136                              &msgs);
22137
22138     msg = hv_fetchs(msgs, "text", 0);
22139     assert(msg);
22140
22141     (void) sv_2mortal((SV *) msgs);
22142
22143     return SvPVX(*msg);
22144 }
22145
22146 #endif
22147
22148 SV *
22149 Perl_handle_user_defined_property(pTHX_
22150
22151     /* Parses the contents of a user-defined property definition; returning the
22152      * expanded definition if possible.  If so, the return is an inversion
22153      * list.
22154      *
22155      * If there are subroutines that are part of the expansion and which aren't
22156      * known at the time of the call to this function, this returns what
22157      * parse_uniprop_string() returned for the first one encountered.
22158      *
22159      * If an error was found, NULL is returned, and 'msg' gets a suitable
22160      * message appended to it.  (Appending allows the back trace of how we got
22161      * to the faulty definition to be displayed through nested calls of
22162      * user-defined subs.)
22163      *
22164      * The caller IS responsible for freeing any returned SV.
22165      *
22166      * The syntax of the contents is pretty much described in perlunicode.pod,
22167      * but we also allow comments on each line */
22168
22169     const char * name,          /* Name of property */
22170     const STRLEN name_len,      /* The name's length in bytes */
22171     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22172     const bool to_fold,         /* ? Is this under /i */
22173     const bool runtime,         /* ? Are we in compile- or run-time */
22174     const bool deferrable,      /* Is it ok for this property's full definition
22175                                    to be deferred until later? */
22176     SV* contents,               /* The property's definition */
22177     bool *user_defined_ptr,     /* This will be set TRUE as we wouldn't be
22178                                    getting called unless this is thought to be
22179                                    a user-defined property */
22180     SV * msg,                   /* Any error or warning msg(s) are appended to
22181                                    this */
22182     const STRLEN level)         /* Recursion level of this call */
22183 {
22184     STRLEN len;
22185     const char * string         = SvPV_const(contents, len);
22186     const char * const e        = string + len;
22187     const bool is_contents_utf8 = cBOOL(SvUTF8(contents));
22188     const STRLEN msgs_length_on_entry = SvCUR(msg);
22189
22190     const char * s0 = string;   /* Points to first byte in the current line
22191                                    being parsed in 'string' */
22192     const char overflow_msg[] = "Code point too large in \"";
22193     SV* running_definition = NULL;
22194
22195     PERL_ARGS_ASSERT_HANDLE_USER_DEFINED_PROPERTY;
22196
22197     *user_defined_ptr = TRUE;
22198
22199     /* Look at each line */
22200     while (s0 < e) {
22201         const char * s;     /* Current byte */
22202         char op = '+';      /* Default operation is 'union' */
22203         IV   min = 0;       /* range begin code point */
22204         IV   max = -1;      /* and range end */
22205         SV* this_definition;
22206
22207         /* Skip comment lines */
22208         if (*s0 == '#') {
22209             s0 = strchr(s0, '\n');
22210             if (s0 == NULL) {
22211                 break;
22212             }
22213             s0++;
22214             continue;
22215         }
22216
22217         /* For backcompat, allow an empty first line */
22218         if (*s0 == '\n') {
22219             s0++;
22220             continue;
22221         }
22222
22223         /* First character in the line may optionally be the operation */
22224         if (   *s0 == '+'
22225             || *s0 == '!'
22226             || *s0 == '-'
22227             || *s0 == '&')
22228         {
22229             op = *s0++;
22230         }
22231
22232         /* If the line is one or two hex digits separated by blank space, its
22233          * a range; otherwise it is either another user-defined property or an
22234          * error */
22235
22236         s = s0;
22237
22238         if (! isXDIGIT(*s)) {
22239             goto check_if_property;
22240         }
22241
22242         do { /* Each new hex digit will add 4 bits. */
22243             if (min > ( (IV) MAX_LEGAL_CP >> 4)) {
22244                 s = strchr(s, '\n');
22245                 if (s == NULL) {
22246                     s = e;
22247                 }
22248                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22249                 sv_catpv(msg, overflow_msg);
22250                 Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22251                                      UTF8fARG(is_contents_utf8, s - s0, s0));
22252                 sv_catpvs(msg, "\"");
22253                 goto return_failure;
22254             }
22255
22256             /* Accumulate this digit into the value */
22257             min = (min << 4) + READ_XDIGIT(s);
22258         } while (isXDIGIT(*s));
22259
22260         while (isBLANK(*s)) { s++; }
22261
22262         /* We allow comments at the end of the line */
22263         if (*s == '#') {
22264             s = strchr(s, '\n');
22265             if (s == NULL) {
22266                 s = e;
22267             }
22268             s++;
22269         }
22270         else if (s < e && *s != '\n') {
22271             if (! isXDIGIT(*s)) {
22272                 goto check_if_property;
22273             }
22274
22275             /* Look for the high point of the range */
22276             max = 0;
22277             do {
22278                 if (max > ( (IV) MAX_LEGAL_CP >> 4)) {
22279                     s = strchr(s, '\n');
22280                     if (s == NULL) {
22281                         s = e;
22282                     }
22283                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22284                     sv_catpv(msg, overflow_msg);
22285                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22286                                       UTF8fARG(is_contents_utf8, s - s0, s0));
22287                     sv_catpvs(msg, "\"");
22288                     goto return_failure;
22289                 }
22290
22291                 max = (max << 4) + READ_XDIGIT(s);
22292             } while (isXDIGIT(*s));
22293
22294             while (isBLANK(*s)) { s++; }
22295
22296             if (*s == '#') {
22297                 s = strchr(s, '\n');
22298                 if (s == NULL) {
22299                     s = e;
22300                 }
22301             }
22302             else if (s < e && *s != '\n') {
22303                 goto check_if_property;
22304             }
22305         }
22306
22307         if (max == -1) {    /* The line only had one entry */
22308             max = min;
22309         }
22310         else if (max < min) {
22311             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22312             sv_catpvs(msg, "Illegal range in \"");
22313             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22314                                 UTF8fARG(is_contents_utf8, s - s0, s0));
22315             sv_catpvs(msg, "\"");
22316             goto return_failure;
22317         }
22318
22319 #if 0   /* See explanation at definition above of get_extended_utf8_msg() */
22320
22321         if (   UNICODE_IS_PERL_EXTENDED(min)
22322             || UNICODE_IS_PERL_EXTENDED(max))
22323         {
22324             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22325
22326             /* If both code points are non-portable, warn only on the lower
22327              * one. */
22328             sv_catpv(msg, get_extended_utf8_msg(
22329                                             (UNICODE_IS_PERL_EXTENDED(min))
22330                                             ? min : max));
22331             sv_catpvs(msg, " in \"");
22332             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22333                                  UTF8fARG(is_contents_utf8, s - s0, s0));
22334             sv_catpvs(msg, "\"");
22335         }
22336
22337 #endif
22338
22339         /* Here, this line contains a legal range */
22340         this_definition = sv_2mortal(_new_invlist(2));
22341         this_definition = _add_range_to_invlist(this_definition, min, max);
22342         goto calculate;
22343
22344       check_if_property:
22345
22346         /* Here it isn't a legal range line.  See if it is a legal property
22347          * line.  First find the end of the meat of the line */
22348         s = strpbrk(s, "#\n");
22349         if (s == NULL) {
22350             s = e;
22351         }
22352
22353         /* Ignore trailing blanks in keeping with the requirements of
22354          * parse_uniprop_string() */
22355         s--;
22356         while (s > s0 && isBLANK_A(*s)) {
22357             s--;
22358         }
22359         s++;
22360
22361         this_definition = parse_uniprop_string(s0, s - s0,
22362                                                is_utf8, to_fold, runtime,
22363                                                deferrable,
22364                                                user_defined_ptr, msg,
22365                                                (name_len == 0)
22366                                                 ? level /* Don't increase level
22367                                                            if input is empty */
22368                                                 : level + 1
22369                                               );
22370         if (this_definition == NULL) {
22371             goto return_failure;    /* 'msg' should have had the reason
22372                                        appended to it by the above call */
22373         }
22374
22375         if (! is_invlist(this_definition)) {    /* Unknown at this time */
22376             return newSVsv(this_definition);
22377         }
22378
22379         if (*s != '\n') {
22380             s = strchr(s, '\n');
22381             if (s == NULL) {
22382                 s = e;
22383             }
22384         }
22385
22386       calculate:
22387
22388         switch (op) {
22389             case '+':
22390                 _invlist_union(running_definition, this_definition,
22391                                                         &running_definition);
22392                 break;
22393             case '-':
22394                 _invlist_subtract(running_definition, this_definition,
22395                                                         &running_definition);
22396                 break;
22397             case '&':
22398                 _invlist_intersection(running_definition, this_definition,
22399                                                         &running_definition);
22400                 break;
22401             case '!':
22402                 _invlist_union_complement_2nd(running_definition,
22403                                         this_definition, &running_definition);
22404                 break;
22405             default:
22406                 Perl_croak(aTHX_ "panic: %s: %d: Unexpected operation %d",
22407                                  __FILE__, __LINE__, op);
22408                 break;
22409         }
22410
22411         /* Position past the '\n' */
22412         s0 = s + 1;
22413     }   /* End of loop through the lines of 'contents' */
22414
22415     /* Here, we processed all the lines in 'contents' without error.  If we
22416      * didn't add any warnings, simply return success */
22417     if (msgs_length_on_entry == SvCUR(msg)) {
22418
22419         /* If the expansion was empty, the answer isn't nothing: its an empty
22420          * inversion list */
22421         if (running_definition == NULL) {
22422             running_definition = _new_invlist(1);
22423         }
22424
22425         return running_definition;
22426     }
22427
22428     /* Otherwise, add some explanatory text, but we will return success */
22429     goto return_msg;
22430
22431   return_failure:
22432     running_definition = NULL;
22433
22434   return_msg:
22435
22436     if (name_len > 0) {
22437         sv_catpvs(msg, " in expansion of ");
22438         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
22439     }
22440
22441     return running_definition;
22442 }
22443
22444 /* As explained below, certain operations need to take place in the first
22445  * thread created.  These macros switch contexts */
22446 #ifdef USE_ITHREADS
22447 #  define DECLARATION_FOR_GLOBAL_CONTEXT                                    \
22448                                         PerlInterpreter * save_aTHX = aTHX;
22449 #  define SWITCH_TO_GLOBAL_CONTEXT                                          \
22450                            PERL_SET_CONTEXT((aTHX = PL_user_def_props_aTHX))
22451 #  define RESTORE_CONTEXT  PERL_SET_CONTEXT((aTHX = save_aTHX));
22452 #  define CUR_CONTEXT      aTHX
22453 #  define ORIGINAL_CONTEXT save_aTHX
22454 #else
22455 #  define DECLARATION_FOR_GLOBAL_CONTEXT
22456 #  define SWITCH_TO_GLOBAL_CONTEXT          NOOP
22457 #  define RESTORE_CONTEXT                   NOOP
22458 #  define CUR_CONTEXT                       NULL
22459 #  define ORIGINAL_CONTEXT                  NULL
22460 #endif
22461
22462 STATIC void
22463 S_delete_recursion_entry(pTHX_ void *key)
22464 {
22465     /* Deletes the entry used to detect recursion when expanding user-defined
22466      * properties.  This is a function so it can be set up to be called even if
22467      * the program unexpectedly quits */
22468
22469     dVAR;
22470     SV ** current_entry;
22471     const STRLEN key_len = strlen((const char *) key);
22472     DECLARATION_FOR_GLOBAL_CONTEXT;
22473
22474     SWITCH_TO_GLOBAL_CONTEXT;
22475
22476     /* If the entry is one of these types, it is a permanent entry, and not the
22477      * one used to detect recursions.  This function should delete only the
22478      * recursion entry */
22479     current_entry = hv_fetch(PL_user_def_props, (const char *) key, key_len, 0);
22480     if (     current_entry
22481         && ! is_invlist(*current_entry)
22482         && ! SvPOK(*current_entry))
22483     {
22484         (void) hv_delete(PL_user_def_props, (const char *) key, key_len,
22485                                                                     G_DISCARD);
22486     }
22487
22488     RESTORE_CONTEXT;
22489 }
22490
22491 STATIC SV *
22492 S_get_fq_name(pTHX_
22493               const char * const name,    /* The first non-blank in the \p{}, \P{} */
22494               const Size_t name_len,      /* Its length in bytes, not including any trailing space */
22495               const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22496               const bool has_colon_colon
22497              )
22498 {
22499     /* Returns a mortal SV containing the fully qualified version of the input
22500      * name */
22501
22502     SV * fq_name;
22503
22504     fq_name = newSVpvs_flags("", SVs_TEMP);
22505
22506     /* Use the current package if it wasn't included in our input */
22507     if (! has_colon_colon) {
22508         const HV * pkg = (IN_PERL_COMPILETIME)
22509                          ? PL_curstash
22510                          : CopSTASH(PL_curcop);
22511         const char* pkgname = HvNAME(pkg);
22512
22513         Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
22514                       UTF8fARG(is_utf8, strlen(pkgname), pkgname));
22515         sv_catpvs(fq_name, "::");
22516     }
22517
22518     Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
22519                          UTF8fARG(is_utf8, name_len, name));
22520     return fq_name;
22521 }
22522
22523 SV *
22524 Perl_parse_uniprop_string(pTHX_
22525
22526     /* Parse the interior of a \p{}, \P{}.  Returns its definition if knowable
22527      * now.  If so, the return is an inversion list.
22528      *
22529      * If the property is user-defined, it is a subroutine, which in turn
22530      * may call other subroutines.  This function will call the whole nest of
22531      * them to get the definition they return; if some aren't known at the time
22532      * of the call to this function, the fully qualified name of the highest
22533      * level sub is returned.  It is an error to call this function at runtime
22534      * without every sub defined.
22535      *
22536      * If an error was found, NULL is returned, and 'msg' gets a suitable
22537      * message appended to it.  (Appending allows the back trace of how we got
22538      * to the faulty definition to be displayed through nested calls of
22539      * user-defined subs.)
22540      *
22541      * The caller should NOT try to free any returned inversion list.
22542      *
22543      * Other parameters will be set on return as described below */
22544
22545     const char * const name,    /* The first non-blank in the \p{}, \P{} */
22546     const Size_t name_len,      /* Its length in bytes, not including any
22547                                    trailing space */
22548     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22549     const bool to_fold,         /* ? Is this under /i */
22550     const bool runtime,         /* TRUE if this is being called at run time */
22551     const bool deferrable,      /* TRUE if it's ok for the definition to not be
22552                                    known at this call */
22553     bool *user_defined_ptr,     /* Upon return from this function it will be
22554                                    set to TRUE if any component is a
22555                                    user-defined property */
22556     SV * msg,                   /* Any error or warning msg(s) are appended to
22557                                    this */
22558    const STRLEN level)          /* Recursion level of this call */
22559 {
22560     dVAR;
22561     char* lookup_name;          /* normalized name for lookup in our tables */
22562     unsigned lookup_len;        /* Its length */
22563     bool stricter = FALSE;      /* Some properties have stricter name
22564                                    normalization rules, which we decide upon
22565                                    based on parsing */
22566
22567     /* nv= or numeric_value=, or possibly one of the cjk numeric properties
22568      * (though it requires extra effort to download them from Unicode and
22569      * compile perl to know about them) */
22570     bool is_nv_type = FALSE;
22571
22572     unsigned int i, j = 0;
22573     int equals_pos = -1;    /* Where the '=' is found, or negative if none */
22574     int slash_pos  = -1;    /* Where the '/' is found, or negative if none */
22575     int table_index = 0;    /* The entry number for this property in the table
22576                                of all Unicode property names */
22577     bool starts_with_Is = FALSE;  /* ? Does the name start with 'Is' */
22578     Size_t lookup_offset = 0;   /* Used to ignore the first few characters of
22579                                    the normalized name in certain situations */
22580     Size_t non_pkg_begin = 0;   /* Offset of first byte in 'name' that isn't
22581                                    part of a package name */
22582     bool could_be_user_defined = TRUE;  /* ? Could this be a user-defined
22583                                              property rather than a Unicode
22584                                              one. */
22585     SV * prop_definition = NULL;  /* The returned definition of 'name' or NULL
22586                                      if an error.  If it is an inversion list,
22587                                      it is the definition.  Otherwise it is a
22588                                      string containing the fully qualified sub
22589                                      name of 'name' */
22590     SV * fq_name = NULL;        /* For user-defined properties, the fully
22591                                    qualified name */
22592     bool invert_return = FALSE; /* ? Do we need to complement the result before
22593                                      returning it */
22594
22595     PERL_ARGS_ASSERT_PARSE_UNIPROP_STRING;
22596
22597     /* The input will be normalized into 'lookup_name' */
22598     Newx(lookup_name, name_len, char);
22599     SAVEFREEPV(lookup_name);
22600
22601     /* Parse the input. */
22602     for (i = 0; i < name_len; i++) {
22603         char cur = name[i];
22604
22605         /* Most of the characters in the input will be of this ilk, being parts
22606          * of a name */
22607         if (isIDCONT_A(cur)) {
22608
22609             /* Case differences are ignored.  Our lookup routine assumes
22610              * everything is lowercase, so normalize to that */
22611             if (isUPPER_A(cur)) {
22612                 lookup_name[j++] = toLOWER_A(cur);
22613                 continue;
22614             }
22615
22616             if (cur == '_') { /* Don't include these in the normalized name */
22617                 continue;
22618             }
22619
22620             lookup_name[j++] = cur;
22621
22622             /* The first character in a user-defined name must be of this type.
22623              * */
22624             if (i - non_pkg_begin == 0 && ! isIDFIRST_A(cur)) {
22625                 could_be_user_defined = FALSE;
22626             }
22627
22628             continue;
22629         }
22630
22631         /* Here, the character is not something typically in a name,  But these
22632          * two types of characters (and the '_' above) can be freely ignored in
22633          * most situations.  Later it may turn out we shouldn't have ignored
22634          * them, and we have to reparse, but we don't have enough information
22635          * yet to make that decision */
22636         if (cur == '-' || isSPACE_A(cur)) {
22637             could_be_user_defined = FALSE;
22638             continue;
22639         }
22640
22641         /* An equals sign or single colon mark the end of the first part of
22642          * the property name */
22643         if (    cur == '='
22644             || (cur == ':' && (i >= name_len - 1 || name[i+1] != ':')))
22645         {
22646             lookup_name[j++] = '='; /* Treat the colon as an '=' */
22647             equals_pos = j; /* Note where it occurred in the input */
22648             could_be_user_defined = FALSE;
22649             break;
22650         }
22651
22652         /* Otherwise, this character is part of the name. */
22653         lookup_name[j++] = cur;
22654
22655         /* Here it isn't a single colon, so if it is a colon, it must be a
22656          * double colon */
22657         if (cur == ':') {
22658
22659             /* A double colon should be a package qualifier.  We note its
22660              * position and continue.  Note that one could have
22661              *      pkg1::pkg2::...::foo
22662              * so that the position at the end of the loop will be just after
22663              * the final qualifier */
22664
22665             i++;
22666             non_pkg_begin = i + 1;
22667             lookup_name[j++] = ':';
22668         }
22669         else { /* Only word chars (and '::') can be in a user-defined name */
22670             could_be_user_defined = FALSE;
22671         }
22672     } /* End of parsing through the lhs of the property name (or all of it if
22673          no rhs) */
22674
22675 #define STRLENs(s)  (sizeof("" s "") - 1)
22676
22677     /* If there is a single package name 'utf8::', it is ambiguous.  It could
22678      * be for a user-defined property, or it could be a Unicode property, as
22679      * all of them are considered to be for that package.  For the purposes of
22680      * parsing the rest of the property, strip it off */
22681     if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
22682         lookup_name +=  STRLENs("utf8::");
22683         j -=  STRLENs("utf8::");
22684         equals_pos -=  STRLENs("utf8::");
22685     }
22686
22687     /* Here, we are either done with the whole property name, if it was simple;
22688      * or are positioned just after the '=' if it is compound. */
22689
22690     if (equals_pos >= 0) {
22691         assert(! stricter); /* We shouldn't have set this yet */
22692
22693         /* Space immediately after the '=' is ignored */
22694         i++;
22695         for (; i < name_len; i++) {
22696             if (! isSPACE_A(name[i])) {
22697                 break;
22698             }
22699         }
22700
22701         /* Most punctuation after the equals indicates a subpattern, like
22702          * \p{foo=/bar/} */
22703         if (   isPUNCT_A(name[i])
22704             && name[i] != '-'
22705             && name[i] != '+'
22706             && name[i] != '_'
22707             && name[i] != '{')
22708         {
22709             /* Find the property.  The table includes the equals sign, so we
22710              * use 'j' as-is */
22711             table_index = match_uniprop((U8 *) lookup_name, j);
22712             if (table_index) {
22713                 const char * const * prop_values
22714                                             = UNI_prop_value_ptrs[table_index];
22715                 SV * subpattern;
22716                 Size_t subpattern_len;
22717                 REGEXP * subpattern_re;
22718                 char open = name[i++];
22719                 char close;
22720                 const char * pos_in_brackets;
22721                 bool escaped = 0;
22722
22723                 /* A backslash means the real delimitter is the next character.
22724                  * */
22725                 if (open == '\\') {
22726                     open = name[i++];
22727                     escaped = 1;
22728                 }
22729
22730                 /* This data structure is constructed so that the matching
22731                  * closing bracket is 3 past its matching opening.  The second
22732                  * set of closing is so that if the opening is something like
22733                  * ']', the closing will be that as well.  Something similar is
22734                  * done in toke.c */
22735                 pos_in_brackets = strchr("([<)]>)]>", open);
22736                 close = (pos_in_brackets) ? pos_in_brackets[3] : open;
22737
22738                 if (    i >= name_len
22739                     ||  name[name_len-1] != close
22740                     || (escaped && name[name_len-2] != '\\'))
22741                 {
22742                     sv_catpvs(msg, "Unicode property wildcard not terminated");
22743                     goto append_name_to_msg;
22744                 }
22745
22746                 Perl_ck_warner_d(aTHX_
22747                     packWARN(WARN_EXPERIMENTAL__UNIPROP_WILDCARDS),
22748                     "The Unicode property wildcards feature is experimental");
22749
22750                 /* Now create and compile the wildcard subpattern.  Use /iaa
22751                  * because nothing outside of ASCII will match, and it the
22752                  * property values should all match /i.  Note that when the
22753                  * pattern fails to compile, our added text to the user's
22754                  * pattern will be displayed to the user, which is not so
22755                  * desirable. */
22756                 subpattern_len = name_len - i - 1 - escaped;
22757                 subpattern = Perl_newSVpvf(aTHX_ "(?iaa:%.*s)",
22758                                               (unsigned) subpattern_len,
22759                                               name + i);
22760                 subpattern = sv_2mortal(subpattern);
22761                 subpattern_re = re_compile(subpattern, 0);
22762                 assert(subpattern_re);  /* Should have died if didn't compile
22763                                          successfully */
22764
22765                 /* For each legal property value, see if the supplied pattern
22766                  * matches it. */
22767                 while (*prop_values) {
22768                     const char * const entry = *prop_values;
22769                     const Size_t len = strlen(entry);
22770                     SV* entry_sv = newSVpvn_flags(entry, len, SVs_TEMP);
22771
22772                     if (pregexec(subpattern_re,
22773                                  (char *) entry,
22774                                  (char *) entry + len,
22775                                  (char *) entry, 0,
22776                                  entry_sv,
22777                                  0))
22778                     { /* Here, matched.  Add to the returned list */
22779                         Size_t total_len = j + len;
22780                         SV * sub_invlist = NULL;
22781                         char * this_string;
22782
22783                         /* We know this is a legal \p{property=value}.  Call
22784                          * the function to return the list of code points that
22785                          * match it */
22786                         Newxz(this_string, total_len + 1, char);
22787                         Copy(lookup_name, this_string, j, char);
22788                         my_strlcat(this_string, entry, total_len + 1);
22789                         SAVEFREEPV(this_string);
22790                         sub_invlist = parse_uniprop_string(this_string,
22791                                                            total_len,
22792                                                            is_utf8,
22793                                                            to_fold,
22794                                                            runtime,
22795                                                            deferrable,
22796                                                            user_defined_ptr,
22797                                                            msg,
22798                                                            level + 1);
22799                         _invlist_union(prop_definition, sub_invlist,
22800                                        &prop_definition);
22801                     }
22802
22803                     prop_values++;  /* Next iteration, look at next propvalue */
22804                 } /* End of looking through property values; (the data
22805                      structure is terminated by a NULL ptr) */
22806
22807                 SvREFCNT_dec_NN(subpattern_re);
22808
22809                 if (prop_definition) {
22810                     return prop_definition;
22811                 }
22812
22813                 sv_catpvs(msg, "No Unicode property value wildcard matches:");
22814                 goto append_name_to_msg;
22815             }
22816
22817             /* Here's how khw thinks we should proceed to handle the properties
22818              * not yet done:    Bidi Mirroring Glyph
22819                                 Bidi Paired Bracket
22820                                 Case Folding  (both full and simple)
22821                                 Decomposition Mapping
22822                                 Equivalent Unified Ideograph
22823                                 Name
22824                                 Name Alias
22825                                 Lowercase Mapping  (both full and simple)
22826                                 NFKC Case Fold
22827                                 Titlecase Mapping  (both full and simple)
22828                                 Uppercase Mapping  (both full and simple)
22829              * Move the part that looks at the property values into a perl
22830              * script, like utf8_heavy.pl is done.  This makes things somewhat
22831              * easier, but most importantly, it avoids always adding all these
22832              * strings to the memory usage when the feature is little-used.
22833              *
22834              * The property values would all be concatenated into a single
22835              * string per property with each value on a separate line, and the
22836              * code point it's for on alternating lines.  Then we match the
22837              * user's input pattern m//mg, without having to worry about their
22838              * uses of '^' and '$'.  Only the values that aren't the default
22839              * would be in the strings.  Code points would be in UTF-8.  The
22840              * search pattern that we would construct would look like
22841              * (?: \n (code-point_re) \n (?aam: user-re ) \n )
22842              * And so $1 would contain the code point that matched the user-re.
22843              * For properties where the default is the code point itself, such
22844              * as any of the case changing mappings, the string would otherwise
22845              * consist of all Unicode code points in UTF-8 strung together.
22846              * This would be impractical.  So instead, examine their compiled
22847              * pattern, looking at the ssc.  If none, reject the pattern as an
22848              * error.  Otherwise run the pattern against every code point in
22849              * the ssc.  The ssc is kind of like tr18's 3.9 Possible Match Sets
22850              * And it might be good to create an API to return the ssc.
22851              *
22852              * For the name properties, a new function could be created in
22853              * charnames which essentially does the same thing as above,
22854              * sharing Name.pl with the other charname functions.  Don't know
22855              * about loose name matching, or algorithmically determined names.
22856              * Decomposition.pl similarly.
22857              *
22858              * It might be that a new pattern modifier would have to be
22859              * created, like /t for resTricTed, which changed the behavior of
22860              * some constructs in their subpattern, like \A. */
22861         } /* End of is a wildcard subppattern */
22862
22863
22864         /* Certain properties whose values are numeric need special handling.
22865          * They may optionally be prefixed by 'is'.  Ignore that prefix for the
22866          * purposes of checking if this is one of those properties */
22867         if (memBEGINPs(lookup_name, name_len, "is")) {
22868             lookup_offset = 2;
22869         }
22870
22871         /* Then check if it is one of these specially-handled properties.  The
22872          * possibilities are hard-coded because easier this way, and the list
22873          * is unlikely to change.
22874          *
22875          * All numeric value type properties are of this ilk, and are also
22876          * special in a different way later on.  So find those first.  There
22877          * are several numeric value type properties in the Unihan DB (which is
22878          * unlikely to be compiled with perl, but we handle it here in case it
22879          * does get compiled).  They all end with 'numeric'.  The interiors
22880          * aren't checked for the precise property.  This would stop working if
22881          * a cjk property were to be created that ended with 'numeric' and
22882          * wasn't a numeric type */
22883         is_nv_type = memEQs(lookup_name + lookup_offset,
22884                        j - 1 - lookup_offset, "numericvalue")
22885                   || memEQs(lookup_name + lookup_offset,
22886                       j - 1 - lookup_offset, "nv")
22887                   || (   memENDPs(lookup_name + lookup_offset,
22888                             j - 1 - lookup_offset, "numeric")
22889                       && (   memBEGINPs(lookup_name + lookup_offset,
22890                                       j - 1 - lookup_offset, "cjk")
22891                           || memBEGINPs(lookup_name + lookup_offset,
22892                                       j - 1 - lookup_offset, "k")));
22893         if (   is_nv_type
22894             || memEQs(lookup_name + lookup_offset,
22895                       j - 1 - lookup_offset, "canonicalcombiningclass")
22896             || memEQs(lookup_name + lookup_offset,
22897                       j - 1 - lookup_offset, "ccc")
22898             || memEQs(lookup_name + lookup_offset,
22899                       j - 1 - lookup_offset, "age")
22900             || memEQs(lookup_name + lookup_offset,
22901                       j - 1 - lookup_offset, "in")
22902             || memEQs(lookup_name + lookup_offset,
22903                       j - 1 - lookup_offset, "presentin"))
22904         {
22905             unsigned int k;
22906
22907             /* Since the stuff after the '=' is a number, we can't throw away
22908              * '-' willy-nilly, as those could be a minus sign.  Other stricter
22909              * rules also apply.  However, these properties all can have the
22910              * rhs not be a number, in which case they contain at least one
22911              * alphabetic.  In those cases, the stricter rules don't apply.
22912              * But the numeric type properties can have the alphas [Ee] to
22913              * signify an exponent, and it is still a number with stricter
22914              * rules.  So look for an alpha that signifies not-strict */
22915             stricter = TRUE;
22916             for (k = i; k < name_len; k++) {
22917                 if (   isALPHA_A(name[k])
22918                     && (! is_nv_type || ! isALPHA_FOLD_EQ(name[k], 'E')))
22919                 {
22920                     stricter = FALSE;
22921                     break;
22922                 }
22923             }
22924         }
22925
22926         if (stricter) {
22927
22928             /* A number may have a leading '+' or '-'.  The latter is retained
22929              * */
22930             if (name[i] == '+') {
22931                 i++;
22932             }
22933             else if (name[i] == '-') {
22934                 lookup_name[j++] = '-';
22935                 i++;
22936             }
22937
22938             /* Skip leading zeros including single underscores separating the
22939              * zeros, or between the final leading zero and the first other
22940              * digit */
22941             for (; i < name_len - 1; i++) {
22942                 if (    name[i] != '0'
22943                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
22944                 {
22945                     break;
22946                 }
22947             }
22948         }
22949     }
22950     else {  /* No '=' */
22951
22952        /* Only a few properties without an '=' should be parsed with stricter
22953         * rules.  The list is unlikely to change. */
22954         if (   memBEGINPs(lookup_name, j, "perl")
22955             && memNEs(lookup_name + 4, j - 4, "space")
22956             && memNEs(lookup_name + 4, j - 4, "word"))
22957         {
22958             stricter = TRUE;
22959
22960             /* We set the inputs back to 0 and the code below will reparse,
22961              * using strict */
22962             i = j = 0;
22963         }
22964     }
22965
22966     /* Here, we have either finished the property, or are positioned to parse
22967      * the remainder, and we know if stricter rules apply.  Finish out, if not
22968      * already done */
22969     for (; i < name_len; i++) {
22970         char cur = name[i];
22971
22972         /* In all instances, case differences are ignored, and we normalize to
22973          * lowercase */
22974         if (isUPPER_A(cur)) {
22975             lookup_name[j++] = toLOWER(cur);
22976             continue;
22977         }
22978
22979         /* An underscore is skipped, but not under strict rules unless it
22980          * separates two digits */
22981         if (cur == '_') {
22982             if (    stricter
22983                 && (     i == 0 || (int) i == equals_pos || i == name_len- 1
22984                     || ! isDIGIT_A(name[i-1]) || ! isDIGIT_A(name[i+1])))
22985             {
22986                 lookup_name[j++] = '_';
22987             }
22988             continue;
22989         }
22990
22991         /* Hyphens are skipped except under strict */
22992         if (cur == '-' && ! stricter) {
22993             continue;
22994         }
22995
22996         /* XXX Bug in documentation.  It says white space skipped adjacent to
22997          * non-word char.  Maybe we should, but shouldn't skip it next to a dot
22998          * in a number */
22999         if (isSPACE_A(cur) && ! stricter) {
23000             continue;
23001         }
23002
23003         lookup_name[j++] = cur;
23004
23005         /* Unless this is a non-trailing slash, we are done with it */
23006         if (i >= name_len - 1 || cur != '/') {
23007             continue;
23008         }
23009
23010         slash_pos = j;
23011
23012         /* A slash in the 'numeric value' property indicates that what follows
23013          * is a denominator.  It can have a leading '+' and '0's that should be
23014          * skipped.  But we have never allowed a negative denominator, so treat
23015          * a minus like every other character.  (No need to rule out a second
23016          * '/', as that won't match anything anyway */
23017         if (is_nv_type) {
23018             i++;
23019             if (i < name_len && name[i] == '+') {
23020                 i++;
23021             }
23022
23023             /* Skip leading zeros including underscores separating digits */
23024             for (; i < name_len - 1; i++) {
23025                 if (   name[i] != '0'
23026                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
23027                 {
23028                     break;
23029                 }
23030             }
23031
23032             /* Store the first real character in the denominator */
23033             lookup_name[j++] = name[i];
23034         }
23035     }
23036
23037     /* Here are completely done parsing the input 'name', and 'lookup_name'
23038      * contains a copy, normalized.
23039      *
23040      * This special case is grandfathered in: 'L_' and 'GC=L_' are accepted and
23041      * different from without the underscores.  */
23042     if (  (   UNLIKELY(memEQs(lookup_name, j, "l"))
23043            || UNLIKELY(memEQs(lookup_name, j, "gc=l")))
23044         && UNLIKELY(name[name_len-1] == '_'))
23045     {
23046         lookup_name[j++] = '&';
23047     }
23048
23049     /* If the original input began with 'In' or 'Is', it could be a subroutine
23050      * call to a user-defined property instead of a Unicode property name. */
23051     if (    non_pkg_begin + name_len > 2
23052         &&  name[non_pkg_begin+0] == 'I'
23053         && (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
23054     {
23055         /* Names that start with In have different characterstics than those
23056          * that start with Is */
23057         if (name[non_pkg_begin+1] == 's') {
23058             starts_with_Is = TRUE;
23059         }
23060     }
23061     else {
23062         could_be_user_defined = FALSE;
23063     }
23064
23065     if (could_be_user_defined) {
23066         CV* user_sub;
23067
23068         /* If the user defined property returns the empty string, it could
23069          * easily be because the pattern is being compiled before the data it
23070          * actually needs to compile is available.  This could be argued to be
23071          * a bug in the perl code, but this is a change of behavior for Perl,
23072          * so we handle it.  This means that intentionally returning nothing
23073          * will not be resolved until runtime */
23074         bool empty_return = FALSE;
23075
23076         /* Here, the name could be for a user defined property, which are
23077          * implemented as subs. */
23078         user_sub = get_cvn_flags(name, name_len, 0);
23079         if (user_sub) {
23080             const char insecure[] = "Insecure user-defined property";
23081
23082             /* Here, there is a sub by the correct name.  Normally we call it
23083              * to get the property definition */
23084             dSP;
23085             SV * user_sub_sv = MUTABLE_SV(user_sub);
23086             SV * error;     /* Any error returned by calling 'user_sub' */
23087             SV * key;       /* The key into the hash of user defined sub names
23088                              */
23089             SV * placeholder;
23090             SV ** saved_user_prop_ptr;      /* Hash entry for this property */
23091
23092             /* How many times to retry when another thread is in the middle of
23093              * expanding the same definition we want */
23094             PERL_INT_FAST8_T retry_countdown = 10;
23095
23096             DECLARATION_FOR_GLOBAL_CONTEXT;
23097
23098             /* If we get here, we know this property is user-defined */
23099             *user_defined_ptr = TRUE;
23100
23101             /* We refuse to call a potentially tainted subroutine; returning an
23102              * error instead */
23103             if (TAINT_get) {
23104                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23105                 sv_catpvn(msg, insecure, sizeof(insecure) - 1);
23106                 goto append_name_to_msg;
23107             }
23108
23109             /* In principal, we only call each subroutine property definition
23110              * once during the life of the program.  This guarantees that the
23111              * property definition never changes.  The results of the single
23112              * sub call are stored in a hash, which is used instead for future
23113              * references to this property.  The property definition is thus
23114              * immutable.  But, to allow the user to have a /i-dependent
23115              * definition, we call the sub once for non-/i, and once for /i,
23116              * should the need arise, passing the /i status as a parameter.
23117              *
23118              * We start by constructing the hash key name, consisting of the
23119              * fully qualified subroutine name, preceded by the /i status, so
23120              * that there is a key for /i and a different key for non-/i */
23121             key = newSVpvn(((to_fold) ? "1" : "0"), 1);
23122             fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
23123                                           non_pkg_begin != 0);
23124             sv_catsv(key, fq_name);
23125             sv_2mortal(key);
23126
23127             /* We only call the sub once throughout the life of the program
23128              * (with the /i, non-/i exception noted above).  That means the
23129              * hash must be global and accessible to all threads.  It is
23130              * created at program start-up, before any threads are created, so
23131              * is accessible to all children.  But this creates some
23132              * complications.
23133              *
23134              * 1) The keys can't be shared, or else problems arise; sharing is
23135              *    turned off at hash creation time
23136              * 2) All SVs in it are there for the remainder of the life of the
23137              *    program, and must be created in the same interpreter context
23138              *    as the hash, or else they will be freed from the wrong pool
23139              *    at global destruction time.  This is handled by switching to
23140              *    the hash's context to create each SV going into it, and then
23141              *    immediately switching back
23142              * 3) All accesses to the hash must be controlled by a mutex, to
23143              *    prevent two threads from getting an unstable state should
23144              *    they simultaneously be accessing it.  The code below is
23145              *    crafted so that the mutex is locked whenever there is an
23146              *    access and unlocked only when the next stable state is
23147              *    achieved.
23148              *
23149              * The hash stores either the definition of the property if it was
23150              * valid, or, if invalid, the error message that was raised.  We
23151              * use the type of SV to distinguish.
23152              *
23153              * There's also the need to guard against the definition expansion
23154              * from infinitely recursing.  This is handled by storing the aTHX
23155              * of the expanding thread during the expansion.  Again the SV type
23156              * is used to distinguish this from the other two cases.  If we
23157              * come to here and the hash entry for this property is our aTHX,
23158              * it means we have recursed, and the code assumes that we would
23159              * infinitely recurse, so instead stops and raises an error.
23160              * (Any recursion has always been treated as infinite recursion in
23161              * this feature.)
23162              *
23163              * If instead, the entry is for a different aTHX, it means that
23164              * that thread has gotten here first, and hasn't finished expanding
23165              * the definition yet.  We just have to wait until it is done.  We
23166              * sleep and retry a few times, returning an error if the other
23167              * thread doesn't complete. */
23168
23169           re_fetch:
23170             USER_PROP_MUTEX_LOCK;
23171
23172             /* If we have an entry for this key, the subroutine has already
23173              * been called once with this /i status. */
23174             saved_user_prop_ptr = hv_fetch(PL_user_def_props,
23175                                                    SvPVX(key), SvCUR(key), 0);
23176             if (saved_user_prop_ptr) {
23177
23178                 /* If the saved result is an inversion list, it is the valid
23179                  * definition of this property */
23180                 if (is_invlist(*saved_user_prop_ptr)) {
23181                     prop_definition = *saved_user_prop_ptr;
23182
23183                     /* The SV in the hash won't be removed until global
23184                      * destruction, so it is stable and we can unlock */
23185                     USER_PROP_MUTEX_UNLOCK;
23186
23187                     /* The caller shouldn't try to free this SV */
23188                     return prop_definition;
23189                 }
23190
23191                 /* Otherwise, if it is a string, it is the error message
23192                  * that was returned when we first tried to evaluate this
23193                  * property.  Fail, and append the message */
23194                 if (SvPOK(*saved_user_prop_ptr)) {
23195                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23196                     sv_catsv(msg, *saved_user_prop_ptr);
23197
23198                     /* The SV in the hash won't be removed until global
23199                      * destruction, so it is stable and we can unlock */
23200                     USER_PROP_MUTEX_UNLOCK;
23201
23202                     return NULL;
23203                 }
23204
23205                 assert(SvIOK(*saved_user_prop_ptr));
23206
23207                 /* Here, we have an unstable entry in the hash.  Either another
23208                  * thread is in the middle of expanding the property's
23209                  * definition, or we are ourselves recursing.  We use the aTHX
23210                  * in it to distinguish */
23211                 if (SvIV(*saved_user_prop_ptr) != PTR2IV(CUR_CONTEXT)) {
23212
23213                     /* Here, it's another thread doing the expanding.  We've
23214                      * looked as much as we are going to at the contents of the
23215                      * hash entry.  It's safe to unlock. */
23216                     USER_PROP_MUTEX_UNLOCK;
23217
23218                     /* Retry a few times */
23219                     if (retry_countdown-- > 0) {
23220                         PerlProc_sleep(1);
23221                         goto re_fetch;
23222                     }
23223
23224                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23225                     sv_catpvs(msg, "Timeout waiting for another thread to "
23226                                    "define");
23227                     goto append_name_to_msg;
23228                 }
23229
23230                 /* Here, we are recursing; don't dig any deeper */
23231                 USER_PROP_MUTEX_UNLOCK;
23232
23233                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23234                 sv_catpvs(msg,
23235                           "Infinite recursion in user-defined property");
23236                 goto append_name_to_msg;
23237             }
23238
23239             /* Here, this thread has exclusive control, and there is no entry
23240              * for this property in the hash.  So we have the go ahead to
23241              * expand the definition ourselves. */
23242
23243             PUSHSTACKi(PERLSI_MAGIC);
23244             ENTER;
23245
23246             /* Create a temporary placeholder in the hash to detect recursion
23247              * */
23248             SWITCH_TO_GLOBAL_CONTEXT;
23249             placeholder= newSVuv(PTR2IV(ORIGINAL_CONTEXT));
23250             (void) hv_store_ent(PL_user_def_props, key, placeholder, 0);
23251             RESTORE_CONTEXT;
23252
23253             /* Now that we have a placeholder, we can let other threads
23254              * continue */
23255             USER_PROP_MUTEX_UNLOCK;
23256
23257             /* Make sure the placeholder always gets destroyed */
23258             SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(key));
23259
23260             PUSHMARK(SP);
23261             SAVETMPS;
23262
23263             /* Call the user's function, with the /i status as a parameter.
23264              * Note that we have gone to a lot of trouble to keep this call
23265              * from being within the locked mutex region. */
23266             XPUSHs(boolSV(to_fold));
23267             PUTBACK;
23268
23269             /* The following block was taken from swash_init().  Presumably
23270              * they apply to here as well, though we no longer use a swash --
23271              * khw */
23272             SAVEHINTS();
23273             save_re_context();
23274             /* We might get here via a subroutine signature which uses a utf8
23275              * parameter name, at which point PL_subname will have been set
23276              * but not yet used. */
23277             save_item(PL_subname);
23278
23279             (void) call_sv(user_sub_sv, G_EVAL|G_SCALAR);
23280
23281             SPAGAIN;
23282
23283             error = ERRSV;
23284             if (TAINT_get || SvTRUE(error)) {
23285                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23286                 if (SvTRUE(error)) {
23287                     sv_catpvs(msg, "Error \"");
23288                     sv_catsv(msg, error);
23289                     sv_catpvs(msg, "\"");
23290                 }
23291                 if (TAINT_get) {
23292                     if (SvTRUE(error)) sv_catpvs(msg, "; ");
23293                     sv_catpvn(msg, insecure, sizeof(insecure) - 1);
23294                 }
23295
23296                 if (name_len > 0) {
23297                     sv_catpvs(msg, " in expansion of ");
23298                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8,
23299                                                                   name_len,
23300                                                                   name));
23301                 }
23302
23303                 (void) POPs;
23304                 prop_definition = NULL;
23305             }
23306             else {  /* G_SCALAR guarantees a single return value */
23307                 SV * contents = POPs;
23308
23309                 /* The contents is supposed to be the expansion of the property
23310                  * definition.  If the definition is deferrable, and we got an
23311                  * empty string back, set a flag to later defer it (after clean
23312                  * up below). */
23313                 if (      deferrable
23314                     && (! SvPOK(contents) || SvCUR(contents) == 0))
23315                 {
23316                         empty_return = TRUE;
23317                 }
23318                 else { /* Otherwise, call a function to check for valid syntax,
23319                           and handle it */
23320
23321                     prop_definition = handle_user_defined_property(
23322                                                     name, name_len,
23323                                                     is_utf8, to_fold, runtime,
23324                                                     deferrable,
23325                                                     contents, user_defined_ptr,
23326                                                     msg,
23327                                                     level);
23328                 }
23329             }
23330
23331             /* Here, we have the results of the expansion.  Delete the
23332              * placeholder, and if the definition is now known, replace it with
23333              * that definition.  We need exclusive access to the hash, and we
23334              * can't let anyone else in, between when we delete the placeholder
23335              * and add the permanent entry */
23336             USER_PROP_MUTEX_LOCK;
23337
23338             S_delete_recursion_entry(aTHX_ SvPVX(key));
23339
23340             if (    ! empty_return
23341                 && (! prop_definition || is_invlist(prop_definition)))
23342             {
23343                 /* If we got success we use the inversion list defining the
23344                  * property; otherwise use the error message */
23345                 SWITCH_TO_GLOBAL_CONTEXT;
23346                 (void) hv_store_ent(PL_user_def_props,
23347                                     key,
23348                                     ((prop_definition)
23349                                      ? newSVsv(prop_definition)
23350                                      : newSVsv(msg)),
23351                                     0);
23352                 RESTORE_CONTEXT;
23353             }
23354
23355             /* All done, and the hash now has a permanent entry for this
23356              * property.  Give up exclusive control */
23357             USER_PROP_MUTEX_UNLOCK;
23358
23359             FREETMPS;
23360             LEAVE;
23361             POPSTACK;
23362
23363             if (empty_return) {
23364                 goto definition_deferred;
23365             }
23366
23367             if (prop_definition) {
23368
23369                 /* If the definition is for something not known at this time,
23370                  * we toss it, and go return the main property name, as that's
23371                  * the one the user will be aware of */
23372                 if (! is_invlist(prop_definition)) {
23373                     SvREFCNT_dec_NN(prop_definition);
23374                     goto definition_deferred;
23375                 }
23376
23377                 sv_2mortal(prop_definition);
23378             }
23379
23380             /* And return */
23381             return prop_definition;
23382
23383         }   /* End of calling the subroutine for the user-defined property */
23384     }       /* End of it could be a user-defined property */
23385
23386     /* Here it wasn't a user-defined property that is known at this time.  See
23387      * if it is a Unicode property */
23388
23389     lookup_len = j;     /* This is a more mnemonic name than 'j' */
23390
23391     /* Get the index into our pointer table of the inversion list corresponding
23392      * to the property */
23393     table_index = match_uniprop((U8 *) lookup_name, lookup_len);
23394
23395     /* If it didn't find the property ... */
23396     if (table_index == 0) {
23397
23398         /* Try again stripping off any initial 'Is'.  This is because we
23399          * promise that an initial Is is optional.  The same isn't true of
23400          * names that start with 'In'.  Those can match only blocks, and the
23401          * lookup table already has those accounted for. */
23402         if (starts_with_Is) {
23403             lookup_name += 2;
23404             lookup_len -= 2;
23405             equals_pos -= 2;
23406             slash_pos -= 2;
23407
23408             table_index = match_uniprop((U8 *) lookup_name, lookup_len);
23409         }
23410
23411         if (table_index == 0) {
23412             char * canonical;
23413
23414             /* Here, we didn't find it.  If not a numeric type property, and
23415              * can't be a user-defined one, it isn't a legal property */
23416             if (! is_nv_type) {
23417                 if (! could_be_user_defined) {
23418                     goto failed;
23419                 }
23420
23421                 /* Here, the property name is legal as a user-defined one.   At
23422                  * compile time, it might just be that the subroutine for that
23423                  * property hasn't been encountered yet, but at runtime, it's
23424                  * an error to try to use an undefined one */
23425                 if (! deferrable) {
23426                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23427                     sv_catpvs(msg, "Unknown user-defined property name");
23428                     goto append_name_to_msg;
23429                 }
23430
23431                 goto definition_deferred;
23432             } /* End of isn't a numeric type property */
23433
23434             /* The numeric type properties need more work to decide.  What we
23435              * do is make sure we have the number in canonical form and look
23436              * that up. */
23437
23438             if (slash_pos < 0) {    /* No slash */
23439
23440                 /* When it isn't a rational, take the input, convert it to a
23441                  * NV, then create a canonical string representation of that
23442                  * NV. */
23443
23444                 NV value;
23445                 SSize_t value_len = lookup_len - equals_pos;
23446
23447                 /* Get the value */
23448                 if (   value_len <= 0
23449                     || my_atof3(lookup_name + equals_pos, &value,
23450                                 value_len)
23451                           != lookup_name + lookup_len)
23452                 {
23453                     goto failed;
23454                 }
23455
23456                 /* If the value is an integer, the canonical value is integral
23457                  * */
23458                 if (Perl_ceil(value) == value) {
23459                     canonical = Perl_form(aTHX_ "%.*s%.0" NVff,
23460                                             equals_pos, lookup_name, value);
23461                 }
23462                 else {  /* Otherwise, it is %e with a known precision */
23463                     char * exp_ptr;
23464
23465                     canonical = Perl_form(aTHX_ "%.*s%.*" NVef,
23466                                                 equals_pos, lookup_name,
23467                                                 PL_E_FORMAT_PRECISION, value);
23468
23469                     /* The exponent generated is expecting two digits, whereas
23470                      * %e on some systems will generate three.  Remove leading
23471                      * zeros in excess of 2 from the exponent.  We start
23472                      * looking for them after the '=' */
23473                     exp_ptr = strchr(canonical + equals_pos, 'e');
23474                     if (exp_ptr) {
23475                         char * cur_ptr = exp_ptr + 2; /* past the 'e[+-]' */
23476                         SSize_t excess_exponent_len = strlen(cur_ptr) - 2;
23477
23478                         assert(*(cur_ptr - 1) == '-' || *(cur_ptr - 1) == '+');
23479
23480                         if (excess_exponent_len > 0) {
23481                             SSize_t leading_zeros = strspn(cur_ptr, "0");
23482                             SSize_t excess_leading_zeros
23483                                     = MIN(leading_zeros, excess_exponent_len);
23484                             if (excess_leading_zeros > 0) {
23485                                 Move(cur_ptr + excess_leading_zeros,
23486                                      cur_ptr,
23487                                      strlen(cur_ptr) - excess_leading_zeros
23488                                        + 1,  /* Copy the NUL as well */
23489                                      char);
23490                             }
23491                         }
23492                     }
23493                 }
23494             }
23495             else {  /* Has a slash.  Create a rational in canonical form  */
23496                 UV numerator, denominator, gcd, trial;
23497                 const char * end_ptr;
23498                 const char * sign = "";
23499
23500                 /* We can't just find the numerator, denominator, and do the
23501                  * division, then use the method above, because that is
23502                  * inexact.  And the input could be a rational that is within
23503                  * epsilon (given our precision) of a valid rational, and would
23504                  * then incorrectly compare valid.
23505                  *
23506                  * We're only interested in the part after the '=' */
23507                 const char * this_lookup_name = lookup_name + equals_pos;
23508                 lookup_len -= equals_pos;
23509                 slash_pos -= equals_pos;
23510
23511                 /* Handle any leading minus */
23512                 if (this_lookup_name[0] == '-') {
23513                     sign = "-";
23514                     this_lookup_name++;
23515                     lookup_len--;
23516                     slash_pos--;
23517                 }
23518
23519                 /* Convert the numerator to numeric */
23520                 end_ptr = this_lookup_name + slash_pos;
23521                 if (! grok_atoUV(this_lookup_name, &numerator, &end_ptr)) {
23522                     goto failed;
23523                 }
23524
23525                 /* It better have included all characters before the slash */
23526                 if (*end_ptr != '/') {
23527                     goto failed;
23528                 }
23529
23530                 /* Set to look at just the denominator */
23531                 this_lookup_name += slash_pos;
23532                 lookup_len -= slash_pos;
23533                 end_ptr = this_lookup_name + lookup_len;
23534
23535                 /* Convert the denominator to numeric */
23536                 if (! grok_atoUV(this_lookup_name, &denominator, &end_ptr)) {
23537                     goto failed;
23538                 }
23539
23540                 /* It better be the rest of the characters, and don't divide by
23541                  * 0 */
23542                 if (   end_ptr != this_lookup_name + lookup_len
23543                     || denominator == 0)
23544                 {
23545                     goto failed;
23546                 }
23547
23548                 /* Get the greatest common denominator using
23549                    http://en.wikipedia.org/wiki/Euclidean_algorithm */
23550                 gcd = numerator;
23551                 trial = denominator;
23552                 while (trial != 0) {
23553                     UV temp = trial;
23554                     trial = gcd % trial;
23555                     gcd = temp;
23556                 }
23557
23558                 /* If already in lowest possible terms, we have already tried
23559                  * looking this up */
23560                 if (gcd == 1) {
23561                     goto failed;
23562                 }
23563
23564                 /* Reduce the rational, which should put it in canonical form
23565                  * */
23566                 numerator /= gcd;
23567                 denominator /= gcd;
23568
23569                 canonical = Perl_form(aTHX_ "%.*s%s%" UVuf "/%" UVuf,
23570                         equals_pos, lookup_name, sign, numerator, denominator);
23571             }
23572
23573             /* Here, we have the number in canonical form.  Try that */
23574             table_index = match_uniprop((U8 *) canonical, strlen(canonical));
23575             if (table_index == 0) {
23576                 goto failed;
23577             }
23578         }   /* End of still didn't find the property in our table */
23579     }       /* End of       didn't find the property in our table */
23580
23581     /* Here, we have a non-zero return, which is an index into a table of ptrs.
23582      * A negative return signifies that the real index is the absolute value,
23583      * but the result needs to be inverted */
23584     if (table_index < 0) {
23585         invert_return = TRUE;
23586         table_index = -table_index;
23587     }
23588
23589     /* Out-of band indices indicate a deprecated property.  The proper index is
23590      * modulo it with the table size.  And dividing by the table size yields
23591      * an offset into a table constructed by regen/mk_invlists.pl to contain
23592      * the corresponding warning message */
23593     if (table_index > MAX_UNI_KEYWORD_INDEX) {
23594         Size_t warning_offset = table_index / MAX_UNI_KEYWORD_INDEX;
23595         table_index %= MAX_UNI_KEYWORD_INDEX;
23596         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
23597                 "Use of '%.*s' in \\p{} or \\P{} is deprecated because: %s",
23598                 (int) name_len, name, deprecated_property_msgs[warning_offset]);
23599     }
23600
23601     /* In a few properties, a different property is used under /i.  These are
23602      * unlikely to change, so are hard-coded here. */
23603     if (to_fold) {
23604         if (   table_index == UNI_XPOSIXUPPER
23605             || table_index == UNI_XPOSIXLOWER
23606             || table_index == UNI_TITLE)
23607         {
23608             table_index = UNI_CASED;
23609         }
23610         else if (   table_index == UNI_UPPERCASELETTER
23611                  || table_index == UNI_LOWERCASELETTER
23612 #  ifdef UNI_TITLECASELETTER   /* Missing from early Unicodes */
23613                  || table_index == UNI_TITLECASELETTER
23614 #  endif
23615         ) {
23616             table_index = UNI_CASEDLETTER;
23617         }
23618         else if (  table_index == UNI_POSIXUPPER
23619                 || table_index == UNI_POSIXLOWER)
23620         {
23621             table_index = UNI_POSIXALPHA;
23622         }
23623     }
23624
23625     /* Create and return the inversion list */
23626     prop_definition =_new_invlist_C_array(uni_prop_ptrs[table_index]);
23627     sv_2mortal(prop_definition);
23628
23629
23630     /* See if there is a private use override to add to this definition */
23631     {
23632         COPHH * hinthash = (IN_PERL_COMPILETIME)
23633                            ? CopHINTHASH_get(&PL_compiling)
23634                            : CopHINTHASH_get(PL_curcop);
23635         SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0);
23636
23637         if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) {
23638
23639             /* See if there is an element in the hints hash for this table */
23640             SV * pu_lookup = Perl_newSVpvf(aTHX_ "%d=", table_index);
23641             const char * pos = strstr(SvPVX(pu_overrides), SvPVX(pu_lookup));
23642
23643             if (pos) {
23644                 bool dummy;
23645                 SV * pu_definition;
23646                 SV * pu_invlist;
23647                 SV * expanded_prop_definition =
23648                             sv_2mortal(invlist_clone(prop_definition, NULL));
23649
23650                 /* If so, it's definition is the string from here to the next
23651                  * \a character.  And its format is the same as a user-defined
23652                  * property */
23653                 pos += SvCUR(pu_lookup);
23654                 pu_definition = newSVpvn(pos, strchr(pos, '\a') - pos);
23655                 pu_invlist = handle_user_defined_property(lookup_name,
23656                                                           lookup_len,
23657                                                           0, /* Not UTF-8 */
23658                                                           0, /* Not folded */
23659                                                           runtime,
23660                                                           deferrable,
23661                                                           pu_definition,
23662                                                           &dummy,
23663                                                           msg,
23664                                                           level);
23665                 if (TAINT_get) {
23666                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23667                     sv_catpvs(msg, "Insecure private-use override");
23668                     goto append_name_to_msg;
23669                 }
23670
23671                 /* For now, as a safety measure, make sure that it doesn't
23672                  * override non-private use code points */
23673                 _invlist_intersection(pu_invlist, PL_Private_Use, &pu_invlist);
23674
23675                 /* Add it to the list to be returned */
23676                 _invlist_union(prop_definition, pu_invlist,
23677                                &expanded_prop_definition);
23678                 prop_definition = expanded_prop_definition;
23679                 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__PRIVATE_USE), "The private_use feature is experimental");
23680             }
23681         }
23682     }
23683
23684     if (invert_return) {
23685         _invlist_invert(prop_definition);
23686     }
23687     return prop_definition;
23688
23689
23690   failed:
23691     if (non_pkg_begin != 0) {
23692         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23693         sv_catpvs(msg, "Illegal user-defined property name");
23694     }
23695     else {
23696         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23697         sv_catpvs(msg, "Can't find Unicode property definition");
23698     }
23699     /* FALLTHROUGH */
23700
23701   append_name_to_msg:
23702     {
23703         const char * prefix = (runtime && level == 0) ?  " \\p{" : " \"";
23704         const char * suffix = (runtime && level == 0) ?  "}" : "\"";
23705
23706         sv_catpv(msg, prefix);
23707         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
23708         sv_catpv(msg, suffix);
23709     }
23710
23711     return NULL;
23712
23713   definition_deferred:
23714
23715     /* Here it could yet to be defined, so defer evaluation of this
23716      * until its needed at runtime.  We need the fully qualified property name
23717      * to avoid ambiguity, and a trailing newline */
23718     if (! fq_name) {
23719         fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
23720                                       non_pkg_begin != 0 /* If has "::" */
23721                                );
23722     }
23723     sv_catpvs(fq_name, "\n");
23724
23725     *user_defined_ptr = TRUE;
23726     return fq_name;
23727 }
23728
23729 #endif
23730
23731 /*
23732  * ex: set ts=8 sts=4 sw=4 et:
23733  */