This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
3c08d7f979f0e38faa3241c104dc69edb5f59627
[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
74 /* Note on debug output:
75  *
76  * This is set up so that -Dr turns on debugging like all other flags that are
77  * enabled by -DDEBUGGING.  -Drv gives more verbose output.  This applies to
78  * all regular expressions encountered in a program, and gives a huge amount of
79  * output for all but the shortest programs.
80  *
81  * The ability to output pattern debugging information lexically, and with much
82  * finer grained control was added, with 'use re qw(Debug ....);' available even
83  * in non-DEBUGGING builds.  This is accomplished by copying the contents of
84  * regcomp.c to ext/re/re_comp.c, and regexec.c is copied to ext/re/re_exec.c.
85  * Those files are compiled and linked into the perl executable, and they are
86  * compiled essentially as if DEBUGGING were enabled, and controlled by calls
87  * to re.pm.
88  *
89  * That would normally mean linking errors when two functions of the same name
90  * are attempted to be placed into the same executable.  That is solved in one
91  * of four ways:
92  *  1)  Static functions aren't known outside the file they are in, so for the
93  *      many functions of that type in this file, it just isn't a problem.
94  *  2)  Most externally known functions are enclosed in
95  *          #ifndef PERL_IN_XSUB_RE
96  *          ...
97  *          #endif
98  *      blocks, so there is only one defintion for them in the whole
99  *      executable, the one in regcomp.c (or regexec.c).  The implication of
100  *      that is any debugging info that comes from them is controlled only by
101  *      -Dr.  Further, any static function they call will also be the version
102  *      in regcomp.c (or regexec.c), so its debugging will also be by -Dr.
103  *  3)  About a dozen external functions are re-#defined in ext/re/re_top.h, to
104  *      have different names, so that what gets loaded in the executable is
105  *      'Perl_foo' from regcomp.c (and regexec.c), and the identical function
106  *      from re_comp.c (and re_exec.c), but with the name 'my_foo'  Debugging
107  *      in the 'Perl_foo' versions is controlled by -Dr, but the 'my_foo'
108  *      versions and their callees are under control of re.pm.   The catch is
109  *      that references to all these go through the regexp_engine structure,
110  *      which is initialized in regcomp.h to the Perl_foo versions, and
111  *      substituted out in lexical scopes where 'use re' is in effect to the
112  *      'my_foo' ones.   That structure is public API, so it would be a hard
113  *      sell to add any additional members.
114  *  4)  For functions in regcomp.c and re_comp.c that are called only from,
115  *      respectively, regexec.c and re_exec.c, they can have two different
116  *      names, depending on #ifdef'ing PERL_IN_XSUB_RE, in both regexec.c and
117  *      embed.fnc.
118  *
119  * The bottom line is that if you add code to one of the public functions
120  * listed in ext/re/re_top.h, debugging automagically works.  But if you write
121  * a new function that needs to do debugging or there is a chain of calls from
122  * it that need to do debugging, all functions in the chain should use options
123  * 2) or 4) above.
124  *
125  * A function may have to be split so that debugging stuff is static, but it
126  * calls out to some other function that only gets compiled in regcomp.c to
127  * access data that we don't want to duplicate.
128  */
129
130 #include "EXTERN.h"
131 #define PERL_IN_REGCOMP_C
132 #include "perl.h"
133
134 #define REG_COMP_C
135 #ifdef PERL_IN_XSUB_RE
136 #  include "re_comp.h"
137 EXTERN_C const struct regexp_engine my_reg_engine;
138 EXTERN_C const struct regexp_engine wild_reg_engine;
139 #else
140 #  include "regcomp.h"
141 #endif
142
143 #include "invlist_inline.h"
144 #include "unicode_constants.h"
145
146 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
147  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
148 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
149  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
150 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
151 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
152
153 #ifndef STATIC
154 #define STATIC  static
155 #endif
156
157 /* this is a chain of data about sub patterns we are processing that
158    need to be handled separately/specially in study_chunk. Its so
159    we can simulate recursion without losing state.  */
160 struct scan_frame;
161 typedef struct scan_frame {
162     regnode *last_regnode;      /* last node to process in this frame */
163     regnode *next_regnode;      /* next node to process when last is reached */
164     U32 prev_recursed_depth;
165     I32 stopparen;              /* what stopparen do we use */
166     bool in_gosub;              /* this or an outer frame is for GOSUB */
167
168     struct scan_frame *this_prev_frame; /* this previous frame */
169     struct scan_frame *prev_frame;      /* previous frame */
170     struct scan_frame *next_frame;      /* next frame */
171 } scan_frame;
172
173 /* Certain characters are output as a sequence with the first being a
174  * backslash. */
175 #define isBACKSLASHED_PUNCT(c)  memCHRs("-[]\\^", c)
176
177
178 struct RExC_state_t {
179     U32         flags;                  /* RXf_* are we folding, multilining? */
180     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
181     char        *precomp;               /* uncompiled string. */
182     char        *precomp_end;           /* pointer to end of uncompiled string. */
183     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
184     regexp      *rx;                    /* perl core regexp structure */
185     regexp_internal     *rxi;           /* internal data for regexp object
186                                            pprivate field */
187     char        *start;                 /* Start of input for compile */
188     char        *end;                   /* End of input for compile */
189     char        *parse;                 /* Input-scan pointer. */
190     char        *copy_start;            /* start of copy of input within
191                                            constructed parse string */
192     char        *save_copy_start;       /* Provides one level of saving
193                                            and restoring 'copy_start' */
194     char        *copy_start_in_input;   /* Position in input string
195                                            corresponding to copy_start */
196     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
197     regnode     *emit_start;            /* Start of emitted-code area */
198     regnode_offset emit;                /* Code-emit pointer */
199     I32         naughty;                /* How bad is this pattern? */
200     I32         sawback;                /* Did we see \1, ...? */
201     SSize_t     size;                   /* Number of regnode equivalents in
202                                            pattern */
203     Size_t      sets_depth;              /* Counts recursion depth of already-
204                                            compiled regex set patterns */
205     U32         seen;
206
207     I32      parens_buf_size;           /* #slots malloced open/close_parens */
208     regnode_offset *open_parens;        /* offsets to open parens */
209     regnode_offset *close_parens;       /* offsets to close parens */
210     HV          *paren_names;           /* Paren names */
211
212     /* position beyond 'precomp' of the warning message furthest away from
213      * 'precomp'.  During the parse, no warnings are raised for any problems
214      * earlier in the parse than this position.  This works if warnings are
215      * raised the first time a given spot is parsed, and if only one
216      * independent warning is raised for any given spot */
217     Size_t      latest_warn_offset;
218
219     I32         npar;                   /* Capture buffer count so far in the
220                                            parse, (OPEN) plus one. ("par" 0 is
221                                            the whole pattern)*/
222     I32         total_par;              /* During initial parse, is either 0,
223                                            or -1; the latter indicating a
224                                            reparse is needed.  After that pass,
225                                            it is what 'npar' became after the
226                                            pass.  Hence, it being > 0 indicates
227                                            we are in a reparse situation */
228     I32         nestroot;               /* root parens we are in - used by
229                                            accept */
230     I32         seen_zerolen;
231     regnode     *end_op;                /* END node in program */
232     I32         utf8;           /* whether the pattern is utf8 or not */
233     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
234                                 /* XXX use this for future optimisation of case
235                                  * where pattern must be upgraded to utf8. */
236     I32         uni_semantics;  /* If a d charset modifier should use unicode
237                                    rules, even if the pattern is not in
238                                    utf8 */
239
240     I32         recurse_count;          /* Number of recurse regops we have generated */
241     regnode     **recurse;              /* Recurse regops */
242     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
243                                            through */
244     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
245     I32         in_lookbehind;
246     I32         in_lookahead;
247     I32         contains_locale;
248     I32         override_recoding;
249     I32         recode_x_to_native;
250     I32         in_multi_char_class;
251     int         code_index;             /* next code_blocks[] slot */
252     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
253                                             within pattern */
254     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
255     scan_frame *frame_head;
256     scan_frame *frame_last;
257     U32         frame_count;
258     AV         *warn_text;
259     HV         *unlexed_names;
260     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
261 #ifdef DEBUGGING
262     const char  *lastparse;
263     I32         lastnum;
264     U32         study_chunk_recursed_count;
265     AV          *paren_name_list;       /* idx -> name */
266     SV          *mysv1;
267     SV          *mysv2;
268
269 #define RExC_lastparse  (pRExC_state->lastparse)
270 #define RExC_lastnum    (pRExC_state->lastnum)
271 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
272 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
273 #define RExC_mysv       (pRExC_state->mysv1)
274 #define RExC_mysv1      (pRExC_state->mysv1)
275 #define RExC_mysv2      (pRExC_state->mysv2)
276
277 #endif
278     bool        seen_d_op;
279     bool        strict;
280     bool        study_started;
281     bool        in_script_run;
282     bool        use_BRANCHJ;
283     bool        sWARN_EXPERIMENTAL__VLB;
284     bool        sWARN_EXPERIMENTAL__REGEX_SETS;
285 };
286
287 #define RExC_flags      (pRExC_state->flags)
288 #define RExC_pm_flags   (pRExC_state->pm_flags)
289 #define RExC_precomp    (pRExC_state->precomp)
290 #define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
291 #define RExC_copy_start_in_constructed  (pRExC_state->copy_start)
292 #define RExC_save_copy_start_in_constructed  (pRExC_state->save_copy_start)
293 #define RExC_precomp_end (pRExC_state->precomp_end)
294 #define RExC_rx_sv      (pRExC_state->rx_sv)
295 #define RExC_rx         (pRExC_state->rx)
296 #define RExC_rxi        (pRExC_state->rxi)
297 #define RExC_start      (pRExC_state->start)
298 #define RExC_end        (pRExC_state->end)
299 #define RExC_parse      (pRExC_state->parse)
300 #define RExC_latest_warn_offset (pRExC_state->latest_warn_offset )
301 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
302 #define RExC_seen_d_op (pRExC_state->seen_d_op) /* Seen something that differs
303                                                    under /d from /u ? */
304
305 #ifdef RE_TRACK_PATTERN_OFFSETS
306 #  define RExC_offsets  (RExC_rxi->u.offsets) /* I am not like the
307                                                          others */
308 #endif
309 #define RExC_emit       (pRExC_state->emit)
310 #define RExC_emit_start (pRExC_state->emit_start)
311 #define RExC_sawback    (pRExC_state->sawback)
312 #define RExC_seen       (pRExC_state->seen)
313 #define RExC_size       (pRExC_state->size)
314 #define RExC_maxlen        (pRExC_state->maxlen)
315 #define RExC_npar       (pRExC_state->npar)
316 #define RExC_total_parens       (pRExC_state->total_par)
317 #define RExC_parens_buf_size    (pRExC_state->parens_buf_size)
318 #define RExC_nestroot   (pRExC_state->nestroot)
319 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
320 #define RExC_utf8       (pRExC_state->utf8)
321 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
322 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
323 #define RExC_open_parens        (pRExC_state->open_parens)
324 #define RExC_close_parens       (pRExC_state->close_parens)
325 #define RExC_end_op     (pRExC_state->end_op)
326 #define RExC_paren_names        (pRExC_state->paren_names)
327 #define RExC_recurse    (pRExC_state->recurse)
328 #define RExC_recurse_count      (pRExC_state->recurse_count)
329 #define RExC_sets_depth         (pRExC_state->sets_depth)
330 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
331 #define RExC_study_chunk_recursed_bytes  \
332                                    (pRExC_state->study_chunk_recursed_bytes)
333 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
334 #define RExC_in_lookahead       (pRExC_state->in_lookahead)
335 #define RExC_contains_locale    (pRExC_state->contains_locale)
336 #define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
337
338 #ifdef EBCDIC
339 #  define SET_recode_x_to_native(x)                                         \
340                     STMT_START { RExC_recode_x_to_native = (x); } STMT_END
341 #else
342 #  define SET_recode_x_to_native(x) NOOP
343 #endif
344
345 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
346 #define RExC_frame_head (pRExC_state->frame_head)
347 #define RExC_frame_last (pRExC_state->frame_last)
348 #define RExC_frame_count (pRExC_state->frame_count)
349 #define RExC_strict (pRExC_state->strict)
350 #define RExC_study_started      (pRExC_state->study_started)
351 #define RExC_warn_text (pRExC_state->warn_text)
352 #define RExC_in_script_run      (pRExC_state->in_script_run)
353 #define RExC_use_BRANCHJ        (pRExC_state->use_BRANCHJ)
354 #define RExC_warned_WARN_EXPERIMENTAL__VLB (pRExC_state->sWARN_EXPERIMENTAL__VLB)
355 #define RExC_warned_WARN_EXPERIMENTAL__REGEX_SETS (pRExC_state->sWARN_EXPERIMENTAL__REGEX_SETS)
356 #define RExC_unlexed_names (pRExC_state->unlexed_names)
357
358 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
359  * a flag to disable back-off on the fixed/floating substrings - if it's
360  * a high complexity pattern we assume the benefit of avoiding a full match
361  * is worth the cost of checking for the substrings even if they rarely help.
362  */
363 #define RExC_naughty    (pRExC_state->naughty)
364 #define TOO_NAUGHTY (10)
365 #define MARK_NAUGHTY(add) \
366     if (RExC_naughty < TOO_NAUGHTY) \
367         RExC_naughty += (add)
368 #define MARK_NAUGHTY_EXP(exp, add) \
369     if (RExC_naughty < TOO_NAUGHTY) \
370         RExC_naughty += RExC_naughty / (exp) + (add)
371
372 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
373 #define ISMULT2(s)      (ISMULT1(*s) || ((*s) == '{' && regcurly(s)))
374
375 /*
376  * Flags to be passed up and down.
377  */
378 #define HASWIDTH        0x01    /* Known to not match null strings, could match
379                                    non-null ones. */
380 #define SIMPLE          0x02    /* Exactly one character wide */
381                                 /* (or LNBREAK as a special case) */
382 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
383 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
384 #define RESTART_PARSE   0x20    /* Need to redo the parse */
385 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PARSE, need to
386                                    calcuate sizes as UTF-8 */
387
388 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
389
390 /* whether trie related optimizations are enabled */
391 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
392 #define TRIE_STUDY_OPT
393 #define FULL_TRIE_STUDY
394 #define TRIE_STCLASS
395 #endif
396
397
398
399 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
400 #define PBITVAL(paren) (1 << ((paren) & 7))
401 #define PAREN_OFFSET(depth) \
402     (RExC_study_chunk_recursed + (depth) * RExC_study_chunk_recursed_bytes)
403 #define PAREN_TEST(depth, paren) \
404     (PBYTE(PAREN_OFFSET(depth), paren) & PBITVAL(paren))
405 #define PAREN_SET(depth, paren) \
406     (PBYTE(PAREN_OFFSET(depth), paren) |= PBITVAL(paren))
407 #define PAREN_UNSET(depth, paren) \
408     (PBYTE(PAREN_OFFSET(depth), paren) &= ~PBITVAL(paren))
409
410 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
411                                      if (!UTF) {                           \
412                                          *flagp = RESTART_PARSE|NEED_UTF8; \
413                                          return 0;                         \
414                                      }                                     \
415                              } STMT_END
416
417 /* Change from /d into /u rules, and restart the parse.  RExC_uni_semantics is
418  * a flag that indicates we need to override /d with /u as a result of
419  * something in the pattern.  It should only be used in regards to calling
420  * set_regex_charset() or get_regex_charset() */
421 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
422     STMT_START {                                                            \
423             if (DEPENDS_SEMANTICS) {                                        \
424                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
425                 RExC_uni_semantics = 1;                                     \
426                 if (RExC_seen_d_op && LIKELY(! IN_PARENS_PASS)) {           \
427                     /* No need to restart the parse if we haven't seen      \
428                      * anything that differs between /u and /d, and no need \
429                      * to restart immediately if we're going to reparse     \
430                      * anyway to count parens */                            \
431                     *flagp |= RESTART_PARSE;                                \
432                     return restart_retval;                                  \
433                 }                                                           \
434             }                                                               \
435     } STMT_END
436
437 #define REQUIRE_BRANCHJ(flagp, restart_retval)                              \
438     STMT_START {                                                            \
439                 RExC_use_BRANCHJ = 1;                                       \
440                 *flagp |= RESTART_PARSE;                                    \
441                 return restart_retval;                                      \
442     } STMT_END
443
444 /* Until we have completed the parse, we leave RExC_total_parens at 0 or
445  * less.  After that, it must always be positive, because the whole re is
446  * considered to be surrounded by virtual parens.  Setting it to negative
447  * indicates there is some construct that needs to know the actual number of
448  * parens to be properly handled.  And that means an extra pass will be
449  * required after we've counted them all */
450 #define ALL_PARENS_COUNTED (RExC_total_parens > 0)
451 #define REQUIRE_PARENS_PASS                                                 \
452     STMT_START {  /* No-op if have completed a pass */                      \
453                     if (! ALL_PARENS_COUNTED) RExC_total_parens = -1;       \
454     } STMT_END
455 #define IN_PARENS_PASS (RExC_total_parens < 0)
456
457
458 /* This is used to return failure (zero) early from the calling function if
459  * various flags in 'flags' are set.  Two flags always cause a return:
460  * 'RESTART_PARSE' and 'NEED_UTF8'.   'extra' can be used to specify any
461  * additional flags that should cause a return; 0 if none.  If the return will
462  * be done, '*flagp' is first set to be all of the flags that caused the
463  * return. */
464 #define RETURN_FAIL_ON_RESTART_OR_FLAGS(flags,flagp,extra)                  \
465     STMT_START {                                                            \
466             if ((flags) & (RESTART_PARSE|NEED_UTF8|(extra))) {              \
467                 *(flagp) = (flags) & (RESTART_PARSE|NEED_UTF8|(extra));     \
468                 return 0;                                                   \
469             }                                                               \
470     } STMT_END
471
472 #define MUST_RESTART(flags) ((flags) & (RESTART_PARSE))
473
474 #define RETURN_FAIL_ON_RESTART(flags,flagp)                                 \
475                         RETURN_FAIL_ON_RESTART_OR_FLAGS( flags, flagp, 0)
476 #define RETURN_FAIL_ON_RESTART_FLAGP(flagp)                                 \
477                                     if (MUST_RESTART(*(flagp))) return 0
478
479 /* This converts the named class defined in regcomp.h to its equivalent class
480  * number defined in handy.h. */
481 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
482 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
483
484 #define _invlist_union_complement_2nd(a, b, output) \
485                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
486 #define _invlist_intersection_complement_2nd(a, b, output) \
487                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
488
489 /* We add a marker if we are deferring expansion of a property that is both
490  * 1) potentiallly user-defined; and
491  * 2) could also be an official Unicode property.
492  *
493  * Without this marker, any deferred expansion can only be for a user-defined
494  * one.  This marker shouldn't conflict with any that could be in a legal name,
495  * and is appended to its name to indicate this.  There is a string and
496  * character form */
497 #define DEFERRED_COULD_BE_OFFICIAL_MARKERs  "~"
498 #define DEFERRED_COULD_BE_OFFICIAL_MARKERc  '~'
499
500 /* What is infinity for optimization purposes */
501 #define OPTIMIZE_INFTY  SSize_t_MAX
502
503 /* About scan_data_t.
504
505   During optimisation we recurse through the regexp program performing
506   various inplace (keyhole style) optimisations. In addition study_chunk
507   and scan_commit populate this data structure with information about
508   what strings MUST appear in the pattern. We look for the longest
509   string that must appear at a fixed location, and we look for the
510   longest string that may appear at a floating location. So for instance
511   in the pattern:
512
513     /FOO[xX]A.*B[xX]BAR/
514
515   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
516   strings (because they follow a .* construct). study_chunk will identify
517   both FOO and BAR as being the longest fixed and floating strings respectively.
518
519   The strings can be composites, for instance
520
521      /(f)(o)(o)/
522
523   will result in a composite fixed substring 'foo'.
524
525   For each string some basic information is maintained:
526
527   - min_offset
528     This is the position the string must appear at, or not before.
529     It also implicitly (when combined with minlenp) tells us how many
530     characters must match before the string we are searching for.
531     Likewise when combined with minlenp and the length of the string it
532     tells us how many characters must appear after the string we have
533     found.
534
535   - max_offset
536     Only used for floating strings. This is the rightmost point that
537     the string can appear at. If set to OPTIMIZE_INFTY it indicates that the
538     string can occur infinitely far to the right.
539     For fixed strings, it is equal to min_offset.
540
541   - minlenp
542     A pointer to the minimum number of characters of the pattern that the
543     string was found inside. This is important as in the case of positive
544     lookahead or positive lookbehind we can have multiple patterns
545     involved. Consider
546
547     /(?=FOO).*F/
548
549     The minimum length of the pattern overall is 3, the minimum length
550     of the lookahead part is 3, but the minimum length of the part that
551     will actually match is 1. So 'FOO's minimum length is 3, but the
552     minimum length for the F is 1. This is important as the minimum length
553     is used to determine offsets in front of and behind the string being
554     looked for.  Since strings can be composites this is the length of the
555     pattern at the time it was committed with a scan_commit. Note that
556     the length is calculated by study_chunk, so that the minimum lengths
557     are not known until the full pattern has been compiled, thus the
558     pointer to the value.
559
560   - lookbehind
561
562     In the case of lookbehind the string being searched for can be
563     offset past the start point of the final matching string.
564     If this value was just blithely removed from the min_offset it would
565     invalidate some of the calculations for how many chars must match
566     before or after (as they are derived from min_offset and minlen and
567     the length of the string being searched for).
568     When the final pattern is compiled and the data is moved from the
569     scan_data_t structure into the regexp structure the information
570     about lookbehind is factored in, with the information that would
571     have been lost precalculated in the end_shift field for the
572     associated string.
573
574   The fields pos_min and pos_delta are used to store the minimum offset
575   and the delta to the maximum offset at the current point in the pattern.
576
577 */
578
579 struct scan_data_substrs {
580     SV      *str;       /* longest substring found in pattern */
581     SSize_t min_offset; /* earliest point in string it can appear */
582     SSize_t max_offset; /* latest point in string it can appear */
583     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
584     SSize_t lookbehind; /* is the pos of the string modified by LB */
585     I32 flags;          /* per substring SF_* and SCF_* flags */
586 };
587
588 typedef struct scan_data_t {
589     /*I32 len_min;      unused */
590     /*I32 len_delta;    unused */
591     SSize_t pos_min;
592     SSize_t pos_delta;
593     SV *last_found;
594     SSize_t last_end;       /* min value, <0 unless valid. */
595     SSize_t last_start_min;
596     SSize_t last_start_max;
597     U8      cur_is_floating; /* whether the last_* values should be set as
598                               * the next fixed (0) or floating (1)
599                               * substring */
600
601     /* [0] is longest fixed substring so far, [1] is longest float so far */
602     struct scan_data_substrs  substrs[2];
603
604     I32 flags;             /* common SF_* and SCF_* flags */
605     I32 whilem_c;
606     SSize_t *last_closep;
607     regnode_ssc *start_class;
608 } scan_data_t;
609
610 /*
611  * Forward declarations for pregcomp()'s friends.
612  */
613
614 static const scan_data_t zero_scan_data = {
615     0, 0, NULL, 0, 0, 0, 0,
616     {
617         { NULL, 0, 0, 0, 0, 0 },
618         { NULL, 0, 0, 0, 0, 0 },
619     },
620     0, 0, NULL, NULL
621 };
622
623 /* study flags */
624
625 #define SF_BEFORE_SEOL          0x0001
626 #define SF_BEFORE_MEOL          0x0002
627 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
628
629 #define SF_IS_INF               0x0040
630 #define SF_HAS_PAR              0x0080
631 #define SF_IN_PAR               0x0100
632 #define SF_HAS_EVAL             0x0200
633
634
635 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
636  * longest substring in the pattern. When it is not set the optimiser keeps
637  * track of position, but does not keep track of the actual strings seen,
638  *
639  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
640  * /foo/i will not.
641  *
642  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
643  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
644  * turned off because of the alternation (BRANCH). */
645 #define SCF_DO_SUBSTR           0x0400
646
647 #define SCF_DO_STCLASS_AND      0x0800
648 #define SCF_DO_STCLASS_OR       0x1000
649 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
650 #define SCF_WHILEM_VISITED_POS  0x2000
651
652 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
653 #define SCF_SEEN_ACCEPT         0x8000
654 #define SCF_TRIE_DOING_RESTUDY 0x10000
655 #define SCF_IN_DEFINE          0x20000
656
657
658
659
660 #define UTF cBOOL(RExC_utf8)
661
662 /* The enums for all these are ordered so things work out correctly */
663 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
664 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
665                                                      == REGEX_DEPENDS_CHARSET)
666 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
667 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
668                                                      >= REGEX_UNICODE_CHARSET)
669 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
670                                             == REGEX_ASCII_RESTRICTED_CHARSET)
671 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
672                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
673 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
674                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
675
676 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
677
678 /* For programs that want to be strictly Unicode compatible by dying if any
679  * attempt is made to match a non-Unicode code point against a Unicode
680  * property.  */
681 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
682
683 #define OOB_NAMEDCLASS          -1
684
685 /* There is no code point that is out-of-bounds, so this is problematic.  But
686  * its only current use is to initialize a variable that is always set before
687  * looked at. */
688 #define OOB_UNICODE             0xDEADBEEF
689
690 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
691
692
693 /* length of regex to show in messages that don't mark a position within */
694 #define RegexLengthToShowInErrorMessages 127
695
696 /*
697  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
698  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
699  * op/pragma/warn/regcomp.
700  */
701 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
702 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
703
704 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
705                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
706
707 /* The code in this file in places uses one level of recursion with parsing
708  * rebased to an alternate string constructed by us in memory.  This can take
709  * the form of something that is completely different from the input, or
710  * something that uses the input as part of the alternate.  In the first case,
711  * there should be no possibility of an error, as we are in complete control of
712  * the alternate string.  But in the second case we don't completely control
713  * the input portion, so there may be errors in that.  Here's an example:
714  *      /[abc\x{DF}def]/ui
715  * is handled specially because \x{df} folds to a sequence of more than one
716  * character: 'ss'.  What is done is to create and parse an alternate string,
717  * which looks like this:
718  *      /(?:\x{DF}|[abc\x{DF}def])/ui
719  * where it uses the input unchanged in the middle of something it constructs,
720  * which is a branch for the DF outside the character class, and clustering
721  * parens around the whole thing. (It knows enough to skip the DF inside the
722  * class while in this substitute parse.) 'abc' and 'def' may have errors that
723  * need to be reported.  The general situation looks like this:
724  *
725  *                                       |<------- identical ------>|
726  *              sI                       tI               xI       eI
727  * Input:       ---------------------------------------------------------------
728  * Constructed:         ---------------------------------------------------
729  *                      sC               tC               xC       eC     EC
730  *                                       |<------- identical ------>|
731  *
732  * sI..eI   is the portion of the input pattern we are concerned with here.
733  * sC..EC   is the constructed substitute parse string.
734  *  sC..tC  is constructed by us
735  *  tC..eC  is an exact duplicate of the portion of the input pattern tI..eI.
736  *          In the diagram, these are vertically aligned.
737  *  eC..EC  is also constructed by us.
738  * xC       is the position in the substitute parse string where we found a
739  *          problem.
740  * xI       is the position in the original pattern corresponding to xC.
741  *
742  * We want to display a message showing the real input string.  Thus we need to
743  * translate from xC to xI.  We know that xC >= tC, since the portion of the
744  * string sC..tC has been constructed by us, and so shouldn't have errors.  We
745  * get:
746  *      xI = tI + (xC - tC)
747  *
748  * When the substitute parse is constructed, the code needs to set:
749  *      RExC_start (sC)
750  *      RExC_end (eC)
751  *      RExC_copy_start_in_input  (tI)
752  *      RExC_copy_start_in_constructed (tC)
753  * and restore them when done.
754  *
755  * During normal processing of the input pattern, both
756  * 'RExC_copy_start_in_input' and 'RExC_copy_start_in_constructed' are set to
757  * sI, so that xC equals xI.
758  */
759
760 #define sI              RExC_precomp
761 #define eI              RExC_precomp_end
762 #define sC              RExC_start
763 #define eC              RExC_end
764 #define tI              RExC_copy_start_in_input
765 #define tC              RExC_copy_start_in_constructed
766 #define xI(xC)          (tI + (xC - tC))
767 #define xI_offset(xC)   (xI(xC) - sI)
768
769 #define REPORT_LOCATION_ARGS(xC)                                            \
770     UTF8fARG(UTF,                                                           \
771              (xI(xC) > eI) /* Don't run off end */                          \
772               ? eI - sI   /* Length before the <--HERE */                   \
773               : ((xI_offset(xC) >= 0)                                       \
774                  ? xI_offset(xC)                                            \
775                  : (Perl_croak(aTHX_ "panic: %s: %d: negative offset: %"    \
776                                     IVdf " trying to output message for "   \
777                                     " pattern %.*s",                        \
778                                     __FILE__, __LINE__, (IV) xI_offset(xC), \
779                                     ((int) (eC - sC)), sC), 0)),            \
780              sI),         /* The input pattern printed up to the <--HERE */ \
781     UTF8fARG(UTF,                                                           \
782              (xI(xC) > eI) ? 0 : eI - xI(xC), /* Length after <--HERE */    \
783              (xI(xC) > eI) ? eI : xI(xC))     /* pattern after <--HERE */
784
785 /* Used to point after bad bytes for an error message, but avoid skipping
786  * past a nul byte. */
787 #define SKIP_IF_CHAR(s, e) (!*(s) ? 0 : UTF ? UTF8_SAFE_SKIP(s, e) : 1)
788
789 /* Set up to clean up after our imminent demise */
790 #define PREPARE_TO_DIE                                                      \
791     STMT_START {                                                            \
792         if (RExC_rx_sv)                                                     \
793             SAVEFREESV(RExC_rx_sv);                                         \
794         if (RExC_open_parens)                                               \
795             SAVEFREEPV(RExC_open_parens);                                   \
796         if (RExC_close_parens)                                              \
797             SAVEFREEPV(RExC_close_parens);                                  \
798     } STMT_END
799
800 /*
801  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
802  * arg. Show regex, up to a maximum length. If it's too long, chop and add
803  * "...".
804  */
805 #define _FAIL(code) STMT_START {                                        \
806     const char *ellipses = "";                                          \
807     IV len = RExC_precomp_end - RExC_precomp;                           \
808                                                                         \
809     PREPARE_TO_DIE;                                                     \
810     if (len > RegexLengthToShowInErrorMessages) {                       \
811         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
812         len = RegexLengthToShowInErrorMessages - 10;                    \
813         ellipses = "...";                                               \
814     }                                                                   \
815     code;                                                               \
816 } STMT_END
817
818 #define FAIL(msg) _FAIL(                            \
819     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
820             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
821
822 #define FAIL2(msg,arg) _FAIL(                       \
823     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
824             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
825
826 #define FAIL3(msg,arg1,arg2) _FAIL(                         \
827     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
828      arg1, arg2, UTF8fARG(UTF, len, RExC_precomp), ellipses))
829
830 /*
831  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
832  */
833 #define Simple_vFAIL(m) STMT_START {                                    \
834     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
835             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
836 } STMT_END
837
838 /*
839  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
840  */
841 #define vFAIL(m) STMT_START {                           \
842     PREPARE_TO_DIE;                                     \
843     Simple_vFAIL(m);                                    \
844 } STMT_END
845
846 /*
847  * Like Simple_vFAIL(), but accepts two arguments.
848  */
849 #define Simple_vFAIL2(m,a1) STMT_START {                        \
850     S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1,                \
851                       REPORT_LOCATION_ARGS(RExC_parse));        \
852 } STMT_END
853
854 /*
855  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
856  */
857 #define vFAIL2(m,a1) STMT_START {                       \
858     PREPARE_TO_DIE;                                     \
859     Simple_vFAIL2(m, a1);                               \
860 } STMT_END
861
862
863 /*
864  * Like Simple_vFAIL(), but accepts three arguments.
865  */
866 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
867     S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2,            \
868             REPORT_LOCATION_ARGS(RExC_parse));                  \
869 } STMT_END
870
871 /*
872  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
873  */
874 #define vFAIL3(m,a1,a2) STMT_START {                    \
875     PREPARE_TO_DIE;                                     \
876     Simple_vFAIL3(m, a1, a2);                           \
877 } STMT_END
878
879 /*
880  * Like Simple_vFAIL(), but accepts four arguments.
881  */
882 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
883     S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, a3,        \
884             REPORT_LOCATION_ARGS(RExC_parse));                  \
885 } STMT_END
886
887 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
888     PREPARE_TO_DIE;                                     \
889     Simple_vFAIL4(m, a1, a2, a3);                       \
890 } STMT_END
891
892 /* A specialized version of vFAIL2 that works with UTF8f */
893 #define vFAIL2utf8f(m, a1) STMT_START {             \
894     PREPARE_TO_DIE;                                 \
895     S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1,  \
896             REPORT_LOCATION_ARGS(RExC_parse));      \
897 } STMT_END
898
899 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
900     PREPARE_TO_DIE;                                     \
901     S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2,  \
902             REPORT_LOCATION_ARGS(RExC_parse));          \
903 } STMT_END
904
905 /* Setting this to NULL is a signal to not output warnings */
906 #define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE                               \
907     STMT_START {                                                            \
908       RExC_save_copy_start_in_constructed  = RExC_copy_start_in_constructed;\
909       RExC_copy_start_in_constructed = NULL;                                \
910     } STMT_END
911 #define RESTORE_WARNINGS                                                    \
912     RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
913
914 /* Since a warning can be generated multiple times as the input is reparsed, we
915  * output it the first time we come to that point in the parse, but suppress it
916  * otherwise.  'RExC_copy_start_in_constructed' being NULL is a flag to not
917  * generate any warnings */
918 #define TO_OUTPUT_WARNINGS(loc)                                         \
919   (   RExC_copy_start_in_constructed                                    \
920    && ((xI(loc)) - RExC_precomp) > (Ptrdiff_t) RExC_latest_warn_offset)
921
922 /* After we've emitted a warning, we save the position in the input so we don't
923  * output it again */
924 #define UPDATE_WARNINGS_LOC(loc)                                        \
925     STMT_START {                                                        \
926         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
927             RExC_latest_warn_offset = MAX(sI, MIN(eI, xI(loc)))         \
928                                                        - RExC_precomp;  \
929         }                                                               \
930     } STMT_END
931
932 /* 'warns' is the output of the packWARNx macro used in 'code' */
933 #define _WARN_HELPER(loc, warns, code)                                  \
934     STMT_START {                                                        \
935         if (! RExC_copy_start_in_constructed) {                         \
936             Perl_croak( aTHX_ "panic! %s: %d: Tried to warn when none"  \
937                               " expected at '%s'",                      \
938                               __FILE__, __LINE__, loc);                 \
939         }                                                               \
940         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
941             if (ckDEAD(warns))                                          \
942                 PREPARE_TO_DIE;                                         \
943             code;                                                       \
944             UPDATE_WARNINGS_LOC(loc);                                   \
945         }                                                               \
946     } STMT_END
947
948 /* m is not necessarily a "literal string", in this macro */
949 #define warn_non_literal_string(loc, packed_warn, m)                    \
950     _WARN_HELPER(loc, packed_warn,                                      \
951                       Perl_warner(aTHX_ packed_warn,                    \
952                                        "%s" REPORT_LOCATION,            \
953                                   m, REPORT_LOCATION_ARGS(loc)))
954 #define reg_warn_non_literal_string(loc, m)                             \
955                 warn_non_literal_string(loc, packWARN(WARN_REGEXP), m)
956
957 #define ckWARN2_non_literal_string(loc, packwarn, m, a1)                    \
958     STMT_START {                                                            \
959                 char * format;                                              \
960                 Size_t format_size = strlen(m) + strlen(REPORT_LOCATION)+ 1;\
961                 Newx(format, format_size, char);                            \
962                 my_strlcpy(format, m, format_size);                         \
963                 my_strlcat(format, REPORT_LOCATION, format_size);           \
964                 SAVEFREEPV(format);                                         \
965                 _WARN_HELPER(loc, packwarn,                                 \
966                       Perl_ck_warner(aTHX_ packwarn,                        \
967                                         format,                             \
968                                         a1, REPORT_LOCATION_ARGS(loc)));    \
969     } STMT_END
970
971 #define ckWARNreg(loc,m)                                                \
972     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
973                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
974                                           m REPORT_LOCATION,            \
975                                           REPORT_LOCATION_ARGS(loc)))
976
977 #define vWARN(loc, m)                                                   \
978     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
979                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
980                                        m REPORT_LOCATION,               \
981                                        REPORT_LOCATION_ARGS(loc)))      \
982
983 #define vWARN_dep(loc, m)                                               \
984     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
985                       Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),      \
986                                        m REPORT_LOCATION,               \
987                                        REPORT_LOCATION_ARGS(loc)))
988
989 #define ckWARNdep(loc,m)                                                \
990     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
991                       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
992                                             m REPORT_LOCATION,          \
993                                             REPORT_LOCATION_ARGS(loc)))
994
995 #define ckWARNregdep(loc,m)                                                 \
996     _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP),              \
997                       Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,     \
998                                                       WARN_REGEXP),         \
999                                              m REPORT_LOCATION,             \
1000                                              REPORT_LOCATION_ARGS(loc)))
1001
1002 #define ckWARN2reg_d(loc,m, a1)                                             \
1003     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
1004                       Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),         \
1005                                             m REPORT_LOCATION,              \
1006                                             a1, REPORT_LOCATION_ARGS(loc)))
1007
1008 #define ckWARN2reg(loc, m, a1)                                              \
1009     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
1010                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
1011                                           m REPORT_LOCATION,                \
1012                                           a1, REPORT_LOCATION_ARGS(loc)))
1013
1014 #define vWARN3(loc, m, a1, a2)                                              \
1015     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
1016                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),              \
1017                                        m REPORT_LOCATION,                   \
1018                                        a1, a2, REPORT_LOCATION_ARGS(loc)))
1019
1020 #define ckWARN3reg(loc, m, a1, a2)                                          \
1021     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
1022                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
1023                                           m REPORT_LOCATION,                \
1024                                           a1, a2,                           \
1025                                           REPORT_LOCATION_ARGS(loc)))
1026
1027 #define vWARN4(loc, m, a1, a2, a3)                                      \
1028     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
1029                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
1030                                        m REPORT_LOCATION,               \
1031                                        a1, a2, a3,                      \
1032                                        REPORT_LOCATION_ARGS(loc)))
1033
1034 #define ckWARN4reg(loc, m, a1, a2, a3)                                  \
1035     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
1036                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
1037                                           m REPORT_LOCATION,            \
1038                                           a1, a2, a3,                   \
1039                                           REPORT_LOCATION_ARGS(loc)))
1040
1041 #define vWARN5(loc, m, a1, a2, a3, a4)                                  \
1042     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
1043                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
1044                                        m REPORT_LOCATION,               \
1045                                        a1, a2, a3, a4,                  \
1046                                        REPORT_LOCATION_ARGS(loc)))
1047
1048 #define ckWARNexperimental(loc, class, m)                               \
1049     STMT_START {                                                        \
1050         if (! RExC_warned_ ## class) { /* warn once per compilation */  \
1051             RExC_warned_ ## class = 1;                                  \
1052             _WARN_HELPER(loc, packWARN(class),                          \
1053                       Perl_ck_warner_d(aTHX_ packWARN(class),           \
1054                                             m REPORT_LOCATION,          \
1055                                             REPORT_LOCATION_ARGS(loc)));\
1056         }                                                               \
1057     } STMT_END
1058
1059 /* Convert between a pointer to a node and its offset from the beginning of the
1060  * program */
1061 #define REGNODE_p(offset)    (RExC_emit_start + (offset))
1062 #define REGNODE_OFFSET(node) ((node) - RExC_emit_start)
1063
1064 /* Macros for recording node offsets.   20001227 mjd@plover.com
1065  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
1066  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
1067  * Element 0 holds the number n.
1068  * Position is 1 indexed.
1069  */
1070 #ifndef RE_TRACK_PATTERN_OFFSETS
1071 #define Set_Node_Offset_To_R(offset,byte)
1072 #define Set_Node_Offset(node,byte)
1073 #define Set_Cur_Node_Offset
1074 #define Set_Node_Length_To_R(node,len)
1075 #define Set_Node_Length(node,len)
1076 #define Set_Node_Cur_Length(node,start)
1077 #define Node_Offset(n)
1078 #define Node_Length(n)
1079 #define Set_Node_Offset_Length(node,offset,len)
1080 #define ProgLen(ri) ri->u.proglen
1081 #define SetProgLen(ri,x) ri->u.proglen = x
1082 #define Track_Code(code)
1083 #else
1084 #define ProgLen(ri) ri->u.offsets[0]
1085 #define SetProgLen(ri,x) ri->u.offsets[0] = x
1086 #define Set_Node_Offset_To_R(offset,byte) STMT_START {                  \
1087         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
1088                     __LINE__, (int)(offset), (int)(byte)));             \
1089         if((offset) < 0) {                                              \
1090             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
1091                                          (int)(offset));                \
1092         } else {                                                        \
1093             RExC_offsets[2*(offset)-1] = (byte);                        \
1094         }                                                               \
1095 } STMT_END
1096
1097 #define Set_Node_Offset(node,byte)                                      \
1098     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (byte)-RExC_start)
1099 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
1100
1101 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
1102         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
1103                 __LINE__, (int)(node), (int)(len)));                    \
1104         if((node) < 0) {                                                \
1105             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
1106                                          (int)(node));                  \
1107         } else {                                                        \
1108             RExC_offsets[2*(node)] = (len);                             \
1109         }                                                               \
1110 } STMT_END
1111
1112 #define Set_Node_Length(node,len) \
1113     Set_Node_Length_To_R(REGNODE_OFFSET(node), len)
1114 #define Set_Node_Cur_Length(node, start)                \
1115     Set_Node_Length(node, RExC_parse - start)
1116
1117 /* Get offsets and lengths */
1118 #define Node_Offset(n) (RExC_offsets[2*(REGNODE_OFFSET(n))-1])
1119 #define Node_Length(n) (RExC_offsets[2*(REGNODE_OFFSET(n))])
1120
1121 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
1122     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (offset));       \
1123     Set_Node_Length_To_R(REGNODE_OFFSET(node), (len));  \
1124 } STMT_END
1125
1126 #define Track_Code(code) STMT_START { code } STMT_END
1127 #endif
1128
1129 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
1130 #define EXPERIMENTAL_INPLACESCAN
1131 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
1132
1133 #ifdef DEBUGGING
1134 int
1135 Perl_re_printf(pTHX_ const char *fmt, ...)
1136 {
1137     va_list ap;
1138     int result;
1139     PerlIO *f= Perl_debug_log;
1140     PERL_ARGS_ASSERT_RE_PRINTF;
1141     va_start(ap, fmt);
1142     result = PerlIO_vprintf(f, fmt, ap);
1143     va_end(ap);
1144     return result;
1145 }
1146
1147 int
1148 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
1149 {
1150     va_list ap;
1151     int result;
1152     PerlIO *f= Perl_debug_log;
1153     PERL_ARGS_ASSERT_RE_INDENTF;
1154     va_start(ap, depth);
1155     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
1156     result = PerlIO_vprintf(f, fmt, ap);
1157     va_end(ap);
1158     return result;
1159 }
1160 #endif /* DEBUGGING */
1161
1162 #define DEBUG_RExC_seen()                                                   \
1163         DEBUG_OPTIMISE_MORE_r({                                             \
1164             Perl_re_printf( aTHX_ "RExC_seen: ");                           \
1165                                                                             \
1166             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
1167                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                \
1168                                                                             \
1169             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
1170                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");              \
1171                                                                             \
1172             if (RExC_seen & REG_GPOS_SEEN)                                  \
1173                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                    \
1174                                                                             \
1175             if (RExC_seen & REG_RECURSE_SEEN)                               \
1176                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                 \
1177                                                                             \
1178             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
1179                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");      \
1180                                                                             \
1181             if (RExC_seen & REG_VERBARG_SEEN)                               \
1182                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                 \
1183                                                                             \
1184             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
1185                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                \
1186                                                                             \
1187             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
1188                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");          \
1189                                                                             \
1190             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
1191                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");          \
1192                                                                             \
1193             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
1194                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");    \
1195                                                                             \
1196             Perl_re_printf( aTHX_ "\n");                                    \
1197         });
1198
1199 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
1200   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
1201
1202
1203 #ifdef DEBUGGING
1204 static void
1205 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
1206                                     const char *close_str)
1207 {
1208     if (!flags)
1209         return;
1210
1211     Perl_re_printf( aTHX_  "%s", open_str);
1212     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
1213     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
1214     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
1215     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
1216     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
1217     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
1218     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
1219     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
1220     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
1221     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
1222     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
1223     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1224     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1225     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1226     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1227     Perl_re_printf( aTHX_  "%s", close_str);
1228 }
1229
1230
1231 static void
1232 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1233                     U32 depth, int is_inf)
1234 {
1235     DECLARE_AND_GET_RE_DEBUG_FLAGS;
1236
1237     DEBUG_OPTIMISE_MORE_r({
1238         if (!data)
1239             return;
1240         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1241             depth,
1242             where,
1243             (IV)data->pos_min,
1244             (IV)data->pos_delta,
1245             (UV)data->flags
1246         );
1247
1248         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1249
1250         Perl_re_printf( aTHX_
1251             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1252             (IV)data->whilem_c,
1253             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1254             is_inf ? "INF " : ""
1255         );
1256
1257         if (data->last_found) {
1258             int i;
1259             Perl_re_printf(aTHX_
1260                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1261                     SvPVX_const(data->last_found),
1262                     (IV)data->last_end,
1263                     (IV)data->last_start_min,
1264                     (IV)data->last_start_max
1265             );
1266
1267             for (i = 0; i < 2; i++) {
1268                 Perl_re_printf(aTHX_
1269                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1270                     data->cur_is_floating == i ? "*" : "",
1271                     i ? "Float" : "Fixed",
1272                     SvPVX_const(data->substrs[i].str),
1273                     (IV)data->substrs[i].min_offset,
1274                     (IV)data->substrs[i].max_offset
1275                 );
1276                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1277             }
1278         }
1279
1280         Perl_re_printf( aTHX_ "\n");
1281     });
1282 }
1283
1284
1285 static void
1286 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1287                 regnode *scan, U32 depth, U32 flags)
1288 {
1289     DECLARE_AND_GET_RE_DEBUG_FLAGS;
1290
1291     DEBUG_OPTIMISE_r({
1292         regnode *Next;
1293
1294         if (!scan)
1295             return;
1296         Next = regnext(scan);
1297         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1298         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1299             depth,
1300             str,
1301             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1302             Next ? (REG_NODE_NUM(Next)) : 0 );
1303         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1304         Perl_re_printf( aTHX_  "\n");
1305    });
1306 }
1307
1308
1309 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1310                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1311
1312 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1313                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1314
1315 #else
1316 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1317 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1318 #endif
1319
1320
1321 /* =========================================================
1322  * BEGIN edit_distance stuff.
1323  *
1324  * This calculates how many single character changes of any type are needed to
1325  * transform a string into another one.  It is taken from version 3.1 of
1326  *
1327  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1328  */
1329
1330 /* Our unsorted dictionary linked list.   */
1331 /* Note we use UVs, not chars. */
1332
1333 struct dictionary{
1334   UV key;
1335   UV value;
1336   struct dictionary* next;
1337 };
1338 typedef struct dictionary item;
1339
1340
1341 PERL_STATIC_INLINE item*
1342 push(UV key, item* curr)
1343 {
1344     item* head;
1345     Newx(head, 1, item);
1346     head->key = key;
1347     head->value = 0;
1348     head->next = curr;
1349     return head;
1350 }
1351
1352
1353 PERL_STATIC_INLINE item*
1354 find(item* head, UV key)
1355 {
1356     item* iterator = head;
1357     while (iterator){
1358         if (iterator->key == key){
1359             return iterator;
1360         }
1361         iterator = iterator->next;
1362     }
1363
1364     return NULL;
1365 }
1366
1367 PERL_STATIC_INLINE item*
1368 uniquePush(item* head, UV key)
1369 {
1370     item* iterator = head;
1371
1372     while (iterator){
1373         if (iterator->key == key) {
1374             return head;
1375         }
1376         iterator = iterator->next;
1377     }
1378
1379     return push(key, head);
1380 }
1381
1382 PERL_STATIC_INLINE void
1383 dict_free(item* head)
1384 {
1385     item* iterator = head;
1386
1387     while (iterator) {
1388         item* temp = iterator;
1389         iterator = iterator->next;
1390         Safefree(temp);
1391     }
1392
1393     head = NULL;
1394 }
1395
1396 /* End of Dictionary Stuff */
1397
1398 /* All calculations/work are done here */
1399 STATIC int
1400 S_edit_distance(const UV* src,
1401                 const UV* tgt,
1402                 const STRLEN x,             /* length of src[] */
1403                 const STRLEN y,             /* length of tgt[] */
1404                 const SSize_t maxDistance
1405 )
1406 {
1407     item *head = NULL;
1408     UV swapCount, swapScore, targetCharCount, i, j;
1409     UV *scores;
1410     UV score_ceil = x + y;
1411
1412     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1413
1414     /* intialize matrix start values */
1415     Newx(scores, ( (x + 2) * (y + 2)), UV);
1416     scores[0] = score_ceil;
1417     scores[1 * (y + 2) + 0] = score_ceil;
1418     scores[0 * (y + 2) + 1] = score_ceil;
1419     scores[1 * (y + 2) + 1] = 0;
1420     head = uniquePush(uniquePush(head, src[0]), tgt[0]);
1421
1422     /* work loops    */
1423     /* i = src index */
1424     /* j = tgt index */
1425     for (i=1;i<=x;i++) {
1426         if (i < x)
1427             head = uniquePush(head, src[i]);
1428         scores[(i+1) * (y + 2) + 1] = i;
1429         scores[(i+1) * (y + 2) + 0] = score_ceil;
1430         swapCount = 0;
1431
1432         for (j=1;j<=y;j++) {
1433             if (i == 1) {
1434                 if(j < y)
1435                 head = uniquePush(head, tgt[j]);
1436                 scores[1 * (y + 2) + (j + 1)] = j;
1437                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1438             }
1439
1440             targetCharCount = find(head, tgt[j-1])->value;
1441             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1442
1443             if (src[i-1] != tgt[j-1]){
1444                 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));
1445             }
1446             else {
1447                 swapCount = j;
1448                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1449             }
1450         }
1451
1452         find(head, src[i-1])->value = i;
1453     }
1454
1455     {
1456         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1457         dict_free(head);
1458         Safefree(scores);
1459         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1460     }
1461 }
1462
1463 /* END of edit_distance() stuff
1464  * ========================================================= */
1465
1466 /* Mark that we cannot extend a found fixed substring at this point.
1467    Update the longest found anchored substring or the longest found
1468    floating substrings if needed. */
1469
1470 STATIC void
1471 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1472                     SSize_t *minlenp, int is_inf)
1473 {
1474     const STRLEN l = CHR_SVLEN(data->last_found);
1475     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1476     const STRLEN old_l = CHR_SVLEN(longest_sv);
1477     DECLARE_AND_GET_RE_DEBUG_FLAGS;
1478
1479     PERL_ARGS_ASSERT_SCAN_COMMIT;
1480
1481     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1482         const U8 i = data->cur_is_floating;
1483         SvSetMagicSV(longest_sv, data->last_found);
1484         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1485
1486         if (!i) /* fixed */
1487             data->substrs[0].max_offset = data->substrs[0].min_offset;
1488         else { /* float */
1489             data->substrs[1].max_offset =
1490                       (is_inf)
1491                        ? OPTIMIZE_INFTY
1492                        : (l
1493                           ? data->last_start_max
1494                           /* temporary underflow guard for 5.32 */
1495                           : data->pos_delta < 0 ? OPTIMIZE_INFTY
1496                           : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min
1497                                          ? OPTIMIZE_INFTY
1498                                          : data->pos_min + data->pos_delta));
1499         }
1500
1501         data->substrs[i].flags &= ~SF_BEFORE_EOL;
1502         data->substrs[i].flags |= data->flags & SF_BEFORE_EOL;
1503         data->substrs[i].minlenp = minlenp;
1504         data->substrs[i].lookbehind = 0;
1505     }
1506
1507     SvCUR_set(data->last_found, 0);
1508     {
1509         SV * const sv = data->last_found;
1510         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1511             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1512             if (mg)
1513                 mg->mg_len = 0;
1514         }
1515     }
1516     data->last_end = -1;
1517     data->flags &= ~SF_BEFORE_EOL;
1518     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1519 }
1520
1521 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1522  * list that describes which code points it matches */
1523
1524 STATIC void
1525 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1526 {
1527     /* Set the SSC 'ssc' to match an empty string or any code point */
1528
1529     PERL_ARGS_ASSERT_SSC_ANYTHING;
1530
1531     assert(is_ANYOF_SYNTHETIC(ssc));
1532
1533     /* mortalize so won't leak */
1534     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1535     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1536 }
1537
1538 STATIC int
1539 S_ssc_is_anything(const regnode_ssc *ssc)
1540 {
1541     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1542      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1543      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1544      * in any way, so there's no point in using it */
1545
1546     UV start, end;
1547     bool ret;
1548
1549     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1550
1551     assert(is_ANYOF_SYNTHETIC(ssc));
1552
1553     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1554         return FALSE;
1555     }
1556
1557     /* See if the list consists solely of the range 0 - Infinity */
1558     invlist_iterinit(ssc->invlist);
1559     ret = invlist_iternext(ssc->invlist, &start, &end)
1560           && start == 0
1561           && end == UV_MAX;
1562
1563     invlist_iterfinish(ssc->invlist);
1564
1565     if (ret) {
1566         return TRUE;
1567     }
1568
1569     /* If e.g., both \w and \W are set, matches everything */
1570     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1571         int i;
1572         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1573             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1574                 return TRUE;
1575             }
1576         }
1577     }
1578
1579     return FALSE;
1580 }
1581
1582 STATIC void
1583 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1584 {
1585     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1586      * string, any code point, or any posix class under locale */
1587
1588     PERL_ARGS_ASSERT_SSC_INIT;
1589
1590     Zero(ssc, 1, regnode_ssc);
1591     set_ANYOF_SYNTHETIC(ssc);
1592     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1593     ssc_anything(ssc);
1594
1595     /* If any portion of the regex is to operate under locale rules that aren't
1596      * fully known at compile time, initialization includes it.  The reason
1597      * this isn't done for all regexes is that the optimizer was written under
1598      * the assumption that locale was all-or-nothing.  Given the complexity and
1599      * lack of documentation in the optimizer, and that there are inadequate
1600      * test cases for locale, many parts of it may not work properly, it is
1601      * safest to avoid locale unless necessary. */
1602     if (RExC_contains_locale) {
1603         ANYOF_POSIXL_SETALL(ssc);
1604     }
1605     else {
1606         ANYOF_POSIXL_ZERO(ssc);
1607     }
1608 }
1609
1610 STATIC int
1611 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1612                         const regnode_ssc *ssc)
1613 {
1614     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1615      * to the list of code points matched, and locale posix classes; hence does
1616      * not check its flags) */
1617
1618     UV start, end;
1619     bool ret;
1620
1621     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1622
1623     assert(is_ANYOF_SYNTHETIC(ssc));
1624
1625     invlist_iterinit(ssc->invlist);
1626     ret = invlist_iternext(ssc->invlist, &start, &end)
1627           && start == 0
1628           && end == UV_MAX;
1629
1630     invlist_iterfinish(ssc->invlist);
1631
1632     if (! ret) {
1633         return FALSE;
1634     }
1635
1636     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1637         return FALSE;
1638     }
1639
1640     return TRUE;
1641 }
1642
1643 #define INVLIST_INDEX 0
1644 #define ONLY_LOCALE_MATCHES_INDEX 1
1645 #define DEFERRED_USER_DEFINED_INDEX 2
1646
1647 STATIC SV*
1648 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1649                                const regnode_charclass* const node)
1650 {
1651     /* Returns a mortal inversion list defining which code points are matched
1652      * by 'node', which is of type ANYOF.  Handles complementing the result if
1653      * appropriate.  If some code points aren't knowable at this time, the
1654      * returned list must, and will, contain every code point that is a
1655      * possibility. */
1656
1657     SV* invlist = NULL;
1658     SV* only_utf8_locale_invlist = NULL;
1659     unsigned int i;
1660     const U32 n = ARG(node);
1661     bool new_node_has_latin1 = FALSE;
1662     const U8 flags = (inRANGE(OP(node), ANYOFH, ANYOFRb))
1663                       ? 0
1664                       : ANYOF_FLAGS(node);
1665
1666     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1667
1668     /* Look at the data structure created by S_set_ANYOF_arg() */
1669     if (n != ANYOF_ONLY_HAS_BITMAP) {
1670         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1671         AV * const av = MUTABLE_AV(SvRV(rv));
1672         SV **const ary = AvARRAY(av);
1673         assert(RExC_rxi->data->what[n] == 's');
1674
1675         if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
1676
1677             /* Here there are things that won't be known until runtime -- we
1678              * have to assume it could be anything */
1679             invlist = sv_2mortal(_new_invlist(1));
1680             return _add_range_to_invlist(invlist, 0, UV_MAX);
1681         }
1682         else if (ary[INVLIST_INDEX]) {
1683
1684             /* Use the node's inversion list */
1685             invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL));
1686         }
1687
1688         /* Get the code points valid only under UTF-8 locales */
1689         if (   (flags & ANYOFL_FOLD)
1690             &&  av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX)
1691         {
1692             only_utf8_locale_invlist = ary[ONLY_LOCALE_MATCHES_INDEX];
1693         }
1694     }
1695
1696     if (! invlist) {
1697         invlist = sv_2mortal(_new_invlist(0));
1698     }
1699
1700     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1701      * code points, and an inversion list for the others, but if there are code
1702      * points that should match only conditionally on the target string being
1703      * UTF-8, those are placed in the inversion list, and not the bitmap.
1704      * Since there are circumstances under which they could match, they are
1705      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1706      * to exclude them here, so that when we invert below, the end result
1707      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1708      * have to do this here before we add the unconditionally matched code
1709      * points */
1710     if (flags & ANYOF_INVERT) {
1711         _invlist_intersection_complement_2nd(invlist,
1712                                              PL_UpperLatin1,
1713                                              &invlist);
1714     }
1715
1716     /* Add in the points from the bit map */
1717     if (! inRANGE(OP(node), ANYOFH, ANYOFRb)) {
1718         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1719             if (ANYOF_BITMAP_TEST(node, i)) {
1720                 unsigned int start = i++;
1721
1722                 for (;    i < NUM_ANYOF_CODE_POINTS
1723                        && ANYOF_BITMAP_TEST(node, i); ++i)
1724                 {
1725                     /* empty */
1726                 }
1727                 invlist = _add_range_to_invlist(invlist, start, i-1);
1728                 new_node_has_latin1 = TRUE;
1729             }
1730         }
1731     }
1732
1733     /* If this can match all upper Latin1 code points, have to add them
1734      * as well.  But don't add them if inverting, as when that gets done below,
1735      * it would exclude all these characters, including the ones it shouldn't
1736      * that were added just above */
1737     if (! (flags & ANYOF_INVERT) && OP(node) == ANYOFD
1738         && (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1739     {
1740         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1741     }
1742
1743     /* Similarly for these */
1744     if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1745         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1746     }
1747
1748     if (flags & ANYOF_INVERT) {
1749         _invlist_invert(invlist);
1750     }
1751     else if (flags & ANYOFL_FOLD) {
1752         if (new_node_has_latin1) {
1753
1754             /* Under /li, any 0-255 could fold to any other 0-255, depending on
1755              * the locale.  We can skip this if there are no 0-255 at all. */
1756             _invlist_union(invlist, PL_Latin1, &invlist);
1757
1758             invlist = add_cp_to_invlist(invlist, LATIN_SMALL_LETTER_DOTLESS_I);
1759             invlist = add_cp_to_invlist(invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
1760         }
1761         else {
1762             if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) {
1763                 invlist = add_cp_to_invlist(invlist, 'I');
1764             }
1765             if (_invlist_contains_cp(invlist,
1766                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE))
1767             {
1768                 invlist = add_cp_to_invlist(invlist, 'i');
1769             }
1770         }
1771     }
1772
1773     /* Similarly add the UTF-8 locale possible matches.  These have to be
1774      * deferred until after the non-UTF-8 locale ones are taken care of just
1775      * above, or it leads to wrong results under ANYOF_INVERT */
1776     if (only_utf8_locale_invlist) {
1777         _invlist_union_maybe_complement_2nd(invlist,
1778                                             only_utf8_locale_invlist,
1779                                             flags & ANYOF_INVERT,
1780                                             &invlist);
1781     }
1782
1783     return invlist;
1784 }
1785
1786 /* These two functions currently do the exact same thing */
1787 #define ssc_init_zero           ssc_init
1788
1789 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1790 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1791
1792 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1793  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1794  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1795
1796 STATIC void
1797 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1798                 const regnode_charclass *and_with)
1799 {
1800     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1801      * another SSC or a regular ANYOF class.  Can create false positives. */
1802
1803     SV* anded_cp_list;
1804     U8  and_with_flags = inRANGE(OP(and_with), ANYOFH, ANYOFRb)
1805                           ? 0
1806                           : ANYOF_FLAGS(and_with);
1807     U8  anded_flags;
1808
1809     PERL_ARGS_ASSERT_SSC_AND;
1810
1811     assert(is_ANYOF_SYNTHETIC(ssc));
1812
1813     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1814      * the code point inversion list and just the relevant flags */
1815     if (is_ANYOF_SYNTHETIC(and_with)) {
1816         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1817         anded_flags = and_with_flags;
1818
1819         /* XXX This is a kludge around what appears to be deficiencies in the
1820          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1821          * there are paths through the optimizer where it doesn't get weeded
1822          * out when it should.  And if we don't make some extra provision for
1823          * it like the code just below, it doesn't get added when it should.
1824          * This solution is to add it only when AND'ing, which is here, and
1825          * only when what is being AND'ed is the pristine, original node
1826          * matching anything.  Thus it is like adding it to ssc_anything() but
1827          * only when the result is to be AND'ed.  Probably the same solution
1828          * could be adopted for the same problem we have with /l matching,
1829          * which is solved differently in S_ssc_init(), and that would lead to
1830          * fewer false positives than that solution has.  But if this solution
1831          * creates bugs, the consequences are only that a warning isn't raised
1832          * that should be; while the consequences for having /l bugs is
1833          * incorrect matches */
1834         if (ssc_is_anything((regnode_ssc *)and_with)) {
1835             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1836         }
1837     }
1838     else {
1839         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1840         if (OP(and_with) == ANYOFD) {
1841             anded_flags = and_with_flags & ANYOF_COMMON_FLAGS;
1842         }
1843         else {
1844             anded_flags = and_with_flags
1845             &( ANYOF_COMMON_FLAGS
1846               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1847               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1848             if (ANYOFL_UTF8_LOCALE_REQD(and_with_flags)) {
1849                 anded_flags &=
1850                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1851             }
1852         }
1853     }
1854
1855     ANYOF_FLAGS(ssc) &= anded_flags;
1856
1857     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1858      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1859      * 'and_with' may be inverted.  When not inverted, we have the situation of
1860      * computing:
1861      *  (C1 | P1) & (C2 | P2)
1862      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1863      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1864      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1865      *                    <=  ((C1 & C2) | P1 | P2)
1866      * Alternatively, the last few steps could be:
1867      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1868      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1869      *                    <=  (C1 | C2 | (P1 & P2))
1870      * We favor the second approach if either P1 or P2 is non-empty.  This is
1871      * because these components are a barrier to doing optimizations, as what
1872      * they match cannot be known until the moment of matching as they are
1873      * dependent on the current locale, 'AND"ing them likely will reduce or
1874      * eliminate them.
1875      * But we can do better if we know that C1,P1 are in their initial state (a
1876      * frequent occurrence), each matching everything:
1877      *  (<everything>) & (C2 | P2) =  C2 | P2
1878      * Similarly, if C2,P2 are in their initial state (again a frequent
1879      * occurrence), the result is a no-op
1880      *  (C1 | P1) & (<everything>) =  C1 | P1
1881      *
1882      * Inverted, we have
1883      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1884      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1885      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1886      * */
1887
1888     if ((and_with_flags & ANYOF_INVERT)
1889         && ! is_ANYOF_SYNTHETIC(and_with))
1890     {
1891         unsigned int i;
1892
1893         ssc_intersection(ssc,
1894                          anded_cp_list,
1895                          FALSE /* Has already been inverted */
1896                          );
1897
1898         /* If either P1 or P2 is empty, the intersection will be also; can skip
1899          * the loop */
1900         if (! (and_with_flags & ANYOF_MATCHES_POSIXL)) {
1901             ANYOF_POSIXL_ZERO(ssc);
1902         }
1903         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1904
1905             /* Note that the Posix class component P from 'and_with' actually
1906              * looks like:
1907              *      P = Pa | Pb | ... | Pn
1908              * where each component is one posix class, such as in [\w\s].
1909              * Thus
1910              *      ~P = ~(Pa | Pb | ... | Pn)
1911              *         = ~Pa & ~Pb & ... & ~Pn
1912              *        <= ~Pa | ~Pb | ... | ~Pn
1913              * The last is something we can easily calculate, but unfortunately
1914              * is likely to have many false positives.  We could do better
1915              * in some (but certainly not all) instances if two classes in
1916              * P have known relationships.  For example
1917              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1918              * So
1919              *      :lower: & :print: = :lower:
1920              * And similarly for classes that must be disjoint.  For example,
1921              * since \s and \w can have no elements in common based on rules in
1922              * the POSIX standard,
1923              *      \w & ^\S = nothing
1924              * Unfortunately, some vendor locales do not meet the Posix
1925              * standard, in particular almost everything by Microsoft.
1926              * The loop below just changes e.g., \w into \W and vice versa */
1927
1928             regnode_charclass_posixl temp;
1929             int add = 1;    /* To calculate the index of the complement */
1930
1931             Zero(&temp, 1, regnode_charclass_posixl);
1932             ANYOF_POSIXL_ZERO(&temp);
1933             for (i = 0; i < ANYOF_MAX; i++) {
1934                 assert(i % 2 != 0
1935                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1936                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1937
1938                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1939                     ANYOF_POSIXL_SET(&temp, i + add);
1940                 }
1941                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1942             }
1943             ANYOF_POSIXL_AND(&temp, ssc);
1944
1945         } /* else ssc already has no posixes */
1946     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1947          in its initial state */
1948     else if (! is_ANYOF_SYNTHETIC(and_with)
1949              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1950     {
1951         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1952          * copy it over 'ssc' */
1953         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1954             if (is_ANYOF_SYNTHETIC(and_with)) {
1955                 StructCopy(and_with, ssc, regnode_ssc);
1956             }
1957             else {
1958                 ssc->invlist = anded_cp_list;
1959                 ANYOF_POSIXL_ZERO(ssc);
1960                 if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1961                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1962                 }
1963             }
1964         }
1965         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1966                  || (and_with_flags & ANYOF_MATCHES_POSIXL))
1967         {
1968             /* One or the other of P1, P2 is non-empty. */
1969             if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1970                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1971             }
1972             ssc_union(ssc, anded_cp_list, FALSE);
1973         }
1974         else { /* P1 = P2 = empty */
1975             ssc_intersection(ssc, anded_cp_list, FALSE);
1976         }
1977     }
1978 }
1979
1980 STATIC void
1981 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1982                const regnode_charclass *or_with)
1983 {
1984     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1985      * another SSC or a regular ANYOF class.  Can create false positives if
1986      * 'or_with' is to be inverted. */
1987
1988     SV* ored_cp_list;
1989     U8 ored_flags;
1990     U8  or_with_flags = inRANGE(OP(or_with), ANYOFH, ANYOFRb)
1991                          ? 0
1992                          : ANYOF_FLAGS(or_with);
1993
1994     PERL_ARGS_ASSERT_SSC_OR;
1995
1996     assert(is_ANYOF_SYNTHETIC(ssc));
1997
1998     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1999      * the code point inversion list and just the relevant flags */
2000     if (is_ANYOF_SYNTHETIC(or_with)) {
2001         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
2002         ored_flags = or_with_flags;
2003     }
2004     else {
2005         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
2006         ored_flags = or_with_flags & ANYOF_COMMON_FLAGS;
2007         if (OP(or_with) != ANYOFD) {
2008             ored_flags
2009             |= or_with_flags
2010              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2011                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
2012             if (ANYOFL_UTF8_LOCALE_REQD(or_with_flags)) {
2013                 ored_flags |=
2014                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
2015             }
2016         }
2017     }
2018
2019     ANYOF_FLAGS(ssc) |= ored_flags;
2020
2021     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
2022      * C2 is the list of code points in 'or-with'; P2, its posix classes.
2023      * 'or_with' may be inverted.  When not inverted, we have the simple
2024      * situation of computing:
2025      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
2026      * If P1|P2 yields a situation with both a class and its complement are
2027      * set, like having both \w and \W, this matches all code points, and we
2028      * can delete these from the P component of the ssc going forward.  XXX We
2029      * might be able to delete all the P components, but I (khw) am not certain
2030      * about this, and it is better to be safe.
2031      *
2032      * Inverted, we have
2033      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
2034      *                         <=  (C1 | P1) | ~C2
2035      *                         <=  (C1 | ~C2) | P1
2036      * (which results in actually simpler code than the non-inverted case)
2037      * */
2038
2039     if ((or_with_flags & ANYOF_INVERT)
2040         && ! is_ANYOF_SYNTHETIC(or_with))
2041     {
2042         /* We ignore P2, leaving P1 going forward */
2043     }   /* else  Not inverted */
2044     else if (or_with_flags & ANYOF_MATCHES_POSIXL) {
2045         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
2046         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2047             unsigned int i;
2048             for (i = 0; i < ANYOF_MAX; i += 2) {
2049                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
2050                 {
2051                     ssc_match_all_cp(ssc);
2052                     ANYOF_POSIXL_CLEAR(ssc, i);
2053                     ANYOF_POSIXL_CLEAR(ssc, i+1);
2054                 }
2055             }
2056         }
2057     }
2058
2059     ssc_union(ssc,
2060               ored_cp_list,
2061               FALSE /* Already has been inverted */
2062               );
2063 }
2064
2065 STATIC void
2066 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
2067 {
2068     PERL_ARGS_ASSERT_SSC_UNION;
2069
2070     assert(is_ANYOF_SYNTHETIC(ssc));
2071
2072     _invlist_union_maybe_complement_2nd(ssc->invlist,
2073                                         invlist,
2074                                         invert2nd,
2075                                         &ssc->invlist);
2076 }
2077
2078 STATIC void
2079 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
2080                          SV* const invlist,
2081                          const bool invert2nd)
2082 {
2083     PERL_ARGS_ASSERT_SSC_INTERSECTION;
2084
2085     assert(is_ANYOF_SYNTHETIC(ssc));
2086
2087     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
2088                                                invlist,
2089                                                invert2nd,
2090                                                &ssc->invlist);
2091 }
2092
2093 STATIC void
2094 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
2095 {
2096     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
2097
2098     assert(is_ANYOF_SYNTHETIC(ssc));
2099
2100     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
2101 }
2102
2103 STATIC void
2104 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
2105 {
2106     /* AND just the single code point 'cp' into the SSC 'ssc' */
2107
2108     SV* cp_list = _new_invlist(2);
2109
2110     PERL_ARGS_ASSERT_SSC_CP_AND;
2111
2112     assert(is_ANYOF_SYNTHETIC(ssc));
2113
2114     cp_list = add_cp_to_invlist(cp_list, cp);
2115     ssc_intersection(ssc, cp_list,
2116                      FALSE /* Not inverted */
2117                      );
2118     SvREFCNT_dec_NN(cp_list);
2119 }
2120
2121 STATIC void
2122 S_ssc_clear_locale(regnode_ssc *ssc)
2123 {
2124     /* Set the SSC 'ssc' to not match any locale things */
2125     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
2126
2127     assert(is_ANYOF_SYNTHETIC(ssc));
2128
2129     ANYOF_POSIXL_ZERO(ssc);
2130     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
2131 }
2132
2133 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
2134
2135 STATIC bool
2136 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
2137 {
2138     /* The synthetic start class is used to hopefully quickly winnow down
2139      * places where a pattern could start a match in the target string.  If it
2140      * doesn't really narrow things down that much, there isn't much point to
2141      * having the overhead of using it.  This function uses some very crude
2142      * heuristics to decide if to use the ssc or not.
2143      *
2144      * It returns TRUE if 'ssc' rules out more than half what it considers to
2145      * be the "likely" possible matches, but of course it doesn't know what the
2146      * actual things being matched are going to be; these are only guesses
2147      *
2148      * For /l matches, it assumes that the only likely matches are going to be
2149      *      in the 0-255 range, uniformly distributed, so half of that is 127
2150      * For /a and /d matches, it assumes that the likely matches will be just
2151      *      the ASCII range, so half of that is 63
2152      * For /u and there isn't anything matching above the Latin1 range, it
2153      *      assumes that that is the only range likely to be matched, and uses
2154      *      half that as the cut-off: 127.  If anything matches above Latin1,
2155      *      it assumes that all of Unicode could match (uniformly), except for
2156      *      non-Unicode code points and things in the General Category "Other"
2157      *      (unassigned, private use, surrogates, controls and formats).  This
2158      *      is a much large number. */
2159
2160     U32 count = 0;      /* Running total of number of code points matched by
2161                            'ssc' */
2162     UV start, end;      /* Start and end points of current range in inversion
2163                            XXX outdated.  UTF-8 locales are common, what about invert? list */
2164     const U32 max_code_points = (LOC)
2165                                 ?  256
2166                                 : ((  ! UNI_SEMANTICS
2167                                     ||  invlist_highest(ssc->invlist) < 256)
2168                                   ? 128
2169                                   : NON_OTHER_COUNT);
2170     const U32 max_match = max_code_points / 2;
2171
2172     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
2173
2174     invlist_iterinit(ssc->invlist);
2175     while (invlist_iternext(ssc->invlist, &start, &end)) {
2176         if (start >= max_code_points) {
2177             break;
2178         }
2179         end = MIN(end, max_code_points - 1);
2180         count += end - start + 1;
2181         if (count >= max_match) {
2182             invlist_iterfinish(ssc->invlist);
2183             return FALSE;
2184         }
2185     }
2186
2187     return TRUE;
2188 }
2189
2190
2191 STATIC void
2192 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
2193 {
2194     /* The inversion list in the SSC is marked mortal; now we need a more
2195      * permanent copy, which is stored the same way that is done in a regular
2196      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
2197      * map */
2198
2199     SV* invlist = invlist_clone(ssc->invlist, NULL);
2200
2201     PERL_ARGS_ASSERT_SSC_FINALIZE;
2202
2203     assert(is_ANYOF_SYNTHETIC(ssc));
2204
2205     /* The code in this file assumes that all but these flags aren't relevant
2206      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
2207      * by the time we reach here */
2208     assert(! (ANYOF_FLAGS(ssc)
2209         & ~( ANYOF_COMMON_FLAGS
2210             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2211             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
2212
2213     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
2214
2215     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL);
2216     SvREFCNT_dec(invlist);
2217
2218     /* Make sure is clone-safe */
2219     ssc->invlist = NULL;
2220
2221     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2222         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
2223         OP(ssc) = ANYOFPOSIXL;
2224     }
2225     else if (RExC_contains_locale) {
2226         OP(ssc) = ANYOFL;
2227     }
2228
2229     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2230 }
2231
2232 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2233 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2234 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2235 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2236                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2237                                : 0 )
2238
2239
2240 #ifdef DEBUGGING
2241 /*
2242    dump_trie(trie,widecharmap,revcharmap)
2243    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2244    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2245
2246    These routines dump out a trie in a somewhat readable format.
2247    The _interim_ variants are used for debugging the interim
2248    tables that are used to generate the final compressed
2249    representation which is what dump_trie expects.
2250
2251    Part of the reason for their existence is to provide a form
2252    of documentation as to how the different representations function.
2253
2254 */
2255
2256 /*
2257   Dumps the final compressed table form of the trie to Perl_debug_log.
2258   Used for debugging make_trie().
2259 */
2260
2261 STATIC void
2262 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2263             AV *revcharmap, U32 depth)
2264 {
2265     U32 state;
2266     SV *sv=sv_newmortal();
2267     int colwidth= widecharmap ? 6 : 4;
2268     U16 word;
2269     DECLARE_AND_GET_RE_DEBUG_FLAGS;
2270
2271     PERL_ARGS_ASSERT_DUMP_TRIE;
2272
2273     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2274         depth+1, "Match","Base","Ofs" );
2275
2276     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2277         SV ** const tmp = av_fetch( revcharmap, state, 0);
2278         if ( tmp ) {
2279             Perl_re_printf( aTHX_  "%*s",
2280                 colwidth,
2281                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2282                             PL_colors[0], PL_colors[1],
2283                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2284                             PERL_PV_ESCAPE_FIRSTCHAR
2285                 )
2286             );
2287         }
2288     }
2289     Perl_re_printf( aTHX_  "\n");
2290     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2291
2292     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2293         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2294     Perl_re_printf( aTHX_  "\n");
2295
2296     for( state = 1 ; state < trie->statecount ; state++ ) {
2297         const U32 base = trie->states[ state ].trans.base;
2298
2299         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2300
2301         if ( trie->states[ state ].wordnum ) {
2302             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2303         } else {
2304             Perl_re_printf( aTHX_  "%6s", "" );
2305         }
2306
2307         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2308
2309         if ( base ) {
2310             U32 ofs = 0;
2311
2312             while( ( base + ofs  < trie->uniquecharcount ) ||
2313                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2314                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2315                                                                     != state))
2316                     ofs++;
2317
2318             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2319
2320             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2321                 if ( ( base + ofs >= trie->uniquecharcount )
2322                         && ( base + ofs - trie->uniquecharcount
2323                                                         < trie->lasttrans )
2324                         && trie->trans[ base + ofs
2325                                     - trie->uniquecharcount ].check == state )
2326                 {
2327                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2328                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2329                    );
2330                 } else {
2331                     Perl_re_printf( aTHX_  "%*s", colwidth,"   ." );
2332                 }
2333             }
2334
2335             Perl_re_printf( aTHX_  "]");
2336
2337         }
2338         Perl_re_printf( aTHX_  "\n" );
2339     }
2340     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2341                                 depth);
2342     for (word=1; word <= trie->wordcount; word++) {
2343         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2344             (int)word, (int)(trie->wordinfo[word].prev),
2345             (int)(trie->wordinfo[word].len));
2346     }
2347     Perl_re_printf( aTHX_  "\n" );
2348 }
2349 /*
2350   Dumps a fully constructed but uncompressed trie in list form.
2351   List tries normally only are used for construction when the number of
2352   possible chars (trie->uniquecharcount) is very high.
2353   Used for debugging make_trie().
2354 */
2355 STATIC void
2356 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2357                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2358                          U32 depth)
2359 {
2360     U32 state;
2361     SV *sv=sv_newmortal();
2362     int colwidth= widecharmap ? 6 : 4;
2363     DECLARE_AND_GET_RE_DEBUG_FLAGS;
2364
2365     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2366
2367     /* print out the table precompression.  */
2368     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2369             depth+1 );
2370     Perl_re_indentf( aTHX_  "%s",
2371             depth+1, "------:-----+-----------------\n" );
2372
2373     for( state=1 ; state < next_alloc ; state ++ ) {
2374         U16 charid;
2375
2376         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2377             depth+1, (UV)state  );
2378         if ( ! trie->states[ state ].wordnum ) {
2379             Perl_re_printf( aTHX_  "%5s| ","");
2380         } else {
2381             Perl_re_printf( aTHX_  "W%4x| ",
2382                 trie->states[ state ].wordnum
2383             );
2384         }
2385         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2386             SV ** const tmp = av_fetch( revcharmap,
2387                                         TRIE_LIST_ITEM(state, charid).forid, 0);
2388             if ( tmp ) {
2389                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2390                     colwidth,
2391                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2392                               colwidth,
2393                               PL_colors[0], PL_colors[1],
2394                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2395                               | PERL_PV_ESCAPE_FIRSTCHAR
2396                     ) ,
2397                     TRIE_LIST_ITEM(state, charid).forid,
2398                     (UV)TRIE_LIST_ITEM(state, charid).newstate
2399                 );
2400                 if (!(charid % 10))
2401                     Perl_re_printf( aTHX_  "\n%*s| ",
2402                         (int)((depth * 2) + 14), "");
2403             }
2404         }
2405         Perl_re_printf( aTHX_  "\n");
2406     }
2407 }
2408
2409 /*
2410   Dumps a fully constructed but uncompressed trie in table form.
2411   This is the normal DFA style state transition table, with a few
2412   twists to facilitate compression later.
2413   Used for debugging make_trie().
2414 */
2415 STATIC void
2416 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2417                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2418                           U32 depth)
2419 {
2420     U32 state;
2421     U16 charid;
2422     SV *sv=sv_newmortal();
2423     int colwidth= widecharmap ? 6 : 4;
2424     DECLARE_AND_GET_RE_DEBUG_FLAGS;
2425
2426     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2427
2428     /*
2429        print out the table precompression so that we can do a visual check
2430        that they are identical.
2431      */
2432
2433     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2434
2435     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2436         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2437         if ( tmp ) {
2438             Perl_re_printf( aTHX_  "%*s",
2439                 colwidth,
2440                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2441                             PL_colors[0], PL_colors[1],
2442                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2443                             PERL_PV_ESCAPE_FIRSTCHAR
2444                 )
2445             );
2446         }
2447     }
2448
2449     Perl_re_printf( aTHX_ "\n");
2450     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2451
2452     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2453         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2454     }
2455
2456     Perl_re_printf( aTHX_  "\n" );
2457
2458     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2459
2460         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2461             depth+1,
2462             (UV)TRIE_NODENUM( state ) );
2463
2464         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2465             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2466             if (v)
2467                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2468             else
2469                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2470         }
2471         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2472             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2473                                             (UV)trie->trans[ state ].check );
2474         } else {
2475             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2476                                             (UV)trie->trans[ state ].check,
2477             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2478         }
2479     }
2480 }
2481
2482 #endif
2483
2484
2485 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2486   startbranch: the first branch in the whole branch sequence
2487   first      : start branch of sequence of branch-exact nodes.
2488                May be the same as startbranch
2489   last       : Thing following the last branch.
2490                May be the same as tail.
2491   tail       : item following the branch sequence
2492   count      : words in the sequence
2493   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2494   depth      : indent depth
2495
2496 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2497
2498 A trie is an N'ary tree where the branches are determined by digital
2499 decomposition of the key. IE, at the root node you look up the 1st character and
2500 follow that branch repeat until you find the end of the branches. Nodes can be
2501 marked as "accepting" meaning they represent a complete word. Eg:
2502
2503   /he|she|his|hers/
2504
2505 would convert into the following structure. Numbers represent states, letters
2506 following numbers represent valid transitions on the letter from that state, if
2507 the number is in square brackets it represents an accepting state, otherwise it
2508 will be in parenthesis.
2509
2510       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2511       |    |
2512       |   (2)
2513       |    |
2514      (1)   +-i->(6)-+-s->[7]
2515       |
2516       +-s->(3)-+-h->(4)-+-e->[5]
2517
2518       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2519
2520 This shows that when matching against the string 'hers' we will begin at state 1
2521 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2522 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2523 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2524 single traverse. We store a mapping from accepting to state to which word was
2525 matched, and then when we have multiple possibilities we try to complete the
2526 rest of the regex in the order in which they occurred in the alternation.
2527
2528 The only prior NFA like behaviour that would be changed by the TRIE support is
2529 the silent ignoring of duplicate alternations which are of the form:
2530
2531  / (DUPE|DUPE) X? (?{ ... }) Y /x
2532
2533 Thus EVAL blocks following a trie may be called a different number of times with
2534 and without the optimisation. With the optimisations dupes will be silently
2535 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2536 the following demonstrates:
2537
2538  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2539
2540 which prints out 'word' three times, but
2541
2542  'words'=~/(word|word|word)(?{ print $1 })S/
2543
2544 which doesnt print it out at all. This is due to other optimisations kicking in.
2545
2546 Example of what happens on a structural level:
2547
2548 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2549
2550    1: CURLYM[1] {1,32767}(18)
2551    5:   BRANCH(8)
2552    6:     EXACT <ac>(16)
2553    8:   BRANCH(11)
2554    9:     EXACT <ad>(16)
2555   11:   BRANCH(14)
2556   12:     EXACT <ab>(16)
2557   16:   SUCCEED(0)
2558   17:   NOTHING(18)
2559   18: END(0)
2560
2561 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2562 and should turn into:
2563
2564    1: CURLYM[1] {1,32767}(18)
2565    5:   TRIE(16)
2566         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2567           <ac>
2568           <ad>
2569           <ab>
2570   16:   SUCCEED(0)
2571   17:   NOTHING(18)
2572   18: END(0)
2573
2574 Cases where tail != last would be like /(?foo|bar)baz/:
2575
2576    1: BRANCH(4)
2577    2:   EXACT <foo>(8)
2578    4: BRANCH(7)
2579    5:   EXACT <bar>(8)
2580    7: TAIL(8)
2581    8: EXACT <baz>(10)
2582   10: END(0)
2583
2584 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2585 and would end up looking like:
2586
2587     1: TRIE(8)
2588       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2589         <foo>
2590         <bar>
2591    7: TAIL(8)
2592    8: EXACT <baz>(10)
2593   10: END(0)
2594
2595     d = uvchr_to_utf8_flags(d, uv, 0);
2596
2597 is the recommended Unicode-aware way of saying
2598
2599     *(d++) = uv;
2600 */
2601
2602 #define TRIE_STORE_REVCHAR(val)                                            \
2603     STMT_START {                                                           \
2604         if (UTF) {                                                         \
2605             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2606             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2607             unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val);     \
2608             *kapow = '\0';                                                 \
2609             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2610             SvPOK_on(zlopp);                                               \
2611             SvUTF8_on(zlopp);                                              \
2612             av_push(revcharmap, zlopp);                                    \
2613         } else {                                                           \
2614             char ooooff = (char)val;                                           \
2615             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2616         }                                                                  \
2617         } STMT_END
2618
2619 /* This gets the next character from the input, folding it if not already
2620  * folded. */
2621 #define TRIE_READ_CHAR STMT_START {                                           \
2622     wordlen++;                                                                \
2623     if ( UTF ) {                                                              \
2624         /* if it is UTF then it is either already folded, or does not need    \
2625          * folding */                                                         \
2626         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2627     }                                                                         \
2628     else if (folder == PL_fold_latin1) {                                      \
2629         /* This folder implies Unicode rules, which in the range expressible  \
2630          *  by not UTF is the lower case, with the two exceptions, one of     \
2631          *  which should have been taken care of before calling this */       \
2632         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2633         uvc = toLOWER_L1(*uc);                                                \
2634         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2635         len = 1;                                                              \
2636     } else {                                                                  \
2637         /* raw data, will be folded later if needed */                        \
2638         uvc = (U32)*uc;                                                       \
2639         len = 1;                                                              \
2640     }                                                                         \
2641 } STMT_END
2642
2643
2644
2645 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2646     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2647         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2648         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2649         TRIE_LIST_LEN( state ) = ging;                          \
2650     }                                                           \
2651     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2652     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2653     TRIE_LIST_CUR( state )++;                                   \
2654 } STMT_END
2655
2656 #define TRIE_LIST_NEW(state) STMT_START {                       \
2657     Newx( trie->states[ state ].trans.list,                     \
2658         4, reg_trie_trans_le );                                 \
2659      TRIE_LIST_CUR( state ) = 1;                                \
2660      TRIE_LIST_LEN( state ) = 4;                                \
2661 } STMT_END
2662
2663 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2664     U16 dupe= trie->states[ state ].wordnum;                    \
2665     regnode * const noper_next = regnext( noper );              \
2666                                                                 \
2667     DEBUG_r({                                                   \
2668         /* store the word for dumping */                        \
2669         SV* tmp;                                                \
2670         if (OP(noper) != NOTHING)                               \
2671             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2672         else                                                    \
2673             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2674         av_push( trie_words, tmp );                             \
2675     });                                                         \
2676                                                                 \
2677     curword++;                                                  \
2678     trie->wordinfo[curword].prev   = 0;                         \
2679     trie->wordinfo[curword].len    = wordlen;                   \
2680     trie->wordinfo[curword].accept = state;                     \
2681                                                                 \
2682     if ( noper_next < tail ) {                                  \
2683         if (!trie->jump)                                        \
2684             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2685                                                  sizeof(U16) ); \
2686         trie->jump[curword] = (U16)(noper_next - convert);      \
2687         if (!jumper)                                            \
2688             jumper = noper_next;                                \
2689         if (!nextbranch)                                        \
2690             nextbranch= regnext(cur);                           \
2691     }                                                           \
2692                                                                 \
2693     if ( dupe ) {                                               \
2694         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2695         /* chain, so that when the bits of chain are later    */\
2696         /* linked together, the dups appear in the chain      */\
2697         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2698         trie->wordinfo[dupe].prev = curword;                    \
2699     } else {                                                    \
2700         /* we haven't inserted this word yet.                */ \
2701         trie->states[ state ].wordnum = curword;                \
2702     }                                                           \
2703 } STMT_END
2704
2705
2706 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2707      ( ( base + charid >=  ucharcount                                   \
2708          && base + charid < ubound                                      \
2709          && state == trie->trans[ base - ucharcount + charid ].check    \
2710          && trie->trans[ base - ucharcount + charid ].next )            \
2711            ? trie->trans[ base - ucharcount + charid ].next             \
2712            : ( state==1 ? special : 0 )                                 \
2713       )
2714
2715 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2716 STMT_START {                                                \
2717     TRIE_BITMAP_SET(trie, uvc);                             \
2718     /* store the folded codepoint */                        \
2719     if ( folder )                                           \
2720         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2721                                                             \
2722     if ( !UTF ) {                                           \
2723         /* store first byte of utf8 representation of */    \
2724         /* variant codepoints */                            \
2725         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2726             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2727         }                                                   \
2728     }                                                       \
2729 } STMT_END
2730 #define MADE_TRIE       1
2731 #define MADE_JUMP_TRIE  2
2732 #define MADE_EXACT_TRIE 4
2733
2734 STATIC I32
2735 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2736                   regnode *first, regnode *last, regnode *tail,
2737                   U32 word_count, U32 flags, U32 depth)
2738 {
2739     /* first pass, loop through and scan words */
2740     reg_trie_data *trie;
2741     HV *widecharmap = NULL;
2742     AV *revcharmap = newAV();
2743     regnode *cur;
2744     STRLEN len = 0;
2745     UV uvc = 0;
2746     U16 curword = 0;
2747     U32 next_alloc = 0;
2748     regnode *jumper = NULL;
2749     regnode *nextbranch = NULL;
2750     regnode *convert = NULL;
2751     U32 *prev_states; /* temp array mapping each state to previous one */
2752     /* we just use folder as a flag in utf8 */
2753     const U8 * folder = NULL;
2754
2755     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2756      * which stands for one trie structure, one hash, optionally followed
2757      * by two arrays */
2758 #ifdef DEBUGGING
2759     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2760     AV *trie_words = NULL;
2761     /* along with revcharmap, this only used during construction but both are
2762      * useful during debugging so we store them in the struct when debugging.
2763      */
2764 #else
2765     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2766     STRLEN trie_charcount=0;
2767 #endif
2768     SV *re_trie_maxbuff;
2769     DECLARE_AND_GET_RE_DEBUG_FLAGS;
2770
2771     PERL_ARGS_ASSERT_MAKE_TRIE;
2772 #ifndef DEBUGGING
2773     PERL_UNUSED_ARG(depth);
2774 #endif
2775
2776     switch (flags) {
2777         case EXACT: case EXACT_REQ8: case EXACTL: break;
2778         case EXACTFAA:
2779         case EXACTFUP:
2780         case EXACTFU:
2781         case EXACTFLU8: folder = PL_fold_latin1; break;
2782         case EXACTF:  folder = PL_fold; break;
2783         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2784     }
2785
2786     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2787     trie->refcount = 1;
2788     trie->startstate = 1;
2789     trie->wordcount = word_count;
2790     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2791     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2792     if (flags == EXACT || flags == EXACT_REQ8 || flags == EXACTL)
2793         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2794     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2795                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2796
2797     DEBUG_r({
2798         trie_words = newAV();
2799     });
2800
2801     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, GV_ADD);
2802     assert(re_trie_maxbuff);
2803     if (!SvIOK(re_trie_maxbuff)) {
2804         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2805     }
2806     DEBUG_TRIE_COMPILE_r({
2807         Perl_re_indentf( aTHX_
2808           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2809           depth+1,
2810           REG_NODE_NUM(startbranch), REG_NODE_NUM(first),
2811           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2812     });
2813
2814    /* Find the node we are going to overwrite */
2815     if ( first == startbranch && OP( last ) != BRANCH ) {
2816         /* whole branch chain */
2817         convert = first;
2818     } else {
2819         /* branch sub-chain */
2820         convert = NEXTOPER( first );
2821     }
2822
2823     /*  -- First loop and Setup --
2824
2825        We first traverse the branches and scan each word to determine if it
2826        contains widechars, and how many unique chars there are, this is
2827        important as we have to build a table with at least as many columns as we
2828        have unique chars.
2829
2830        We use an array of integers to represent the character codes 0..255
2831        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2832        the native representation of the character value as the key and IV's for
2833        the coded index.
2834
2835        *TODO* If we keep track of how many times each character is used we can
2836        remap the columns so that the table compression later on is more
2837        efficient in terms of memory by ensuring the most common value is in the
2838        middle and the least common are on the outside.  IMO this would be better
2839        than a most to least common mapping as theres a decent chance the most
2840        common letter will share a node with the least common, meaning the node
2841        will not be compressible. With a middle is most common approach the worst
2842        case is when we have the least common nodes twice.
2843
2844      */
2845
2846     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2847         regnode *noper = NEXTOPER( cur );
2848         const U8 *uc;
2849         const U8 *e;
2850         int foldlen = 0;
2851         U32 wordlen      = 0;         /* required init */
2852         STRLEN minchars = 0;
2853         STRLEN maxchars = 0;
2854         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2855                                                bitmap?*/
2856
2857         if (OP(noper) == NOTHING) {
2858             /* skip past a NOTHING at the start of an alternation
2859              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2860              *
2861              * If the next node is not something we are supposed to process
2862              * we will just ignore it due to the condition guarding the
2863              * next block.
2864              */
2865
2866             regnode *noper_next= regnext(noper);
2867             if (noper_next < tail)
2868                 noper= noper_next;
2869         }
2870
2871         if (    noper < tail
2872             && (    OP(noper) == flags
2873                 || (flags == EXACT && OP(noper) == EXACT_REQ8)
2874                 || (flags == EXACTFU && (   OP(noper) == EXACTFU_REQ8
2875                                          || OP(noper) == EXACTFUP))))
2876         {
2877             uc= (U8*)STRING(noper);
2878             e= uc + STR_LEN(noper);
2879         } else {
2880             trie->minlen= 0;
2881             continue;
2882         }
2883
2884
2885         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2886             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2887                                           regardless of encoding */
2888             if (OP( noper ) == EXACTFUP) {
2889                 /* false positives are ok, so just set this */
2890                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2891             }
2892         }
2893
2894         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2895                                            branch */
2896             TRIE_CHARCOUNT(trie)++;
2897             TRIE_READ_CHAR;
2898
2899             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2900              * is in effect.  Under /i, this character can match itself, or
2901              * anything that folds to it.  If not under /i, it can match just
2902              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2903              * all fold to k, and all are single characters.   But some folds
2904              * expand to more than one character, so for example LATIN SMALL
2905              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2906              * the string beginning at 'uc' is 'ffi', it could be matched by
2907              * three characters, or just by the one ligature character. (It
2908              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2909              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2910              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2911              * match.)  The trie needs to know the minimum and maximum number
2912              * of characters that could match so that it can use size alone to
2913              * quickly reject many match attempts.  The max is simple: it is
2914              * the number of folded characters in this branch (since a fold is
2915              * never shorter than what folds to it. */
2916
2917             maxchars++;
2918
2919             /* And the min is equal to the max if not under /i (indicated by
2920              * 'folder' being NULL), or there are no multi-character folds.  If
2921              * there is a multi-character fold, the min is incremented just
2922              * once, for the character that folds to the sequence.  Each
2923              * character in the sequence needs to be added to the list below of
2924              * characters in the trie, but we count only the first towards the
2925              * min number of characters needed.  This is done through the
2926              * variable 'foldlen', which is returned by the macros that look
2927              * for these sequences as the number of bytes the sequence
2928              * occupies.  Each time through the loop, we decrement 'foldlen' by
2929              * how many bytes the current char occupies.  Only when it reaches
2930              * 0 do we increment 'minchars' or look for another multi-character
2931              * sequence. */
2932             if (folder == NULL) {
2933                 minchars++;
2934             }
2935             else if (foldlen > 0) {
2936                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2937             }
2938             else {
2939                 minchars++;
2940
2941                 /* See if *uc is the beginning of a multi-character fold.  If
2942                  * so, we decrement the length remaining to look at, to account
2943                  * for the current character this iteration.  (We can use 'uc'
2944                  * instead of the fold returned by TRIE_READ_CHAR because the
2945                  * macro is smart enough to account for any unfolded
2946                  * characters. */
2947                 if (UTF) {
2948                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2949                         foldlen -= UTF8SKIP(uc);
2950                     }
2951                 }
2952                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2953                     foldlen--;
2954                 }
2955             }
2956
2957             /* The current character (and any potential folds) should be added
2958              * to the possible matching characters for this position in this
2959              * branch */
2960             if ( uvc < 256 ) {
2961                 if ( folder ) {
2962                     U8 folded= folder[ (U8) uvc ];
2963                     if ( !trie->charmap[ folded ] ) {
2964                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2965                         TRIE_STORE_REVCHAR( folded );
2966                     }
2967                 }
2968                 if ( !trie->charmap[ uvc ] ) {
2969                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2970                     TRIE_STORE_REVCHAR( uvc );
2971                 }
2972                 if ( set_bit ) {
2973                     /* store the codepoint in the bitmap, and its folded
2974                      * equivalent. */
2975                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2976                     set_bit = 0; /* We've done our bit :-) */
2977                 }
2978             } else {
2979
2980                 /* XXX We could come up with the list of code points that fold
2981                  * to this using PL_utf8_foldclosures, except not for
2982                  * multi-char folds, as there may be multiple combinations
2983                  * there that could work, which needs to wait until runtime to
2984                  * resolve (The comment about LIGATURE FFI above is such an
2985                  * example */
2986
2987                 SV** svpp;
2988                 if ( !widecharmap )
2989                     widecharmap = newHV();
2990
2991                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2992
2993                 if ( !svpp )
2994                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2995
2996                 if ( !SvTRUE( *svpp ) ) {
2997                     sv_setiv( *svpp, ++trie->uniquecharcount );
2998                     TRIE_STORE_REVCHAR(uvc);
2999                 }
3000             }
3001         } /* end loop through characters in this branch of the trie */
3002
3003         /* We take the min and max for this branch and combine to find the min
3004          * and max for all branches processed so far */
3005         if( cur == first ) {
3006             trie->minlen = minchars;
3007             trie->maxlen = maxchars;
3008         } else if (minchars < trie->minlen) {
3009             trie->minlen = minchars;
3010         } else if (maxchars > trie->maxlen) {
3011             trie->maxlen = maxchars;
3012         }
3013     } /* end first pass */
3014     DEBUG_TRIE_COMPILE_r(
3015         Perl_re_indentf( aTHX_
3016                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
3017                 depth+1,
3018                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
3019                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
3020                 (int)trie->minlen, (int)trie->maxlen )
3021     );
3022
3023     /*
3024         We now know what we are dealing with in terms of unique chars and
3025         string sizes so we can calculate how much memory a naive
3026         representation using a flat table  will take. If it's over a reasonable
3027         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
3028         conservative but potentially much slower representation using an array
3029         of lists.
3030
3031         At the end we convert both representations into the same compressed
3032         form that will be used in regexec.c for matching with. The latter
3033         is a form that cannot be used to construct with but has memory
3034         properties similar to the list form and access properties similar
3035         to the table form making it both suitable for fast searches and
3036         small enough that its feasable to store for the duration of a program.
3037
3038         See the comment in the code where the compressed table is produced
3039         inplace from the flat tabe representation for an explanation of how
3040         the compression works.
3041
3042     */
3043
3044
3045     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
3046     prev_states[1] = 0;
3047
3048     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
3049                                                     > SvIV(re_trie_maxbuff) )
3050     {
3051         /*
3052             Second Pass -- Array Of Lists Representation
3053
3054             Each state will be represented by a list of charid:state records
3055             (reg_trie_trans_le) the first such element holds the CUR and LEN
3056             points of the allocated array. (See defines above).
3057
3058             We build the initial structure using the lists, and then convert
3059             it into the compressed table form which allows faster lookups
3060             (but cant be modified once converted).
3061         */
3062
3063         STRLEN transcount = 1;
3064
3065         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
3066             depth+1));
3067
3068         trie->states = (reg_trie_state *)
3069             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3070                                   sizeof(reg_trie_state) );
3071         TRIE_LIST_NEW(1);
3072         next_alloc = 2;
3073
3074         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3075
3076             regnode *noper   = NEXTOPER( cur );
3077             U32 state        = 1;         /* required init */
3078             U16 charid       = 0;         /* sanity init */
3079             U32 wordlen      = 0;         /* required init */
3080
3081             if (OP(noper) == NOTHING) {
3082                 regnode *noper_next= regnext(noper);
3083                 if (noper_next < tail)
3084                     noper= noper_next;
3085                 /* we will undo this assignment if noper does not
3086                  * point at a trieable type in the else clause of
3087                  * the following statement. */
3088             }
3089
3090             if (    noper < tail
3091                 && (    OP(noper) == flags
3092                     || (flags == EXACT && OP(noper) == EXACT_REQ8)
3093                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_REQ8
3094                                              || OP(noper) == EXACTFUP))))
3095             {
3096                 const U8 *uc= (U8*)STRING(noper);
3097                 const U8 *e= uc + STR_LEN(noper);
3098
3099                 for ( ; uc < e ; uc += len ) {
3100
3101                     TRIE_READ_CHAR;
3102
3103                     if ( uvc < 256 ) {
3104                         charid = trie->charmap[ uvc ];
3105                     } else {
3106                         SV** const svpp = hv_fetch( widecharmap,
3107                                                     (char*)&uvc,
3108                                                     sizeof( UV ),
3109                                                     0);
3110                         if ( !svpp ) {
3111                             charid = 0;
3112                         } else {
3113                             charid=(U16)SvIV( *svpp );
3114                         }
3115                     }
3116                     /* charid is now 0 if we dont know the char read, or
3117                      * nonzero if we do */
3118                     if ( charid ) {
3119
3120                         U16 check;
3121                         U32 newstate = 0;
3122
3123                         charid--;
3124                         if ( !trie->states[ state ].trans.list ) {
3125                             TRIE_LIST_NEW( state );
3126                         }
3127                         for ( check = 1;
3128                               check <= TRIE_LIST_USED( state );
3129                               check++ )
3130                         {
3131                             if ( TRIE_LIST_ITEM( state, check ).forid
3132                                                                     == charid )
3133                             {
3134                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
3135                                 break;
3136                             }
3137                         }
3138                         if ( ! newstate ) {
3139                             newstate = next_alloc++;
3140                             prev_states[newstate] = state;
3141                             TRIE_LIST_PUSH( state, charid, newstate );
3142                             transcount++;
3143                         }
3144                         state = newstate;
3145                     } else {
3146                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3147                     }
3148                 }
3149             } else {
3150                 /* If we end up here it is because we skipped past a NOTHING, but did not end up
3151                  * on a trieable type. So we need to reset noper back to point at the first regop
3152                  * in the branch before we call TRIE_HANDLE_WORD()
3153                 */
3154                 noper= NEXTOPER(cur);
3155             }
3156             TRIE_HANDLE_WORD(state);
3157
3158         } /* end second pass */
3159
3160         /* next alloc is the NEXT state to be allocated */
3161         trie->statecount = next_alloc;
3162         trie->states = (reg_trie_state *)
3163             PerlMemShared_realloc( trie->states,
3164                                    next_alloc
3165                                    * sizeof(reg_trie_state) );
3166
3167         /* and now dump it out before we compress it */
3168         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
3169                                                          revcharmap, next_alloc,
3170                                                          depth+1)
3171         );
3172
3173         trie->trans = (reg_trie_trans *)
3174             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
3175         {
3176             U32 state;
3177             U32 tp = 0;
3178             U32 zp = 0;
3179
3180
3181             for( state=1 ; state < next_alloc ; state ++ ) {
3182                 U32 base=0;
3183
3184                 /*
3185                 DEBUG_TRIE_COMPILE_MORE_r(
3186                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
3187                 );
3188                 */
3189
3190                 if (trie->states[state].trans.list) {
3191                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
3192                     U16 maxid=minid;
3193                     U16 idx;
3194
3195                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3196                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
3197                         if ( forid < minid ) {
3198                             minid=forid;
3199                         } else if ( forid > maxid ) {
3200                             maxid=forid;
3201                         }
3202                     }
3203                     if ( transcount < tp + maxid - minid + 1) {
3204                         transcount *= 2;
3205                         trie->trans = (reg_trie_trans *)
3206                             PerlMemShared_realloc( trie->trans,
3207                                                      transcount
3208                                                      * sizeof(reg_trie_trans) );
3209                         Zero( trie->trans + (transcount / 2),
3210                               transcount / 2,
3211                               reg_trie_trans );
3212                     }
3213                     base = trie->uniquecharcount + tp - minid;
3214                     if ( maxid == minid ) {
3215                         U32 set = 0;
3216                         for ( ; zp < tp ; zp++ ) {
3217                             if ( ! trie->trans[ zp ].next ) {
3218                                 base = trie->uniquecharcount + zp - minid;
3219                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
3220                                                                    1).newstate;
3221                                 trie->trans[ zp ].check = state;
3222                                 set = 1;
3223                                 break;
3224                             }
3225                         }
3226                         if ( !set ) {
3227                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
3228                                                                    1).newstate;
3229                             trie->trans[ tp ].check = state;
3230                             tp++;
3231                             zp = tp;
3232                         }
3233                     } else {
3234                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3235                             const U32 tid = base
3236                                            - trie->uniquecharcount
3237                                            + TRIE_LIST_ITEM( state, idx ).forid;
3238                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
3239                                                                 idx ).newstate;
3240                             trie->trans[ tid ].check = state;
3241                         }
3242                         tp += ( maxid - minid + 1 );
3243                     }
3244                     Safefree(trie->states[ state ].trans.list);
3245                 }
3246                 /*
3247                 DEBUG_TRIE_COMPILE_MORE_r(
3248                     Perl_re_printf( aTHX_  " base: %d\n",base);
3249                 );
3250                 */
3251                 trie->states[ state ].trans.base=base;
3252             }
3253             trie->lasttrans = tp + 1;
3254         }
3255     } else {
3256         /*
3257            Second Pass -- Flat Table Representation.
3258
3259            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3260            each.  We know that we will need Charcount+1 trans at most to store
3261            the data (one row per char at worst case) So we preallocate both
3262            structures assuming worst case.
3263
3264            We then construct the trie using only the .next slots of the entry
3265            structs.
3266
3267            We use the .check field of the first entry of the node temporarily
3268            to make compression both faster and easier by keeping track of how
3269            many non zero fields are in the node.
3270
3271            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3272            transition.
3273
3274            There are two terms at use here: state as a TRIE_NODEIDX() which is
3275            a number representing the first entry of the node, and state as a
3276            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3277            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3278            if there are 2 entrys per node. eg:
3279
3280              A B       A B
3281           1. 2 4    1. 3 7
3282           2. 0 3    3. 0 5
3283           3. 0 0    5. 0 0
3284           4. 0 0    7. 0 0
3285
3286            The table is internally in the right hand, idx form. However as we
3287            also have to deal with the states array which is indexed by nodenum
3288            we have to use TRIE_NODENUM() to convert.
3289
3290         */
3291         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3292             depth+1));
3293
3294         trie->trans = (reg_trie_trans *)
3295             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3296                                   * trie->uniquecharcount + 1,
3297                                   sizeof(reg_trie_trans) );
3298         trie->states = (reg_trie_state *)
3299             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3300                                   sizeof(reg_trie_state) );
3301         next_alloc = trie->uniquecharcount + 1;
3302
3303
3304         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3305
3306             regnode *noper   = NEXTOPER( cur );
3307
3308             U32 state        = 1;         /* required init */
3309
3310             U16 charid       = 0;         /* sanity init */
3311             U32 accept_state = 0;         /* sanity init */
3312
3313             U32 wordlen      = 0;         /* required init */
3314
3315             if (OP(noper) == NOTHING) {
3316                 regnode *noper_next= regnext(noper);
3317                 if (noper_next < tail)
3318                     noper= noper_next;
3319                 /* we will undo this assignment if noper does not
3320                  * point at a trieable type in the else clause of
3321                  * the following statement. */
3322             }
3323
3324             if (    noper < tail
3325                 && (    OP(noper) == flags
3326                     || (flags == EXACT && OP(noper) == EXACT_REQ8)
3327                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_REQ8
3328                                              || OP(noper) == EXACTFUP))))
3329             {
3330                 const U8 *uc= (U8*)STRING(noper);
3331                 const U8 *e= uc + STR_LEN(noper);
3332
3333                 for ( ; uc < e ; uc += len ) {
3334
3335                     TRIE_READ_CHAR;
3336
3337                     if ( uvc < 256 ) {
3338                         charid = trie->charmap[ uvc ];
3339                     } else {
3340                         SV* const * const svpp = hv_fetch( widecharmap,
3341                                                            (char*)&uvc,
3342                                                            sizeof( UV ),
3343                                                            0);
3344                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3345                     }
3346                     if ( charid ) {
3347                         charid--;
3348                         if ( !trie->trans[ state + charid ].next ) {
3349                             trie->trans[ state + charid ].next = next_alloc;
3350                             trie->trans[ state ].check++;
3351                             prev_states[TRIE_NODENUM(next_alloc)]
3352                                     = TRIE_NODENUM(state);
3353                             next_alloc += trie->uniquecharcount;
3354                         }
3355                         state = trie->trans[ state + charid ].next;
3356                     } else {
3357                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3358                     }
3359                     /* charid is now 0 if we dont know the char read, or
3360                      * nonzero if we do */
3361                 }
3362             } else {
3363                 /* If we end up here it is because we skipped past a NOTHING, but did not end up
3364                  * on a trieable type. So we need to reset noper back to point at the first regop
3365                  * in the branch before we call TRIE_HANDLE_WORD().
3366                 */
3367                 noper= NEXTOPER(cur);
3368             }
3369             accept_state = TRIE_NODENUM( state );
3370             TRIE_HANDLE_WORD(accept_state);
3371
3372         } /* end second pass */
3373
3374         /* and now dump it out before we compress it */
3375         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3376                                                           revcharmap,
3377                                                           next_alloc, depth+1));
3378
3379         {
3380         /*
3381            * Inplace compress the table.*
3382
3383            For sparse data sets the table constructed by the trie algorithm will
3384            be mostly 0/FAIL transitions or to put it another way mostly empty.
3385            (Note that leaf nodes will not contain any transitions.)
3386
3387            This algorithm compresses the tables by eliminating most such
3388            transitions, at the cost of a modest bit of extra work during lookup:
3389
3390            - Each states[] entry contains a .base field which indicates the
3391            index in the state[] array wheres its transition data is stored.
3392
3393            - If .base is 0 there are no valid transitions from that node.
3394
3395            - If .base is nonzero then charid is added to it to find an entry in
3396            the trans array.
3397
3398            -If trans[states[state].base+charid].check!=state then the
3399            transition is taken to be a 0/Fail transition. Thus if there are fail
3400            transitions at the front of the node then the .base offset will point
3401            somewhere inside the previous nodes data (or maybe even into a node
3402            even earlier), but the .check field determines if the transition is
3403            valid.
3404
3405            XXX - wrong maybe?
3406            The following process inplace converts the table to the compressed
3407            table: We first do not compress the root node 1,and mark all its
3408            .check pointers as 1 and set its .base pointer as 1 as well. This
3409            allows us to do a DFA construction from the compressed table later,
3410            and ensures that any .base pointers we calculate later are greater
3411            than 0.
3412
3413            - We set 'pos' to indicate the first entry of the second node.
3414
3415            - We then iterate over the columns of the node, finding the first and
3416            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3417            and set the .check pointers accordingly, and advance pos
3418            appropriately and repreat for the next node. Note that when we copy
3419            the next pointers we have to convert them from the original
3420            NODEIDX form to NODENUM form as the former is not valid post
3421            compression.
3422
3423            - If a node has no transitions used we mark its base as 0 and do not
3424            advance the pos pointer.
3425
3426            - If a node only has one transition we use a second pointer into the
3427            structure to fill in allocated fail transitions from other states.
3428            This pointer is independent of the main pointer and scans forward
3429            looking for null transitions that are allocated to a state. When it
3430            finds one it writes the single transition into the "hole".  If the
3431            pointer doesnt find one the single transition is appended as normal.
3432
3433            - Once compressed we can Renew/realloc the structures to release the
3434            excess space.
3435
3436            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3437            specifically Fig 3.47 and the associated pseudocode.
3438
3439            demq
3440         */
3441         const U32 laststate = TRIE_NODENUM( next_alloc );
3442         U32 state, charid;
3443         U32 pos = 0, zp=0;
3444         trie->statecount = laststate;
3445
3446         for ( state = 1 ; state < laststate ; state++ ) {
3447             U8 flag = 0;
3448             const U32 stateidx = TRIE_NODEIDX( state );
3449             const U32 o_used = trie->trans[ stateidx ].check;
3450             U32 used = trie->trans[ stateidx ].check;
3451             trie->trans[ stateidx ].check = 0;
3452
3453             for ( charid = 0;
3454                   used && charid < trie->uniquecharcount;
3455                   charid++ )
3456             {
3457                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3458                     if ( trie->trans[ stateidx + charid ].next ) {
3459                         if (o_used == 1) {
3460                             for ( ; zp < pos ; zp++ ) {
3461                                 if ( ! trie->trans[ zp ].next ) {
3462                                     break;
3463                                 }
3464                             }
3465                             trie->states[ state ].trans.base
3466                                                     = zp
3467                                                       + trie->uniquecharcount
3468                                                       - charid ;
3469                             trie->trans[ zp ].next
3470                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3471                                                              + charid ].next );
3472                             trie->trans[ zp ].check = state;
3473                             if ( ++zp > pos ) pos = zp;
3474                             break;
3475                         }
3476                         used--;
3477                     }
3478                     if ( !flag ) {
3479                         flag = 1;
3480                         trie->states[ state ].trans.base
3481                                        = pos + trie->uniquecharcount - charid ;
3482                     }
3483                     trie->trans[ pos ].next
3484                         = SAFE_TRIE_NODENUM(
3485                                        trie->trans[ stateidx + charid ].next );
3486                     trie->trans[ pos ].check = state;
3487                     pos++;
3488                 }
3489             }
3490         }
3491         trie->lasttrans = pos + 1;
3492         trie->states = (reg_trie_state *)
3493             PerlMemShared_realloc( trie->states, laststate
3494                                    * sizeof(reg_trie_state) );
3495         DEBUG_TRIE_COMPILE_MORE_r(
3496             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3497                 depth+1,
3498                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3499                        + 1 ),
3500                 (IV)next_alloc,
3501                 (IV)pos,
3502                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3503             );
3504
3505         } /* end table compress */
3506     }
3507     DEBUG_TRIE_COMPILE_MORE_r(
3508             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3509                 depth+1,
3510                 (UV)trie->statecount,
3511                 (UV)trie->lasttrans)
3512     );
3513     /* resize the trans array to remove unused space */
3514     trie->trans = (reg_trie_trans *)
3515         PerlMemShared_realloc( trie->trans, trie->lasttrans
3516                                * sizeof(reg_trie_trans) );
3517
3518     {   /* Modify the program and insert the new TRIE node */
3519         U8 nodetype =(U8)(flags & 0xFF);
3520         char *str=NULL;
3521
3522 #ifdef DEBUGGING
3523         regnode *optimize = NULL;
3524 #ifdef RE_TRACK_PATTERN_OFFSETS
3525
3526         U32 mjd_offset = 0;
3527         U32 mjd_nodelen = 0;
3528 #endif /* RE_TRACK_PATTERN_OFFSETS */
3529 #endif /* DEBUGGING */
3530         /*
3531            This means we convert either the first branch or the first Exact,
3532            depending on whether the thing following (in 'last') is a branch
3533            or not and whther first is the startbranch (ie is it a sub part of
3534            the alternation or is it the whole thing.)
3535            Assuming its a sub part we convert the EXACT otherwise we convert
3536            the whole branch sequence, including the first.
3537          */
3538         /* Find the node we are going to overwrite */
3539         if ( first != startbranch || OP( last ) == BRANCH ) {
3540             /* branch sub-chain */
3541             NEXT_OFF( first ) = (U16)(last - first);
3542 #ifdef RE_TRACK_PATTERN_OFFSETS
3543             DEBUG_r({
3544                 mjd_offset= Node_Offset((convert));
3545                 mjd_nodelen= Node_Length((convert));
3546             });
3547 #endif
3548             /* whole branch chain */
3549         }
3550 #ifdef RE_TRACK_PATTERN_OFFSETS
3551         else {
3552             DEBUG_r({
3553                 const  regnode *nop = NEXTOPER( convert );
3554                 mjd_offset= Node_Offset((nop));
3555                 mjd_nodelen= Node_Length((nop));
3556             });
3557         }
3558         DEBUG_OPTIMISE_r(
3559             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3560                 depth+1,
3561                 (UV)mjd_offset, (UV)mjd_nodelen)
3562         );
3563 #endif
3564         /* But first we check to see if there is a common prefix we can
3565            split out as an EXACT and put in front of the TRIE node.  */
3566         trie->startstate= 1;
3567         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3568             /* we want to find the first state that has more than
3569              * one transition, if that state is not the first state
3570              * then we have a common prefix which we can remove.
3571              */
3572             U32 state;
3573             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3574                 U32 ofs = 0;
3575                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3576                                        transition, -1 means none */
3577                 U32 count = 0;
3578                 const U32 base = trie->states[ state ].trans.base;
3579
3580                 /* does this state terminate an alternation? */
3581                 if ( trie->states[state].wordnum )
3582                         count = 1;
3583
3584                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3585                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3586                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3587                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3588                     {
3589                         if ( ++count > 1 ) {
3590                             /* we have more than one transition */
3591                             SV **tmp;
3592                             U8 *ch;
3593                             /* if this is the first state there is no common prefix
3594                              * to extract, so we can exit */
3595                             if ( state == 1 ) break;
3596                             tmp = av_fetch( revcharmap, ofs, 0);
3597                             ch = (U8*)SvPV_nolen_const( *tmp );
3598
3599                             /* if we are on count 2 then we need to initialize the
3600                              * bitmap, and store the previous char if there was one
3601                              * in it*/
3602                             if ( count == 2 ) {
3603                                 /* clear the bitmap */
3604                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3605                                 DEBUG_OPTIMISE_r(
3606                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3607                                         depth+1,
3608                                         (UV)state));
3609                                 if (first_ofs >= 0) {
3610                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3611                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3612
3613                                     TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3614                                     DEBUG_OPTIMISE_r(
3615                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3616                                     );
3617                                 }
3618                             }
3619                             /* store the current firstchar in the bitmap */
3620                             TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3621                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3622                         }
3623                         first_ofs = ofs;
3624                     }
3625                 }
3626                 if ( count == 1 ) {
3627                     /* This state has only one transition, its transition is part
3628                      * of a common prefix - we need to concatenate the char it
3629                      * represents to what we have so far. */
3630                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3631                     STRLEN len;
3632                     char *ch = SvPV( *tmp, len );
3633                     DEBUG_OPTIMISE_r({
3634                         SV *sv=sv_newmortal();
3635                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3636                             depth+1,
3637                             (UV)state, (UV)first_ofs,
3638                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3639                                 PL_colors[0], PL_colors[1],
3640                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3641                                 PERL_PV_ESCAPE_FIRSTCHAR
3642                             )
3643                         );
3644                     });
3645                     if ( state==1 ) {
3646                         OP( convert ) = nodetype;
3647                         str=STRING(convert);
3648                         setSTR_LEN(convert, 0);
3649                     }
3650                     assert( ( STR_LEN(convert) + len ) < 256 );
3651                     setSTR_LEN(convert, (U8)(STR_LEN(convert) + len));
3652                     while (len--)
3653                         *str++ = *ch++;
3654                 } else {
3655 #ifdef DEBUGGING
3656                     if (state>1)
3657                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3658 #endif
3659                     break;
3660                 }
3661             }
3662             trie->prefixlen = (state-1);
3663             if (str) {
3664                 regnode *n = convert+NODE_SZ_STR(convert);
3665                 assert( NODE_SZ_STR(convert) <= U16_MAX );
3666                 NEXT_OFF(convert) = (U16)(NODE_SZ_STR(convert));
3667                 trie->startstate = state;
3668                 trie->minlen -= (state - 1);
3669                 trie->maxlen -= (state - 1);
3670 #ifdef DEBUGGING
3671                /* At least the UNICOS C compiler choked on this
3672                 * being argument to DEBUG_r(), so let's just have
3673                 * it right here. */
3674                if (
3675 #ifdef PERL_EXT_RE_BUILD
3676                    1
3677 #else
3678                    DEBUG_r_TEST
3679 #endif
3680                    ) {
3681                    regnode *fix = convert;
3682                    U32 word = trie->wordcount;
3683 #ifdef RE_TRACK_PATTERN_OFFSETS
3684                    mjd_nodelen++;
3685 #endif
3686                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3687                    while( ++fix < n ) {
3688                        Set_Node_Offset_Length(fix, 0, 0);
3689                    }
3690                    while (word--) {
3691                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3692                        if (tmp) {
3693                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3694                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3695                            else
3696                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3697                        }
3698                    }
3699                }
3700 #endif
3701                 if (trie->maxlen) {
3702                     convert = n;
3703                 } else {
3704                     NEXT_OFF(convert) = (U16)(tail - convert);
3705                     DEBUG_r(optimize= n);
3706                 }
3707             }
3708         }
3709         if (!jumper)
3710             jumper = last;
3711         if ( trie->maxlen ) {
3712             NEXT_OFF( convert ) = (U16)(tail - convert);
3713             ARG_SET( convert, data_slot );
3714             /* Store the offset to the first unabsorbed branch in
3715                jump[0], which is otherwise unused by the jump logic.
3716                We use this when dumping a trie and during optimisation. */
3717             if (trie->jump)
3718                 trie->jump[0] = (U16)(nextbranch - convert);
3719
3720             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3721              *   and there is a bitmap
3722              *   and the first "jump target" node we found leaves enough room
3723              * then convert the TRIE node into a TRIEC node, with the bitmap
3724              * embedded inline in the opcode - this is hypothetically faster.
3725              */
3726             if ( !trie->states[trie->startstate].wordnum
3727                  && trie->bitmap
3728                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3729             {
3730                 OP( convert ) = TRIEC;
3731                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3732                 PerlMemShared_free(trie->bitmap);
3733                 trie->bitmap= NULL;
3734             } else
3735                 OP( convert ) = TRIE;
3736
3737             /* store the type in the flags */
3738             convert->flags = nodetype;
3739             DEBUG_r({
3740             optimize = convert
3741                       + NODE_STEP_REGNODE
3742                       + regarglen[ OP( convert ) ];
3743             });
3744             /* XXX We really should free up the resource in trie now,
3745                    as we won't use them - (which resources?) dmq */
3746         }
3747         /* needed for dumping*/
3748         DEBUG_r(if (optimize) {
3749             regnode *opt = convert;
3750
3751             while ( ++opt < optimize) {
3752                 Set_Node_Offset_Length(opt, 0, 0);
3753             }
3754             /*
3755                 Try to clean up some of the debris left after the
3756                 optimisation.
3757              */
3758             while( optimize < jumper ) {
3759                 Track_Code( mjd_nodelen += Node_Length((optimize)); );
3760                 OP( optimize ) = OPTIMIZED;
3761                 Set_Node_Offset_Length(optimize, 0, 0);
3762                 optimize++;
3763             }
3764             Set_Node_Offset_Length(convert, mjd_offset, mjd_nodelen);
3765         });
3766     } /* end node insert */
3767
3768     /*  Finish populating the prev field of the wordinfo array.  Walk back
3769      *  from each accept state until we find another accept state, and if
3770      *  so, point the first word's .prev field at the second word. If the
3771      *  second already has a .prev field set, stop now. This will be the
3772      *  case either if we've already processed that word's accept state,
3773      *  or that state had multiple words, and the overspill words were
3774      *  already linked up earlier.
3775      */
3776     {
3777         U16 word;
3778         U32 state;
3779         U16 prev;
3780
3781         for (word=1; word <= trie->wordcount; word++) {
3782             prev = 0;
3783             if (trie->wordinfo[word].prev)
3784                 continue;
3785             state = trie->wordinfo[word].accept;
3786             while (state) {
3787                 state = prev_states[state];
3788                 if (!state)
3789                     break;
3790                 prev = trie->states[state].wordnum;
3791                 if (prev)
3792                     break;
3793             }
3794             trie->wordinfo[word].prev = prev;
3795         }
3796         Safefree(prev_states);
3797     }
3798
3799
3800     /* and now dump out the compressed format */
3801     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3802
3803     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3804 #ifdef DEBUGGING
3805     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3806     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3807 #else
3808     SvREFCNT_dec_NN(revcharmap);
3809 #endif
3810     return trie->jump
3811            ? MADE_JUMP_TRIE
3812            : trie->startstate>1
3813              ? MADE_EXACT_TRIE
3814              : MADE_TRIE;
3815 }
3816
3817 STATIC regnode *
3818 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3819 {
3820 /* The Trie is constructed and compressed now so we can build a fail array if
3821  * it's needed
3822
3823    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3824    3.32 in the
3825    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3826    Ullman 1985/88
3827    ISBN 0-201-10088-6
3828
3829    We find the fail state for each state in the trie, this state is the longest
3830    proper suffix of the current state's 'word' that is also a proper prefix of
3831    another word in our trie. State 1 represents the word '' and is thus the
3832    default fail state. This allows the DFA not to have to restart after its
3833    tried and failed a word at a given point, it simply continues as though it
3834    had been matching the other word in the first place.
3835    Consider
3836       'abcdgu'=~/abcdefg|cdgu/
3837    When we get to 'd' we are still matching the first word, we would encounter
3838    'g' which would fail, which would bring us to the state representing 'd' in
3839    the second word where we would try 'g' and succeed, proceeding to match
3840    'cdgu'.
3841  */
3842  /* add a fail transition */
3843     const U32 trie_offset = ARG(source);
3844     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3845     U32 *q;
3846     const U32 ucharcount = trie->uniquecharcount;
3847     const U32 numstates = trie->statecount;
3848     const U32 ubound = trie->lasttrans + ucharcount;
3849     U32 q_read = 0;
3850     U32 q_write = 0;
3851     U32 charid;
3852     U32 base = trie->states[ 1 ].trans.base;
3853     U32 *fail;
3854     reg_ac_data *aho;
3855     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3856     regnode *stclass;
3857     DECLARE_AND_GET_RE_DEBUG_FLAGS;
3858
3859     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3860     PERL_UNUSED_CONTEXT;
3861 #ifndef DEBUGGING
3862     PERL_UNUSED_ARG(depth);
3863 #endif
3864
3865     if ( OP(source) == TRIE ) {
3866         struct regnode_1 *op = (struct regnode_1 *)
3867             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3868         StructCopy(source, op, struct regnode_1);
3869         stclass = (regnode *)op;
3870     } else {
3871         struct regnode_charclass *op = (struct regnode_charclass *)
3872             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3873         StructCopy(source, op, struct regnode_charclass);
3874         stclass = (regnode *)op;
3875     }
3876     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3877
3878     ARG_SET( stclass, data_slot );
3879     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3880     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3881     aho->trie=trie_offset;
3882     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3883     Copy( trie->states, aho->states, numstates, reg_trie_state );
3884     Newx( q, numstates, U32);
3885     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3886     aho->refcount = 1;
3887     fail = aho->fail;
3888     /* initialize fail[0..1] to be 1 so that we always have
3889        a valid final fail state */
3890     fail[ 0 ] = fail[ 1 ] = 1;
3891
3892     for ( charid = 0; charid < ucharcount ; charid++ ) {
3893         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3894         if ( newstate ) {
3895             q[ q_write ] = newstate;
3896             /* set to point at the root */
3897             fail[ q[ q_write++ ] ]=1;
3898         }
3899     }
3900     while ( q_read < q_write) {
3901         const U32 cur = q[ q_read++ % numstates ];
3902         base = trie->states[ cur ].trans.base;
3903
3904         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3905             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3906             if (ch_state) {
3907                 U32 fail_state = cur;
3908                 U32 fail_base;
3909                 do {
3910                     fail_state = fail[ fail_state ];
3911                     fail_base = aho->states[ fail_state ].trans.base;
3912                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3913
3914                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3915                 fail[ ch_state ] = fail_state;
3916                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3917                 {
3918                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3919                 }
3920                 q[ q_write++ % numstates] = ch_state;
3921             }
3922         }
3923     }
3924     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3925        when we fail in state 1, this allows us to use the
3926        charclass scan to find a valid start char. This is based on the principle
3927        that theres a good chance the string being searched contains lots of stuff
3928        that cant be a start char.
3929      */
3930     fail[ 0 ] = fail[ 1 ] = 0;
3931     DEBUG_TRIE_COMPILE_r({
3932         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3933                       depth, (UV)numstates
3934         );
3935         for( q_read=1; q_read<numstates; q_read++ ) {
3936             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3937         }
3938         Perl_re_printf( aTHX_  "\n");
3939     });
3940     Safefree(q);
3941     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3942     return stclass;
3943 }
3944
3945
3946 /* The below joins as many adjacent EXACTish nodes as possible into a single
3947  * one.  The regop may be changed if the node(s) contain certain sequences that
3948  * require special handling.  The joining is only done if:
3949  * 1) there is room in the current conglomerated node to entirely contain the
3950  *    next one.
3951  * 2) they are compatible node types
3952  *
3953  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3954  * these get optimized out
3955  *
3956  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3957  * as possible, even if that means splitting an existing node so that its first
3958  * part is moved to the preceeding node.  This would maximise the efficiency of
3959  * memEQ during matching.
3960  *
3961  * If a node is to match under /i (folded), the number of characters it matches
3962  * can be different than its character length if it contains a multi-character
3963  * fold.  *min_subtract is set to the total delta number of characters of the
3964  * input nodes.
3965  *
3966  * And *unfolded_multi_char is set to indicate whether or not the node contains
3967  * an unfolded multi-char fold.  This happens when it won't be known until
3968  * runtime whether the fold is valid or not; namely
3969  *  1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
3970  *      target string being matched against turns out to be UTF-8 is that fold
3971  *      valid; or
3972  *  2) for EXACTFL nodes whose folding rules depend on the locale in force at
3973  *      runtime.
3974  * (Multi-char folds whose components are all above the Latin1 range are not
3975  * run-time locale dependent, and have already been folded by the time this
3976  * function is called.)
3977  *
3978  * This is as good a place as any to discuss the design of handling these
3979  * multi-character fold sequences.  It's been wrong in Perl for a very long
3980  * time.  There are three code points in Unicode whose multi-character folds
3981  * were long ago discovered to mess things up.  The previous designs for
3982  * dealing with these involved assigning a special node for them.  This
3983  * approach doesn't always work, as evidenced by this example:
3984  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3985  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3986  * would match just the \xDF, it won't be able to handle the case where a
3987  * successful match would have to cross the node's boundary.  The new approach
3988  * that hopefully generally solves the problem generates an EXACTFUP node
3989  * that is "sss" in this case.
3990  *
3991  * It turns out that there are problems with all multi-character folds, and not
3992  * just these three.  Now the code is general, for all such cases.  The
3993  * approach taken is:
3994  * 1)   This routine examines each EXACTFish node that could contain multi-
3995  *      character folded sequences.  Since a single character can fold into
3996  *      such a sequence, the minimum match length for this node is less than
3997  *      the number of characters in the node.  This routine returns in
3998  *      *min_subtract how many characters to subtract from the actual
3999  *      length of the string to get a real minimum match length; it is 0 if
4000  *      there are no multi-char foldeds.  This delta is used by the caller to
4001  *      adjust the min length of the match, and the delta between min and max,
4002  *      so that the optimizer doesn't reject these possibilities based on size
4003  *      constraints.
4004  *
4005  * 2)   For the sequence involving the LATIN SMALL LETTER SHARP S (U+00DF)
4006  *      under /u, we fold it to 'ss' in regatom(), and in this routine, after
4007  *      joining, we scan for occurrences of the sequence 'ss' in non-UTF-8
4008  *      EXACTFU nodes.  The node type of such nodes is then changed to
4009  *      EXACTFUP, indicating it is problematic, and needs careful handling.
4010  *      (The procedures in step 1) above are sufficient to handle this case in
4011  *      UTF-8 encoded nodes.)  The reason this is problematic is that this is
4012  *      the only case where there is a possible fold length change in non-UTF-8
4013  *      patterns.  By reserving a special node type for problematic cases, the
4014  *      far more common regular EXACTFU nodes can be processed faster.
4015  *      regexec.c takes advantage of this.
4016  *
4017  *      EXACTFUP has been created as a grab-bag for (hopefully uncommon)
4018  *      problematic cases.   These all only occur when the pattern is not
4019  *      UTF-8.  In addition to the 'ss' sequence where there is a possible fold
4020  *      length change, it handles the situation where the string cannot be
4021  *      entirely folded.  The strings in an EXACTFish node are folded as much
4022  *      as possible during compilation in regcomp.c.  This saves effort in
4023  *      regex matching.  By using an EXACTFUP node when it is not possible to
4024  *      fully fold at compile time, regexec.c can know that everything in an
4025  *      EXACTFU node is folded, so folding can be skipped at runtime.  The only
4026  *      case where folding in EXACTFU nodes can't be done at compile time is
4027  *      the presumably uncommon MICRO SIGN, when the pattern isn't UTF-8.  This
4028  *      is because its fold requires UTF-8 to represent.  Thus EXACTFUP nodes
4029  *      handle two very different cases.  Alternatively, there could have been
4030  *      a node type where there are length changes, one for unfolded, and one
4031  *      for both.  If yet another special case needed to be created, the number
4032  *      of required node types would have to go to 7.  khw figures that even
4033  *      though there are plenty of node types to spare, that the maintenance
4034  *      cost wasn't worth the small speedup of doing it that way, especially
4035  *      since he thinks the MICRO SIGN is rarely encountered in practice.
4036  *
4037  *      There are other cases where folding isn't done at compile time, but
4038  *      none of them are under /u, and hence not for EXACTFU nodes.  The folds
4039  *      in EXACTFL nodes aren't known until runtime, and vary as the locale
4040  *      changes.  Some folds in EXACTF depend on if the runtime target string
4041  *      is UTF-8 or not.  (regatom() will create an EXACTFU node even under /di
4042  *      when no fold in it depends on the UTF-8ness of the target string.)
4043  *
4044  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
4045  *      validity of the fold won't be known until runtime, and so must remain
4046  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFAA
4047  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
4048  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
4049  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
4050  *      The reason this is a problem is that the optimizer part of regexec.c
4051  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
4052  *      that a character in the pattern corresponds to at most a single
4053  *      character in the target string.  (And I do mean character, and not byte
4054  *      here, unlike other parts of the documentation that have never been
4055  *      updated to account for multibyte Unicode.)  Sharp s in EXACTF and
4056  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
4057  *      nodes it can match "\x{17F}\x{17F}".  These, along with other ones in
4058  *      EXACTFL nodes, violate the assumption, and they are the only instances
4059  *      where it is violated.  I'm reluctant to try to change the assumption,
4060  *      as the code involved is impenetrable to me (khw), so instead the code
4061  *      here punts.  This routine examines EXACTFL nodes, and (when the pattern
4062  *      isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
4063  *      boolean indicating whether or not the node contains such a fold.  When
4064  *      it is true, the caller sets a flag that later causes the optimizer in
4065  *      this file to not set values for the floating and fixed string lengths,
4066  *      and thus avoids the optimizer code in regexec.c that makes the invalid
4067  *      assumption.  Thus, there is no optimization based on string lengths for
4068  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
4069  *      EXACTF and EXACTFAA nodes that contain the sharp s.  (The reason the
4070  *      assumption is wrong only in these cases is that all other non-UTF-8
4071  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
4072  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
4073  *      EXACTF nodes because we don't know at compile time if it actually
4074  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
4075  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
4076  *      always matches; and EXACTFAA where it never does.  In an EXACTFAA node
4077  *      in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
4078  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
4079  *      string would require the pattern to be forced into UTF-8, the overhead
4080  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
4081  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
4082  *      locale.)
4083  *
4084  *      Similarly, the code that generates tries doesn't currently handle
4085  *      not-already-folded multi-char folds, and it looks like a pain to change
4086  *      that.  Therefore, trie generation of EXACTFAA nodes with the sharp s
4087  *      doesn't work.  Instead, such an EXACTFAA is turned into a new regnode,
4088  *      EXACTFAA_NO_TRIE, which the trie code knows not to handle.  Most people
4089  *      using /iaa matching will be doing so almost entirely with ASCII
4090  *      strings, so this should rarely be encountered in practice */
4091
4092 STATIC U32
4093 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
4094                    UV *min_subtract, bool *unfolded_multi_char,
4095                    U32 flags, regnode *val, U32 depth)
4096 {
4097     /* Merge several consecutive EXACTish nodes into one. */
4098
4099     regnode *n = regnext(scan);
4100     U32 stringok = 1;
4101     regnode *next = scan + NODE_SZ_STR(scan);
4102     U32 merged = 0;
4103     U32 stopnow = 0;
4104 #ifdef DEBUGGING
4105     regnode *stop = scan;
4106     DECLARE_AND_GET_RE_DEBUG_FLAGS;
4107 #else
4108     PERL_UNUSED_ARG(depth);
4109 #endif
4110
4111     PERL_ARGS_ASSERT_JOIN_EXACT;
4112 #ifndef EXPERIMENTAL_INPLACESCAN
4113     PERL_UNUSED_ARG(flags);
4114     PERL_UNUSED_ARG(val);
4115 #endif
4116     DEBUG_PEEP("join", scan, depth, 0);
4117
4118     assert(PL_regkind[OP(scan)] == EXACT);
4119
4120     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
4121      * EXACT ones that are mergeable to the current one. */
4122     while (    n
4123            && (    PL_regkind[OP(n)] == NOTHING
4124                || (stringok && PL_regkind[OP(n)] == EXACT))
4125            && NEXT_OFF(n)
4126            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
4127     {
4128
4129         if (OP(n) == TAIL || n > next)
4130             stringok = 0;
4131         if (PL_regkind[OP(n)] == NOTHING) {
4132             DEBUG_PEEP("skip:", n, depth, 0);
4133             NEXT_OFF(scan) += NEXT_OFF(n);
4134             next = n + NODE_STEP_REGNODE;
4135 #ifdef DEBUGGING
4136             if (stringok)
4137                 stop = n;
4138 #endif
4139             n = regnext(n);
4140         }
4141         else if (stringok) {
4142             const unsigned int oldl = STR_LEN(scan);
4143             regnode * const nnext = regnext(n);
4144
4145             /* XXX I (khw) kind of doubt that this works on platforms (should
4146              * Perl ever run on one) where U8_MAX is above 255 because of lots
4147              * of other assumptions */
4148             /* Don't join if the sum can't fit into a single node */
4149             if (oldl + STR_LEN(n) > U8_MAX)
4150                 break;
4151
4152             /* Joining something that requires UTF-8 with something that
4153              * doesn't, means the result requires UTF-8. */
4154             if (OP(scan) == EXACT && (OP(n) == EXACT_REQ8)) {
4155                 OP(scan) = EXACT_REQ8;
4156             }
4157             else if (OP(scan) == EXACT_REQ8 && (OP(n) == EXACT)) {
4158                 ;   /* join is compatible, no need to change OP */
4159             }
4160             else if ((OP(scan) == EXACTFU) && (OP(n) == EXACTFU_REQ8)) {
4161                 OP(scan) = EXACTFU_REQ8;
4162             }
4163             else if ((OP(scan) == EXACTFU_REQ8) && (OP(n) == EXACTFU)) {
4164                 ;   /* join is compatible, no need to change OP */
4165             }
4166             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU) {
4167                 ;   /* join is compatible, no need to change OP */
4168             }
4169             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU_S_EDGE) {
4170
4171                  /* Under /di, temporary EXACTFU_S_EDGE nodes are generated,
4172                   * which can join with EXACTFU ones.  We check for this case
4173                   * here.  These need to be resolved to either EXACTFU or
4174                   * EXACTF at joining time.  They have nothing in them that
4175                   * would forbid them from being the more desirable EXACTFU
4176                   * nodes except that they begin and/or end with a single [Ss].
4177                   * The reason this is problematic is because they could be
4178                   * joined in this loop with an adjacent node that ends and/or
4179                   * begins with [Ss] which would then form the sequence 'ss',
4180                   * which matches differently under /di than /ui, in which case
4181                   * EXACTFU can't be used.  If the 'ss' sequence doesn't get
4182                   * formed, the nodes get absorbed into any adjacent EXACTFU
4183                   * node.  And if the only adjacent node is EXACTF, they get
4184                   * absorbed into that, under the theory that a longer node is
4185                   * better than two shorter ones, even if one is EXACTFU.  Note
4186                   * that EXACTFU_REQ8 is generated only for UTF-8 patterns,
4187                   * and the EXACTFU_S_EDGE ones only for non-UTF-8.  */
4188
4189                 if (STRING(n)[STR_LEN(n)-1] == 's') {
4190
4191                     /* Here the joined node would end with 's'.  If the node
4192                      * following the combination is an EXACTF one, it's better to
4193                      * join this trailing edge 's' node with that one, leaving the
4194                      * current one in 'scan' be the more desirable EXACTFU */
4195                     if (OP(nnext) == EXACTF) {
4196                         break;
4197                     }
4198
4199                     OP(scan) = EXACTFU_S_EDGE;
4200
4201                 }   /* Otherwise, the beginning 's' of the 2nd node just
4202                        becomes an interior 's' in 'scan' */
4203             }
4204             else if (OP(scan) == EXACTF && OP(n) == EXACTF) {
4205                 ;   /* join is compatible, no need to change OP */
4206             }
4207             else if (OP(scan) == EXACTF && OP(n) == EXACTFU_S_EDGE) {
4208
4209                 /* EXACTF nodes are compatible for joining with EXACTFU_S_EDGE
4210                  * nodes.  But the latter nodes can be also joined with EXACTFU
4211                  * ones, and that is a better outcome, so if the node following
4212                  * 'n' is EXACTFU, quit now so that those two can be joined
4213                  * later */
4214                 if (OP(nnext) == EXACTFU) {
4215                     break;
4216                 }
4217
4218                 /* The join is compatible, and the combined node will be
4219                  * EXACTF.  (These don't care if they begin or end with 's' */
4220             }
4221             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU_S_EDGE) {
4222                 if (   STRING(scan)[STR_LEN(scan)-1] == 's'
4223                     && STRING(n)[0] == 's')
4224                 {
4225                     /* When combined, we have the sequence 'ss', which means we
4226                      * have to remain /di */
4227                     OP(scan) = EXACTF;
4228                 }
4229             }
4230             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU) {
4231                 if (STRING(n)[0] == 's') {
4232                     ;   /* Here the join is compatible and the combined node
4233                            starts with 's', no need to change OP */
4234                 }
4235                 else {  /* Now the trailing 's' is in the interior */
4236                     OP(scan) = EXACTFU;
4237                 }
4238             }
4239             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTF) {
4240
4241                 /* The join is compatible, and the combined node will be
4242                  * EXACTF.  (These don't care if they begin or end with 's' */
4243                 OP(scan) = EXACTF;
4244             }
4245             else if (OP(scan) != OP(n)) {
4246
4247                 /* The only other compatible joinings are the same node type */
4248                 break;
4249             }
4250
4251             DEBUG_PEEP("merg", n, depth, 0);
4252             merged++;
4253
4254             NEXT_OFF(scan) += NEXT_OFF(n);
4255             assert( ( STR_LEN(scan) + STR_LEN(n) ) < 256 );
4256             setSTR_LEN(scan, (U8)(STR_LEN(scan) + STR_LEN(n)));
4257             next = n + NODE_SZ_STR(n);
4258             /* Now we can overwrite *n : */
4259             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
4260 #ifdef DEBUGGING
4261             stop = next - 1;
4262 #endif
4263             n = nnext;
4264             if (stopnow) break;
4265         }
4266
4267 #ifdef EXPERIMENTAL_INPLACESCAN
4268         if (flags && !NEXT_OFF(n)) {
4269             DEBUG_PEEP("atch", val, depth, 0);
4270             if (reg_off_by_arg[OP(n)]) {
4271                 ARG_SET(n, val - n);
4272             }
4273             else {
4274                 NEXT_OFF(n) = val - n;
4275             }
4276             stopnow = 1;
4277         }
4278 #endif
4279     }
4280
4281     /* This temporary node can now be turned into EXACTFU, and must, as
4282      * regexec.c doesn't handle it */
4283     if (OP(scan) == EXACTFU_S_EDGE) {
4284         OP(scan) = EXACTFU;
4285     }
4286
4287     *min_subtract = 0;
4288     *unfolded_multi_char = FALSE;
4289
4290     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
4291      * can now analyze for sequences of problematic code points.  (Prior to
4292      * this final joining, sequences could have been split over boundaries, and
4293      * hence missed).  The sequences only happen in folding, hence for any
4294      * non-EXACT EXACTish node */
4295     if (OP(scan) != EXACT && OP(scan) != EXACT_REQ8 && OP(scan) != EXACTL) {
4296         U8* s0 = (U8*) STRING(scan);
4297         U8* s = s0;
4298         U8* s_end = s0 + STR_LEN(scan);
4299
4300         int total_count_delta = 0;  /* Total delta number of characters that
4301                                        multi-char folds expand to */
4302
4303         /* One pass is made over the node's string looking for all the
4304          * possibilities.  To avoid some tests in the loop, there are two main
4305          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
4306          * non-UTF-8 */
4307         if (UTF) {
4308             U8* folded = NULL;
4309
4310             if (OP(scan) == EXACTFL) {
4311                 U8 *d;
4312
4313                 /* An EXACTFL node would already have been changed to another
4314                  * node type unless there is at least one character in it that
4315                  * is problematic; likely a character whose fold definition
4316                  * won't be known until runtime, and so has yet to be folded.
4317                  * For all but the UTF-8 locale, folds are 1-1 in length, but
4318                  * to handle the UTF-8 case, we need to create a temporary
4319                  * folded copy using UTF-8 locale rules in order to analyze it.
4320                  * This is because our macros that look to see if a sequence is
4321                  * a multi-char fold assume everything is folded (otherwise the
4322                  * tests in those macros would be too complicated and slow).
4323                  * Note that here, the non-problematic folds will have already
4324                  * been done, so we can just copy such characters.  We actually
4325                  * don't completely fold the EXACTFL string.  We skip the
4326                  * unfolded multi-char folds, as that would just create work
4327                  * below to figure out the size they already are */
4328
4329                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
4330                 d = folded;
4331                 while (s < s_end) {
4332                     STRLEN s_len = UTF8SKIP(s);
4333                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
4334                         Copy(s, d, s_len, U8);
4335                         d += s_len;
4336                     }
4337                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
4338                         *unfolded_multi_char = TRUE;
4339                         Copy(s, d, s_len, U8);
4340                         d += s_len;
4341                     }
4342                     else if (isASCII(*s)) {
4343                         *(d++) = toFOLD(*s);
4344                     }
4345                     else {
4346                         STRLEN len;
4347                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
4348                         d += len;
4349                     }
4350                     s += s_len;
4351                 }
4352
4353                 /* Point the remainder of the routine to look at our temporary
4354                  * folded copy */
4355                 s = folded;
4356                 s_end = d;
4357             } /* End of creating folded copy of EXACTFL string */
4358
4359             /* Examine the string for a multi-character fold sequence.  UTF-8
4360              * patterns have all characters pre-folded by the time this code is
4361              * executed */
4362             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
4363                                      length sequence we are looking for is 2 */
4364             {
4365                 int count = 0;  /* How many characters in a multi-char fold */
4366                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
4367                 if (! len) {    /* Not a multi-char fold: get next char */
4368                     s += UTF8SKIP(s);
4369                     continue;
4370                 }
4371
4372                 { /* Here is a generic multi-char fold. */
4373                     U8* multi_end  = s + len;
4374
4375                     /* Count how many characters are in it.  In the case of
4376                      * /aa, no folds which contain ASCII code points are
4377                      * allowed, so check for those, and skip if found. */
4378                     if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
4379                         count = utf8_length(s, multi_end);
4380                         s = multi_end;
4381                     }
4382                     else {
4383                         while (s < multi_end) {
4384                             if (isASCII(*s)) {
4385                                 s++;
4386                                 goto next_iteration;
4387                             }
4388                             else {
4389                                 s += UTF8SKIP(s);
4390                             }
4391                             count++;
4392                         }
4393                     }
4394                 }
4395
4396                 /* The delta is how long the sequence is minus 1 (1 is how long
4397                  * the character that folds to the sequence is) */
4398                 total_count_delta += count - 1;
4399               next_iteration: ;
4400             }
4401
4402             /* We created a temporary folded copy of the string in EXACTFL
4403              * nodes.  Therefore we need to be sure it doesn't go below zero,
4404              * as the real string could be shorter */
4405             if (OP(scan) == EXACTFL) {
4406                 int total_chars = utf8_length((U8*) STRING(scan),
4407                                            (U8*) STRING(scan) + STR_LEN(scan));
4408                 if (total_count_delta > total_chars) {
4409                     total_count_delta = total_chars;
4410                 }
4411             }
4412
4413             *min_subtract += total_count_delta;
4414             Safefree(folded);
4415         }
4416         else if (OP(scan) == EXACTFAA) {
4417
4418             /* Non-UTF-8 pattern, EXACTFAA node.  There can't be a multi-char
4419              * fold to the ASCII range (and there are no existing ones in the
4420              * upper latin1 range).  But, as outlined in the comments preceding
4421              * this function, we need to flag any occurrences of the sharp s.
4422              * This character forbids trie formation (because of added
4423              * complexity) */
4424 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4425    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4426                                       || UNICODE_DOT_DOT_VERSION > 0)
4427             while (s < s_end) {
4428                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4429                     OP(scan) = EXACTFAA_NO_TRIE;
4430                     *unfolded_multi_char = TRUE;
4431                     break;
4432                 }
4433                 s++;
4434             }
4435         }
4436         else if (OP(scan) != EXACTFAA_NO_TRIE) {
4437
4438             /* Non-UTF-8 pattern, not EXACTFAA node.  Look for the multi-char
4439              * folds that are all Latin1.  As explained in the comments
4440              * preceding this function, we look also for the sharp s in EXACTF
4441              * and EXACTFL nodes; it can be in the final position.  Otherwise
4442              * we can stop looking 1 byte earlier because have to find at least
4443              * two characters for a multi-fold */
4444             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4445                               ? s_end
4446                               : s_end -1;
4447
4448             while (s < upper) {
4449                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4450                 if (! len) {    /* Not a multi-char fold. */
4451                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4452                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4453                     {
4454                         *unfolded_multi_char = TRUE;
4455                     }
4456                     s++;
4457                     continue;
4458                 }
4459
4460                 if (len == 2
4461                     && isALPHA_FOLD_EQ(*s, 's')
4462                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4463                 {
4464
4465                     /* EXACTF nodes need to know that the minimum length
4466                      * changed so that a sharp s in the string can match this
4467                      * ss in the pattern, but they remain EXACTF nodes, as they
4468                      * won't match this unless the target string is in UTF-8,
4469                      * which we don't know until runtime.  EXACTFL nodes can't
4470                      * transform into EXACTFU nodes */
4471                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4472                         OP(scan) = EXACTFUP;
4473                     }
4474                 }
4475
4476                 *min_subtract += len - 1;
4477                 s += len;
4478             }
4479 #endif
4480         }
4481     }
4482
4483 #ifdef DEBUGGING
4484     /* Allow dumping but overwriting the collection of skipped
4485      * ops and/or strings with fake optimized ops */
4486     n = scan + NODE_SZ_STR(scan);
4487     while (n <= stop) {
4488         OP(n) = OPTIMIZED;
4489         FLAGS(n) = 0;
4490         NEXT_OFF(n) = 0;
4491         n++;
4492     }
4493 #endif
4494     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4495     return stopnow;
4496 }
4497
4498 /* REx optimizer.  Converts nodes into quicker variants "in place".
4499    Finds fixed substrings.  */
4500
4501 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4502    to the position after last scanned or to NULL. */
4503
4504 #define INIT_AND_WITHP \
4505     assert(!and_withp); \
4506     Newx(and_withp, 1, regnode_ssc); \
4507     SAVEFREEPV(and_withp)
4508
4509
4510 static void
4511 S_unwind_scan_frames(pTHX_ const void *p)
4512 {
4513     scan_frame *f= (scan_frame *)p;
4514     do {
4515         scan_frame *n= f->next_frame;
4516         Safefree(f);
4517         f= n;
4518     } while (f);
4519 }
4520
4521 /* Follow the next-chain of the current node and optimize away
4522    all the NOTHINGs from it.
4523  */
4524 STATIC void
4525 S_rck_elide_nothing(pTHX_ regnode *node)
4526 {
4527     PERL_ARGS_ASSERT_RCK_ELIDE_NOTHING;
4528
4529     if (OP(node) != CURLYX) {
4530         const int max = (reg_off_by_arg[OP(node)]
4531                         ? I32_MAX
4532                           /* I32 may be smaller than U16 on CRAYs! */
4533                         : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4534         int off = (reg_off_by_arg[OP(node)] ? ARG(node) : NEXT_OFF(node));
4535         int noff;
4536         regnode *n = node;
4537
4538         /* Skip NOTHING and LONGJMP. */
4539         while (
4540             (n = regnext(n))
4541             && (
4542                 (PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4543                 || ((OP(n) == LONGJMP) && (noff = ARG(n)))
4544             )
4545             && off + noff < max
4546         ) {
4547             off += noff;
4548         }
4549         if (reg_off_by_arg[OP(node)])
4550             ARG(node) = off;
4551         else
4552             NEXT_OFF(node) = off;
4553     }
4554     return;
4555 }
4556
4557 /* the return from this sub is the minimum length that could possibly match */
4558 STATIC SSize_t
4559 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4560                         SSize_t *minlenp, SSize_t *deltap,
4561                         regnode *last,
4562                         scan_data_t *data,
4563                         I32 stopparen,
4564                         U32 recursed_depth,
4565                         regnode_ssc *and_withp,
4566                         U32 flags, U32 depth, bool was_mutate_ok)
4567                         /* scanp: Start here (read-write). */
4568                         /* deltap: Write maxlen-minlen here. */
4569                         /* last: Stop before this one. */
4570                         /* data: string data about the pattern */
4571                         /* stopparen: treat close N as END */
4572                         /* recursed: which subroutines have we recursed into */
4573                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4574 {
4575     SSize_t final_minlen;
4576     /* There must be at least this number of characters to match */
4577     SSize_t min = 0;
4578     I32 pars = 0, code;
4579     regnode *scan = *scanp, *next;
4580     SSize_t delta = 0;
4581     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4582     int is_inf_internal = 0;            /* The studied chunk is infinite */
4583     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4584     scan_data_t data_fake;
4585     SV *re_trie_maxbuff = NULL;
4586     regnode *first_non_open = scan;
4587     SSize_t stopmin = OPTIMIZE_INFTY;
4588     scan_frame *frame = NULL;
4589     DECLARE_AND_GET_RE_DEBUG_FLAGS;
4590
4591     PERL_ARGS_ASSERT_STUDY_CHUNK;
4592     RExC_study_started= 1;
4593
4594     Zero(&data_fake, 1, scan_data_t);
4595
4596     if ( depth == 0 ) {
4597         while (first_non_open && OP(first_non_open) == OPEN)
4598             first_non_open=regnext(first_non_open);
4599     }
4600
4601
4602   fake_study_recurse:
4603     DEBUG_r(
4604         RExC_study_chunk_recursed_count++;
4605     );
4606     DEBUG_OPTIMISE_MORE_r(
4607     {
4608         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4609             depth, (long)stopparen,
4610             (unsigned long)RExC_study_chunk_recursed_count,
4611             (unsigned long)depth, (unsigned long)recursed_depth,
4612             scan,
4613             last);
4614         if (recursed_depth) {
4615             U32 i;
4616             U32 j;
4617             for ( j = 0 ; j < recursed_depth ; j++ ) {
4618                 for ( i = 0 ; i < (U32)RExC_total_parens ; i++ ) {
4619                     if (PAREN_TEST(j, i) && (!j || !PAREN_TEST(j - 1, i))) {
4620                         Perl_re_printf( aTHX_ " %d",(int)i);
4621                         break;
4622                     }
4623                 }
4624                 if ( j + 1 < recursed_depth ) {
4625                     Perl_re_printf( aTHX_  ",");
4626                 }
4627             }
4628         }
4629         Perl_re_printf( aTHX_ "\n");
4630     }
4631     );
4632     while ( scan && OP(scan) != END && scan < last ){
4633         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4634                                    node length to get a real minimum (because
4635                                    the folded version may be shorter) */
4636         bool unfolded_multi_char = FALSE;
4637         /* avoid mutating ops if we are anywhere within the recursed or
4638          * enframed handling for a GOSUB: the outermost level will handle it.
4639          */
4640         bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub);
4641         /* Peephole optimizer: */
4642         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4643         DEBUG_PEEP("Peep", scan, depth, flags);
4644
4645
4646         /* The reason we do this here is that we need to deal with things like
4647          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4648          * parsing code, as each (?:..) is handled by a different invocation of
4649          * reg() -- Yves
4650          */
4651         if (PL_regkind[OP(scan)] == EXACT
4652             && OP(scan) != LEXACT
4653             && OP(scan) != LEXACT_REQ8
4654             && mutate_ok
4655         ) {
4656             join_exact(pRExC_state, scan, &min_subtract, &unfolded_multi_char,
4657                     0, NULL, depth + 1);
4658         }
4659
4660         /* Follow the next-chain of the current node and optimize
4661            away all the NOTHINGs from it.
4662          */
4663         rck_elide_nothing(scan);
4664
4665         /* The principal pseudo-switch.  Cannot be a switch, since we look into
4666          * several different things.  */
4667         if ( OP(scan) == DEFINEP ) {
4668             SSize_t minlen = 0;
4669             SSize_t deltanext = 0;
4670             SSize_t fake_last_close = 0;
4671             I32 f = SCF_IN_DEFINE;
4672
4673             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4674             scan = regnext(scan);
4675             assert( OP(scan) == IFTHEN );
4676             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4677
4678             data_fake.last_closep= &fake_last_close;
4679             minlen = *minlenp;
4680             next = regnext(scan);
4681             scan = NEXTOPER(NEXTOPER(scan));
4682             DEBUG_PEEP("scan", scan, depth, flags);
4683             DEBUG_PEEP("next", next, depth, flags);
4684
4685             /* we suppose the run is continuous, last=next...
4686              * NOTE we dont use the return here! */
4687             /* DEFINEP study_chunk() recursion */
4688             (void)study_chunk(pRExC_state, &scan, &minlen,
4689                               &deltanext, next, &data_fake, stopparen,
4690                               recursed_depth, NULL, f, depth+1, mutate_ok);
4691
4692             scan = next;
4693         } else
4694         if (
4695             OP(scan) == BRANCH  ||
4696             OP(scan) == BRANCHJ ||
4697             OP(scan) == IFTHEN
4698         ) {
4699             next = regnext(scan);
4700             code = OP(scan);
4701
4702             /* The op(next)==code check below is to see if we
4703              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4704              * IFTHEN is special as it might not appear in pairs.
4705              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4706              * we dont handle it cleanly. */
4707             if (OP(next) == code || code == IFTHEN) {
4708                 /* NOTE - There is similar code to this block below for
4709                  * handling TRIE nodes on a re-study.  If you change stuff here
4710                  * check there too. */
4711                 SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0;
4712                 regnode_ssc accum;
4713                 regnode * const startbranch=scan;
4714
4715                 if (flags & SCF_DO_SUBSTR) {
4716                     /* Cannot merge strings after this. */
4717                     scan_commit(pRExC_state, data, minlenp, is_inf);
4718                 }
4719
4720                 if (flags & SCF_DO_STCLASS)
4721                     ssc_init_zero(pRExC_state, &accum);
4722
4723                 while (OP(scan) == code) {
4724                     SSize_t deltanext, minnext, fake;
4725                     I32 f = 0;
4726                     regnode_ssc this_class;
4727
4728                     DEBUG_PEEP("Branch", scan, depth, flags);
4729
4730                     num++;
4731                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4732                     if (data) {
4733                         data_fake.whilem_c = data->whilem_c;
4734                         data_fake.last_closep = data->last_closep;
4735                     }
4736                     else
4737                         data_fake.last_closep = &fake;
4738
4739                     data_fake.pos_delta = delta;
4740                     next = regnext(scan);
4741
4742                     scan = NEXTOPER(scan); /* everything */
4743                     if (code != BRANCH)    /* everything but BRANCH */
4744                         scan = NEXTOPER(scan);
4745
4746                     if (flags & SCF_DO_STCLASS) {
4747                         ssc_init(pRExC_state, &this_class);
4748                         data_fake.start_class = &this_class;
4749                         f = SCF_DO_STCLASS_AND;
4750                     }
4751                     if (flags & SCF_WHILEM_VISITED_POS)
4752                         f |= SCF_WHILEM_VISITED_POS;
4753
4754                     /* we suppose the run is continuous, last=next...*/
4755                     /* recurse study_chunk() for each BRANCH in an alternation */
4756                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4757                                       &deltanext, next, &data_fake, stopparen,
4758                                       recursed_depth, NULL, f, depth+1,
4759                                       mutate_ok);
4760
4761                     if (min1 > minnext)
4762                         min1 = minnext;
4763                     if (deltanext == OPTIMIZE_INFTY) {
4764                         is_inf = is_inf_internal = 1;
4765                         max1 = OPTIMIZE_INFTY;
4766                     } else if (max1 < minnext + deltanext)
4767                         max1 = minnext + deltanext;
4768                     scan = next;
4769                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4770                         pars++;
4771                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4772                         if ( stopmin > minnext)
4773                             stopmin = min + min1;
4774                         flags &= ~SCF_DO_SUBSTR;
4775                         if (data)
4776                             data->flags |= SCF_SEEN_ACCEPT;
4777                     }
4778                     if (data) {
4779                         if (data_fake.flags & SF_HAS_EVAL)
4780                             data->flags |= SF_HAS_EVAL;
4781                         data->whilem_c = data_fake.whilem_c;
4782                     }
4783                     if (flags & SCF_DO_STCLASS)
4784                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4785                 }
4786                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4787                     min1 = 0;
4788                 if (flags & SCF_DO_SUBSTR) {
4789                     data->pos_min += min1;
4790                     if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1))
4791                         data->pos_delta = OPTIMIZE_INFTY;
4792                     else
4793                         data->pos_delta += max1 - min1;
4794                     if (max1 != min1 || is_inf)
4795                         data->cur_is_floating = 1;
4796                 }
4797                 min += min1;
4798                 if (delta == OPTIMIZE_INFTY
4799                  || OPTIMIZE_INFTY - delta - (max1 - min1) < 0)
4800                     delta = OPTIMIZE_INFTY;
4801                 else
4802                     delta += max1 - min1;
4803                 if (flags & SCF_DO_STCLASS_OR) {
4804                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4805                     if (min1) {
4806                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4807                         flags &= ~SCF_DO_STCLASS;
4808                     }
4809                 }
4810                 else if (flags & SCF_DO_STCLASS_AND) {
4811                     if (min1) {
4812                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4813                         flags &= ~SCF_DO_STCLASS;
4814                     }
4815                     else {
4816                         /* Switch to OR mode: cache the old value of
4817                          * data->start_class */
4818                         INIT_AND_WITHP;
4819                         StructCopy(data->start_class, and_withp, regnode_ssc);
4820                         flags &= ~SCF_DO_STCLASS_AND;
4821                         StructCopy(&accum, data->start_class, regnode_ssc);
4822                         flags |= SCF_DO_STCLASS_OR;
4823                     }
4824                 }
4825
4826                 if (PERL_ENABLE_TRIE_OPTIMISATION
4827                     && OP(startbranch) == BRANCH
4828                     && mutate_ok
4829                 ) {
4830                 /* demq.
4831
4832                    Assuming this was/is a branch we are dealing with: 'scan'
4833                    now points at the item that follows the branch sequence,
4834                    whatever it is. We now start at the beginning of the
4835                    sequence and look for subsequences of
4836
4837                    BRANCH->EXACT=>x1
4838                    BRANCH->EXACT=>x2
4839                    tail
4840
4841                    which would be constructed from a pattern like
4842                    /A|LIST|OF|WORDS/
4843
4844                    If we can find such a subsequence we need to turn the first
4845                    element into a trie and then add the subsequent branch exact
4846                    strings to the trie.
4847
4848                    We have two cases
4849
4850                      1. patterns where the whole set of branches can be
4851                         converted.
4852
4853                      2. patterns where only a subset can be converted.
4854
4855                    In case 1 we can replace the whole set with a single regop
4856                    for the trie. In case 2 we need to keep the start and end
4857                    branches so
4858
4859                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4860                      becomes BRANCH TRIE; BRANCH X;
4861
4862                   There is an additional case, that being where there is a
4863                   common prefix, which gets split out into an EXACT like node
4864                   preceding the TRIE node.
4865
4866                   If x(1..n)==tail then we can do a simple trie, if not we make
4867                   a "jump" trie, such that when we match the appropriate word
4868                   we "jump" to the appropriate tail node. Essentially we turn
4869                   a nested if into a case structure of sorts.
4870
4871                 */
4872
4873                     int made=0;
4874                     if (!re_trie_maxbuff) {
4875                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4876                         if (!SvIOK(re_trie_maxbuff))
4877                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4878                     }
4879                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4880                         regnode *cur;
4881                         regnode *first = (regnode *)NULL;
4882                         regnode *prev = (regnode *)NULL;
4883                         regnode *tail = scan;
4884                         U8 trietype = 0;
4885                         U32 count=0;
4886
4887                         /* var tail is used because there may be a TAIL
4888                            regop in the way. Ie, the exacts will point to the
4889                            thing following the TAIL, but the last branch will
4890                            point at the TAIL. So we advance tail. If we
4891                            have nested (?:) we may have to move through several
4892                            tails.
4893                          */
4894
4895                         while ( OP( tail ) == TAIL ) {
4896                             /* this is the TAIL generated by (?:) */
4897                             tail = regnext( tail );
4898                         }
4899
4900
4901                         DEBUG_TRIE_COMPILE_r({
4902                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4903                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4904                               depth+1,
4905                               "Looking for TRIE'able sequences. Tail node is ",
4906                               (UV) REGNODE_OFFSET(tail),
4907                               SvPV_nolen_const( RExC_mysv )
4908                             );
4909                         });
4910
4911                         /*
4912
4913                             Step through the branches
4914                                 cur represents each branch,
4915                                 noper is the first thing to be matched as part
4916                                       of that branch
4917                                 noper_next is the regnext() of that node.
4918
4919                             We normally handle a case like this
4920                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4921                             support building with NOJUMPTRIE, which restricts
4922                             the trie logic to structures like /FOO|BAR/.
4923
4924                             If noper is a trieable nodetype then the branch is
4925                             a possible optimization target. If we are building
4926                             under NOJUMPTRIE then we require that noper_next is
4927                             the same as scan (our current position in the regex
4928                             program).
4929
4930                             Once we have two or more consecutive such branches
4931                             we can create a trie of the EXACT's contents and
4932                             stitch it in place into the program.
4933
4934                             If the sequence represents all of the branches in
4935                             the alternation we replace the entire thing with a
4936                             single TRIE node.
4937
4938                             Otherwise when it is a subsequence we need to
4939                             stitch it in place and replace only the relevant
4940                             branches. This means the first branch has to remain
4941                             as it is used by the alternation logic, and its
4942                             next pointer, and needs to be repointed at the item
4943                             on the branch chain following the last branch we
4944                             have optimized away.
4945
4946                             This could be either a BRANCH, in which case the
4947                             subsequence is internal, or it could be the item
4948                             following the branch sequence in which case the
4949                             subsequence is at the end (which does not
4950                             necessarily mean the first node is the start of the
4951                             alternation).
4952
4953                             TRIE_TYPE(X) is a define which maps the optype to a
4954                             trietype.
4955
4956                                 optype          |  trietype
4957                                 ----------------+-----------
4958                                 NOTHING         | NOTHING
4959                                 EXACT           | EXACT
4960                                 EXACT_REQ8     | EXACT
4961                                 EXACTFU         | EXACTFU
4962                                 EXACTFU_REQ8   | EXACTFU
4963                                 EXACTFUP        | EXACTFU
4964                                 EXACTFAA        | EXACTFAA
4965                                 EXACTL          | EXACTL
4966                                 EXACTFLU8       | EXACTFLU8
4967
4968
4969                         */
4970 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4971                        ? NOTHING                                            \
4972                        : ( EXACT == (X) || EXACT_REQ8 == (X) )             \
4973                          ? EXACT                                            \
4974                          : (     EXACTFU == (X)                             \
4975                               || EXACTFU_REQ8 == (X)                       \
4976                               || EXACTFUP == (X) )                          \
4977                            ? EXACTFU                                        \
4978                            : ( EXACTFAA == (X) )                            \
4979                              ? EXACTFAA                                     \
4980                              : ( EXACTL == (X) )                            \
4981                                ? EXACTL                                     \
4982                                : ( EXACTFLU8 == (X) )                       \
4983                                  ? EXACTFLU8                                \
4984                                  : 0 )
4985
4986                         /* dont use tail as the end marker for this traverse */
4987                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4988                             regnode * const noper = NEXTOPER( cur );
4989                             U8 noper_type = OP( noper );
4990                             U8 noper_trietype = TRIE_TYPE( noper_type );
4991 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4992                             regnode * const noper_next = regnext( noper );
4993                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4994                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4995 #endif
4996
4997                             DEBUG_TRIE_COMPILE_r({
4998                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4999                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
5000                                    depth+1,
5001                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
5002
5003                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
5004                                 Perl_re_printf( aTHX_  " -> %d:%s",
5005                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
5006
5007                                 if ( noper_next ) {
5008                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
5009                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
5010                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
5011                                 }
5012                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
5013                                    REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur),
5014                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
5015                                 );
5016                             });
5017
5018                             /* Is noper a trieable nodetype that can be merged
5019                              * with the current trie (if there is one)? */
5020                             if ( noper_trietype
5021                                   &&
5022                                   (
5023                                         ( noper_trietype == NOTHING )
5024                                         || ( trietype == NOTHING )
5025                                         || ( trietype == noper_trietype )
5026                                   )
5027 #ifdef NOJUMPTRIE
5028                                   && noper_next >= tail
5029 #endif
5030                                   && count < U16_MAX)
5031                             {
5032                                 /* Handle mergable triable node Either we are
5033                                  * the first node in a new trieable sequence,
5034                                  * in which case we do some bookkeeping,
5035                                  * otherwise we update the end pointer. */
5036                                 if ( !first ) {
5037                                     first = cur;
5038                                     if ( noper_trietype == NOTHING ) {
5039 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
5040                                         regnode * const noper_next = regnext( noper );
5041                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
5042                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
5043 #endif
5044
5045                                         if ( noper_next_trietype ) {
5046                                             trietype = noper_next_trietype;
5047                                         } else if (noper_next_type)  {
5048                                             /* a NOTHING regop is 1 regop wide.
5049                                              * We need at least two for a trie
5050                                              * so we can't merge this in */
5051                                             first = NULL;
5052                                         }
5053                                     } else {
5054                                         trietype = noper_trietype;
5055                                     }
5056                                 } else {
5057                                     if ( trietype == NOTHING )
5058                                         trietype = noper_trietype;
5059                                     prev = cur;
5060                                 }
5061                                 if (first)
5062                                     count++;
5063                             } /* end handle mergable triable node */
5064                             else {
5065                                 /* handle unmergable node -
5066                                  * noper may either be a triable node which can
5067                                  * not be tried together with the current trie,
5068                                  * or a non triable node */
5069                                 if ( prev ) {
5070                                     /* If last is set and trietype is not
5071                                      * NOTHING then we have found at least two
5072                                      * triable branch sequences in a row of a
5073                                      * similar trietype so we can turn them
5074                                      * into a trie. If/when we allow NOTHING to
5075                                      * start a trie sequence this condition
5076                                      * will be required, and it isn't expensive
5077                                      * so we leave it in for now. */
5078                                     if ( trietype && trietype != NOTHING )
5079                                         make_trie( pRExC_state,
5080                                                 startbranch, first, cur, tail,
5081                                                 count, trietype, depth+1 );
5082                                     prev = NULL; /* note: we clear/update
5083                                                     first, trietype etc below,
5084                                                     so we dont do it here */
5085                                 }
5086                                 if ( noper_trietype
5087 #ifdef NOJUMPTRIE
5088                                      && noper_next >= tail
5089 #endif
5090                                 ){
5091                                     /* noper is triable, so we can start a new
5092                                      * trie sequence */
5093                                     count = 1;
5094                                     first = cur;
5095                                     trietype = noper_trietype;
5096                                 } else if (first) {
5097                                     /* if we already saw a first but the
5098                                      * current node is not triable then we have
5099                                      * to reset the first information. */
5100                                     count = 0;
5101                                     first = NULL;
5102                                     trietype = 0;
5103                                 }
5104                             } /* end handle unmergable node */
5105                         } /* loop over branches */
5106                         DEBUG_TRIE_COMPILE_r({
5107                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
5108                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
5109                               depth+1, SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
5110                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
5111                                REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur),
5112                                PL_reg_name[trietype]
5113                             );
5114
5115                         });
5116                         if ( prev && trietype ) {
5117                             if ( trietype != NOTHING ) {
5118                                 /* the last branch of the sequence was part of
5119                                  * a trie, so we have to construct it here
5120                                  * outside of the loop */
5121                                 made= make_trie( pRExC_state, startbranch,
5122                                                  first, scan, tail, count,
5123                                                  trietype, depth+1 );
5124 #ifdef TRIE_STUDY_OPT
5125                                 if ( ((made == MADE_EXACT_TRIE &&
5126                                      startbranch == first)
5127                                      || ( first_non_open == first )) &&
5128                                      depth==0 ) {
5129                                     flags |= SCF_TRIE_RESTUDY;
5130                                     if ( startbranch == first
5131                                          && scan >= tail )
5132                                     {
5133                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
5134                                     }
5135                                 }
5136 #endif
5137                             } else {
5138                                 /* at this point we know whatever we have is a
5139                                  * NOTHING sequence/branch AND if 'startbranch'
5140                                  * is 'first' then we can turn the whole thing
5141                                  * into a NOTHING
5142                                  */
5143                                 if ( startbranch == first ) {
5144                                     regnode *opt;
5145                                     /* the entire thing is a NOTHING sequence,
5146                                      * something like this: (?:|) So we can
5147                                      * turn it into a plain NOTHING op. */
5148                                     DEBUG_TRIE_COMPILE_r({
5149                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
5150                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
5151                                           depth+1,
5152                                           SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
5153
5154                                     });
5155                                     OP(startbranch)= NOTHING;
5156                                     NEXT_OFF(startbranch)= tail - startbranch;
5157                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
5158                                         OP(opt)= OPTIMIZED;
5159                                 }
5160                             }
5161                         } /* end if ( prev) */
5162                     } /* TRIE_MAXBUF is non zero */
5163                 } /* do trie */
5164
5165             }
5166             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
5167                 scan = NEXTOPER(NEXTOPER(scan));
5168             } else                      /* single branch is optimized. */
5169                 scan = NEXTOPER(scan);
5170             continue;
5171         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
5172             I32 paren = 0;
5173             regnode *start = NULL;
5174             regnode *end = NULL;
5175             U32 my_recursed_depth= recursed_depth;
5176
5177             if (OP(scan) != SUSPEND) { /* GOSUB */
5178                 /* Do setup, note this code has side effects beyond
5179                  * the rest of this block. Specifically setting
5180                  * RExC_recurse[] must happen at least once during
5181                  * study_chunk(). */
5182                 paren = ARG(scan);
5183                 RExC_recurse[ARG2L(scan)] = scan;
5184                 start = REGNODE_p(RExC_open_parens[paren]);
5185                 end   = REGNODE_p(RExC_close_parens[paren]);
5186
5187                 /* NOTE we MUST always execute the above code, even
5188                  * if we do nothing with a GOSUB */
5189                 if (
5190                     ( flags & SCF_IN_DEFINE )
5191                     ||
5192                     (
5193                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
5194                         &&
5195                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
5196                     )
5197                 ) {
5198                     /* no need to do anything here if we are in a define. */
5199                     /* or we are after some kind of infinite construct
5200                      * so we can skip recursing into this item.
5201                      * Since it is infinite we will not change the maxlen
5202                      * or delta, and if we miss something that might raise
5203                      * the minlen it will merely pessimise a little.
5204                      *
5205                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
5206                      * might result in a minlen of 1 and not of 4,
5207                      * but this doesn't make us mismatch, just try a bit
5208                      * harder than we should.
5209                      *
5210                      * However we must assume this GOSUB is infinite, to
5211                      * avoid wrongly applying other optimizations in the
5212                      * enclosing scope - see GH 18096, for example.
5213                      */
5214                     is_inf = is_inf_internal = 1;
5215                     scan= regnext(scan);
5216                     continue;
5217                 }
5218
5219                 if (
5220                     !recursed_depth
5221                     || !PAREN_TEST(recursed_depth - 1, paren)
5222                 ) {
5223                     /* it is quite possible that there are more efficient ways
5224                      * to do this. We maintain a bitmap per level of recursion
5225                      * of which patterns we have entered so we can detect if a
5226                      * pattern creates a possible infinite loop. When we
5227                      * recurse down a level we copy the previous levels bitmap
5228                      * down. When we are at recursion level 0 we zero the top
5229                      * level bitmap. It would be nice to implement a different
5230                      * more efficient way of doing this. In particular the top
5231                      * level bitmap may be unnecessary.
5232                      */
5233                     if (!recursed_depth) {
5234                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
5235                     } else {
5236                         Copy(PAREN_OFFSET(recursed_depth - 1),
5237                              PAREN_OFFSET(recursed_depth),
5238                              RExC_study_chunk_recursed_bytes, U8);
5239                     }
5240                     /* we havent recursed into this paren yet, so recurse into it */
5241                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
5242                     PAREN_SET(recursed_depth, paren);
5243                     my_recursed_depth= recursed_depth + 1;
5244                 } else {
5245                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
5246                     /* some form of infinite recursion, assume infinite length
5247                      * */
5248                     if (flags & SCF_DO_SUBSTR) {
5249                         scan_commit(pRExC_state, data, minlenp, is_inf);
5250                         data->cur_is_floating = 1;
5251                     }
5252                     is_inf = is_inf_internal = 1;
5253                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5254                         ssc_anything(data->start_class);
5255                     flags &= ~SCF_DO_STCLASS;
5256
5257                     start= NULL; /* reset start so we dont recurse later on. */
5258                 }
5259             } else {
5260                 paren = stopparen;
5261                 start = scan + 2;
5262                 end = regnext(scan);
5263             }
5264             if (start) {
5265                 scan_frame *newframe;
5266                 assert(end);
5267                 if (!RExC_frame_last) {
5268                     Newxz(newframe, 1, scan_frame);
5269                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
5270                     RExC_frame_head= newframe;
5271                     RExC_frame_count++;
5272                 } else if (!RExC_frame_last->next_frame) {
5273                     Newxz(newframe, 1, scan_frame);
5274                     RExC_frame_last->next_frame= newframe;
5275                     newframe->prev_frame= RExC_frame_last;
5276                     RExC_frame_count++;
5277                 } else {
5278                     newframe= RExC_frame_last->next_frame;
5279                 }
5280                 RExC_frame_last= newframe;
5281
5282                 newframe->next_regnode = regnext(scan);
5283                 newframe->last_regnode = last;
5284                 newframe->stopparen = stopparen;
5285                 newframe->prev_recursed_depth = recursed_depth;
5286                 newframe->this_prev_frame= frame;
5287                 newframe->in_gosub = (
5288                     (frame && frame->in_gosub) || OP(scan) == GOSUB
5289                 );
5290
5291                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
5292                 DEBUG_PEEP("fnew", scan, depth, flags);
5293
5294                 frame = newframe;
5295                 scan =  start;
5296                 stopparen = paren;
5297                 last = end;
5298                 depth = depth + 1;
5299                 recursed_depth= my_recursed_depth;
5300
5301                 continue;
5302             }
5303         }
5304         else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) {
5305             SSize_t bytelen = STR_LEN(scan), charlen;
5306             UV uc;
5307             assert(bytelen);
5308             if (UTF) {
5309                 const U8 * const s = (U8*)STRING(scan);
5310                 uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
5311                 charlen = utf8_length(s, s + bytelen);
5312             } else {
5313                 uc = *((U8*)STRING(scan));
5314                 charlen = bytelen;
5315             }
5316             min += charlen;
5317             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
5318                 /* The code below prefers earlier match for fixed
5319                    offset, later match for variable offset.  */
5320                 if (data->last_end == -1) { /* Update the start info. */
5321                     data->last_start_min = data->pos_min;
5322                     data->last_start_max =
5323                         is_inf ? OPTIMIZE_INFTY
5324                         : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min)
5325                             ? OPTIMIZE_INFTY : data->pos_min + data->pos_delta;
5326                 }
5327                 sv_catpvn(data->last_found, STRING(scan), bytelen);
5328                 if (UTF)
5329                     SvUTF8_on(data->last_found);
5330                 {
5331                     SV * const sv = data->last_found;
5332                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5333                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5334                     if (mg && mg->mg_len >= 0)
5335                         mg->mg_len += charlen;
5336                 }
5337                 data->last_end = data->pos_min + charlen;
5338                 data->pos_min += charlen; /* As in the first entry. */
5339                 data->flags &= ~SF_BEFORE_EOL;
5340             }
5341
5342             /* ANDing the code point leaves at most it, and not in locale, and
5343              * can't match null string */
5344             if (flags & SCF_DO_STCLASS_AND) {
5345                 ssc_cp_and(data->start_class, uc);
5346                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5347                 ssc_clear_locale(data->start_class);
5348             }
5349             else if (flags & SCF_DO_STCLASS_OR) {
5350                 ssc_add_cp(data->start_class, uc);
5351                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5352
5353                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5354                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5355             }
5356             flags &= ~SCF_DO_STCLASS;
5357         }
5358         else if (PL_regkind[OP(scan)] == EXACT) {
5359             /* But OP != EXACT!, so is EXACTFish */
5360             SSize_t bytelen = STR_LEN(scan), charlen;
5361             const U8 * s = (U8*)STRING(scan);
5362
5363             /* Replace a length 1 ASCII fold pair node with an ANYOFM node,
5364              * with the mask set to the complement of the bit that differs
5365              * between upper and lower case, and the lowest code point of the
5366              * pair (which the '&' forces) */
5367             if (     bytelen == 1
5368                 &&   isALPHA_A(*s)
5369                 &&  (         OP(scan) == EXACTFAA
5370                      || (     OP(scan) == EXACTFU
5371                          && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(*s)))
5372                 &&   mutate_ok
5373             ) {
5374                 U8 mask = ~ ('A' ^ 'a'); /* These differ in just one bit */
5375
5376                 OP(scan) = ANYOFM;
5377                 ARG_SET(scan, *s & mask);
5378                 FLAGS(scan) = mask;
5379                 /* we're not EXACTFish any more, so restudy */
5380                 continue;
5381             }
5382
5383             /* Search for fixed substrings supports EXACT only. */
5384             if (flags & SCF_DO_SUBSTR) {
5385                 assert(data);
5386                 scan_commit(pRExC_state, data, minlenp, is_inf);
5387             }
5388             charlen = UTF ? (SSize_t) utf8_length(s, s + bytelen) : bytelen;
5389             if (unfolded_multi_char) {
5390                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
5391             }
5392             min += charlen - min_subtract;
5393             assert (min >= 0);
5394             delta += min_subtract;
5395             if (flags & SCF_DO_SUBSTR) {
5396                 data->pos_min += charlen - min_subtract;
5397                 if (data->pos_min < 0) {
5398                     data->pos_min = 0;
5399                 }
5400                 data->pos_delta += min_subtract;
5401                 if (min_subtract) {
5402                     data->cur_is_floating = 1; /* float */
5403                 }
5404             }
5405
5406             if (flags & SCF_DO_STCLASS) {
5407                 SV* EXACTF_invlist = make_exactf_invlist(pRExC_state, scan);
5408
5409                 assert(EXACTF_invlist);
5410                 if (flags & SCF_DO_STCLASS_AND) {
5411                     if (OP(scan) != EXACTFL)
5412                         ssc_clear_locale(data->start_class);
5413                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5414                     ANYOF_POSIXL_ZERO(data->start_class);
5415                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
5416                 }
5417                 else {  /* SCF_DO_STCLASS_OR */
5418                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
5419                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5420
5421                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5422                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5423                 }
5424                 flags &= ~SCF_DO_STCLASS;
5425                 SvREFCNT_dec(EXACTF_invlist);
5426             }
5427         }
5428         else if (REGNODE_VARIES(OP(scan))) {
5429             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
5430             I32 fl = 0, f = flags;
5431             regnode * const oscan = scan;
5432             regnode_ssc this_class;
5433             regnode_ssc *oclass = NULL;
5434             I32 next_is_eval = 0;
5435
5436             switch (PL_regkind[OP(scan)]) {
5437             case WHILEM:                /* End of (?:...)* . */
5438                 scan = NEXTOPER(scan);
5439                 goto finish;
5440             case PLUS:
5441                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5442                     next = NEXTOPER(scan);
5443                     if (   (     PL_regkind[OP(next)] == EXACT
5444                             && ! isEXACTFish(OP(next)))
5445                         || (flags & SCF_DO_STCLASS))
5446                     {
5447                         mincount = 1;
5448                         maxcount = REG_INFTY;
5449                         next = regnext(scan);
5450                         scan = NEXTOPER(scan);
5451                         goto do_curly;
5452                     }
5453                 }
5454                 if (flags & SCF_DO_SUBSTR)
5455                     data->pos_min++;
5456                 /* This will bypass the formal 'min += minnext * mincount'
5457                  * calculation in the do_curly path, so assumes min width
5458                  * of the PLUS payload is exactly one. */
5459                 min++;
5460                 /* FALLTHROUGH */
5461             case STAR:
5462                 next = NEXTOPER(scan);
5463
5464                 /* This temporary node can now be turned into EXACTFU, and
5465                  * must, as regexec.c doesn't handle it */
5466                 if (OP(next) == EXACTFU_S_EDGE && mutate_ok) {
5467                     OP(next) = EXACTFU;
5468                 }
5469
5470                 if (     STR_LEN(next) == 1
5471                     &&   isALPHA_A(* STRING(next))
5472                     && (         OP(next) == EXACTFAA
5473                         || (     OP(next) == EXACTFU
5474                             && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next))))
5475                     &&   mutate_ok
5476                 ) {
5477                     /* These differ in just one bit */
5478                     U8 mask = ~ ('A' ^ 'a');
5479
5480                     assert(isALPHA_A(* STRING(next)));
5481
5482                     /* Then replace it by an ANYOFM node, with
5483                     * the mask set to the complement of the
5484                     * bit that differs between upper and lower
5485                     * case, and the lowest code point of the
5486                     * pair (which the '&' forces) */
5487                     OP(next) = ANYOFM;
5488                     ARG_SET(next, *STRING(next) & mask);
5489                     FLAGS(next) = mask;
5490                 }
5491
5492                 if (flags & SCF_DO_STCLASS) {
5493                     mincount = 0;
5494                     maxcount = REG_INFTY;
5495                     next = regnext(scan);
5496                     scan = NEXTOPER(scan);
5497                     goto do_curly;
5498                 }
5499                 if (flags & SCF_DO_SUBSTR) {
5500                     scan_commit(pRExC_state, data, minlenp, is_inf);
5501                     /* Cannot extend fixed substrings */
5502                     data->cur_is_floating = 1; /* float */
5503                 }
5504                 is_inf = is_inf_internal = 1;
5505                 scan = regnext(scan);
5506                 goto optimize_curly_tail;
5507             case CURLY:
5508                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5509                     && (scan->flags == stopparen))
5510                 {
5511                     mincount = 1;
5512                     maxcount = 1;
5513                 } else {
5514                     mincount = ARG1(scan);
5515                     maxcount = ARG2(scan);
5516                 }
5517                 next = regnext(scan);
5518                 if (OP(scan) == CURLYX) {
5519                     I32 lp = (data ? *(data->last_closep) : 0);
5520                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5521                 }
5522                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5523                 next_is_eval = (OP(scan) == EVAL);
5524               do_curly:
5525                 if (flags & SCF_DO_SUBSTR) {
5526                     if (mincount == 0)
5527                         scan_commit(pRExC_state, data, minlenp, is_inf);
5528                     /* Cannot extend fixed substrings */
5529                     pos_before = data->pos_min;
5530                 }
5531                 if (data) {
5532                     fl = data->flags;
5533                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5534                     if (is_inf)
5535                         data->flags |= SF_IS_INF;
5536                 }
5537                 if (flags & SCF_DO_STCLASS) {
5538                     ssc_init(pRExC_state, &this_class);
5539                     oclass = data->start_class;
5540                     data->start_class = &this_class;
5541                     f |= SCF_DO_STCLASS_AND;
5542                     f &= ~SCF_DO_STCLASS_OR;
5543                 }
5544                 /* Exclude from super-linear cache processing any {n,m}
5545                    regops for which the combination of input pos and regex
5546                    pos is not enough information to determine if a match
5547                    will be possible.
5548
5549                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5550                    regex pos at the \s*, the prospects for a match depend not
5551                    only on the input position but also on how many (bar\s*)
5552                    repeats into the {4,8} we are. */
5553                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5554                     f &= ~SCF_WHILEM_VISITED_POS;
5555
5556                 /* This will finish on WHILEM, setting scan, or on NULL: */
5557                 /* recurse study_chunk() on loop bodies */
5558                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5559                                   last, data, stopparen, recursed_depth, NULL,
5560                                   (mincount == 0
5561                                    ? (f & ~SCF_DO_SUBSTR)
5562                                    : f)
5563                                   , depth+1, mutate_ok);
5564
5565                 if (flags & SCF_DO_STCLASS)
5566                     data->start_class = oclass;
5567                 if (mincount == 0 || minnext == 0) {
5568                     if (flags & SCF_DO_STCLASS_OR) {
5569                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5570                     }
5571                     else if (flags & SCF_DO_STCLASS_AND) {
5572                         /* Switch to OR mode: cache the old value of
5573                          * data->start_class */
5574                         INIT_AND_WITHP;
5575                         StructCopy(data->start_class, and_withp, regnode_ssc);
5576                         flags &= ~SCF_DO_STCLASS_AND;
5577                         StructCopy(&this_class, data->start_class, regnode_ssc);
5578                         flags |= SCF_DO_STCLASS_OR;
5579                         ANYOF_FLAGS(data->start_class)
5580                                                 |= SSC_MATCHES_EMPTY_STRING;
5581                     }
5582                 } else {                /* Non-zero len */
5583                     if (flags & SCF_DO_STCLASS_OR) {
5584                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5585                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5586                     }
5587                     else if (flags & SCF_DO_STCLASS_AND)
5588                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5589                     flags &= ~SCF_DO_STCLASS;
5590                 }
5591                 if (!scan)              /* It was not CURLYX, but CURLY. */
5592                     scan = next;
5593                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5594                     /* ? quantifier ok, except for (?{ ... }) */
5595                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5596                     && (minnext == 0) && (deltanext == 0)
5597                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5598                     && maxcount <= REG_INFTY/3) /* Complement check for big
5599                                                    count */
5600                 {
5601                     _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP),
5602                         Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5603                             "Quantifier unexpected on zero-length expression "
5604                             "in regex m/%" UTF8f "/",
5605                              UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5606                                   RExC_precomp)));
5607                 }
5608
5609                 if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext )
5610                     || min >= SSize_t_MAX - minnext * mincount )
5611                 {
5612                     FAIL("Regexp out of space");
5613                 }
5614
5615                 min += minnext * mincount;
5616                 is_inf_internal |= deltanext == OPTIMIZE_INFTY
5617                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5618                 is_inf |= is_inf_internal;
5619                 if (is_inf) {
5620                     delta = OPTIMIZE_INFTY;
5621                 } else {
5622                     delta += (minnext + deltanext) * maxcount
5623                              - minnext * mincount;
5624                 }
5625                 /* Try powerful optimization CURLYX => CURLYN. */
5626                 if (  OP(oscan) == CURLYX && data
5627                       && data->flags & SF_IN_PAR
5628                       && !(data->flags & SF_HAS_EVAL)
5629                       && !deltanext && minnext == 1
5630                       && mutate_ok
5631                 ) {
5632                     /* Try to optimize to CURLYN.  */
5633                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5634                     regnode * const nxt1 = nxt;
5635 #ifdef DEBUGGING
5636                     regnode *nxt2;
5637 #endif
5638
5639                     /* Skip open. */
5640                     nxt = regnext(nxt);
5641                     if (!REGNODE_SIMPLE(OP(nxt))
5642                         && !(PL_regkind[OP(nxt)] == EXACT
5643                              && STR_LEN(nxt) == 1))
5644                         goto nogo;
5645 #ifdef DEBUGGING
5646                     nxt2 = nxt;
5647 #endif
5648                     nxt = regnext(nxt);
5649                     if (OP(nxt) != CLOSE)
5650                         goto nogo;
5651                     if (RExC_open_parens) {
5652
5653                         /*open->CURLYM*/
5654                         RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5655
5656                         /*close->while*/
5657                         RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2;
5658                     }
5659                     /* Now we know that nxt2 is the only contents: */
5660                     oscan->flags = (U8)ARG(nxt);
5661                     OP(oscan) = CURLYN;
5662                     OP(nxt1) = NOTHING; /* was OPEN. */
5663
5664 #ifdef DEBUGGING
5665                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5666                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5667                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5668                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5669                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5670                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5671 #endif
5672                 }
5673               nogo:
5674
5675                 /* Try optimization CURLYX => CURLYM. */
5676                 if (  OP(oscan) == CURLYX && data
5677                       && !(data->flags & SF_HAS_PAR)
5678                       && !(data->flags & SF_HAS_EVAL)
5679                       && !deltanext     /* atom is fixed width */
5680                       && minnext != 0   /* CURLYM can't handle zero width */
5681                          /* Nor characters whose fold at run-time may be
5682                           * multi-character */
5683                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5684                       && mutate_ok
5685                 ) {
5686                     /* XXXX How to optimize if data == 0? */
5687                     /* Optimize to a simpler form.  */
5688                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5689                     regnode *nxt2;
5690
5691                     OP(oscan) = CURLYM;
5692                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5693                             && (OP(nxt2) != WHILEM))
5694                         nxt = nxt2;
5695                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5696                     /* Need to optimize away parenths. */
5697                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5698                         /* Set the parenth number.  */
5699                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5700
5701                         oscan->flags = (U8)ARG(nxt);
5702                         if (RExC_open_parens) {
5703                              /*open->CURLYM*/
5704                             RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5705
5706                             /*close->NOTHING*/
5707                             RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2)
5708                                                          + 1;
5709                         }
5710                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5711                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5712
5713 #ifdef DEBUGGING
5714                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5715                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5716                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5717                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5718 #endif
5719 #if 0
5720                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5721                             regnode *nnxt = regnext(nxt1);
5722                             if (nnxt == nxt) {
5723                                 if (reg_off_by_arg[OP(nxt1)])
5724                                     ARG_SET(nxt1, nxt2 - nxt1);
5725                                 else if (nxt2 - nxt1 < U16_MAX)
5726                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5727                                 else
5728                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5729                             }
5730                             nxt1 = nnxt;
5731                         }
5732 #endif
5733                         /* Optimize again: */
5734                         /* recurse study_chunk() on optimised CURLYX => CURLYM */
5735                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5736                                     NULL, stopparen, recursed_depth, NULL, 0,
5737                                     depth+1, mutate_ok);
5738                     }
5739                     else
5740                         oscan->flags = 0;
5741                 }
5742                 else if ((OP(oscan) == CURLYX)
5743                          && (flags & SCF_WHILEM_VISITED_POS)
5744                          /* See the comment on a similar expression above.
5745                             However, this time it's not a subexpression
5746                             we care about, but the expression itself. */
5747                          && (maxcount == REG_INFTY)
5748                          && data) {
5749                     /* This stays as CURLYX, we can put the count/of pair. */
5750                     /* Find WHILEM (as in regexec.c) */
5751                     regnode *nxt = oscan + NEXT_OFF(oscan);
5752
5753                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5754                         nxt += ARG(nxt);
5755                     nxt = PREVOPER(nxt);
5756                     if (nxt->flags & 0xf) {
5757                         /* we've already set whilem count on this node */
5758                     } else if (++data->whilem_c < 16) {
5759                         assert(data->whilem_c <= RExC_whilem_seen);
5760                         nxt->flags = (U8)(data->whilem_c
5761                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5762                     }
5763                 }
5764                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5765                     pars++;
5766                 if (flags & SCF_DO_SUBSTR) {
5767                     SV *last_str = NULL;
5768                     STRLEN last_chrs = 0;
5769                     int counted = mincount != 0;
5770
5771                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5772                                                                   string. */
5773                         SSize_t b = pos_before >= data->last_start_min
5774                             ? pos_before : data->last_start_min;
5775                         STRLEN l;
5776                         const char * const s = SvPV_const(data->last_found, l);
5777                         SSize_t old = b - data->last_start_min;
5778                         assert(old >= 0);
5779
5780                         if (UTF)
5781                             old = utf8_hop_forward((U8*)s, old,
5782                                                (U8 *) SvEND(data->last_found))
5783                                 - (U8*)s;
5784                         l -= old;
5785                         /* Get the added string: */
5786                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5787                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5788                                             (U8*)(s + old + l)) : l;
5789                         if (deltanext == 0 && pos_before == b) {
5790                             /* What was added is a constant string */
5791                             if (mincount > 1) {
5792
5793                                 SvGROW(last_str, (mincount * l) + 1);
5794                                 repeatcpy(SvPVX(last_str) + l,
5795                                           SvPVX_const(last_str), l,
5796                                           mincount - 1);
5797                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5798                                 /* Add additional parts. */
5799                                 SvCUR_set(data->last_found,
5800                                           SvCUR(data->last_found) - l);
5801                                 sv_catsv(data->last_found, last_str);
5802                                 {
5803                                     SV * sv = data->last_found;
5804                                     MAGIC *mg =
5805                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5806                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5807                                     if (mg && mg->mg_len >= 0)
5808                                         mg->mg_len += last_chrs * (mincount-1);
5809                                 }
5810                                 last_chrs *= mincount;
5811                                 data->last_end += l * (mincount - 1);
5812                             }
5813                         } else {
5814                             /* start offset must point into the last copy */
5815                             data->last_start_min += minnext * (mincount - 1);
5816                             data->last_start_max =
5817                               is_inf
5818                                ? OPTIMIZE_INFTY
5819                                : data->last_start_max +
5820                                  (maxcount - 1) * (minnext + data->pos_delta);
5821                         }
5822                     }
5823                     /* It is counted once already... */
5824                     data->pos_min += minnext * (mincount - counted);
5825 #if 0
5826 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5827                               " OPTIMIZE_INFTY=%" UVuf " minnext=%" UVuf
5828                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5829     (UV)counted, (UV)deltanext, (UV)OPTIMIZE_INFTY, (UV)minnext, (UV)maxcount,
5830     (UV)mincount);
5831 if (deltanext != OPTIMIZE_INFTY)
5832 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5833     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5834           - minnext * mincount), (UV)(OPTIMIZE_INFTY - data->pos_delta));
5835 #endif
5836                     if (deltanext == OPTIMIZE_INFTY
5837                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= OPTIMIZE_INFTY - data->pos_delta)
5838                         data->pos_delta = OPTIMIZE_INFTY;
5839                     else
5840                         data->pos_delta += - counted * deltanext +
5841                         (minnext + deltanext) * maxcount - minnext * mincount;
5842                     if (mincount != maxcount) {
5843                          /* Cannot extend fixed substrings found inside
5844                             the group.  */
5845                         scan_commit(pRExC_state, data, minlenp, is_inf);
5846                         if (mincount && last_str) {
5847                             SV * const sv = data->last_found;
5848                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5849                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5850
5851                             if (mg)
5852                                 mg->mg_len = -1;
5853                             sv_setsv(sv, last_str);
5854                             data->last_end = data->pos_min;
5855                             data->last_start_min = data->pos_min - last_chrs;
5856                             data->last_start_max = is_inf
5857                                 ? OPTIMIZE_INFTY
5858                                 : data->pos_min + data->pos_delta - last_chrs;
5859                         }
5860                         data->cur_is_floating = 1; /* float */
5861                     }
5862                     SvREFCNT_dec(last_str);
5863                 }
5864                 if (data && (fl & SF_HAS_EVAL))
5865                     data->flags |= SF_HAS_EVAL;
5866               optimize_curly_tail:
5867                 rck_elide_nothing(oscan);
5868                 continue;
5869
5870             default:
5871                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5872                                                                     OP(scan));
5873             case REF:
5874             case CLUMP:
5875                 if (flags & SCF_DO_SUBSTR) {
5876                     /* Cannot expect anything... */
5877                     scan_commit(pRExC_state, data, minlenp, is_inf);
5878                     data->cur_is_floating = 1; /* float */
5879                 }
5880                 is_inf = is_inf_internal = 1;
5881                 if (flags & SCF_DO_STCLASS_OR) {
5882                     if (OP(scan) == CLUMP) {
5883                         /* Actually is any start char, but very few code points
5884                          * aren't start characters */
5885                         ssc_match_all_cp(data->start_class);
5886                     }
5887                     else {
5888                         ssc_anything(data->start_class);
5889                     }
5890                 }
5891                 flags &= ~SCF_DO_STCLASS;
5892                 break;
5893             }
5894         }
5895         else if (OP(scan) == LNBREAK) {
5896             if (flags & SCF_DO_STCLASS) {
5897                 if (flags & SCF_DO_STCLASS_AND) {
5898                     ssc_intersection(data->start_class,
5899                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5900                     ssc_clear_locale(data->start_class);
5901                     ANYOF_FLAGS(data->start_class)
5902                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5903                 }
5904                 else if (flags & SCF_DO_STCLASS_OR) {
5905                     ssc_union(data->start_class,
5906                               PL_XPosix_ptrs[_CC_VERTSPACE],
5907                               FALSE);
5908                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5909
5910                     /* See commit msg for
5911                      * 749e076fceedeb708a624933726e7989f2302f6a */
5912                     ANYOF_FLAGS(data->start_class)
5913                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5914                 }
5915                 flags &= ~SCF_DO_STCLASS;
5916             }
5917             min++;
5918             if (delta != OPTIMIZE_INFTY)
5919                 delta++;    /* Because of the 2 char string cr-lf */
5920             if (flags & SCF_DO_SUBSTR) {
5921                 /* Cannot expect anything... */
5922                 scan_commit(pRExC_state, data, minlenp, is_inf);
5923                 data->pos_min += 1;
5924                 if (data->pos_delta != OPTIMIZE_INFTY) {
5925                     data->pos_delta += 1;
5926                 }
5927                 data->cur_is_floating = 1; /* float */
5928             }
5929         }
5930         else if (REGNODE_SIMPLE(OP(scan))) {
5931
5932             if (flags & SCF_DO_SUBSTR) {
5933                 scan_commit(pRExC_state, data, minlenp, is_inf);
5934                 data->pos_min++;
5935             }
5936             min++;
5937             if (flags & SCF_DO_STCLASS) {
5938                 bool invert = 0;
5939                 SV* my_invlist = NULL;
5940                 U8 namedclass;
5941
5942                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5943                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5944
5945                 /* Some of the logic below assumes that switching
5946                    locale on will only add false positives. */
5947                 switch (OP(scan)) {
5948
5949                 default:
5950 #ifdef DEBUGGING
5951                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5952                                                                      OP(scan));
5953 #endif
5954                 case SANY:
5955                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5956                         ssc_match_all_cp(data->start_class);
5957                     break;
5958
5959                 case REG_ANY:
5960                     {
5961                         SV* REG_ANY_invlist = _new_invlist(2);
5962                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5963                                                             '\n');
5964                         if (flags & SCF_DO_STCLASS_OR) {
5965                             ssc_union(data->start_class,
5966                                       REG_ANY_invlist,
5967                                       TRUE /* TRUE => invert, hence all but \n
5968                                             */
5969                                       );
5970                         }
5971                         else if (flags & SCF_DO_STCLASS_AND) {
5972                             ssc_intersection(data->start_class,
5973                                              REG_ANY_invlist,
5974                                              TRUE  /* TRUE => invert */
5975                                              );
5976                             ssc_clear_locale(data->start_class);
5977                         }
5978                         SvREFCNT_dec_NN(REG_ANY_invlist);
5979                     }
5980                     break;
5981
5982                 case ANYOFD:
5983                 case ANYOFL:
5984                 case ANYOFPOSIXL:
5985                 case ANYOFH:
5986                 case ANYOFHb:
5987                 case ANYOFHr:
5988                 case ANYOFHs:
5989                 case ANYOF:
5990                     if (flags & SCF_DO_STCLASS_AND)
5991                         ssc_and(pRExC_state, data->start_class,
5992                                 (regnode_charclass *) scan);
5993                     else
5994                         ssc_or(pRExC_state, data->start_class,
5995                                                           (regnode_charclass *) scan);
5996                     break;
5997
5998                 case NANYOFM: /* NANYOFM already contains the inversion of the
5999                                  input ANYOF data, so, unlike things like
6000                                  NPOSIXA, don't change 'invert' to TRUE */
6001                     /* FALLTHROUGH */
6002                 case ANYOFM:
6003                   {
6004                     SV* cp_list = get_ANYOFM_contents(scan);
6005
6006                     if (flags & SCF_DO_STCLASS_OR) {
6007                         ssc_union(data->start_class, cp_list, invert);
6008                     }
6009                     else if (flags & SCF_DO_STCLASS_AND) {
6010                         ssc_intersection(data->start_class, cp_list, invert);
6011                     }
6012
6013                     SvREFCNT_dec_NN(cp_list);
6014                     break;
6015                   }
6016
6017                 case ANYOFR:
6018                 case ANYOFRb:
6019                   {
6020                     SV* cp_list = NULL;
6021
6022                     cp_list = _add_range_to_invlist(cp_list,
6023                                         ANYOFRbase(scan),
6024                                         ANYOFRbase(scan) + ANYOFRdelta(scan));
6025
6026                     if (flags & SCF_DO_STCLASS_OR) {
6027                         ssc_union(data->start_class, cp_list, invert);
6028                     }
6029                     else if (flags & SCF_DO_STCLASS_AND) {
6030                         ssc_intersection(data->start_class, cp_list, invert);
6031                     }
6032
6033                     SvREFCNT_dec_NN(cp_list);
6034                     break;
6035                   }
6036
6037                 case NPOSIXL:
6038                     invert = 1;
6039                     /* FALLTHROUGH */
6040
6041                 case POSIXL:
6042                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
6043                     if (flags & SCF_DO_STCLASS_AND) {
6044                         bool was_there = cBOOL(
6045                                           ANYOF_POSIXL_TEST(data->start_class,
6046                                                                  namedclass));
6047                         ANYOF_POSIXL_ZERO(data->start_class);
6048                         if (was_there) {    /* Do an AND */
6049                             ANYOF_POSIXL_SET(data->start_class, namedclass);
6050                         }
6051                         /* No individual code points can now match */
6052                         data->start_class->invlist
6053                                                 = sv_2mortal(_new_invlist(0));
6054                     }
6055                     else {
6056                         int complement = namedclass + ((invert) ? -1 : 1);
6057
6058                         assert(flags & SCF_DO_STCLASS_OR);
6059
6060                         /* If the complement of this class was already there,
6061                          * the result is that they match all code points,
6062                          * (\d + \D == everything).  Remove the classes from
6063                          * future consideration.  Locale is not relevant in
6064                          * this case */
6065                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
6066                             ssc_match_all_cp(data->start_class);
6067                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
6068                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
6069                         }
6070                         else {  /* The usual case; just add this class to the
6071                                    existing set */
6072                             ANYOF_POSIXL_SET(data->start_class, namedclass);
6073                         }
6074                     }
6075                     break;
6076
6077                 case NPOSIXA:   /* For these, we always know the exact set of
6078                                    what's matched */
6079                     invert = 1;
6080                     /* FALLTHROUGH */
6081                 case POSIXA:
6082                     my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL);
6083                     goto join_posix_and_ascii;
6084
6085                 case NPOSIXD:
6086                 case NPOSIXU:
6087                     invert = 1;
6088                     /* FALLTHROUGH */
6089                 case POSIXD:
6090                 case POSIXU:
6091                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL);
6092
6093                     /* NPOSIXD matches all upper Latin1 code points unless the
6094                      * target string being matched is UTF-8, which is
6095                      * unknowable until match time.  Since we are going to
6096                      * invert, we want to get rid of all of them so that the
6097                      * inversion will match all */
6098                     if (OP(scan) == NPOSIXD) {
6099                         _invlist_subtract(my_invlist, PL_UpperLatin1,
6100                                           &my_invlist);
6101                     }
6102
6103                   join_posix_and_ascii:
6104
6105                     if (flags & SCF_DO_STCLASS_AND) {
6106                         ssc_intersection(data->start_class, my_invlist, invert);
6107                         ssc_clear_locale(data->start_class);
6108                     }
6109                     else {
6110                         assert(flags & SCF_DO_STCLASS_OR);
6111                         ssc_union(data->start_class, my_invlist, invert);
6112                     }
6113                     SvREFCNT_dec(my_invlist);
6114                 }
6115                 if (flags & SCF_DO_STCLASS_OR)
6116                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6117                 flags &= ~SCF_DO_STCLASS;
6118             }
6119         }
6120         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
6121             data->flags |= (OP(scan) == MEOL
6122                             ? SF_BEFORE_MEOL
6123                             : SF_BEFORE_SEOL);
6124             scan_commit(pRExC_state, data, minlenp, is_inf);
6125
6126         }
6127         else if (  PL_regkind[OP(scan)] == BRANCHJ
6128                  /* Lookbehind, or need to calculate parens/evals/stclass: */
6129                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
6130                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
6131         {
6132             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
6133                 || OP(scan) == UNLESSM )
6134             {
6135                 /* Negative Lookahead/lookbehind
6136                    In this case we can't do fixed string optimisation.
6137                 */
6138
6139                 SSize_t deltanext, minnext, fake = 0;
6140                 regnode *nscan;
6141                 regnode_ssc intrnl;
6142                 int f = 0;
6143
6144                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
6145                 if (data) {
6146                     data_fake.whilem_c = data->whilem_c;
6147                     data_fake.last_closep = data->last_closep;
6148                 }
6149                 else
6150                     data_fake.last_closep = &fake;
6151                 data_fake.pos_delta = delta;
6152                 if ( flags & SCF_DO_STCLASS && !scan->flags
6153                      && OP(scan) == IFMATCH ) { /* Lookahead */
6154                     ssc_init(pRExC_state, &intrnl);
6155                     data_fake.start_class = &intrnl;
6156                     f |= SCF_DO_STCLASS_AND;
6157                 }
6158                 if (flags & SCF_WHILEM_VISITED_POS)
6159                     f |= SCF_WHILEM_VISITED_POS;
6160                 next = regnext(scan);
6161                 nscan = NEXTOPER(NEXTOPER(scan));
6162
6163                 /* recurse study_chunk() for lookahead body */
6164                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
6165                                       last, &data_fake, stopparen,
6166                                       recursed_depth, NULL, f, depth+1,
6167                                       mutate_ok);
6168                 if (scan->flags) {
6169                     if (   deltanext < 0
6170                         || deltanext > (I32) U8_MAX
6171                         || minnext > (I32)U8_MAX
6172                         || minnext + deltanext > (I32)U8_MAX)
6173                     {
6174                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6175                               (UV)U8_MAX);
6176                     }
6177
6178                     /* The 'next_off' field has been repurposed to count the
6179                      * additional starting positions to try beyond the initial
6180                      * one.  (This leaves it at 0 for non-variable length
6181                      * matches to avoid breakage for those not using this
6182                      * extension) */
6183                     if (deltanext) {
6184                         scan->next_off = deltanext;
6185                         ckWARNexperimental(RExC_parse,
6186                             WARN_EXPERIMENTAL__VLB,
6187                             "Variable length lookbehind is experimental");
6188                     }
6189                     scan->flags = (U8)minnext + deltanext;
6190                 }
6191                 if (data) {
6192                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6193                         pars++;
6194                     if (data_fake.flags & SF_HAS_EVAL)
6195                         data->flags |= SF_HAS_EVAL;
6196                     data->whilem_c = data_fake.whilem_c;
6197                 }
6198                 if (f & SCF_DO_STCLASS_AND) {
6199                     if (flags & SCF_DO_STCLASS_OR) {
6200                         /* OR before, AND after: ideally we would recurse with
6201                          * data_fake to get the AND applied by study of the
6202                          * remainder of the pattern, and then derecurse;
6203                          * *** HACK *** for now just treat as "no information".
6204                          * See [perl #56690].
6205                          */
6206                         ssc_init(pRExC_state, data->start_class);
6207                     }  else {
6208                         /* AND before and after: combine and continue.  These
6209                          * assertions are zero-length, so can match an EMPTY
6210                          * string */
6211                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6212                         ANYOF_FLAGS(data->start_class)
6213                                                    |= SSC_MATCHES_EMPTY_STRING;
6214                     }
6215                 }
6216             }
6217 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
6218             else {
6219                 /* Positive Lookahead/lookbehind
6220                    In this case we can do fixed string optimisation,
6221                    but we must be careful about it. Note in the case of
6222                    lookbehind the positions will be offset by the minimum
6223                    length of the pattern, something we won't know about
6224                    until after the recurse.
6225                 */
6226                 SSize_t deltanext, fake = 0;
6227                 regnode *nscan;
6228                 regnode_ssc intrnl;
6229                 int f = 0;
6230                 /* We use SAVEFREEPV so that when the full compile
6231                     is finished perl will clean up the allocated
6232                     minlens when it's all done. This way we don't
6233                     have to worry about freeing them when we know
6234                     they wont be used, which would be a pain.
6235                  */
6236                 SSize_t *minnextp;
6237                 Newx( minnextp, 1, SSize_t );
6238                 SAVEFREEPV(minnextp);
6239
6240                 if (data) {
6241                     StructCopy(data, &data_fake, scan_data_t);
6242                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
6243                         f |= SCF_DO_SUBSTR;
6244                         if (scan->flags)
6245                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
6246                         data_fake.last_found=newSVsv(data->last_found);
6247                     }
6248                 }
6249                 else
6250                     data_fake.last_closep = &fake;
6251                 data_fake.flags = 0;
6252                 data_fake.substrs[0].flags = 0;
6253                 data_fake.substrs[1].flags = 0;
6254                 data_fake.pos_delta = delta;
6255                 if (is_inf)
6256                     data_fake.flags |= SF_IS_INF;
6257                 if ( flags & SCF_DO_STCLASS && !scan->flags
6258                      && OP(scan) == IFMATCH ) { /* Lookahead */
6259                     ssc_init(pRExC_state, &intrnl);
6260                     data_fake.start_class = &intrnl;
6261                     f |= SCF_DO_STCLASS_AND;
6262                 }
6263                 if (flags & SCF_WHILEM_VISITED_POS)
6264                     f |= SCF_WHILEM_VISITED_POS;
6265                 next = regnext(scan);
6266                 nscan = NEXTOPER(NEXTOPER(scan));
6267
6268                 /* positive lookahead study_chunk() recursion */
6269                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
6270                                         &deltanext, last, &data_fake,
6271                                         stopparen, recursed_depth, NULL,
6272                                         f, depth+1, mutate_ok);
6273                 if (scan->flags) {
6274                     assert(0);  /* This code has never been tested since this
6275                                    is normally not compiled */
6276                     if (   deltanext < 0
6277                         || deltanext > (I32) U8_MAX
6278                         || *minnextp > (I32)U8_MAX
6279                         || *minnextp + deltanext > (I32)U8_MAX)
6280                     {
6281                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6282                               (UV)U8_MAX);
6283                     }
6284
6285                     if (deltanext) {
6286                         scan->next_off = deltanext;
6287                     }
6288                     scan->flags = (U8)*minnextp + deltanext;
6289                 }
6290
6291                 *minnextp += min;
6292
6293                 if (f & SCF_DO_STCLASS_AND) {
6294                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6295                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
6296                 }
6297                 if (data) {
6298                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6299                         pars++;
6300                     if (data_fake.flags & SF_HAS_EVAL)
6301                         data->flags |= SF_HAS_EVAL;
6302                     data->whilem_c = data_fake.whilem_c;
6303                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
6304                         int i;
6305                         if (RExC_rx->minlen<*minnextp)
6306                             RExC_rx->minlen=*minnextp;
6307                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
6308                         SvREFCNT_dec_NN(data_fake.last_found);
6309
6310                         for (i = 0; i < 2; i++) {
6311                             if (data_fake.substrs[i].minlenp != minlenp) {
6312                                 data->substrs[i].min_offset =
6313                                             data_fake.substrs[i].min_offset;
6314                                 data->substrs[i].max_offset =
6315                                             data_fake.substrs[i].max_offset;
6316                                 data->substrs[i].minlenp =
6317                                             data_fake.substrs[i].minlenp;
6318                                 data->substrs[i].lookbehind += scan->flags;
6319                             }
6320                         }
6321                     }
6322                 }
6323             }
6324 #endif
6325         }
6326         else if (OP(scan) == OPEN) {
6327             if (stopparen != (I32)ARG(scan))
6328                 pars++;
6329         }
6330         else if (OP(scan) == CLOSE) {
6331             if (stopparen == (I32)ARG(scan)) {
6332                 break;
6333             }
6334             if ((I32)ARG(scan) == is_par) {
6335                 next = regnext(scan);
6336
6337                 if ( next && (OP(next) != WHILEM) && next < last)
6338                     is_par = 0;         /* Disable optimization */
6339             }
6340             if (data)
6341                 *(data->last_closep) = ARG(scan);
6342         }
6343         else if (OP(scan) == EVAL) {
6344                 if (data)
6345                     data->flags |= SF_HAS_EVAL;
6346         }
6347         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
6348             if (flags & SCF_DO_SUBSTR) {
6349                 scan_commit(pRExC_state, data, minlenp, is_inf);
6350                 flags &= ~SCF_DO_SUBSTR;
6351             }
6352             if (data && OP(scan)==ACCEPT) {
6353                 data->flags |= SCF_SEEN_ACCEPT;
6354                 if (stopmin > min)
6355                     stopmin = min;
6356             }
6357         }
6358         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
6359         {
6360                 if (flags & SCF_DO_SUBSTR) {
6361                     scan_commit(pRExC_state, data, minlenp, is_inf);
6362                     data->cur_is_floating = 1; /* float */
6363                 }
6364                 is_inf = is_inf_internal = 1;
6365                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
6366                     ssc_anything(data->start_class);
6367                 flags &= ~SCF_DO_STCLASS;
6368         }
6369         else if (OP(scan) == GPOS) {
6370             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
6371                 !(delta || is_inf || (data && data->pos_delta)))
6372             {
6373                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
6374                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
6375                 if (RExC_rx->gofs < (STRLEN)min)
6376                     RExC_rx->gofs = min;
6377             } else {
6378                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
6379                 RExC_rx->gofs = 0;
6380             }
6381         }
6382 #ifdef TRIE_STUDY_OPT
6383 #ifdef FULL_TRIE_STUDY
6384         else if (PL_regkind[OP(scan)] == TRIE) {
6385             /* NOTE - There is similar code to this block above for handling
6386                BRANCH nodes on the initial study.  If you change stuff here
6387                check there too. */
6388             regnode *trie_node= scan;
6389             regnode *tail= regnext(scan);
6390             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6391             SSize_t max1 = 0, min1 = OPTIMIZE_INFTY;
6392             regnode_ssc accum;
6393
6394             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
6395                 /* Cannot merge strings after this. */
6396                 scan_commit(pRExC_state, data, minlenp, is_inf);
6397             }
6398             if (flags & SCF_DO_STCLASS)
6399                 ssc_init_zero(pRExC_state, &accum);
6400
6401             if (!trie->jump) {
6402                 min1= trie->minlen;
6403                 max1= trie->maxlen;
6404             } else {
6405                 const regnode *nextbranch= NULL;
6406                 U32 word;
6407
6408                 for ( word=1 ; word <= trie->wordcount ; word++)
6409                 {
6410                     SSize_t deltanext=0, minnext=0, f = 0, fake;
6411                     regnode_ssc this_class;
6412
6413                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
6414                     if (data) {
6415                         data_fake.whilem_c = data->whilem_c;
6416                         data_fake.last_closep = data->last_closep;
6417                     }
6418                     else
6419                         data_fake.last_closep = &fake;
6420                     data_fake.pos_delta = delta;
6421                     if (flags & SCF_DO_STCLASS) {
6422                         ssc_init(pRExC_state, &this_class);
6423                         data_fake.start_class = &this_class;
6424                         f = SCF_DO_STCLASS_AND;
6425                     }
6426                     if (flags & SCF_WHILEM_VISITED_POS)
6427                         f |= SCF_WHILEM_VISITED_POS;
6428
6429                     if (trie->jump[word]) {
6430                         if (!nextbranch)
6431                             nextbranch = trie_node + trie->jump[0];
6432                         scan= trie_node + trie->jump[word];
6433                         /* We go from the jump point to the branch that follows
6434                            it. Note this means we need the vestigal unused
6435                            branches even though they arent otherwise used. */
6436                         /* optimise study_chunk() for TRIE */
6437                         minnext = study_chunk(pRExC_state, &scan, minlenp,
6438                             &deltanext, (regnode *)nextbranch, &data_fake,
6439                             stopparen, recursed_depth, NULL, f, depth+1,
6440                             mutate_ok);
6441                     }
6442                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
6443                         nextbranch= regnext((regnode*)nextbranch);
6444
6445                     if (min1 > (SSize_t)(minnext + trie->minlen))
6446                         min1 = minnext + trie->minlen;
6447                     if (deltanext == OPTIMIZE_INFTY) {
6448                         is_inf = is_inf_internal = 1;
6449                         max1 = OPTIMIZE_INFTY;
6450                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
6451                         max1 = minnext + deltanext + trie->maxlen;
6452
6453                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6454                         pars++;
6455                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
6456                         if ( stopmin > min + min1)
6457                             stopmin = min + min1;
6458                         flags &= ~SCF_DO_SUBSTR;
6459                         if (data)
6460                             data->flags |= SCF_SEEN_ACCEPT;
6461                     }
6462                     if (data) {
6463                         if (data_fake.flags & SF_HAS_EVAL)
6464                             data->flags |= SF_HAS_EVAL;
6465                         data->whilem_c = data_fake.whilem_c;
6466                     }
6467                     if (flags & SCF_DO_STCLASS)
6468                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
6469                 }
6470             }
6471             if (flags & SCF_DO_SUBSTR) {
6472                 data->pos_min += min1;
6473                 data->pos_delta += max1 - min1;
6474                 if (max1 != min1 || is_inf)
6475                     data->cur_is_floating = 1; /* float */
6476             }
6477             min += min1;
6478             if (delta != OPTIMIZE_INFTY) {
6479                 if (OPTIMIZE_INFTY - (max1 - min1) >= delta)
6480                     delta += max1 - min1;
6481                 else
6482                     delta = OPTIMIZE_INFTY;
6483             }
6484             if (flags & SCF_DO_STCLASS_OR) {
6485                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6486                 if (min1) {
6487                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6488                     flags &= ~SCF_DO_STCLASS;
6489                 }
6490             }
6491             else if (flags & SCF_DO_STCLASS_AND) {
6492                 if (min1) {
6493                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6494                     flags &= ~SCF_DO_STCLASS;
6495                 }
6496                 else {
6497                     /* Switch to OR mode: cache the old value of
6498                      * data->start_class */
6499                     INIT_AND_WITHP;
6500                     StructCopy(data->start_class, and_withp, regnode_ssc);
6501                     flags &= ~SCF_DO_STCLASS_AND;
6502                     StructCopy(&accum, data->start_class, regnode_ssc);
6503                     flags |= SCF_DO_STCLASS_OR;
6504                 }
6505             }
6506             scan= tail;
6507             continue;
6508         }
6509 #else
6510         else if (PL_regkind[OP(scan)] == TRIE) {
6511             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6512             U8*bang=NULL;
6513
6514             min += trie->minlen;
6515             delta += (trie->maxlen - trie->minlen);
6516             flags &= ~SCF_DO_STCLASS; /* xxx */
6517             if (flags & SCF_DO_SUBSTR) {
6518                 /* Cannot expect anything... */
6519                 scan_commit(pRExC_state, data, minlenp, is_inf);
6520                 data->pos_min += trie->minlen;
6521                 data->pos_delta += (trie->maxlen - trie->minlen);
6522                 if (trie->maxlen != trie->minlen)
6523                     data->cur_is_floating = 1; /* float */
6524             }
6525             if (trie->jump) /* no more substrings -- for now /grr*/
6526                flags &= ~SCF_DO_SUBSTR;
6527         }
6528         else if (OP(scan) == REGEX_SET) {
6529             Perl_croak(aTHX_ "panic: %s regnode should be resolved"
6530                              " before optimization", reg_name[REGEX_SET]);
6531         }
6532
6533 #endif /* old or new */
6534 #endif /* TRIE_STUDY_OPT */
6535
6536         /* Else: zero-length, ignore. */
6537         scan = regnext(scan);
6538     }
6539
6540   finish:
6541     if (frame) {
6542         /* we need to unwind recursion. */
6543         depth = depth - 1;
6544
6545         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
6546         DEBUG_PEEP("fend", scan, depth, flags);
6547
6548         /* restore previous context */
6549         last = frame->last_regnode;
6550         scan = frame->next_regnode;
6551         stopparen = frame->stopparen;
6552         recursed_depth = frame->prev_recursed_depth;
6553
6554         RExC_frame_last = frame->prev_frame;
6555         frame = frame->this_prev_frame;
6556         goto fake_study_recurse;
6557     }
6558
6559     assert(!frame);
6560     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6561
6562     *scanp = scan;
6563     *deltap = is_inf_internal ? OPTIMIZE_INFTY : delta;
6564
6565     if (flags & SCF_DO_SUBSTR && is_inf)
6566         data->pos_delta = OPTIMIZE_INFTY - data->pos_min;
6567     if (is_par > (I32)U8_MAX)
6568         is_par = 0;
6569     if (is_par && pars==1 && data) {
6570         data->flags |= SF_IN_PAR;
6571         data->flags &= ~SF_HAS_PAR;
6572     }
6573     else if (pars && data) {
6574         data->flags |= SF_HAS_PAR;
6575         data->flags &= ~SF_IN_PAR;
6576     }
6577     if (flags & SCF_DO_STCLASS_OR)
6578         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6579     if (flags & SCF_TRIE_RESTUDY)
6580         data->flags |=  SCF_TRIE_RESTUDY;
6581
6582     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6583
6584     final_minlen = min < stopmin
6585             ? min : stopmin;
6586
6587     if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6588         if (final_minlen > OPTIMIZE_INFTY - delta)
6589             RExC_maxlen = OPTIMIZE_INFTY;
6590         else if (RExC_maxlen < final_minlen + delta)
6591             RExC_maxlen = final_minlen + delta;
6592     }
6593     return final_minlen;
6594 }
6595
6596 STATIC U32
6597 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6598 {
6599     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6600
6601     PERL_ARGS_ASSERT_ADD_DATA;
6602
6603     Renewc(RExC_rxi->data,
6604            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6605            char, struct reg_data);
6606     if(count)
6607         Renew(RExC_rxi->data->what, count + n, U8);
6608     else
6609         Newx(RExC_rxi->data->what, n, U8);
6610     RExC_rxi->data->count = count + n;
6611     Copy(s, RExC_rxi->data->what + count, n, U8);
6612     return count;
6613 }
6614
6615 /*XXX: todo make this not included in a non debugging perl, but appears to be
6616  * used anyway there, in 'use re' */
6617 #ifndef PERL_IN_XSUB_RE
6618 void
6619 Perl_reginitcolors(pTHX)
6620 {
6621     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6622     if (s) {
6623         char *t = savepv(s);
6624         int i = 0;
6625         PL_colors[0] = t;
6626         while (++i < 6) {
6627             t = strchr(t, '\t');
6628             if (t) {
6629                 *t = '\0';
6630                 PL_colors[i] = ++t;
6631             }
6632             else
6633                 PL_colors[i] = t = (char *)"";
6634         }
6635     } else {
6636         int i = 0;
6637         while (i < 6)
6638             PL_colors[i++] = (char *)"";
6639     }
6640     PL_colorset = 1;
6641 }
6642 #endif
6643
6644
6645 #ifdef TRIE_STUDY_OPT
6646 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6647     STMT_START {                                            \
6648         if (                                                \
6649               (data.flags & SCF_TRIE_RESTUDY)               \
6650               && ! restudied++                              \
6651         ) {                                                 \
6652             dOsomething;                                    \
6653             goto reStudy;                                   \
6654         }                                                   \
6655     } STMT_END
6656 #else
6657 #define CHECK_RESTUDY_GOTO_butfirst
6658 #endif
6659
6660 /*
6661  * pregcomp - compile a regular expression into internal code
6662  *
6663  * Decides which engine's compiler to call based on the hint currently in
6664  * scope
6665  */
6666
6667 #ifndef PERL_IN_XSUB_RE
6668
6669 /* return the currently in-scope regex engine (or the default if none)  */
6670
6671 regexp_engine const *
6672 Perl_current_re_engine(pTHX)
6673 {
6674     if (IN_PERL_COMPILETIME) {
6675         HV * const table = GvHV(PL_hintgv);
6676         SV **ptr;
6677
6678         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6679             return &PL_core_reg_engine;
6680         ptr = hv_fetchs(table, "regcomp", FALSE);
6681         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6682             return &PL_core_reg_engine;
6683         return INT2PTR(regexp_engine*, SvIV(*ptr));
6684     }
6685     else {
6686         SV *ptr;
6687         if (!PL_curcop->cop_hints_hash)
6688             return &PL_core_reg_engine;
6689         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6690         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6691             return &PL_core_reg_engine;
6692         return INT2PTR(regexp_engine*, SvIV(ptr));
6693     }
6694 }
6695
6696
6697 REGEXP *
6698 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6699 {
6700     regexp_engine const *eng = current_re_engine();
6701     DECLARE_AND_GET_RE_DEBUG_FLAGS;
6702
6703     PERL_ARGS_ASSERT_PREGCOMP;
6704
6705     /* Dispatch a request to compile a regexp to correct regexp engine. */
6706     DEBUG_COMPILE_r({
6707         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6708                         PTR2UV(eng));
6709     });
6710     return CALLREGCOMP_ENG(eng, pattern, flags);
6711 }
6712 #endif
6713
6714 /* public(ish) entry point for the perl core's own regex compiling code.
6715  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6716  * pattern rather than a list of OPs, and uses the internal engine rather
6717  * than the current one */
6718
6719 REGEXP *
6720 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6721 {
6722     SV *pat = pattern; /* defeat constness! */
6723
6724     PERL_ARGS_ASSERT_RE_COMPILE;
6725
6726     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6727 #ifdef PERL_IN_XSUB_RE
6728                                 &my_reg_engine,
6729 #else
6730                                 &PL_core_reg_engine,
6731 #endif
6732                                 NULL, NULL, rx_flags, 0);
6733 }
6734
6735 static void
6736 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6737 {
6738     int n;
6739
6740     if (--cbs->refcnt > 0)
6741         return;
6742     for (n = 0; n < cbs->count; n++) {
6743         REGEXP *rx = cbs->cb[n].src_regex;
6744         if (rx) {
6745             cbs->cb[n].src_regex = NULL;
6746             SvREFCNT_dec_NN(rx);
6747         }
6748     }
6749     Safefree(cbs->cb);
6750     Safefree(cbs);
6751 }
6752
6753
6754 static struct reg_code_blocks *
6755 S_alloc_code_blocks(pTHX_  int ncode)
6756 {
6757      struct reg_code_blocks *cbs;
6758     Newx(cbs, 1, struct reg_code_blocks);
6759     cbs->count = ncode;
6760     cbs->refcnt = 1;
6761     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6762     if (ncode)
6763         Newx(cbs->cb, ncode, struct reg_code_block);
6764     else
6765         cbs->cb = NULL;
6766     return cbs;
6767 }
6768
6769
6770 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6771  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6772  * point to the realloced string and length.
6773  *
6774  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6775  * stuff added */
6776
6777 static void
6778 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6779                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6780 {
6781     U8 *const src = (U8*)*pat_p;
6782     U8 *dst, *d;
6783     int n=0;
6784     STRLEN s = 0;
6785     bool do_end = 0;
6786     DECLARE_AND_GET_RE_DEBUG_FLAGS;
6787
6788     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6789         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6790
6791     /* 1 for each byte + 1 for each byte that expands to two, + trailing NUL */
6792     Newx(dst, *plen_p + variant_under_utf8_count(src, src + *plen_p) + 1, U8);
6793     d = dst;
6794
6795     while (s < *plen_p) {
6796         append_utf8_from_native_byte(src[s], &d);
6797
6798         if (n < num_code_blocks) {
6799             assert(pRExC_state->code_blocks);
6800             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6801                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6802                 assert(*(d - 1) == '(');
6803                 do_end = 1;
6804             }
6805             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6806                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6807                 assert(*(d - 1) == ')');
6808                 do_end = 0;
6809                 n++;
6810             }
6811         }
6812         s++;
6813     }
6814     *d = '\0';
6815     *plen_p = d - dst;
6816     *pat_p = (char*) dst;
6817     SAVEFREEPV(*pat_p);
6818     RExC_orig_utf8 = RExC_utf8 = 1;
6819 }
6820
6821
6822
6823 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6824  * while recording any code block indices, and handling overloading,
6825  * nested qr// objects etc.  If pat is null, it will allocate a new
6826  * string, or just return the first arg, if there's only one.
6827  *
6828  * Returns the malloced/updated pat.
6829  * patternp and pat_count is the array of SVs to be concatted;
6830  * oplist is the optional list of ops that generated the SVs;
6831  * recompile_p is a pointer to a boolean that will be set if
6832  *   the regex will need to be recompiled.
6833  * delim, if non-null is an SV that will be inserted between each element
6834  */
6835
6836 static SV*
6837 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6838                 SV *pat, SV ** const patternp, int pat_count,
6839                 OP *oplist, bool *recompile_p, SV *delim)
6840 {
6841     SV **svp;
6842     int n = 0;
6843     bool use_delim = FALSE;
6844     bool alloced = FALSE;
6845
6846     /* if we know we have at least two args, create an empty string,
6847      * then concatenate args to that. For no args, return an empty string */
6848     if (!pat && pat_count != 1) {
6849         pat = newSVpvs("");
6850         SAVEFREESV(pat);
6851         alloced = TRUE;
6852     }
6853
6854     for (svp = patternp; svp < patternp + pat_count; svp++) {
6855         SV *sv;
6856         SV *rx  = NULL;
6857         STRLEN orig_patlen = 0;
6858         bool code = 0;
6859         SV *msv = use_delim ? delim : *svp;
6860         if (!msv) msv = &PL_sv_undef;
6861
6862         /* if we've got a delimiter, we go round the loop twice for each
6863          * svp slot (except the last), using the delimiter the second
6864          * time round */
6865         if (use_delim) {
6866             svp--;
6867             use_delim = FALSE;
6868         }
6869         else if (delim)
6870             use_delim = TRUE;
6871
6872         if (SvTYPE(msv) == SVt_PVAV) {
6873             /* we've encountered an interpolated array within
6874              * the pattern, e.g. /...@a..../. Expand the list of elements,
6875              * then recursively append elements.
6876              * The code in this block is based on S_pushav() */
6877
6878             AV *const av = (AV*)msv;
6879             const SSize_t maxarg = AvFILL(av) + 1;
6880             SV **array;
6881
6882             if (oplist) {
6883                 assert(oplist->op_type == OP_PADAV
6884                     || oplist->op_type == OP_RV2AV);
6885                 oplist = OpSIBLING(oplist);
6886             }
6887
6888             if (SvRMAGICAL(av)) {
6889                 SSize_t i;
6890
6891                 Newx(array, maxarg, SV*);
6892                 SAVEFREEPV(array);
6893                 for (i=0; i < maxarg; i++) {
6894                     SV ** const svp = av_fetch(av, i, FALSE);
6895                     array[i] = svp ? *svp : &PL_sv_undef;
6896                 }
6897             }
6898             else
6899                 array = AvARRAY(av);
6900
6901             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6902                                 array, maxarg, NULL, recompile_p,
6903                                 /* $" */
6904                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6905
6906             continue;
6907         }
6908
6909
6910         /* we make the assumption here that each op in the list of
6911          * op_siblings maps to one SV pushed onto the stack,
6912          * except for code blocks, with have both an OP_NULL and
6913          * an OP_CONST.
6914          * This allows us to match up the list of SVs against the
6915          * list of OPs to find the next code block.
6916          *
6917          * Note that       PUSHMARK PADSV PADSV ..
6918          * is optimised to
6919          *                 PADRANGE PADSV  PADSV  ..
6920          * so the alignment still works. */
6921
6922         if (oplist) {
6923             if (oplist->op_type == OP_NULL
6924                 && (oplist->op_flags & OPf_SPECIAL))
6925             {
6926                 assert(n < pRExC_state->code_blocks->count);
6927                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6928                 pRExC_state->code_blocks->cb[n].block = oplist;
6929                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6930                 n++;
6931                 code = 1;
6932                 oplist = OpSIBLING(oplist); /* skip CONST */
6933                 assert(oplist);
6934             }
6935             oplist = OpSIBLING(oplist);;
6936         }
6937
6938         /* apply magic and QR overloading to arg */
6939
6940         SvGETMAGIC(msv);
6941         if (SvROK(msv) && SvAMAGIC(msv)) {
6942             SV *sv = AMG_CALLunary(msv, regexp_amg);
6943             if (sv) {
6944                 if (SvROK(sv))
6945                     sv = SvRV(sv);
6946                 if (SvTYPE(sv) != SVt_REGEXP)
6947                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6948                 msv = sv;
6949             }
6950         }
6951
6952         /* try concatenation overload ... */
6953         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6954                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6955         {
6956             sv_setsv(pat, sv);
6957             /* overloading involved: all bets are off over literal
6958              * code. Pretend we haven't seen it */
6959             if (n)
6960                 pRExC_state->code_blocks->count -= n;
6961             n = 0;
6962         }
6963         else {
6964             /* ... or failing that, try "" overload */
6965             while (SvAMAGIC(msv)
6966                     && (sv = AMG_CALLunary(msv, string_amg))
6967                     && sv != msv
6968                     &&  !(   SvROK(msv)
6969                           && SvROK(sv)
6970                           && SvRV(msv) == SvRV(sv))
6971             ) {
6972                 msv = sv;
6973                 SvGETMAGIC(msv);
6974             }
6975             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6976                 msv = SvRV(msv);
6977
6978             if (pat) {
6979                 /* this is a partially unrolled
6980                  *     sv_catsv_nomg(pat, msv);
6981                  * that allows us to adjust code block indices if
6982                  * needed */
6983                 STRLEN dlen;
6984                 char *dst = SvPV_force_nomg(pat, dlen);
6985                 orig_patlen = dlen;
6986                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6987                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6988                     sv_setpvn(pat, dst, dlen);
6989                     SvUTF8_on(pat);
6990                 }
6991                 sv_catsv_nomg(pat, msv);
6992                 rx = msv;
6993             }
6994             else {
6995                 /* We have only one SV to process, but we need to verify
6996                  * it is properly null terminated or we will fail asserts
6997                  * later. In theory we probably shouldn't get such SV's,
6998                  * but if we do we should handle it gracefully. */
6999                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
7000                     /* not a string, or a string with a trailing null */
7001                     pat = msv;
7002                 } else {
7003                     /* a string with no trailing null, we need to copy it
7004                      * so it has a trailing null */
7005                     pat = sv_2mortal(newSVsv(msv));
7006                 }
7007             }
7008
7009             if (code)
7010                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
7011         }
7012
7013         /* extract any code blocks within any embedded qr//'s */
7014         if (rx && SvTYPE(rx) == SVt_REGEXP
7015             && RX_ENGINE((REGEXP*)rx)->op_comp)
7016         {
7017
7018             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
7019             if (ri->code_blocks && ri->code_blocks->count) {
7020                 int i;
7021                 /* the presence of an embedded qr// with code means
7022                  * we should always recompile: the text of the
7023                  * qr// may not have changed, but it may be a
7024                  * different closure than last time */
7025                 *recompile_p = 1;
7026                 if (pRExC_state->code_blocks) {
7027                     int new_count = pRExC_state->code_blocks->count
7028                             + ri->code_blocks->count;
7029                     Renew(pRExC_state->code_blocks->cb,
7030                             new_count, struct reg_code_block);
7031                     pRExC_state->code_blocks->count = new_count;
7032                 }
7033                 else
7034                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
7035                                                     ri->code_blocks->count);
7036
7037                 for (i=0; i < ri->code_blocks->count; i++) {
7038                     struct reg_code_block *src, *dst;
7039                     STRLEN offset =  orig_patlen
7040                         + ReANY((REGEXP *)rx)->pre_prefix;
7041                     assert(n < pRExC_state->code_blocks->count);
7042                     src = &ri->code_blocks->cb[i];
7043                     dst = &pRExC_state->code_blocks->cb[n];
7044                     dst->start      = src->start + offset;
7045                     dst->end        = src->end   + offset;
7046                     dst->block      = src->block;
7047                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
7048                                             src->src_regex
7049                                                 ? src->src_regex
7050                                                 : (REGEXP*)rx);
7051                     n++;
7052                 }
7053             }
7054         }
7055     }
7056     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
7057     if (alloced)
7058         SvSETMAGIC(pat);
7059
7060     return pat;
7061 }
7062
7063
7064
7065 /* see if there are any run-time code blocks in the pattern.
7066  * False positives are allowed */
7067
7068 static bool
7069 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
7070                     char *pat, STRLEN plen)
7071 {
7072     int n = 0;
7073     STRLEN s;
7074
7075     PERL_UNUSED_CONTEXT;
7076
7077     for (s = 0; s < plen; s++) {
7078         if (   pRExC_state->code_blocks
7079             && n < pRExC_state->code_blocks->count
7080             && s == pRExC_state->code_blocks->cb[n].start)
7081         {
7082             s = pRExC_state->code_blocks->cb[n].end;
7083             n++;
7084             continue;
7085         }
7086         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
7087          * positives here */
7088         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
7089             (pat[s+2] == '{'
7090                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
7091         )
7092             return 1;
7093     }
7094     return 0;
7095 }
7096
7097 /* Handle run-time code blocks. We will already have compiled any direct
7098  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
7099  * copy of it, but with any literal code blocks blanked out and
7100  * appropriate chars escaped; then feed it into
7101  *
7102  *    eval "qr'modified_pattern'"
7103  *
7104  * For example,
7105  *
7106  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
7107  *
7108  * becomes
7109  *
7110  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
7111  *
7112  * After eval_sv()-ing that, grab any new code blocks from the returned qr
7113  * and merge them with any code blocks of the original regexp.
7114  *
7115  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
7116  * instead, just save the qr and return FALSE; this tells our caller that
7117  * the original pattern needs upgrading to utf8.
7118  */
7119
7120 static bool
7121 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
7122     char *pat, STRLEN plen)
7123 {
7124     SV *qr;
7125
7126     DECLARE_AND_GET_RE_DEBUG_FLAGS;
7127
7128     if (pRExC_state->runtime_code_qr) {
7129         /* this is the second time we've been called; this should
7130          * only happen if the main pattern got upgraded to utf8
7131          * during compilation; re-use the qr we compiled first time
7132          * round (which should be utf8 too)
7133          */
7134         qr = pRExC_state->runtime_code_qr;
7135         pRExC_state->runtime_code_qr = NULL;
7136         assert(RExC_utf8 && SvUTF8(qr));
7137     }
7138     else {
7139         int n = 0;
7140         STRLEN s;
7141         char *p, *newpat;
7142         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
7143         SV *sv, *qr_ref;
7144         dSP;
7145
7146         /* determine how many extra chars we need for ' and \ escaping */
7147         for (s = 0; s < plen; s++) {
7148             if (pat[s] == '\'' || pat[s] == '\\')
7149                 newlen++;
7150         }
7151
7152         Newx(newpat, newlen, char);
7153         p = newpat;
7154         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
7155
7156         for (s = 0; s < plen; s++) {
7157             if (   pRExC_state->code_blocks
7158                 && n < pRExC_state->code_blocks->count
7159                 && s == pRExC_state->code_blocks->cb[n].start)
7160             {
7161                 /* blank out literal code block so that they aren't
7162                  * recompiled: eg change from/to:
7163                  *     /(?{xyz})/
7164                  *     /(?=====)/
7165                  * and
7166                  *     /(??{xyz})/
7167                  *     /(?======)/
7168                  * and
7169                  *     /(?(?{xyz}))/
7170                  *     /(?(?=====))/
7171                 */
7172                 assert(pat[s]   == '(');
7173                 assert(pat[s+1] == '?');
7174                 *p++ = '(';
7175                 *p++ = '?';
7176                 s += 2;
7177                 while (s < pRExC_state->code_blocks->cb[n].end) {
7178                     *p++ = '=';
7179                     s++;
7180                 }
7181                 *p++ = ')';
7182                 n++;
7183                 continue;
7184             }
7185             if (pat[s] == '\'' || pat[s] == '\\')
7186                 *p++ = '\\';
7187             *p++ = pat[s];
7188         }
7189         *p++ = '\'';
7190         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
7191             *p++ = 'x';
7192             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
7193                 *p++ = 'x';
7194             }
7195         }
7196         *p++ = '\0';
7197         DEBUG_COMPILE_r({
7198             Perl_re_printf( aTHX_
7199                 "%sre-parsing pattern for runtime code:%s %s\n",
7200                 PL_colors[4], PL_colors[5], newpat);
7201         });
7202
7203         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
7204         Safefree(newpat);
7205
7206         ENTER;
7207         SAVETMPS;
7208         save_re_context();
7209         PUSHSTACKi(PERLSI_REQUIRE);
7210         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
7211          * parsing qr''; normally only q'' does this. It also alters
7212          * hints handling */
7213         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
7214         SvREFCNT_dec_NN(sv);
7215         SPAGAIN;
7216         qr_ref = POPs;
7217         PUTBACK;
7218         {
7219             SV * const errsv = ERRSV;
7220             if (SvTRUE_NN(errsv))
7221                 /* use croak_sv ? */
7222                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
7223         }
7224         assert(SvROK(qr_ref));
7225         qr = SvRV(qr_ref);
7226         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
7227         /* the leaving below frees the tmp qr_ref.
7228          * Give qr a life of its own */
7229         SvREFCNT_inc(qr);
7230         POPSTACK;
7231         FREETMPS;
7232         LEAVE;
7233
7234     }
7235
7236     if (!RExC_utf8 && SvUTF8(qr)) {
7237         /* first time through; the pattern got upgraded; save the
7238          * qr for the next time through */
7239         assert(!pRExC_state->runtime_code_qr);
7240         pRExC_state->runtime_code_qr = qr;
7241         return 0;
7242     }
7243
7244
7245     /* extract any code blocks within the returned qr//  */
7246
7247
7248     /* merge the main (r1) and run-time (r2) code blocks into one */
7249     {
7250         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
7251         struct reg_code_block *new_block, *dst;
7252         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
7253         int i1 = 0, i2 = 0;
7254         int r1c, r2c;
7255
7256         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
7257         {
7258             SvREFCNT_dec_NN(qr);
7259             return 1;
7260         }
7261
7262         if (!r1->code_blocks)
7263             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
7264
7265         r1c = r1->code_blocks->count;
7266         r2c = r2->code_blocks->count;
7267
7268         Newx(new_block, r1c + r2c, struct reg_code_block);
7269
7270         dst = new_block;
7271
7272         while (i1 < r1c || i2 < r2c) {
7273             struct reg_code_block *src;
7274             bool is_qr = 0;
7275
7276             if (i1 == r1c) {
7277                 src = &r2->code_blocks->cb[i2++];
7278                 is_qr = 1;
7279             }
7280             else if (i2 == r2c)
7281                 src = &r1->code_blocks->cb[i1++];
7282             else if (  r1->code_blocks->cb[i1].start
7283                      < r2->code_blocks->cb[i2].start)
7284             {
7285                 src = &r1->code_blocks->cb[i1++];
7286                 assert(src->end < r2->code_blocks->cb[i2].start);
7287             }
7288             else {
7289                 assert(  r1->code_blocks->cb[i1].start
7290                        > r2->code_blocks->cb[i2].start);
7291                 src = &r2->code_blocks->cb[i2++];
7292                 is_qr = 1;
7293                 assert(src->end < r1->code_blocks->cb[i1].start);
7294             }
7295
7296             assert(pat[src->start] == '(');
7297             assert(pat[src->end]   == ')');
7298             dst->start      = src->start;
7299             dst->end        = src->end;
7300             dst->block      = src->block;
7301             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
7302                                     : src->src_regex;
7303             dst++;
7304         }
7305         r1->code_blocks->count += r2c;
7306         Safefree(r1->code_blocks->cb);
7307         r1->code_blocks->cb = new_block;
7308     }
7309
7310     SvREFCNT_dec_NN(qr);
7311     return 1;
7312 }
7313
7314
7315 STATIC bool
7316 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
7317                       struct reg_substr_datum  *rsd,
7318                       struct scan_data_substrs *sub,
7319                       STRLEN longest_length)
7320 {
7321     /* This is the common code for setting up the floating and fixed length
7322      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
7323      * as to whether succeeded or not */
7324
7325     I32 t;
7326     SSize_t ml;
7327     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
7328     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
7329
7330     if (! (longest_length
7331            || (eol /* Can't have SEOL and MULTI */
7332                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
7333           )
7334             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
7335         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
7336     {
7337         return FALSE;
7338     }
7339
7340     /* copy the information about the longest from the reg_scan_data
7341         over to the program. */
7342     if (SvUTF8(sub->str)) {
7343         rsd->substr      = NULL;
7344         rsd->utf8_substr = sub->str;
7345     } else {
7346         rsd->substr      = sub->str;
7347         rsd->utf8_substr = NULL;
7348     }
7349     /* end_shift is how many chars that must be matched that
7350         follow this item. We calculate it ahead of time as once the
7351         lookbehind offset is added in we lose the ability to correctly
7352         calculate it.*/
7353     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
7354     rsd->end_shift = ml - sub->min_offset
7355         - longest_length
7356             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
7357              * intead? - DAPM
7358             + (SvTAIL(sub->str) != 0)
7359             */
7360         + sub->lookbehind;
7361
7362     t = (eol/* Can't have SEOL and MULTI */
7363          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
7364     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
7365
7366     return TRUE;
7367 }
7368
7369 STATIC void
7370 S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx)
7371 {
7372     /* Calculates and sets in the compiled pattern 'Rx' the string to compile,
7373      * properly wrapped with the right modifiers */
7374
7375     bool has_p     = ((RExC_rx->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7376     bool has_charset = RExC_utf8 || (get_regex_charset(RExC_rx->extflags)
7377                                                 != REGEX_DEPENDS_CHARSET);
7378
7379     /* The caret is output if there are any defaults: if not all the STD
7380         * flags are set, or if no character set specifier is needed */
7381     bool has_default =
7382                 (((RExC_rx->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7383                 || ! has_charset);
7384     bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7385                                                 == REG_RUN_ON_COMMENT_SEEN);
7386     U8 reganch = (U8)((RExC_rx->extflags & RXf_PMf_STD_PMMOD)
7387                         >> RXf_PMf_STD_PMMOD_SHIFT);
7388     const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7389     char *p;
7390     STRLEN pat_len = RExC_precomp_end - RExC_precomp;
7391
7392     /* We output all the necessary flags; we never output a minus, as all
7393         * those are defaults, so are
7394         * covered by the caret */
7395     const STRLEN wraplen = pat_len + has_p + has_runon
7396         + has_default       /* If needs a caret */
7397         + PL_bitcount[reganch] /* 1 char for each set standard flag */
7398
7399             /* If needs a character set specifier */
7400         + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7401         + (sizeof("(?:)") - 1);
7402
7403     PERL_ARGS_ASSERT_SET_REGEX_PV;
7404
7405     /* make sure PL_bitcount bounds not exceeded */
7406     STATIC_ASSERT_STMT(sizeof(STD_PAT_MODS) <= 8);
7407
7408     p = sv_grow(MUTABLE_SV(Rx), wraplen + 1); /* +1 for the ending NUL */
7409     SvPOK_on(Rx);
7410     if (RExC_utf8)
7411         SvFLAGS(Rx) |= SVf_UTF8;
7412     *p++='('; *p++='?';
7413
7414     /* If a default, cover it using the caret */
7415     if (has_default) {
7416         *p++= DEFAULT_PAT_MOD;
7417     }
7418     if (has_charset) {
7419         STRLEN len;
7420         const char* name;
7421
7422         name = get_regex_charset_name(RExC_rx->extflags, &len);
7423         if (strEQ(name, DEPENDS_PAT_MODS)) {  /* /d under UTF-8 => /u */
7424             assert(RExC_utf8);
7425             name = UNICODE_PAT_MODS;
7426             len = sizeof(UNICODE_PAT_MODS) - 1;
7427         }
7428         Copy(name, p, len, char);
7429         p += len;
7430     }
7431     if (has_p)
7432         *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7433     {
7434         char ch;
7435         while((ch = *fptr++)) {
7436             if(reganch & 1)
7437                 *p++ = ch;
7438             reganch >>= 1;
7439         }
7440     }
7441
7442     *p++ = ':';
7443     Copy(RExC_precomp, p, pat_len, char);
7444     assert ((RX_WRAPPED(Rx) - p) < 16);
7445     RExC_rx->pre_prefix = p - RX_WRAPPED(Rx);
7446     p += pat_len;
7447
7448     /* Adding a trailing \n causes this to compile properly:
7449             my $R = qr / A B C # D E/x; /($R)/
7450         Otherwise the parens are considered part of the comment */
7451     if (has_runon)
7452         *p++ = '\n';
7453     *p++ = ')';
7454     *p = 0;
7455     SvCUR_set(Rx, p - RX_WRAPPED(Rx));
7456 }
7457
7458 /*
7459  * Perl_re_op_compile - the perl internal RE engine's function to compile a
7460  * regular expression into internal code.
7461  * The pattern may be passed either as:
7462  *    a list of SVs (patternp plus pat_count)
7463  *    a list of OPs (expr)
7464  * If both are passed, the SV list is used, but the OP list indicates
7465  * which SVs are actually pre-compiled code blocks
7466  *
7467  * The SVs in the list have magic and qr overloading applied to them (and
7468  * the list may be modified in-place with replacement SVs in the latter
7469  * case).
7470  *
7471  * If the pattern hasn't changed from old_re, then old_re will be
7472  * returned.
7473  *
7474  * eng is the current engine. If that engine has an op_comp method, then
7475  * handle directly (i.e. we assume that op_comp was us); otherwise, just
7476  * do the initial concatenation of arguments and pass on to the external
7477  * engine.
7478  *
7479  * If is_bare_re is not null, set it to a boolean indicating whether the
7480  * arg list reduced (after overloading) to a single bare regex which has
7481  * been returned (i.e. /$qr/).
7482  *
7483  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
7484  *
7485  * pm_flags contains the PMf_* flags, typically based on those from the
7486  * pm_flags field of the related PMOP. Currently we're only interested in
7487  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL, PMf_WILDCARD.
7488  *
7489  * For many years this code had an initial sizing pass that calculated
7490  * (sometimes incorrectly, leading to security holes) the size needed for the
7491  * compiled pattern.  That was changed by commit
7492  * 7c932d07cab18751bfc7515b4320436273a459e2 in 5.29, which reallocs the size, a
7493  * node at a time, as parsing goes along.  Patches welcome to fix any obsolete
7494  * references to this sizing pass.
7495  *
7496  * Now, an initial crude guess as to the size needed is made, based on the
7497  * length of the pattern.  Patches welcome to improve that guess.  That amount
7498  * of space is malloc'd and then immediately freed, and then clawed back node
7499  * by node.  This design is to minimze, to the extent possible, memory churn
7500  * when doing the reallocs.
7501  *
7502  * A separate parentheses counting pass may be needed in some cases.
7503  * (Previously the sizing pass did this.)  Patches welcome to reduce the number
7504  * of these cases.
7505  *
7506  * The existence of a sizing pass necessitated design decisions that are no
7507  * longer needed.  There are potential areas of simplification.
7508  *
7509  * Beware that the optimization-preparation code in here knows about some
7510  * of the structure of the compiled regexp.  [I'll say.]
7511  */
7512
7513 REGEXP *
7514 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
7515                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
7516                      bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags)
7517 {
7518     REGEXP *Rx;         /* Capital 'R' means points to a REGEXP */
7519     STRLEN plen;
7520     char *exp;
7521     regnode *scan;
7522     I32 flags;
7523     SSize_t minlen = 0;
7524     U32 rx_flags;
7525     SV *pat;
7526     SV** new_patternp = patternp;
7527
7528     /* these are all flags - maybe they should be turned
7529      * into a single int with different bit masks */
7530     I32 sawlookahead = 0;
7531     I32 sawplus = 0;
7532     I32 sawopen = 0;
7533     I32 sawminmod = 0;
7534
7535     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
7536     bool recompile = 0;
7537     bool runtime_code = 0;
7538     scan_data_t data;
7539     RExC_state_t RExC_state;
7540     RExC_state_t * const pRExC_state = &RExC_state;
7541 #ifdef TRIE_STUDY_OPT
7542     int restudied = 0;
7543     RExC_state_t copyRExC_state;
7544 #endif
7545     DECLARE_AND_GET_RE_DEBUG_FLAGS;
7546
7547     PERL_ARGS_ASSERT_RE_OP_COMPILE;
7548
7549     DEBUG_r(if (!PL_colorset) reginitcolors());
7550
7551
7552     pRExC_state->warn_text = NULL;
7553     pRExC_state->unlexed_names = NULL;
7554     pRExC_state->code_blocks = NULL;
7555
7556     if (is_bare_re)
7557         *is_bare_re = FALSE;
7558
7559     if (expr && (expr->op_type == OP_LIST ||
7560                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
7561         /* allocate code_blocks if needed */
7562         OP *o;
7563         int ncode = 0;
7564
7565         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
7566             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
7567                 ncode++; /* count of DO blocks */
7568
7569         if (ncode)
7570             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
7571     }
7572
7573     if (!pat_count) {
7574         /* compile-time pattern with just OP_CONSTs and DO blocks */
7575
7576         int n;
7577         OP *o;
7578
7579         /* find how many CONSTs there are */
7580         assert(expr);
7581         n = 0;
7582         if (expr->op_type == OP_CONST)
7583             n = 1;
7584         else
7585             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7586                 if (o->op_type == OP_CONST)
7587                     n++;
7588             }
7589
7590         /* fake up an SV array */
7591
7592         assert(!new_patternp);
7593         Newx(new_patternp, n, SV*);
7594         SAVEFREEPV(new_patternp);
7595         pat_count = n;
7596
7597         n = 0;
7598         if (expr->op_type == OP_CONST)
7599             new_patternp[n] = cSVOPx_sv(expr);
7600         else
7601             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7602                 if (o->op_type == OP_CONST)
7603                     new_patternp[n++] = cSVOPo_sv;
7604             }
7605
7606     }
7607
7608     DEBUG_PARSE_r(Perl_re_printf( aTHX_
7609         "Assembling pattern from %d elements%s\n", pat_count,
7610             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7611
7612     /* set expr to the first arg op */
7613
7614     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
7615          && expr->op_type != OP_CONST)
7616     {
7617             expr = cLISTOPx(expr)->op_first;
7618             assert(   expr->op_type == OP_PUSHMARK
7619                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
7620                    || expr->op_type == OP_PADRANGE);
7621             expr = OpSIBLING(expr);
7622     }
7623
7624     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
7625                         expr, &recompile, NULL);
7626
7627     /* handle bare (possibly after overloading) regex: foo =~ $re */
7628     {
7629         SV *re = pat;
7630         if (SvROK(re))
7631             re = SvRV(re);
7632         if (SvTYPE(re) == SVt_REGEXP) {
7633             if (is_bare_re)
7634                 *is_bare_re = TRUE;
7635             SvREFCNT_inc(re);
7636             DEBUG_PARSE_r(Perl_re_printf( aTHX_
7637                 "Precompiled pattern%s\n",
7638                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7639
7640             return (REGEXP*)re;
7641         }
7642     }
7643
7644     exp = SvPV_nomg(pat, plen);
7645
7646     if (!eng->op_comp) {
7647         if ((SvUTF8(pat) && IN_BYTES)
7648                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7649         {
7650             /* make a temporary copy; either to convert to bytes,
7651              * or to avoid repeating get-magic / overloaded stringify */
7652             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7653                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7654         }
7655         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7656     }
7657
7658     /* ignore the utf8ness if the pattern is 0 length */
7659     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7660     RExC_uni_semantics = 0;
7661     RExC_contains_locale = 0;
7662     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7663     RExC_in_script_run = 0;
7664     RExC_study_started = 0;
7665     pRExC_state->runtime_code_qr = NULL;
7666     RExC_frame_head= NULL;
7667     RExC_frame_last= NULL;
7668     RExC_frame_count= 0;
7669     RExC_latest_warn_offset = 0;
7670     RExC_use_BRANCHJ = 0;
7671     RExC_warned_WARN_EXPERIMENTAL__VLB = 0;
7672     RExC_warned_WARN_EXPERIMENTAL__REGEX_SETS = 0;
7673     RExC_total_parens = 0;
7674     RExC_open_parens = NULL;
7675     RExC_close_parens = NULL;
7676     RExC_paren_names = NULL;
7677     RExC_size = 0;
7678     RExC_seen_d_op = FALSE;
7679 #ifdef DEBUGGING
7680     RExC_paren_name_list = NULL;
7681 #endif
7682
7683     DEBUG_r({
7684         RExC_mysv1= sv_newmortal();
7685         RExC_mysv2= sv_newmortal();
7686     });
7687
7688     DEBUG_COMPILE_r({
7689             SV *dsv= sv_newmortal();
7690             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7691             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7692                           PL_colors[4], PL_colors[5], s);
7693         });
7694
7695     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7696      * to utf8 */
7697
7698     if ((pm_flags & PMf_USE_RE_EVAL)
7699                 /* this second condition covers the non-regex literal case,
7700                  * i.e.  $foo =~ '(?{})'. */
7701                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7702     )
7703         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7704
7705   redo_parse:
7706     /* return old regex if pattern hasn't changed */
7707     /* XXX: note in the below we have to check the flags as well as the
7708      * pattern.
7709      *
7710      * Things get a touch tricky as we have to compare the utf8 flag
7711      * independently from the compile flags.  */
7712
7713     if (   old_re
7714         && !recompile
7715         && !!RX_UTF8(old_re) == !!RExC_utf8
7716         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7717         && RX_PRECOMP(old_re)
7718         && RX_PRELEN(old_re) == plen
7719         && memEQ(RX_PRECOMP(old_re), exp, plen)
7720         && !runtime_code /* with runtime code, always recompile */ )
7721     {
7722         DEBUG_COMPILE_r({
7723             SV *dsv= sv_newmortal();
7724             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7725             Perl_re_printf( aTHX_  "%sSkipping recompilation of unchanged REx%s %s\n",
7726                           PL_colors[4], PL_colors[5], s);
7727         });
7728         return old_re;
7729     }
7730
7731     /* Allocate the pattern's SV */
7732     RExC_rx_sv = Rx = (REGEXP*) newSV_type(SVt_REGEXP);
7733     RExC_rx = ReANY(Rx);
7734     if ( RExC_rx == NULL )
7735         FAIL("Regexp out of space");
7736
7737     rx_flags = orig_rx_flags;
7738
7739     if (   (UTF || RExC_uni_semantics)
7740         && initial_charset == REGEX_DEPENDS_CHARSET)
7741     {
7742
7743         /* Set to use unicode semantics if the pattern is in utf8 and has the
7744          * 'depends' charset specified, as it means unicode when utf8  */
7745         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7746         RExC_uni_semantics = 1;
7747     }
7748
7749     RExC_pm_flags = pm_flags;
7750
7751     if (runtime_code) {
7752         assert(TAINTING_get || !TAINT_get);
7753         if (TAINT_get)
7754             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7755
7756         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7757             /* whoops, we have a non-utf8 pattern, whilst run-time code
7758              * got compiled as utf8. Try again with a utf8 pattern */
7759             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7760                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7761             goto redo_parse;
7762         }
7763     }
7764     assert(!pRExC_state->runtime_code_qr);
7765
7766     RExC_sawback = 0;
7767
7768     RExC_seen = 0;
7769     RExC_maxlen = 0;
7770     RExC_in_lookbehind = 0;
7771     RExC_in_lookahead = 0;
7772     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7773     RExC_recode_x_to_native = 0;
7774     RExC_in_multi_char_class = 0;
7775
7776     RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = RExC_precomp = exp;
7777     RExC_precomp_end = RExC_end = exp + plen;
7778     RExC_nestroot = 0;
7779     RExC_whilem_seen = 0;
7780     RExC_end_op = NULL;
7781     RExC_recurse = NULL;
7782     RExC_study_chunk_recursed = NULL;
7783     RExC_study_chunk_recursed_bytes= 0;
7784     RExC_recurse_count = 0;
7785     RExC_sets_depth = 0;
7786     pRExC_state->code_index = 0;
7787
7788     /* Initialize the string in the compiled pattern.  This is so that there is
7789      * something to output if necessary */
7790     set_regex_pv(pRExC_state, Rx);
7791
7792     DEBUG_PARSE_r({
7793         Perl_re_printf( aTHX_
7794             "Starting parse and generation\n");
7795         RExC_lastnum=0;
7796         RExC_lastparse=NULL;
7797     });
7798
7799     /* Allocate space and zero-initialize. Note, the two step process
7800        of zeroing when in debug mode, thus anything assigned has to
7801        happen after that */
7802     if (!  RExC_size) {
7803
7804         /* On the first pass of the parse, we guess how big this will be.  Then
7805          * we grow in one operation to that amount and then give it back.  As
7806          * we go along, we re-allocate what we need.
7807          *
7808          * XXX Currently the guess is essentially that the pattern will be an
7809          * EXACT node with one byte input, one byte output.  This is crude, and
7810          * better heuristics are welcome.
7811          *
7812          * On any subsequent passes, we guess what we actually computed in the
7813          * latest earlier pass.  Such a pass probably didn't complete so is
7814          * missing stuff.  We could improve those guesses by knowing where the
7815          * parse stopped, and use the length so far plus apply the above
7816          * assumption to what's left. */
7817         RExC_size = STR_SZ(RExC_end - RExC_start);
7818     }
7819
7820     Newxc(RExC_rxi, sizeof(regexp_internal) + RExC_size, char, regexp_internal);
7821     if ( RExC_rxi == NULL )
7822         FAIL("Regexp out of space");
7823
7824     Zero(RExC_rxi, sizeof(regexp_internal) + RExC_size, char);
7825     RXi_SET( RExC_rx, RExC_rxi );
7826
7827     /* We start from 0 (over from 0 in the case this is a reparse.  The first
7828      * node parsed will give back any excess memory we have allocated so far).
7829      * */
7830     RExC_size = 0;
7831
7832     /* non-zero initialization begins here */
7833     RExC_rx->engine= eng;
7834     RExC_rx->extflags = rx_flags;
7835     RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7836
7837     if (pm_flags & PMf_IS_QR) {
7838         RExC_rxi->code_blocks = pRExC_state->code_blocks;
7839         if (RExC_rxi->code_blocks) {
7840             RExC_rxi->code_blocks->refcnt++;
7841         }
7842     }
7843
7844     RExC_rx->intflags = 0;
7845
7846     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7847     RExC_parse = exp;
7848
7849     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7850      * code makes sure the final byte is an uncounted NUL.  But should this
7851      * ever not be the case, lots of things could read beyond the end of the
7852      * buffer: loops like
7853      *      while(isFOO(*RExC_parse)) RExC_parse++;
7854      *      strchr(RExC_parse, "foo");
7855      * etc.  So it is worth noting. */
7856     assert(*RExC_end == '\0');
7857
7858     RExC_naughty = 0;
7859     RExC_npar = 1;
7860     RExC_parens_buf_size = 0;
7861     RExC_emit_start = RExC_rxi->program;
7862     pRExC_state->code_index = 0;
7863
7864     *((char*) RExC_emit_start) = (char) REG_MAGIC;
7865     RExC_emit = 1;
7866
7867     /* Do the parse */
7868     if (reg(pRExC_state, 0, &flags, 1)) {
7869
7870         /* Success!, But we may need to redo the parse knowing how many parens
7871          * there actually are */
7872         if (IN_PARENS_PASS) {
7873             flags |= RESTART_PARSE;
7874         }
7875
7876         /* We have that number in RExC_npar */
7877         RExC_total_parens = RExC_npar;
7878     }
7879     else if (! MUST_RESTART(flags)) {
7880         ReREFCNT_dec(Rx);
7881         Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags);
7882     }
7883
7884     /* Here, we either have success, or we have to redo the parse for some reason */
7885     if (MUST_RESTART(flags)) {
7886
7887         /* It's possible to write a regexp in ascii that represents Unicode
7888         codepoints outside of the byte range, such as via \x{100}. If we
7889         detect such a sequence we have to convert the entire pattern to utf8
7890         and then recompile, as our sizing calculation will have been based
7891         on 1 byte == 1 character, but we will need to use utf8 to encode
7892         at least some part of the pattern, and therefore must convert the whole
7893         thing.
7894         -- dmq */
7895         if (flags & NEED_UTF8) {
7896
7897             /* We have stored the offset of the final warning output so far.
7898              * That must be adjusted.  Any variant characters between the start
7899              * of the pattern and this warning count for 2 bytes in the final,
7900              * so just add them again */
7901             if (UNLIKELY(RExC_latest_warn_offset > 0)) {
7902                 RExC_latest_warn_offset +=
7903                             variant_under_utf8_count((U8 *) exp, (U8 *) exp
7904                                                 + RExC_latest_warn_offset);
7905             }
7906             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7907             pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7908             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse after upgrade\n"));
7909         }
7910         else {
7911             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse\n"));
7912         }
7913
7914         if (ALL_PARENS_COUNTED) {
7915             /* Make enough room for all the known parens, and zero it */
7916             Renew(RExC_open_parens, RExC_total_parens, regnode_offset);
7917             Zero(RExC_open_parens, RExC_total_parens, regnode_offset);
7918             RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
7919
7920             Renew(RExC_close_parens, RExC_total_parens, regnode_offset);
7921             Zero(RExC_close_parens, RExC_total_parens, regnode_offset);
7922         }
7923         else { /* Parse did not complete.  Reinitialize the parentheses
7924                   structures */
7925             RExC_total_parens = 0;
7926             if (RExC_open_parens) {
7927                 Safefree(RExC_open_parens);
7928                 RExC_open_parens = NULL;
7929             }
7930             if (RExC_close_parens) {
7931                 Safefree(RExC_close_parens);
7932                 RExC_close_parens = NULL;
7933             }
7934         }
7935
7936         /* Clean up what we did in this parse */
7937         SvREFCNT_dec_NN(RExC_rx_sv);
7938
7939         goto redo_parse;
7940     }
7941
7942     /* Here, we have successfully parsed and generated the pattern's program
7943      * for the regex engine.  We are ready to finish things up and look for
7944      * optimizations. */
7945
7946     /* Update the string to compile, with correct modifiers, etc */
7947     set_regex_pv(pRExC_state, Rx);
7948
7949     RExC_rx->nparens = RExC_total_parens - 1;
7950
7951     /* Uses the upper 4 bits of the FLAGS field, so keep within that size */
7952     if (RExC_whilem_seen > 15)
7953         RExC_whilem_seen = 15;
7954
7955     DEBUG_PARSE_r({
7956         Perl_re_printf( aTHX_
7957             "Required size %" IVdf " nodes\n", (IV)RExC_size);
7958         RExC_lastnum=0;
7959         RExC_lastparse=NULL;
7960     });
7961
7962 #ifdef RE_TRACK_PATTERN_OFFSETS
7963     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7964                           "%s %" UVuf " bytes for offset annotations.\n",
7965                           RExC_offsets ? "Got" : "Couldn't get",
7966                           (UV)((RExC_offsets[0] * 2 + 1))));
7967     DEBUG_OFFSETS_r(if (RExC_offsets) {
7968         const STRLEN len = RExC_offsets[0];
7969         STRLEN i;
7970         DECLARE_AND_GET_RE_DEBUG_FLAGS;
7971         Perl_re_printf( aTHX_
7972                       "Offsets: [%" UVuf "]\n\t", (UV)RExC_offsets[0]);
7973         for (i = 1; i <= len; i++) {
7974             if (RExC_offsets[i*2-1] || RExC_offsets[i*2])
7975                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7976                 (UV)i, (UV)RExC_offsets[i*2-1], (UV)RExC_offsets[i*2]);
7977         }
7978         Perl_re_printf( aTHX_  "\n");
7979     });
7980
7981 #else
7982     SetProgLen(RExC_rxi,RExC_size);
7983 #endif
7984
7985     DEBUG_DUMP_PRE_OPTIMIZE_r({
7986         SV * const sv = sv_newmortal();
7987         RXi_GET_DECL(RExC_rx, ri);
7988         DEBUG_RExC_seen();
7989         Perl_re_printf( aTHX_ "Program before optimization:\n");
7990
7991         (void)dumpuntil(RExC_rx, ri->program, ri->program + 1, NULL, NULL,
7992                         sv, 0, 0);
7993     });
7994
7995     DEBUG_OPTIMISE_r(
7996         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7997     );
7998
7999     /* XXXX To minimize changes to RE engine we always allocate
8000        3-units-long substrs field. */
8001     Newx(RExC_rx->substrs, 1, struct reg_substr_data);
8002     if (RExC_recurse_count) {
8003         Newx(RExC_recurse, RExC_recurse_count, regnode *);
8004         SAVEFREEPV(RExC_recurse);
8005     }
8006
8007     if (RExC_seen & REG_RECURSE_SEEN) {
8008         /* Note, RExC_total_parens is 1 + the number of parens in a pattern.
8009          * So its 1 if there are no parens. */
8010         RExC_study_chunk_recursed_bytes= (RExC_total_parens >> 3) +
8011                                          ((RExC_total_parens & 0x07) != 0);
8012         Newx(RExC_study_chunk_recursed,
8013              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
8014         SAVEFREEPV(RExC_study_chunk_recursed);
8015     }
8016
8017   reStudy:
8018     RExC_rx->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
8019     DEBUG_r(
8020         RExC_study_chunk_recursed_count= 0;
8021     );
8022     Zero(RExC_rx->substrs, 1, struct reg_substr_data);
8023     if (RExC_study_chunk_recursed) {
8024         Zero(RExC_study_chunk_recursed,
8025              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
8026     }
8027
8028
8029 #ifdef TRIE_STUDY_OPT
8030     if (!restudied) {
8031         StructCopy(&zero_scan_data, &data, scan_data_t);
8032         copyRExC_state = RExC_state;
8033     } else {
8034         U32 seen=RExC_seen;
8035         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
8036
8037         RExC_state = copyRExC_state;
8038         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
8039             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
8040         else
8041             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
8042         StructCopy(&zero_scan_data, &data, scan_data_t);
8043     }
8044 #else
8045     StructCopy(&zero_scan_data, &data, scan_data_t);
8046 #endif
8047
8048     /* Dig out information for optimizations. */
8049     RExC_rx->extflags = RExC_flags; /* was pm_op */
8050     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
8051
8052     if (UTF)
8053         SvUTF8_on(Rx);  /* Unicode in it? */
8054     RExC_rxi->regstclass = NULL;
8055     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
8056         RExC_rx->intflags |= PREGf_NAUGHTY;
8057     scan = RExC_rxi->program + 1;               /* First BRANCH. */
8058
8059     /* testing for BRANCH here tells us whether there is "must appear"
8060        data in the pattern. If there is then we can use it for optimisations */
8061     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
8062                                                   */
8063         SSize_t fake;
8064         STRLEN longest_length[2];
8065         regnode_ssc ch_class; /* pointed to by data */
8066         int stclass_flag;
8067         SSize_t last_close = 0; /* pointed to by data */
8068         regnode *first= scan;
8069         regnode *first_next= regnext(first);
8070         int i;
8071
8072         /*
8073          * Skip introductions and multiplicators >= 1
8074          * so that we can extract the 'meat' of the pattern that must
8075          * match in the large if() sequence following.
8076          * NOTE that EXACT is NOT covered here, as it is normally
8077          * picked up by the optimiser separately.
8078          *
8079          * This is unfortunate as the optimiser isnt handling lookahead
8080          * properly currently.
8081          *
8082          */
8083         while ((OP(first) == OPEN && (sawopen = 1)) ||
8084                /* An OR of *one* alternative - should not happen now. */
8085             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
8086             /* for now we can't handle lookbehind IFMATCH*/
8087             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
8088             (OP(first) == PLUS) ||
8089             (OP(first) == MINMOD) ||
8090                /* An {n,m} with n>0 */
8091             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
8092             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
8093         {
8094                 /*
8095                  * the only op that could be a regnode is PLUS, all the rest
8096                  * will be regnode_1 or regnode_2.
8097                  *
8098                  * (yves doesn't think this is true)
8099                  */
8100                 if (OP(first) == PLUS)
8101                     sawplus = 1;
8102                 else {
8103                     if (OP(first) == MINMOD)
8104                         sawminmod = 1;
8105                     first += regarglen[OP(first)];
8106                 }
8107                 first = NEXTOPER(first);
8108                 first_next= regnext(first);
8109         }
8110
8111         /* Starting-point info. */
8112       again:
8113         DEBUG_PEEP("first:", first, 0, 0);
8114         /* Ignore EXACT as we deal with it later. */
8115         if (PL_regkind[OP(first)] == EXACT) {
8116             if (! isEXACTFish(OP(first))) {
8117                 NOOP;   /* Empty, get anchored substr later. */
8118             }
8119             else
8120                 RExC_rxi->regstclass = first;
8121         }
8122 #ifdef TRIE_STCLASS
8123         else if (PL_regkind[OP(first)] == TRIE &&
8124                 ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0)
8125         {
8126             /* this can happen only on restudy */
8127             RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
8128         }
8129 #endif
8130         else if (REGNODE_SIMPLE(OP(first)))
8131             RExC_rxi->regstclass = first;
8132         else if (PL_regkind[OP(first)] == BOUND ||
8133                  PL_regkind[OP(first)] == NBOUND)
8134             RExC_rxi->regstclass = first;
8135         else if (PL_regkind[OP(first)] == BOL) {
8136             RExC_rx->intflags |= (OP(first) == MBOL
8137                            ? PREGf_ANCH_MBOL
8138                            : PREGf_ANCH_SBOL);
8139             first = NEXTOPER(first);
8140             goto again;
8141         }
8142         else if (OP(first) == GPOS) {
8143             RExC_rx->intflags |= PREGf_ANCH_GPOS;
8144             first = NEXTOPER(first);
8145             goto again;
8146         }
8147         else if ((!sawopen || !RExC_sawback) &&
8148             !sawlookahead &&
8149             (OP(first) == STAR &&
8150             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
8151             !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
8152         {
8153             /* turn .* into ^.* with an implied $*=1 */
8154             const int type =
8155                 (OP(NEXTOPER(first)) == REG_ANY)
8156                     ? PREGf_ANCH_MBOL
8157                     : PREGf_ANCH_SBOL;
8158             RExC_rx->intflags |= (type | PREGf_IMPLICIT);
8159             first = NEXTOPER(first);
8160             goto again;
8161         }
8162         if (sawplus && !sawminmod && !sawlookahead
8163             && (!sawopen || !RExC_sawback)
8164             && !pRExC_state->code_blocks) /* May examine pos and $& */
8165             /* x+ must match at the 1st pos of run of x's */
8166             RExC_rx->intflags |= PREGf_SKIP;
8167
8168         /* Scan is after the zeroth branch, first is atomic matcher. */
8169 #ifdef TRIE_STUDY_OPT
8170         DEBUG_PARSE_r(
8171             if (!restudied)
8172                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8173                               (IV)(first - scan + 1))
8174         );
8175 #else
8176         DEBUG_PARSE_r(
8177             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8178                 (IV)(first - scan + 1))
8179         );
8180 #endif
8181
8182
8183         /*
8184         * If there's something expensive in the r.e., find the
8185         * longest literal string that must appear and make it the
8186         * regmust.  Resolve ties in favor of later strings, since
8187         * the regstart check works with the beginning of the r.e.
8188         * and avoiding duplication strengthens checking.  Not a
8189         * strong reason, but sufficient in the absence of others.
8190         * [Now we resolve ties in favor of the earlier string if
8191         * it happens that c_offset_min has been invalidated, since the
8192         * earlier string may buy us something the later one won't.]
8193         */
8194
8195         data.substrs[0].str = newSVpvs("");
8196         data.substrs[1].str = newSVpvs("");
8197         data.last_found = newSVpvs("");
8198         data.cur_is_floating = 0; /* initially any found substring is fixed */
8199         ENTER_with_name("study_chunk");
8200         SAVEFREESV(data.substrs[0].str);
8201         SAVEFREESV(data.substrs[1].str);
8202         SAVEFREESV(data.last_found);
8203         first = scan;
8204         if (!RExC_rxi->regstclass) {
8205             ssc_init(pRExC_state, &ch_class);
8206             data.start_class = &ch_class;
8207             stclass_flag = SCF_DO_STCLASS_AND;
8208         } else                          /* XXXX Check for BOUND? */
8209             stclass_flag = 0;
8210         data.last_closep = &last_close;
8211
8212         DEBUG_RExC_seen();
8213         /*
8214          * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
8215          * (NO top level branches)
8216          */
8217         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
8218                              scan + RExC_size, /* Up to end */
8219             &data, -1, 0, NULL,
8220             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
8221                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
8222             0, TRUE);
8223
8224
8225         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
8226
8227
8228         if ( RExC_total_parens == 1 && !data.cur_is_floating
8229              && data.last_start_min == 0 && data.last_end > 0
8230              && !RExC_seen_zerolen
8231              && !(RExC_seen & REG_VERBARG_SEEN)
8232              && !(RExC_seen & REG_GPOS_SEEN)
8233         ){
8234             RExC_rx->extflags |= RXf_CHECK_ALL;
8235         }
8236         scan_commit(pRExC_state, &data,&minlen, 0);
8237
8238
8239         /* XXX this is done in reverse order because that's the way the
8240          * code was before it was parameterised. Don't know whether it
8241          * actually needs doing in reverse order. DAPM */
8242         for (i = 1; i >= 0; i--) {
8243             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
8244
8245             if (   !(   i
8246                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
8247                      &&    data.substrs[0].min_offset
8248                         == data.substrs[1].min_offset
8249                      &&    SvCUR(data.substrs[0].str)
8250                         == SvCUR(data.substrs[1].str)
8251                     )
8252                 && S_setup_longest (aTHX_ pRExC_state,
8253                                         &(RExC_rx->substrs->data[i]),
8254                                         &(data.substrs[i]),
8255                                         longest_length[i]))
8256             {
8257                 RExC_rx->substrs->data[i].min_offset =
8258                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
8259
8260                 RExC_rx->substrs->data[i].max_offset = data.substrs[i].max_offset;
8261                 /* Don't offset infinity */
8262                 if (data.substrs[i].max_offset < OPTIMIZE_INFTY)
8263                     RExC_rx->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
8264                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
8265             }
8266             else {
8267                 RExC_rx->substrs->data[i].substr      = NULL;
8268                 RExC_rx->substrs->data[i].utf8_substr = NULL;
8269                 longest_length[i] = 0;
8270             }
8271         }
8272
8273         LEAVE_with_name("study_chunk");
8274
8275         if (RExC_rxi->regstclass
8276             && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY))
8277             RExC_rxi->regstclass = NULL;
8278
8279         if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr)
8280               || RExC_rx->substrs->data[0].min_offset)
8281             && stclass_flag
8282             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8283             && is_ssc_worth_it(pRExC_state, data.start_class))
8284         {
8285             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8286
8287             ssc_finalize(pRExC_state, data.start_class);
8288
8289             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8290             StructCopy(data.start_class,
8291                        (regnode_ssc*)RExC_rxi->data->data[n],
8292                        regnode_ssc);
8293             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8294             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8295             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
8296                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8297                       Perl_re_printf( aTHX_
8298                                     "synthetic stclass \"%s\".\n",
8299                                     SvPVX_const(sv));});
8300             data.start_class = NULL;
8301         }
8302
8303         /* A temporary algorithm prefers floated substr to fixed one of
8304          * same length to dig more info. */
8305         i = (longest_length[0] <= longest_length[1]);
8306         RExC_rx->substrs->check_ix = i;
8307         RExC_rx->check_end_shift  = RExC_rx->substrs->data[i].end_shift;
8308         RExC_rx->check_substr     = RExC_rx->substrs->data[i].substr;
8309         RExC_rx->check_utf8       = RExC_rx->substrs->data[i].utf8_substr;
8310         RExC_rx->check_offset_min = RExC_rx->substrs->data[i].min_offset;
8311         RExC_rx->check_offset_max = RExC_rx->substrs->data[i].max_offset;
8312         if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
8313             RExC_rx->intflags |= PREGf_NOSCAN;
8314
8315         if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) {
8316             RExC_rx->extflags |= RXf_USE_INTUIT;
8317             if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8))
8318                 RExC_rx->extflags |= RXf_INTUIT_TAIL;
8319         }
8320
8321         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
8322         if ( (STRLEN)minlen < longest_length[1] )
8323             minlen= longest_length[1];
8324         if ( (STRLEN)minlen < longest_length[0] )
8325             minlen= longest_length[0];
8326         */
8327     }
8328     else {
8329         /* Several toplevels. Best we can is to set minlen. */
8330         SSize_t fake;
8331         regnode_ssc ch_class;
8332         SSize_t last_close = 0;
8333
8334         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
8335
8336         scan = RExC_rxi->program + 1;
8337         ssc_init(pRExC_state, &ch_class);
8338         data.start_class = &ch_class;
8339         data.last_closep = &last_close;
8340
8341         DEBUG_RExC_seen();
8342         /*
8343          * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
8344          * (patterns WITH top level branches)
8345          */
8346         minlen = study_chunk(pRExC_state,
8347             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
8348             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
8349                                                       ? SCF_TRIE_DOING_RESTUDY
8350                                                       : 0),
8351             0, TRUE);
8352
8353         CHECK_RESTUDY_GOTO_butfirst(NOOP);
8354
8355         RExC_rx->check_substr = NULL;
8356         RExC_rx->check_utf8 = NULL;
8357         RExC_rx->substrs->data[0].substr      = NULL;
8358         RExC_rx->substrs->data[0].utf8_substr = NULL;
8359         RExC_rx->substrs->data[1].substr      = NULL;
8360         RExC_rx->substrs->data[1].utf8_substr = NULL;
8361
8362         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8363             && is_ssc_worth_it(pRExC_state, data.start_class))
8364         {
8365             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8366
8367             ssc_finalize(pRExC_state, data.start_class);
8368
8369             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8370             StructCopy(data.start_class,
8371                        (regnode_ssc*)RExC_rxi->data->data[n],
8372                        regnode_ssc);
8373             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8374             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8375             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
8376                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8377                       Perl_re_printf( aTHX_
8378                                     "synthetic stclass \"%s\".\n",
8379                                     SvPVX_const(sv));});
8380             data.start_class = NULL;
8381         }
8382     }
8383
8384     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
8385         RExC_rx->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
8386         RExC_rx->maxlen = REG_INFTY;
8387     }
8388     else {
8389         RExC_rx->maxlen = RExC_maxlen;
8390     }
8391
8392     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
8393        the "real" pattern. */
8394     DEBUG_OPTIMISE_r({
8395         Perl_re_printf( aTHX_ "minlen: %" IVdf " RExC_rx->minlen:%" IVdf " maxlen:%" IVdf "\n",
8396                       (IV)minlen, (IV)RExC_rx->minlen, (IV)RExC_maxlen);
8397     });
8398     RExC_rx->minlenret = minlen;
8399     if (RExC_rx->minlen < minlen)
8400         RExC_rx->minlen = minlen;
8401
8402     if (RExC_seen & REG_RECURSE_SEEN ) {
8403         RExC_rx->intflags |= PREGf_RECURSE_SEEN;
8404         Newx(RExC_rx->recurse_locinput, RExC_rx->nparens + 1, char *);
8405     }
8406     if (RExC_seen & REG_GPOS_SEEN)
8407         RExC_rx->intflags |= PREGf_GPOS_SEEN;
8408     if (RExC_seen & REG_LOOKBEHIND_SEEN)
8409         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
8410                                                 lookbehind */
8411     if (pRExC_state->code_blocks)
8412         RExC_rx->extflags |= RXf_EVAL_SEEN;
8413     if (RExC_seen & REG_VERBARG_SEEN)
8414     {
8415         RExC_rx->intflags |= PREGf_VERBARG_SEEN;
8416         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
8417     }
8418     if (RExC_seen & REG_CUTGROUP_SEEN)
8419         RExC_rx->intflags |= PREGf_CUTGROUP_SEEN;
8420     if (pm_flags & PMf_USE_RE_EVAL)
8421         RExC_rx->intflags |= PREGf_USE_RE_EVAL;
8422     if (RExC_paren_names)
8423         RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
8424     else
8425         RXp_PAREN_NAMES(RExC_rx) = NULL;
8426
8427     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
8428      * so it can be used in pp.c */
8429     if (RExC_rx->intflags & PREGf_ANCH)
8430         RExC_rx->extflags |= RXf_IS_ANCHORED;
8431
8432
8433     {
8434         /* this is used to identify "special" patterns that might result
8435          * in Perl NOT calling the regex engine and instead doing the match "itself",
8436          * particularly special cases in split//. By having the regex compiler
8437          * do this pattern matching at a regop level (instead of by inspecting the pattern)
8438          * we avoid weird issues with equivalent patterns resulting in different behavior,
8439          * AND we allow non Perl engines to get the same optimizations by the setting the
8440          * flags appropriately - Yves */
8441         regnode *first = RExC_rxi->program + 1;
8442         U8 fop = OP(first);
8443         regnode *next = regnext(first);
8444         U8 nop = OP(next);
8445
8446         if (PL_regkind[fop] == NOTHING && nop == END)
8447             RExC_rx->extflags |= RXf_NULL;
8448         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
8449             /* when fop is SBOL first->flags will be true only when it was
8450              * produced by parsing /\A/, and not when parsing /^/. This is
8451              * very important for the split code as there we want to
8452              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
8453              * See rt #122761 for more details. -- Yves */
8454             RExC_rx->extflags |= RXf_START_ONLY;
8455         else if (fop == PLUS
8456                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
8457                  && nop == END)
8458             RExC_rx->extflags |= RXf_WHITE;
8459         else if ( RExC_rx->extflags & RXf_SPLIT
8460                   && (PL_regkind[fop] == EXACT && ! isEXACTFish(fop))
8461                   && STR_LEN(first) == 1
8462                   && *(STRING(first)) == ' '
8463                   && nop == END )
8464             RExC_rx->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
8465
8466     }
8467
8468     if (RExC_contains_locale) {
8469         RXp_EXTFLAGS(RExC_rx) |= RXf_TAINTED;
8470     }
8471
8472 #ifdef DEBUGGING
8473     if (RExC_paren_names) {
8474         RExC_rxi->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
8475         RExC_rxi->data->data[RExC_rxi->name_list_idx]
8476                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
8477     } else
8478 #endif
8479     RExC_rxi->name_list_idx = 0;
8480
8481     while ( RExC_recurse_count > 0 ) {
8482         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
8483         /*
8484          * This data structure is set up in study_chunk() and is used
8485          * to calculate the distance between a GOSUB regopcode and
8486          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
8487          * it refers to.
8488          *
8489          * If for some reason someone writes code that optimises
8490          * away a GOSUB opcode then the assert should be changed to
8491          * an if(scan) to guard the ARG2L_SET() - Yves
8492          *
8493          */
8494         assert(scan && OP(scan) == GOSUB);
8495         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - REGNODE_OFFSET(scan));
8496     }
8497
8498     Newxz(RExC_rx->offs, RExC_total_parens, regexp_paren_pair);
8499     /* assume we don't need to swap parens around before we match */
8500     DEBUG_TEST_r({
8501         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
8502             (unsigned long)RExC_study_chunk_recursed_count);
8503     });
8504     DEBUG_DUMP_r({
8505         DEBUG_RExC_seen();
8506         Perl_re_printf( aTHX_ "Final program:\n");
8507         regdump(RExC_rx);
8508     });
8509
8510     if (RExC_open_parens) {
8511         Safefree(RExC_open_parens);
8512         RExC_open_parens = NULL;
8513     }
8514     if (RExC_close_parens) {
8515         Safefree(RExC_close_parens);
8516         RExC_close_parens = NULL;
8517     }
8518
8519 #ifdef USE_ITHREADS
8520     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
8521      * by setting the regexp SV to readonly-only instead. If the
8522      * pattern's been recompiled, the USEDness should remain. */
8523     if (old_re && SvREADONLY(old_re))
8524         SvREADONLY_on(Rx);
8525 #endif
8526     return Rx;
8527 }
8528
8529
8530 SV*
8531 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
8532                     const U32 flags)
8533 {
8534     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
8535
8536     PERL_UNUSED_ARG(value);
8537
8538     if (flags & RXapif_FETCH) {
8539         return reg_named_buff_fetch(rx, key, flags);
8540     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
8541         Perl_croak_no_modify();
8542         return NULL;
8543     } else if (flags & RXapif_EXISTS) {
8544         return reg_named_buff_exists(rx, key, flags)
8545             ? &PL_sv_yes
8546             : &PL_sv_no;
8547     } else if (flags & RXapif_REGNAMES) {
8548         return reg_named_buff_all(rx, flags);
8549     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
8550         return reg_named_buff_scalar(rx, flags);
8551     } else {
8552         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
8553         return NULL;
8554     }
8555 }
8556
8557 SV*
8558 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
8559                          const U32 flags)
8560 {
8561     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
8562     PERL_UNUSED_ARG(lastkey);
8563
8564     if (flags & RXapif_FIRSTKEY)
8565         return reg_named_buff_firstkey(rx, flags);
8566     else if (flags & RXapif_NEXTKEY)
8567         return reg_named_buff_nextkey(rx, flags);
8568     else {
8569         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
8570                                             (int)flags);
8571         return NULL;
8572     }
8573 }
8574
8575 SV*
8576 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
8577                           const U32 flags)
8578 {
8579     SV *ret;
8580     struct regexp *const rx = ReANY(r);
8581
8582     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
8583
8584     if (rx && RXp_PAREN_NAMES(rx)) {
8585         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
8586         if (he_str) {
8587             IV i;
8588             SV* sv_dat=HeVAL(he_str);
8589             I32 *nums=(I32*)SvPVX(sv_dat);
8590             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
8591             for ( i=0; i<SvIVX(sv_dat); i++ ) {
8592                 if ((I32)(rx->nparens) >= nums[i]
8593                     && rx->offs[nums[i]].start != -1
8594                     && rx->offs[nums[i]].end != -1)
8595                 {
8596                     ret = newSVpvs("");
8597                     CALLREG_NUMBUF_FETCH(r, nums[i], ret);
8598                     if (!retarray)
8599                         return ret;
8600                 } else {
8601                     if (retarray)
8602                         ret = newSVsv(&PL_sv_undef);
8603                 }
8604                 if (retarray)
8605                     av_push(retarray, ret);
8606             }
8607             if (retarray)
8608                 return newRV_noinc(MUTABLE_SV(retarray));
8609         }
8610     }
8611     return NULL;
8612 }
8613
8614 bool
8615 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
8616                            const U32 flags)
8617 {
8618     struct regexp *const rx = ReANY(r);
8619
8620     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
8621
8622     if (rx && RXp_PAREN_NAMES(rx)) {
8623         if (flags & RXapif_ALL) {
8624             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
8625         } else {
8626             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
8627             if (sv) {
8628                 SvREFCNT_dec_NN(sv);
8629                 return TRUE;
8630             } else {
8631                 return FALSE;
8632             }
8633         }
8634     } else {
8635         return FALSE;
8636     }
8637 }
8638
8639 SV*
8640 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8641 {
8642     struct regexp *const rx = ReANY(r);
8643
8644     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8645
8646     if ( rx && RXp_PAREN_NAMES(rx) ) {
8647         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8648
8649         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8650     } else {
8651         return FALSE;
8652     }
8653 }
8654
8655 SV*
8656 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8657 {
8658     struct regexp *const rx = ReANY(r);
8659     DECLARE_AND_GET_RE_DEBUG_FLAGS;
8660
8661     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8662
8663     if (rx && RXp_PAREN_NAMES(rx)) {
8664         HV *hv = RXp_PAREN_NAMES(rx);
8665         HE *temphe;
8666         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8667             IV i;
8668             IV parno = 0;
8669             SV* sv_dat = HeVAL(temphe);
8670             I32 *nums = (I32*)SvPVX(sv_dat);
8671             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8672                 if ((I32)(rx->lastparen) >= nums[i] &&
8673                     rx->offs[nums[i]].start != -1 &&
8674                     rx->offs[nums[i]].end != -1)
8675                 {
8676                     parno = nums[i];
8677                     break;
8678                 }
8679             }
8680             if (parno || flags & RXapif_ALL) {
8681                 return newSVhek(HeKEY_hek(temphe));
8682             }
8683         }
8684     }
8685     return NULL;
8686 }
8687
8688 SV*
8689 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8690 {
8691     SV *ret;
8692     AV *av;
8693     SSize_t length;
8694     struct regexp *const rx = ReANY(r);
8695
8696     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8697
8698     if (rx && RXp_PAREN_NAMES(rx)) {
8699         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8700             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8701         } else if (flags & RXapif_ONE) {
8702             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8703             av = MUTABLE_AV(SvRV(ret));
8704             length = av_count(av);
8705             SvREFCNT_dec_NN(ret);
8706             return newSViv(length);
8707         } else {
8708             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8709                                                 (int)flags);
8710             return NULL;
8711         }
8712     }
8713     return &PL_sv_undef;
8714 }
8715
8716 SV*
8717 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8718 {
8719     struct regexp *const rx = ReANY(r);
8720     AV *av = newAV();
8721
8722     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8723
8724     if (rx && RXp_PAREN_NAMES(rx)) {
8725         HV *hv= RXp_PAREN_NAMES(rx);
8726         HE *temphe;
8727         (void)hv_iterinit(hv);
8728         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8729             IV i;
8730             IV parno = 0;
8731             SV* sv_dat = HeVAL(temphe);
8732             I32 *nums = (I32*)SvPVX(sv_dat);
8733             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8734                 if ((I32)(rx->lastparen) >= nums[i] &&
8735                     rx->offs[nums[i]].start != -1 &&
8736                     rx->offs[nums[i]].end != -1)
8737                 {
8738                     parno = nums[i];
8739                     break;
8740                 }
8741             }
8742             if (parno || flags & RXapif_ALL) {
8743                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8744             }
8745         }
8746     }
8747
8748     return newRV_noinc(MUTABLE_SV(av));
8749 }
8750
8751 void
8752 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8753                              SV * const sv)
8754 {
8755     struct regexp *const rx = ReANY(r);
8756     char *s = NULL;
8757     SSize_t i = 0;
8758     SSize_t s1, t1;
8759     I32 n = paren;
8760
8761     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8762
8763     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8764            || n == RX_BUFF_IDX_CARET_FULLMATCH
8765            || n == RX_BUFF_IDX_CARET_POSTMATCH
8766        )
8767     {
8768         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8769         if (!keepcopy) {
8770             /* on something like
8771              *    $r = qr/.../;
8772              *    /$qr/p;
8773              * the KEEPCOPY is set on the PMOP rather than the regex */
8774             if (PL_curpm && r == PM_GETRE(PL_curpm))
8775                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8776         }
8777         if (!keepcopy)
8778             goto ret_undef;
8779     }
8780
8781     if (!rx->subbeg)
8782         goto ret_undef;
8783
8784     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8785         /* no need to distinguish between them any more */
8786         n = RX_BUFF_IDX_FULLMATCH;
8787
8788     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8789         && rx->offs[0].start != -1)
8790     {
8791         /* $`, ${^PREMATCH} */
8792         i = rx->offs[0].start;
8793         s = rx->subbeg;
8794     }
8795     else
8796     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8797         && rx->offs[0].end != -1)
8798     {
8799         /* $', ${^POSTMATCH} */
8800         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8801         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8802     }
8803     else
8804     if (inRANGE(n, 0, (I32)rx->nparens) &&
8805         (s1 = rx->offs[n].start) != -1  &&
8806         (t1 = rx->offs[n].end) != -1)
8807     {
8808         /* $&, ${^MATCH},  $1 ... */
8809         i = t1 - s1;
8810         s = rx->subbeg + s1 - rx->suboffset;
8811     } else {
8812         goto ret_undef;
8813     }
8814
8815     assert(s >= rx->subbeg);
8816     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8817     if (i >= 0) {
8818 #ifdef NO_TAINT_SUPPORT
8819         sv_setpvn(sv, s, i);
8820 #else
8821         const int oldtainted = TAINT_get;
8822         TAINT_NOT;
8823         sv_setpvn(sv, s, i);
8824         TAINT_set(oldtainted);
8825 #endif
8826         if (RXp_MATCH_UTF8(rx))
8827             SvUTF8_on(sv);
8828         else
8829             SvUTF8_off(sv);
8830         if (TAINTING_get) {
8831             if (RXp_MATCH_TAINTED(rx)) {
8832                 if (SvTYPE(sv) >= SVt_PVMG) {
8833                     MAGIC* const mg = SvMAGIC(sv);
8834                     MAGIC* mgt;
8835                     TAINT;
8836                     SvMAGIC_set(sv, mg->mg_moremagic);
8837                     SvTAINT(sv);
8838                     if ((mgt = SvMAGIC(sv))) {
8839                         mg->mg_moremagic = mgt;
8840                         SvMAGIC_set(sv, mg);
8841                     }
8842                 } else {
8843                     TAINT;
8844                     SvTAINT(sv);
8845                 }
8846             } else
8847                 SvTAINTED_off(sv);
8848         }
8849     } else {
8850       ret_undef:
8851         sv_set_undef(sv);
8852         return;
8853     }
8854 }
8855
8856 void
8857 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8858                                                          SV const * const value)
8859 {
8860     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8861
8862     PERL_UNUSED_ARG(rx);
8863     PERL_UNUSED_ARG(paren);
8864     PERL_UNUSED_ARG(value);
8865
8866     if (!PL_localizing)
8867         Perl_croak_no_modify();
8868 }
8869
8870 I32
8871 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8872                               const I32 paren)
8873 {
8874     struct regexp *const rx = ReANY(r);
8875     I32 i;
8876     I32 s1, t1;
8877
8878     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8879
8880     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8881         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8882         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8883     )
8884     {
8885         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8886         if (!keepcopy) {
8887             /* on something like
8888              *    $r = qr/.../;
8889              *    /$qr/p;
8890              * the KEEPCOPY is set on the PMOP rather than the regex */
8891             if (PL_curpm && r == PM_GETRE(PL_curpm))
8892                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8893         }
8894         if (!keepcopy)
8895             goto warn_undef;
8896     }
8897
8898     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8899     switch (paren) {
8900       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8901       case RX_BUFF_IDX_PREMATCH:       /* $` */
8902         if (rx->offs[0].start != -1) {
8903                         i = rx->offs[0].start;
8904                         if (i > 0) {
8905                                 s1 = 0;
8906                                 t1 = i;
8907                                 goto getlen;
8908                         }
8909             }
8910         return 0;
8911
8912       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8913       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8914             if (rx->offs[0].end != -1) {
8915                         i = rx->sublen - rx->offs[0].end;
8916                         if (i > 0) {
8917                                 s1 = rx->offs[0].end;
8918                                 t1 = rx->sublen;
8919                                 goto getlen;
8920                         }
8921             }
8922         return 0;
8923
8924       default: /* $& / ${^MATCH}, $1, $2, ... */
8925             if (paren <= (I32)rx->nparens &&
8926             (s1 = rx->offs[paren].start) != -1 &&
8927             (t1 = rx->offs[paren].end) != -1)
8928             {
8929             i = t1 - s1;
8930             goto getlen;
8931         } else {
8932           warn_undef:
8933             if (ckWARN(WARN_UNINITIALIZED))
8934                 report_uninit((const SV *)sv);
8935             return 0;
8936         }
8937     }
8938   getlen:
8939     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8940         const char * const s = rx->subbeg - rx->suboffset + s1;
8941         const U8 *ep;
8942         STRLEN el;
8943
8944         i = t1 - s1;
8945         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8946             i = el;
8947     }
8948     return i;
8949 }
8950
8951 SV*
8952 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8953 {
8954     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8955         PERL_UNUSED_ARG(rx);
8956         if (0)
8957             return NULL;
8958         else
8959             return newSVpvs("Regexp");
8960 }
8961
8962 /* Scans the name of a named buffer from the pattern.
8963  * If flags is REG_RSN_RETURN_NULL returns null.
8964  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8965  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8966  * to the parsed name as looked up in the RExC_paren_names hash.
8967  * If there is an error throws a vFAIL().. type exception.
8968  */
8969
8970 #define REG_RSN_RETURN_NULL    0
8971 #define REG_RSN_RETURN_NAME    1
8972 #define REG_RSN_RETURN_DATA    2
8973
8974 STATIC SV*
8975 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8976 {
8977     char *name_start = RExC_parse;
8978     SV* sv_name;
8979
8980     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8981
8982     assert (RExC_parse <= RExC_end);
8983     if (RExC_parse == RExC_end) NOOP;
8984     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8985          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8986           * using do...while */
8987         if (UTF)
8988             do {
8989                 RExC_parse += UTF8SKIP(RExC_parse);
8990             } while (   RExC_parse < RExC_end
8991                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8992         else
8993             do {
8994                 RExC_parse++;
8995             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8996     } else {
8997         RExC_parse++; /* so the <- from the vFAIL is after the offending
8998                          character */
8999         vFAIL("Group name must start with a non-digit word character");
9000     }
9001     sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
9002                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
9003     if ( flags == REG_RSN_RETURN_NAME)
9004         return sv_name;
9005     else if (flags==REG_RSN_RETURN_DATA) {
9006         HE *he_str = NULL;
9007         SV *sv_dat = NULL;
9008         if ( ! sv_name )      /* should not happen*/
9009             Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
9010         if (RExC_paren_names)
9011             he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
9012         if ( he_str )
9013             sv_dat = HeVAL(he_str);
9014         if ( ! sv_dat ) {   /* Didn't find group */
9015
9016             /* It might be a forward reference; we can't fail until we
9017                 * know, by completing the parse to get all the groups, and
9018                 * then reparsing */
9019             if (ALL_PARENS_COUNTED)  {
9020                 vFAIL("Reference to nonexistent named group");
9021             }
9022             else {
9023                 REQUIRE_PARENS_PASS;
9024             }
9025         }
9026         return sv_dat;
9027     }
9028
9029     Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
9030                      (unsigned long) flags);
9031 }
9032
9033 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
9034     if (RExC_lastparse!=RExC_parse) {                           \
9035         Perl_re_printf( aTHX_  "%s",                            \
9036             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
9037                 RExC_end - RExC_parse, 16,                      \
9038                 "", "",                                         \
9039                 PERL_PV_ESCAPE_UNI_DETECT |                     \
9040                 PERL_PV_PRETTY_ELLIPSES   |                     \
9041                 PERL_PV_PRETTY_LTGT       |                     \
9042                 PERL_PV_ESCAPE_RE         |                     \
9043                 PERL_PV_PRETTY_EXACTSIZE                        \
9044             )                                                   \
9045         );                                                      \
9046     } else                                                      \
9047         Perl_re_printf( aTHX_ "%16s","");                       \
9048                                                                 \
9049     if (RExC_lastnum!=RExC_emit)                                \
9050        Perl_re_printf( aTHX_ "|%4zu", RExC_emit);                \
9051     else                                                        \
9052        Perl_re_printf( aTHX_ "|%4s","");                        \
9053     Perl_re_printf( aTHX_ "|%*s%-4s",                           \
9054         (int)((depth*2)), "",                                   \
9055         (funcname)                                              \
9056     );                                                          \
9057     RExC_lastnum=RExC_emit;                                     \
9058     RExC_lastparse=RExC_parse;                                  \
9059 })
9060
9061
9062
9063 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
9064     DEBUG_PARSE_MSG((funcname));                            \
9065     Perl_re_printf( aTHX_ "%4s","\n");                                  \
9066 })
9067 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
9068     DEBUG_PARSE_MSG((funcname));                            \
9069     Perl_re_printf( aTHX_ fmt "\n",args);                               \
9070 })
9071
9072 /* This section of code defines the inversion list object and its methods.  The
9073  * interfaces are highly subject to change, so as much as possible is static to
9074  * this file.  An inversion list is here implemented as a malloc'd C UV array
9075  * as an SVt_INVLIST scalar.
9076  *
9077  * An inversion list for Unicode is an array of code points, sorted by ordinal
9078  * number.  Each element gives the code point that begins a range that extends
9079  * up-to but not including the code point given by the next element.  The final
9080  * element gives the first code point of a range that extends to the platform's
9081  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
9082  * ...) give ranges whose code points are all in the inversion list.  We say
9083  * that those ranges are in the set.  The odd-numbered elements give ranges
9084  * whose code points are not in the inversion list, and hence not in the set.
9085  * Thus, element [0] is the first code point in the list.  Element [1]
9086  * is the first code point beyond that not in the list; and element [2] is the
9087  * first code point beyond that that is in the list.  In other words, the first
9088  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
9089  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
9090  * all code points in that range are not in the inversion list.  The third
9091  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
9092  * list, and so forth.  Thus every element whose index is divisible by two
9093  * gives the beginning of a range that is in the list, and every element whose
9094  * index is not divisible by two gives the beginning of a range not in the
9095  * list.  If the final element's index is divisible by two, the inversion list
9096  * extends to the platform's infinity; otherwise the highest code point in the
9097  * inversion list is the contents of that element minus 1.
9098  *
9099  * A range that contains just a single code point N will look like
9100  *  invlist[i]   == N
9101  *  invlist[i+1] == N+1
9102  *
9103  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
9104  * impossible to represent, so element [i+1] is omitted.  The single element
9105  * inversion list
9106  *  invlist[0] == UV_MAX
9107  * contains just UV_MAX, but is interpreted as matching to infinity.
9108  *
9109  * Taking the complement (inverting) an inversion list is quite simple, if the
9110  * first element is 0, remove it; otherwise add a 0 element at the beginning.
9111  * This implementation reserves an element at the beginning of each inversion
9112  * list to always contain 0; there is an additional flag in the header which
9113  * indicates if the list begins at the 0, or is offset to begin at the next
9114  * element.  This means that the inversion list can be inverted without any
9115  * copying; just flip the flag.
9116  *
9117  * More about inversion lists can be found in "Unicode Demystified"
9118  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
9119  *
9120  * The inversion list data structure is currently implemented as an SV pointing
9121  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
9122  * array of UV whose memory management is automatically handled by the existing
9123  * facilities for SV's.
9124  *
9125  * Some of the methods should always be private to the implementation, and some
9126  * should eventually be made public */
9127
9128 /* The header definitions are in F<invlist_inline.h> */
9129
9130 #ifndef PERL_IN_XSUB_RE
9131
9132 PERL_STATIC_INLINE UV*
9133 S__invlist_array_init(SV* const invlist, const bool will_have_0)
9134 {
9135     /* Returns a pointer to the first element in the inversion list's array.
9136      * This is called upon initialization of an inversion list.  Where the
9137      * array begins depends on whether the list has the code point U+0000 in it
9138      * or not.  The other parameter tells it whether the code that follows this
9139      * call is about to put a 0 in the inversion list or not.  The first
9140      * element is either the element reserved for 0, if TRUE, or the element
9141      * after it, if FALSE */
9142
9143     bool* offset = get_invlist_offset_addr(invlist);
9144     UV* zero_addr = (UV *) SvPVX(invlist);
9145
9146     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
9147
9148     /* Must be empty */
9149     assert(! _invlist_len(invlist));
9150
9151     *zero_addr = 0;
9152
9153     /* 1^1 = 0; 1^0 = 1 */
9154     *offset = 1 ^ will_have_0;
9155     return zero_addr + *offset;
9156 }
9157
9158 STATIC void
9159 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
9160 {
9161     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
9162      * steals the list from 'src', so 'src' is made to have a NULL list.  This
9163      * is similar to what SvSetMagicSV() would do, if it were implemented on
9164      * inversion lists, though this routine avoids a copy */
9165
9166     const UV src_len          = _invlist_len(src);
9167     const bool src_offset     = *get_invlist_offset_addr(src);
9168     const STRLEN src_byte_len = SvLEN(src);
9169     char * array              = SvPVX(src);
9170
9171     const int oldtainted = TAINT_get;
9172
9173     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
9174
9175     assert(is_invlist(src));
9176     assert(is_invlist(dest));
9177     assert(! invlist_is_iterating(src));
9178     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
9179
9180     /* Make sure it ends in the right place with a NUL, as our inversion list
9181      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
9182      * asserts it */
9183     array[src_byte_len - 1] = '\0';
9184
9185     TAINT_NOT;      /* Otherwise it breaks */
9186     sv_usepvn_flags(dest,
9187                     (char *) array,
9188                     src_byte_len - 1,
9189
9190                     /* This flag is documented to cause a copy to be avoided */
9191                     SV_HAS_TRAILING_NUL);
9192     TAINT_set(oldtainted);
9193     SvPV_set(src, 0);
9194     SvLEN_set(src, 0);
9195     SvCUR_set(src, 0);
9196
9197     /* Finish up copying over the other fields in an inversion list */
9198     *get_invlist_offset_addr(dest) = src_offset;
9199     invlist_set_len(dest, src_len, src_offset);
9200     *get_invlist_previous_index_addr(dest) = 0;
9201     invlist_iterfinish(dest);
9202 }
9203
9204 PERL_STATIC_INLINE IV*
9205 S_get_invlist_previous_index_addr(SV* invlist)
9206 {
9207     /* Return the address of the IV that is reserved to hold the cached index
9208      * */
9209     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
9210
9211     assert(is_invlist(invlist));
9212
9213     return &(((XINVLIST*) SvANY(invlist))->prev_index);
9214 }
9215
9216 PERL_STATIC_INLINE IV
9217 S_invlist_previous_index(SV* const invlist)
9218 {
9219     /* Returns cached index of previous search */
9220
9221     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
9222
9223     return *get_invlist_previous_index_addr(invlist);
9224 }
9225
9226 PERL_STATIC_INLINE void
9227 S_invlist_set_previous_index(SV* const invlist, const IV index)
9228 {
9229     /* Caches <index> for later retrieval */
9230
9231     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
9232
9233     assert(index == 0 || index < (int) _invlist_len(invlist));
9234
9235     *get_invlist_previous_index_addr(invlist) = index;
9236 }
9237
9238 PERL_STATIC_INLINE void
9239 S_invlist_trim(SV* invlist)
9240 {
9241     /* Free the not currently-being-used space in an inversion list */
9242
9243     /* But don't free up the space needed for the 0 UV that is always at the
9244      * beginning of the list, nor the trailing NUL */
9245     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
9246
9247     PERL_ARGS_ASSERT_INVLIST_TRIM;
9248
9249     assert(is_invlist(invlist));
9250
9251     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
9252 }
9253
9254 PERL_STATIC_INLINE void
9255 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
9256 {
9257     PERL_ARGS_ASSERT_INVLIST_CLEAR;
9258
9259     assert(is_invlist(invlist));
9260
9261     invlist_set_len(invlist, 0, 0);
9262     invlist_trim(invlist);
9263 }
9264
9265 #endif /* ifndef PERL_IN_XSUB_RE */
9266
9267 PERL_STATIC_INLINE bool
9268 S_invlist_is_iterating(SV* const invlist)
9269 {
9270     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
9271
9272     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
9273 }
9274
9275 #ifndef PERL_IN_XSUB_RE
9276
9277 PERL_STATIC_INLINE UV
9278 S_invlist_max(SV* const invlist)
9279 {
9280     /* Returns the maximum number of elements storable in the inversion list's
9281      * array, without having to realloc() */
9282
9283     PERL_ARGS_ASSERT_INVLIST_MAX;
9284
9285     assert(is_invlist(invlist));
9286
9287     /* Assumes worst case, in which the 0 element is not counted in the
9288      * inversion list, so subtracts 1 for that */
9289     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
9290            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
9291            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
9292 }
9293
9294 STATIC void
9295 S_initialize_invlist_guts(pTHX_ SV* invlist, const Size_t initial_size)
9296 {
9297     PERL_ARGS_ASSERT_INITIALIZE_INVLIST_GUTS;
9298
9299     /* First 1 is in case the zero element isn't in the list; second 1 is for
9300      * trailing NUL */
9301     SvGROW(invlist, TO_INTERNAL_SIZE(initial_size + 1) + 1);
9302     invlist_set_len(invlist, 0, 0);
9303
9304     /* Force iterinit() to be used to get iteration to work */
9305     invlist_iterfinish(invlist);
9306
9307     *get_invlist_previous_index_addr(invlist) = 0;
9308     SvPOK_on(invlist);  /* This allows B to extract the PV */
9309 }
9310
9311 SV*
9312 Perl__new_invlist(pTHX_ IV initial_size)
9313 {
9314
9315     /* Return a pointer to a newly constructed inversion list, with enough
9316      * space to store 'initial_size' elements.  If that number is negative, a
9317      * system default is used instead */
9318
9319     SV* new_list;
9320
9321     if (initial_size < 0) {
9322         initial_size = 10;
9323     }
9324
9325     new_list = newSV_type(SVt_INVLIST);
9326     initialize_invlist_guts(new_list, initial_size);
9327
9328     return new_list;
9329 }
9330
9331 SV*
9332 Perl__new_invlist_C_array(pTHX_ const UV* const list)
9333 {
9334     /* Return a pointer to a newly constructed inversion list, initialized to
9335      * point to <list>, which has to be in the exact correct inversion list
9336      * form, including internal fields.  Thus this is a dangerous routine that
9337      * should not be used in the wrong hands.  The passed in 'list' contains
9338      * several header fields at the beginning that are not part of the
9339      * inversion list body proper */
9340
9341     const STRLEN length = (STRLEN) list[0];
9342     const UV version_id =          list[1];
9343     const bool offset   =    cBOOL(list[2]);
9344 #define HEADER_LENGTH 3
9345     /* If any of the above changes in any way, you must change HEADER_LENGTH
9346      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
9347      *      perl -E 'say int(rand 2**31-1)'
9348      */
9349 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
9350                                         data structure type, so that one being
9351                                         passed in can be validated to be an
9352                                         inversion list of the correct vintage.
9353                                        */
9354
9355     SV* invlist = newSV_type(SVt_INVLIST);
9356
9357     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
9358
9359     if (version_id != INVLIST_VERSION_ID) {
9360         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
9361     }
9362
9363     /* The generated array passed in includes header elements that aren't part
9364      * of the list proper, so start it just after them */
9365     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
9366
9367     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
9368                                shouldn't touch it */
9369
9370     *(get_invlist_offset_addr(invlist)) = offset;
9371
9372     /* The 'length' passed to us is the physical number of elements in the
9373      * inversion list.  But if there is an offset the logical number is one
9374      * less than that */
9375     invlist_set_len(invlist, length  - offset, offset);
9376
9377     invlist_set_previous_index(invlist, 0);
9378
9379     /* Initialize the iteration pointer. */
9380     invlist_iterfinish(invlist);
9381
9382     SvREADONLY_on(invlist);
9383     SvPOK_on(invlist);
9384
9385     return invlist;
9386 }
9387
9388 STATIC void
9389 S__append_range_to_invlist(pTHX_ SV* const invlist,
9390                                  const UV start, const UV end)
9391 {
9392    /* Subject to change or removal.  Append the range from 'start' to 'end' at
9393     * the end of the inversion list.  The range must be above any existing
9394     * ones. */
9395
9396     UV* array;
9397     UV max = invlist_max(invlist);
9398     UV len = _invlist_len(invlist);
9399     bool offset;
9400
9401     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
9402
9403     if (len == 0) { /* Empty lists must be initialized */
9404         offset = start != 0;
9405         array = _invlist_array_init(invlist, ! offset);
9406     }
9407     else {
9408         /* Here, the existing list is non-empty. The current max entry in the
9409          * list is generally the first value not in the set, except when the
9410          * set extends to the end of permissible values, in which case it is
9411          * the first entry in that final set, and so this call is an attempt to
9412          * append out-of-order */
9413
9414         UV final_element = len - 1;
9415         array = invlist_array(invlist);
9416         if (   array[final_element] > start
9417             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
9418         {
9419             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",
9420                      array[final_element], start,
9421                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
9422         }
9423
9424         /* Here, it is a legal append.  If the new range begins 1 above the end
9425          * of the range below it, it is extending the range below it, so the
9426          * new first value not in the set is one greater than the newly
9427          * extended range.  */
9428         offset = *get_invlist_offset_addr(invlist);
9429         if (array[final_element] == start) {
9430             if (end != UV_MAX) {
9431                 array[final_element] = end + 1;
9432             }
9433             else {
9434                 /* But if the end is the maximum representable on the machine,
9435                  * assume that infinity was actually what was meant.  Just let
9436                  * the range that this would extend to have no end */
9437                 invlist_set_len(invlist, len - 1, offset);
9438             }
9439             return;
9440         }
9441     }
9442
9443     /* Here the new range doesn't extend any existing set.  Add it */
9444
9445     len += 2;   /* Includes an element each for the start and end of range */
9446
9447     /* If wll overflow the existing space, extend, which may cause the array to
9448      * be moved */
9449     if (max < len) {
9450         invlist_extend(invlist, len);
9451
9452         /* Have to set len here to avoid assert failure in invlist_array() */
9453         invlist_set_len(invlist, len, offset);
9454
9455         array = invlist_array(invlist);
9456     }
9457     else {
9458         invlist_set_len(invlist, len, offset);
9459     }
9460
9461     /* The next item on the list starts the range, the one after that is
9462      * one past the new range.  */
9463     array[len - 2] = start;
9464     if (end != UV_MAX) {
9465         array[len - 1] = end + 1;
9466     }
9467     else {
9468         /* But if the end is the maximum representable on the machine, just let
9469          * the range have no end */
9470         invlist_set_len(invlist, len - 1, offset);
9471     }
9472 }
9473
9474 SSize_t
9475 Perl__invlist_search(SV* const invlist, const UV cp)
9476 {
9477     /* Searches the inversion list for the entry that contains the input code
9478      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
9479      * return value is the index into the list's array of the range that
9480      * contains <cp>, that is, 'i' such that
9481      *  array[i] <= cp < array[i+1]
9482      */
9483
9484     IV low = 0;
9485     IV mid;
9486     IV high = _invlist_len(invlist);
9487     const IV highest_element = high - 1;
9488     const UV* array;
9489
9490     PERL_ARGS_ASSERT__INVLIST_SEARCH;
9491
9492     /* If list is empty, return failure. */
9493     if (high == 0) {
9494         return -1;
9495     }
9496
9497     /* (We can't get the array unless we know the list is non-empty) */
9498     array = invlist_array(invlist);
9499
9500     mid = invlist_previous_index(invlist);
9501     assert(mid >=0);
9502     if (mid > highest_element) {
9503         mid = highest_element;
9504     }
9505
9506     /* <mid> contains the cache of the result of the previous call to this
9507      * function (0 the first time).  See if this call is for the same result,
9508      * or if it is for mid-1.  This is under the theory that calls to this
9509      * function will often be for related code points that are near each other.
9510      * And benchmarks show that caching gives better results.  We also test
9511      * here if the code point is within the bounds of the list.  These tests
9512      * replace others that would have had to be made anyway to make sure that
9513      * the array bounds were not exceeded, and these give us extra information
9514      * at the same time */
9515     if (cp >= array[mid]) {
9516         if (cp >= array[highest_element]) {
9517             return highest_element;
9518         }
9519
9520         /* Here, array[mid] <= cp < array[highest_element].  This means that
9521          * the final element is not the answer, so can exclude it; it also
9522          * means that <mid> is not the final element, so can refer to 'mid + 1'
9523          * safely */
9524         if (cp < array[mid + 1]) {
9525             return mid;
9526         }
9527         high--;
9528         low = mid + 1;
9529     }
9530     else { /* cp < aray[mid] */
9531         if (cp < array[0]) { /* Fail if outside the array */
9532             return -1;
9533         }
9534         high = mid;
9535         if (cp >= array[mid - 1]) {
9536             goto found_entry;
9537         }
9538     }
9539
9540     /* Binary search.  What we are looking for is <i> such that
9541      *  array[i] <= cp < array[i+1]
9542      * The loop below converges on the i+1.  Note that there may not be an
9543      * (i+1)th element in the array, and things work nonetheless */
9544     while (low < high) {
9545         mid = (low + high) / 2;
9546         assert(mid <= highest_element);
9547         if (array[mid] <= cp) { /* cp >= array[mid] */
9548             low = mid + 1;
9549
9550             /* We could do this extra test to exit the loop early.
9551             if (cp < array[low]) {
9552                 return mid;
9553             }
9554             */
9555         }
9556         else { /* cp < array[mid] */
9557             high = mid;
9558         }
9559     }
9560
9561   found_entry:
9562     high--;
9563     invlist_set_previous_index(invlist, high);
9564     return high;
9565 }
9566
9567 void
9568 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9569                                          const bool complement_b, SV** output)
9570 {
9571     /* Take the union of two inversion lists and point '*output' to it.  On
9572      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9573      * even 'a' or 'b').  If to an inversion list, the contents of the original
9574      * list will be replaced by the union.  The first list, 'a', may be
9575      * NULL, in which case a copy of the second list is placed in '*output'.
9576      * If 'complement_b' is TRUE, the union is taken of the complement
9577      * (inversion) of 'b' instead of b itself.
9578      *
9579      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9580      * Richard Gillam, published by Addison-Wesley, and explained at some
9581      * length there.  The preface says to incorporate its examples into your
9582      * code at your own risk.
9583      *
9584      * The algorithm is like a merge sort. */
9585
9586     const UV* array_a;    /* a's array */
9587     const UV* array_b;
9588     UV len_a;       /* length of a's array */
9589     UV len_b;
9590
9591     SV* u;                      /* the resulting union */
9592     UV* array_u;
9593     UV len_u = 0;
9594
9595     UV i_a = 0;             /* current index into a's array */
9596     UV i_b = 0;
9597     UV i_u = 0;
9598
9599     /* running count, as explained in the algorithm source book; items are
9600      * stopped accumulating and are output when the count changes to/from 0.
9601      * The count is incremented when we start a range that's in an input's set,
9602      * and decremented when we start a range that's not in a set.  So this
9603      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9604      * and hence nothing goes into the union; 1, just one of the inputs is in
9605      * its set (and its current range gets added to the union); and 2 when both
9606      * inputs are in their sets.  */
9607     UV count = 0;
9608
9609     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9610     assert(a != b);
9611     assert(*output == NULL || is_invlist(*output));
9612
9613     len_b = _invlist_len(b);
9614     if (len_b == 0) {
9615
9616         /* Here, 'b' is empty, hence it's complement is all possible code
9617          * points.  So if the union includes the complement of 'b', it includes
9618          * everything, and we need not even look at 'a'.  It's easiest to
9619          * create a new inversion list that matches everything.  */
9620         if (complement_b) {
9621             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9622
9623             if (*output == NULL) { /* If the output didn't exist, just point it
9624                                       at the new list */
9625                 *output = everything;
9626             }
9627             else { /* Otherwise, replace its contents with the new list */
9628                 invlist_replace_list_destroys_src(*output, everything);
9629                 SvREFCNT_dec_NN(everything);
9630             }
9631
9632             return;
9633         }
9634
9635         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9636          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9637          * output will be empty */
9638
9639         if (a == NULL || _invlist_len(a) == 0) {
9640             if (*output == NULL) {
9641                 *output = _new_invlist(0);
9642             }
9643             else {
9644                 invlist_clear(*output);
9645             }
9646             return;
9647         }
9648
9649         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9650          * union.  We can just return a copy of 'a' if '*output' doesn't point
9651          * to an existing list */
9652         if (*output == NULL) {
9653             *output = invlist_clone(a, NULL);
9654             return;
9655         }
9656
9657         /* If the output is to overwrite 'a', we have a no-op, as it's
9658          * already in 'a' */
9659         if (*output == a) {
9660             return;
9661         }
9662
9663         /* Here, '*output' is to be overwritten by 'a' */
9664         u = invlist_clone(a, NULL);
9665         invlist_replace_list_destroys_src(*output, u);
9666         SvREFCNT_dec_NN(u);
9667
9668         return;
9669     }
9670
9671     /* Here 'b' is not empty.  See about 'a' */
9672
9673     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9674
9675         /* Here, 'a' is empty (and b is not).  That means the union will come
9676          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9677          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9678          * the clone */
9679
9680         SV ** dest = (*output == NULL) ? output : &u;
9681         *dest = invlist_clone(b, NULL);
9682         if (complement_b) {
9683             _invlist_invert(*dest);
9684         }
9685
9686         if (dest == &u) {
9687             invlist_replace_list_destroys_src(*output, u);
9688             SvREFCNT_dec_NN(u);
9689         }
9690
9691         return;
9692     }
9693
9694     /* Here both lists exist and are non-empty */
9695     array_a = invlist_array(a);
9696     array_b = invlist_array(b);
9697
9698     /* If are to take the union of 'a' with the complement of b, set it
9699      * up so are looking at b's complement. */
9700     if (complement_b) {
9701
9702         /* To complement, we invert: if the first element is 0, remove it.  To
9703          * do this, we just pretend the array starts one later */
9704         if (array_b[0] == 0) {
9705             array_b++;
9706             len_b--;
9707         }
9708         else {
9709
9710             /* But if the first element is not zero, we pretend the list starts
9711              * at the 0 that is always stored immediately before the array. */
9712             array_b--;
9713             len_b++;
9714         }
9715     }
9716
9717     /* Size the union for the worst case: that the sets are completely
9718      * disjoint */
9719     u = _new_invlist(len_a + len_b);
9720
9721     /* Will contain U+0000 if either component does */
9722     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9723                                       || (len_b > 0 && array_b[0] == 0));
9724
9725     /* Go through each input list item by item, stopping when have exhausted
9726      * one of them */
9727     while (i_a < len_a && i_b < len_b) {
9728         UV cp;      /* The element to potentially add to the union's array */
9729         bool cp_in_set;   /* is it in the input list's set or not */
9730
9731         /* We need to take one or the other of the two inputs for the union.
9732          * Since we are merging two sorted lists, we take the smaller of the
9733          * next items.  In case of a tie, we take first the one that is in its
9734          * set.  If we first took the one not in its set, it would decrement
9735          * the count, possibly to 0 which would cause it to be output as ending
9736          * the range, and the next time through we would take the same number,
9737          * and output it again as beginning the next range.  By doing it the
9738          * opposite way, there is no possibility that the count will be
9739          * momentarily decremented to 0, and thus the two adjoining ranges will
9740          * be seamlessly merged.  (In a tie and both are in the set or both not
9741          * in the set, it doesn't matter which we take first.) */
9742         if (       array_a[i_a] < array_b[i_b]
9743             || (   array_a[i_a] == array_b[i_b]
9744                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9745         {
9746             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9747             cp = array_a[i_a++];
9748         }
9749         else {
9750             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9751             cp = array_b[i_b++];
9752         }
9753
9754         /* Here, have chosen which of the two inputs to look at.  Only output
9755          * if the running count changes to/from 0, which marks the
9756          * beginning/end of a range that's in the set */
9757         if (cp_in_set) {
9758             if (count == 0) {
9759                 array_u[i_u++] = cp;
9760             }
9761             count++;
9762         }
9763         else {
9764             count--;
9765             if (count == 0) {
9766                 array_u[i_u++] = cp;
9767             }
9768         }
9769     }
9770
9771
9772     /* The loop above increments the index into exactly one of the input lists
9773      * each iteration, and ends when either index gets to its list end.  That
9774      * means the other index is lower than its end, and so something is
9775      * remaining in that one.  We decrement 'count', as explained below, if
9776      * that list is in its set.  (i_a and i_b each currently index the element
9777      * beyond the one we care about.) */
9778     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9779         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9780     {
9781         count--;
9782     }
9783
9784     /* Above we decremented 'count' if the list that had unexamined elements in
9785      * it was in its set.  This has made it so that 'count' being non-zero
9786      * means there isn't anything left to output; and 'count' equal to 0 means
9787      * that what is left to output is precisely that which is left in the
9788      * non-exhausted input list.
9789      *
9790      * To see why, note first that the exhausted input obviously has nothing
9791      * left to add to the union.  If it was in its set at its end, that means
9792      * the set extends from here to the platform's infinity, and hence so does
9793      * the union and the non-exhausted set is irrelevant.  The exhausted set
9794      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9795      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9796      * 'count' remains at 1.  This is consistent with the decremented 'count'
9797      * != 0 meaning there's nothing left to add to the union.
9798      *
9799      * But if the exhausted input wasn't in its set, it contributed 0 to
9800      * 'count', and the rest of the union will be whatever the other input is.
9801      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9802      * otherwise it gets decremented to 0.  This is consistent with 'count'
9803      * == 0 meaning the remainder of the union is whatever is left in the
9804      * non-exhausted list. */
9805     if (count != 0) {
9806         len_u = i_u;
9807     }
9808     else {
9809         IV copy_count = len_a - i_a;
9810         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9811             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9812         }
9813         else { /* The non-exhausted input is b */
9814             copy_count = len_b - i_b;
9815             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9816         }
9817         len_u = i_u + copy_count;
9818     }
9819
9820     /* Set the result to the final length, which can change the pointer to
9821      * array_u, so re-find it.  (Note that it is unlikely that this will
9822      * change, as we are shrinking the space, not enlarging it) */
9823     if (len_u != _invlist_len(u)) {
9824         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9825         invlist_trim(u);
9826         array_u = invlist_array(u);
9827     }
9828
9829     if (*output == NULL) {  /* Simply return the new inversion list */
9830         *output = u;
9831     }
9832     else {
9833         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9834          * could instead free '*output', and then set it to 'u', but experience
9835          * has shown [perl #127392] that if the input is a mortal, we can get a
9836          * huge build-up of these during regex compilation before they get
9837          * freed. */
9838         invlist_replace_list_destroys_src(*output, u);
9839         SvREFCNT_dec_NN(u);
9840     }
9841
9842     return;
9843 }
9844
9845 void
9846 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9847                                                const bool complement_b, SV** i)
9848 {
9849     /* Take the intersection of two inversion lists and point '*i' to it.  On
9850      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9851      * even 'a' or 'b').  If to an inversion list, the contents of the original
9852      * list will be replaced by the intersection.  The first list, 'a', may be
9853      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9854      * TRUE, the result will be the intersection of 'a' and the complement (or
9855      * inversion) of 'b' instead of 'b' directly.
9856      *
9857      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9858      * Richard Gillam, published by Addison-Wesley, and explained at some
9859      * length there.  The preface says to incorporate its examples into your
9860      * code at your own risk.  In fact, it had bugs
9861      *
9862      * The algorithm is like a merge sort, and is essentially the same as the
9863      * union above
9864      */
9865
9866     const UV* array_a;          /* a's array */
9867     const UV* array_b;
9868     UV len_a;   /* length of a's array */
9869     UV len_b;
9870
9871     SV* r;                   /* the resulting intersection */
9872     UV* array_r;
9873     UV len_r = 0;
9874
9875     UV i_a = 0;             /* current index into a's array */
9876     UV i_b = 0;
9877     UV i_r = 0;
9878
9879     /* running count of how many of the two inputs are postitioned at ranges
9880      * that are in their sets.  As explained in the algorithm source book,
9881      * items are stopped accumulating and are output when the count changes
9882      * to/from 2.  The count is incremented when we start a range that's in an
9883      * input's set, and decremented when we start a range that's not in a set.
9884      * Only when it is 2 are we in the intersection. */
9885     UV count = 0;
9886
9887     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9888     assert(a != b);
9889     assert(*i == NULL || is_invlist(*i));
9890
9891     /* Special case if either one is empty */
9892     len_a = (a == NULL) ? 0 : _invlist_len(a);
9893     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9894         if (len_a != 0 && complement_b) {
9895
9896             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9897              * must be empty.  Here, also we are using 'b's complement, which
9898              * hence must be every possible code point.  Thus the intersection
9899              * is simply 'a'. */
9900
9901             if (*i == a) {  /* No-op */
9902                 return;
9903             }
9904
9905             if (*i == NULL) {
9906                 *i = invlist_clone(a, NULL);
9907                 return;
9908             }
9909
9910             r = invlist_clone(a, NULL);
9911             invlist_replace_list_destroys_src(*i, r);
9912             SvREFCNT_dec_NN(r);
9913             return;
9914         }
9915
9916         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9917          * intersection must be empty */
9918         if (*i == NULL) {
9919             *i = _new_invlist(0);
9920             return;
9921         }
9922
9923         invlist_clear(*i);
9924         return;
9925     }
9926
9927     /* Here both lists exist and are non-empty */
9928     array_a = invlist_array(a);
9929     array_b = invlist_array(b);
9930
9931     /* If are to take the intersection of 'a' with the complement of b, set it
9932      * up so are looking at b's complement. */
9933     if (complement_b) {
9934
9935         /* To complement, we invert: if the first element is 0, remove it.  To
9936          * do this, we just pretend the array starts one later */
9937         if (array_b[0] == 0) {
9938             array_b++;
9939             len_b--;
9940         }
9941         else {
9942
9943             /* But if the first element is not zero, we pretend the list starts
9944              * at the 0 that is always stored immediately before the array. */
9945             array_b--;
9946             len_b++;
9947         }
9948     }
9949
9950     /* Size the intersection for the worst case: that the intersection ends up
9951      * fragmenting everything to be completely disjoint */
9952     r= _new_invlist(len_a + len_b);
9953
9954     /* Will contain U+0000 iff both components do */
9955     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9956                                      && len_b > 0 && array_b[0] == 0);
9957
9958     /* Go through each list item by item, stopping when have exhausted one of
9959      * them */
9960     while (i_a < len_a && i_b < len_b) {
9961         UV cp;      /* The element to potentially add to the intersection's
9962                        array */
9963         bool cp_in_set; /* Is it in the input list's set or not */
9964
9965         /* We need to take one or the other of the two inputs for the
9966          * intersection.  Since we are merging two sorted lists, we take the
9967          * smaller of the next items.  In case of a tie, we take first the one
9968          * that is not in its set (a difference from the union algorithm).  If
9969          * we first took the one in its set, it would increment the count,
9970          * possibly to 2 which would cause it to be output as starting a range
9971          * in the intersection, and the next time through we would take that
9972          * same number, and output it again as ending the set.  By doing the
9973          * opposite of this, there is no possibility that the count will be
9974          * momentarily incremented to 2.  (In a tie and both are in the set or
9975          * both not in the set, it doesn't matter which we take first.) */
9976         if (       array_a[i_a] < array_b[i_b]
9977             || (   array_a[i_a] == array_b[i_b]
9978                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9979         {
9980             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9981             cp = array_a[i_a++];
9982         }
9983         else {
9984             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9985             cp= array_b[i_b++];
9986         }
9987
9988         /* Here, have chosen which of the two inputs to look at.  Only output
9989          * if the running count changes to/from 2, which marks the
9990          * beginning/end of a range that's in the intersection */
9991         if (cp_in_set) {
9992             count++;
9993             if (count == 2) {
9994                 array_r[i_r++] = cp;
9995             }
9996         }
9997         else {
9998             if (count == 2) {
9999                 array_r[i_r++] = cp;
10000             }
10001             count--;
10002         }
10003
10004     }
10005
10006     /* The loop above increments the index into exactly one of the input lists
10007      * each iteration, and ends when either index gets to its list end.  That
10008      * means the other index is lower than its end, and so something is
10009      * remaining in that one.  We increment 'count', as explained below, if the
10010      * exhausted list was in its set.  (i_a and i_b each currently index the
10011      * element beyond the one we care about.) */
10012     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
10013         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
10014     {
10015         count++;
10016     }
10017
10018     /* Above we incremented 'count' if the exhausted list was in its set.  This
10019      * has made it so that 'count' being below 2 means there is nothing left to
10020      * output; otheriwse what's left to add to the intersection is precisely
10021      * that which is left in the non-exhausted input list.
10022      *
10023      * To see why, note first that the exhausted input obviously has nothing
10024      * left to affect the intersection.  If it was in its set at its end, that
10025      * means the set extends from here to the platform's infinity, and hence
10026      * anything in the non-exhausted's list will be in the intersection, and
10027      * anything not in it won't be.  Hence, the rest of the intersection is
10028      * precisely what's in the non-exhausted list  The exhausted set also
10029      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
10030      * it means 'count' is now at least 2.  This is consistent with the
10031      * incremented 'count' being >= 2 means to add the non-exhausted list to
10032      * the intersection.
10033      *
10034      * But if the exhausted input wasn't in its set, it contributed 0 to
10035      * 'count', and the intersection can't include anything further; the
10036      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
10037      * incremented.  This is consistent with 'count' being < 2 meaning nothing
10038      * further to add to the intersection. */
10039     if (count < 2) { /* Nothing left to put in the intersection. */
10040         len_r = i_r;
10041     }
10042     else { /* copy the non-exhausted list, unchanged. */
10043         IV copy_count = len_a - i_a;
10044         if (copy_count > 0) {   /* a is the one with stuff left */
10045             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
10046         }
10047         else {  /* b is the one with stuff left */
10048             copy_count = len_b - i_b;
10049             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
10050         }
10051         len_r = i_r + copy_count;
10052     }
10053
10054     /* Set the result to the final length, which can change the pointer to
10055      * array_r, so re-find it.  (Note that it is unlikely that this will
10056      * change, as we are shrinking the space, not enlarging it) */
10057     if (len_r != _invlist_len(r)) {
10058         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
10059         invlist_trim(r);
10060         array_r = invlist_array(r);
10061     }
10062
10063     if (*i == NULL) { /* Simply return the calculated intersection */
10064         *i = r;
10065     }
10066     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
10067               instead free '*i', and then set it to 'r', but experience has
10068               shown [perl #127392] that if the input is a mortal, we can get a
10069               huge build-up of these during regex compilation before they get
10070               freed. */
10071         if (len_r) {
10072             invlist_replace_list_destroys_src(*i, r);
10073         }
10074         else {
10075             invlist_clear(*i);
10076         }
10077         SvREFCNT_dec_NN(r);
10078     }
10079
10080     return;
10081 }
10082
10083 SV*
10084 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
10085 {
10086     /* Add the range from 'start' to 'end' inclusive to the inversion list's
10087      * set.  A pointer to the inversion list is returned.  This may actually be
10088      * a new list, in which case the passed in one has been destroyed.  The
10089      * passed-in inversion list can be NULL, in which case a new one is created
10090      * with just the one range in it.  The new list is not necessarily
10091      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
10092      * result of this function.  The gain would not be large, and in many
10093      * cases, this is called multiple times on a single inversion list, so
10094      * anything freed may almost immediately be needed again.
10095      *
10096      * This used to mostly call the 'union' routine, but that is much more
10097      * heavyweight than really needed for a single range addition */
10098
10099     UV* array;              /* The array implementing the inversion list */
10100     UV len;                 /* How many elements in 'array' */
10101     SSize_t i_s;            /* index into the invlist array where 'start'
10102                                should go */
10103     SSize_t i_e = 0;        /* And the index where 'end' should go */
10104     UV cur_highest;         /* The highest code point in the inversion list
10105                                upon entry to this function */
10106
10107     /* This range becomes the whole inversion list if none already existed */
10108     if (invlist == NULL) {
10109         invlist = _new_invlist(2);
10110         _append_range_to_invlist(invlist, start, end);
10111         return invlist;
10112     }
10113
10114     /* Likewise, if the inversion list is currently empty */
10115     len = _invlist_len(invlist);
10116     if (len == 0) {
10117         _append_range_to_invlist(invlist, start, end);
10118         return invlist;
10119     }
10120
10121     /* Starting here, we have to know the internals of the list */
10122     array = invlist_array(invlist);
10123
10124     /* If the new range ends higher than the current highest ... */
10125     cur_highest = invlist_highest(invlist);
10126     if (end > cur_highest) {
10127
10128         /* If the whole range is higher, we can just append it */
10129         if (start > cur_highest) {
10130             _append_range_to_invlist(invlist, start, end);
10131             return invlist;
10132         }
10133
10134         /* Otherwise, add the portion that is higher ... */
10135         _append_range_to_invlist(invlist, cur_highest + 1, end);
10136
10137         /* ... and continue on below to handle the rest.  As a result of the
10138          * above append, we know that the index of the end of the range is the
10139          * final even numbered one of the array.  Recall that the final element
10140          * always starts a range that extends to infinity.  If that range is in
10141          * the set (meaning the set goes from here to infinity), it will be an
10142          * even index, but if it isn't in the set, it's odd, and the final
10143          * range in the set is one less, which is even. */
10144         if (end == UV_MAX) {
10145             i_e = len;
10146         }
10147         else {
10148             i_e = len - 2;
10149         }
10150     }
10151
10152     /* We have dealt with appending, now see about prepending.  If the new
10153      * range starts lower than the current lowest ... */
10154     if (start < array[0]) {
10155
10156         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
10157          * Let the union code handle it, rather than having to know the
10158          * trickiness in two code places.  */
10159         if (UNLIKELY(start == 0)) {
10160             SV* range_invlist;
10161
10162             range_invlist = _new_invlist(2);
10163             _append_range_to_invlist(range_invlist, start, end);
10164
10165             _invlist_union(invlist, range_invlist, &invlist);
10166
10167             SvREFCNT_dec_NN(range_invlist);
10168
10169             return invlist;
10170         }
10171
10172         /* If the whole new range comes before the first entry, and doesn't
10173          * extend it, we have to insert it as an additional range */
10174         if (end < array[0] - 1) {
10175             i_s = i_e = -1;
10176             goto splice_in_new_range;
10177         }
10178
10179         /* Here the new range adjoins the existing first range, extending it
10180          * downwards. */
10181         array[0] = start;
10182
10183         /* And continue on below to handle the rest.  We know that the index of
10184          * the beginning of the range is the first one of the array */
10185         i_s = 0;
10186     }
10187     else { /* Not prepending any part of the new range to the existing list.
10188             * Find where in the list it should go.  This finds i_s, such that:
10189             *     invlist[i_s] <= start < array[i_s+1]
10190             */
10191         i_s = _invlist_search(invlist, start);
10192     }
10193
10194     /* At this point, any extending before the beginning of the inversion list
10195      * and/or after the end has been done.  This has made it so that, in the
10196      * code below, each endpoint of the new range is either in a range that is
10197      * in the set, or is in a gap between two ranges that are.  This means we
10198      * don't have to worry about exceeding the array bounds.
10199      *
10200      * Find where in the list the new range ends (but we can skip this if we
10201      * have already determined what it is, or if it will be the same as i_s,
10202      * which we already have computed) */
10203     if (i_e == 0) {
10204         i_e = (start == end)
10205               ? i_s
10206               : _invlist_search(invlist, end);
10207     }
10208
10209     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
10210      * is a range that goes to infinity there is no element at invlist[i_e+1],
10211      * so only the first relation holds. */
10212
10213     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10214
10215         /* Here, the ranges on either side of the beginning of the new range
10216          * are in the set, and this range starts in the gap between them.
10217          *
10218          * The new range extends the range above it downwards if the new range
10219          * ends at or above that range's start */
10220         const bool extends_the_range_above = (   end == UV_MAX
10221                                               || end + 1 >= array[i_s+1]);
10222
10223         /* The new range extends the range below it upwards if it begins just
10224          * after where that range ends */
10225         if (start == array[i_s]) {
10226
10227             /* If the new range fills the entire gap between the other ranges,
10228              * they will get merged together.  Other ranges may also get
10229              * merged, depending on how many of them the new range spans.  In
10230              * the general case, we do the merge later, just once, after we
10231              * figure out how many to merge.  But in the case where the new
10232              * range exactly spans just this one gap (possibly extending into
10233              * the one above), we do the merge here, and an early exit.  This
10234              * is done here to avoid having to special case later. */
10235             if (i_e - i_s <= 1) {
10236
10237                 /* If i_e - i_s == 1, it means that the new range terminates
10238                  * within the range above, and hence 'extends_the_range_above'
10239                  * must be true.  (If the range above it extends to infinity,
10240                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
10241                  * will be 0, so no harm done.) */
10242                 if (extends_the_range_above) {
10243                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
10244                     invlist_set_len(invlist,
10245                                     len - 2,
10246                                     *(get_invlist_offset_addr(invlist)));
10247                     return invlist;
10248                 }
10249
10250                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
10251                  * to the same range, and below we are about to decrement i_s
10252                  * */
10253                 i_e--;
10254             }
10255
10256             /* Here, the new range is adjacent to the one below.  (It may also
10257              * span beyond the range above, but that will get resolved later.)
10258              * Extend the range below to include this one. */
10259             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
10260             i_s--;
10261             start = array[i_s];
10262         }
10263         else if (extends_the_range_above) {
10264
10265             /* Here the new range only extends the range above it, but not the
10266              * one below.  It merges with the one above.  Again, we keep i_e
10267              * and i_s in sync if they point to the same range */
10268             if (i_e == i_s) {
10269                 i_e++;
10270             }
10271             i_s++;
10272             array[i_s] = start;
10273         }
10274     }
10275
10276     /* Here, we've dealt with the new range start extending any adjoining
10277      * existing ranges.
10278      *
10279      * If the new range extends to infinity, it is now the final one,
10280      * regardless of what was there before */
10281     if (UNLIKELY(end == UV_MAX)) {
10282         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
10283         return invlist;
10284     }
10285
10286     /* If i_e started as == i_s, it has also been dealt with,
10287      * and been updated to the new i_s, which will fail the following if */
10288     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
10289
10290         /* Here, the ranges on either side of the end of the new range are in
10291          * the set, and this range ends in the gap between them.
10292          *
10293          * If this range is adjacent to (hence extends) the range above it, it
10294          * becomes part of that range; likewise if it extends the range below,
10295          * it becomes part of that range */
10296         if (end + 1 == array[i_e+1]) {
10297             i_e++;
10298             array[i_e] = start;
10299         }
10300         else if (start <= array[i_e]) {
10301             array[i_e] = end + 1;
10302             i_e--;
10303         }
10304     }
10305
10306     if (i_s == i_e) {
10307
10308         /* If the range fits entirely in an existing range (as possibly already
10309          * extended above), it doesn't add anything new */
10310         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10311             return invlist;
10312         }
10313
10314         /* Here, no part of the range is in the list.  Must add it.  It will
10315          * occupy 2 more slots */
10316       splice_in_new_range:
10317
10318         invlist_extend(invlist, len + 2);
10319         array = invlist_array(invlist);
10320         /* Move the rest of the array down two slots. Don't include any
10321          * trailing NUL */
10322         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
10323
10324         /* Do the actual splice */
10325         array[i_e+1] = start;
10326         array[i_e+2] = end + 1;
10327         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
10328         return invlist;
10329     }
10330
10331     /* Here the new range crossed the boundaries of a pre-existing range.  The
10332      * code above has adjusted things so that both ends are in ranges that are
10333      * in the set.  This means everything in between must also be in the set.
10334      * Just squash things together */
10335     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
10336     invlist_set_len(invlist,
10337                     len - i_e + i_s,
10338                     *(get_invlist_offset_addr(invlist)));
10339
10340     return invlist;
10341 }
10342
10343 SV*
10344 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
10345                                  UV** other_elements_ptr)
10346 {
10347     /* Create and return an inversion list whose contents are to be populated
10348      * by the caller.  The caller gives the number of elements (in 'size') and
10349      * the very first element ('element0').  This function will set
10350      * '*other_elements_ptr' to an array of UVs, where the remaining elements
10351      * are to be placed.
10352      *
10353      * Obviously there is some trust involved that the caller will properly
10354      * fill in the other elements of the array.
10355      *
10356      * (The first element needs to be passed in, as the underlying code does
10357      * things differently depending on whether it is zero or non-zero) */
10358
10359     SV* invlist = _new_invlist(size);
10360     bool offset;
10361
10362     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
10363
10364     invlist = add_cp_to_invlist(invlist, element0);
10365     offset = *get_invlist_offset_addr(invlist);
10366
10367     invlist_set_len(invlist, size, offset);
10368     *other_elements_ptr = invlist_array(invlist) + 1;
10369     return invlist;
10370 }
10371
10372 #endif
10373
10374 #ifndef PERL_IN_XSUB_RE
10375 void
10376 Perl__invlist_invert(pTHX_ SV* const invlist)
10377 {
10378     /* Complement the input inversion list.  This adds a 0 if the list didn't
10379      * have a zero; removes it otherwise.  As described above, the data
10380      * structure is set up so that this is very efficient */
10381
10382     PERL_ARGS_ASSERT__INVLIST_INVERT;
10383
10384     assert(! invlist_is_iterating(invlist));
10385
10386     /* The inverse of matching nothing is matching everything */
10387     if (_invlist_len(invlist) == 0) {
10388         _append_range_to_invlist(invlist, 0, UV_MAX);
10389         return;
10390     }
10391
10392     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
10393 }
10394
10395 SV*
10396 Perl_invlist_clone(pTHX_ SV* const invlist, SV* new_invlist)
10397 {
10398     /* Return a new inversion list that is a copy of the input one, which is
10399      * unchanged.  The new list will not be mortal even if the old one was. */
10400
10401     const STRLEN nominal_length = _invlist_len(invlist);
10402     const STRLEN physical_length = SvCUR(invlist);
10403     const bool offset = *(get_invlist_offset_addr(invlist));
10404
10405     PERL_ARGS_ASSERT_INVLIST_CLONE;
10406
10407     if (new_invlist == NULL) {
10408         new_invlist = _new_invlist(nominal_length);
10409     }
10410     else {
10411         sv_upgrade(new_invlist, SVt_INVLIST);
10412         initialize_invlist_guts(new_invlist, nominal_length);
10413     }
10414
10415     *(get_invlist_offset_addr(new_invlist)) = offset;
10416     invlist_set_len(new_invlist, nominal_length, offset);
10417     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
10418
10419     return new_invlist;
10420 }
10421
10422 #endif
10423
10424 PERL_STATIC_INLINE UV
10425 S_invlist_lowest(SV* const invlist)
10426 {
10427     /* Returns the lowest code point that matches an inversion list.  This API
10428      * has an ambiguity, as it returns 0 under either the lowest is actually
10429      * 0, or if the list is empty.  If this distinction matters to you, check
10430      * for emptiness before calling this function */
10431
10432     UV len = _invlist_len(invlist);
10433     UV *array;
10434
10435     PERL_ARGS_ASSERT_INVLIST_LOWEST;
10436
10437     if (len == 0) {
10438         return 0;
10439     }
10440
10441     array = invlist_array(invlist);
10442
10443     return array[0];
10444 }
10445
10446 STATIC SV *
10447 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10448 {
10449     /* Get the contents of an inversion list into a string SV so that they can
10450      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10451      * traditionally done for debug tracing; otherwise it uses a format
10452      * suitable for just copying to the output, with blanks between ranges and
10453      * a dash between range components */
10454
10455     UV start, end;
10456     SV* output;
10457     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10458     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10459
10460     if (traditional_style) {
10461         output = newSVpvs("\n");
10462     }
10463     else {
10464         output = newSVpvs("");
10465     }
10466
10467     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10468
10469     assert(! invlist_is_iterating(invlist));
10470
10471     invlist_iterinit(invlist);
10472     while (invlist_iternext(invlist, &start, &end)) {
10473         if (end == UV_MAX) {
10474             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c",
10475                                           start, intra_range_delimiter,
10476                                                  inter_range_delimiter);
10477         }
10478         else if (end != start) {
10479             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10480                                           start,
10481                                                    intra_range_delimiter,
10482                                                   end, inter_range_delimiter);
10483         }
10484         else {
10485             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10486                                           start, inter_range_delimiter);
10487         }
10488     }
10489
10490     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10491         SvCUR_set(output, SvCUR(output) - 1);
10492     }
10493
10494     return output;
10495 }
10496
10497 #ifndef PERL_IN_XSUB_RE
10498 void
10499 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10500                          const char * const indent, SV* const invlist)
10501 {
10502     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10503      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10504      * the string 'indent'.  The output looks like this:
10505          [0] 0x000A .. 0x000D
10506          [2] 0x0085
10507          [4] 0x2028 .. 0x2029
10508          [6] 0x3104 .. INFTY
10509      * This means that the first range of code points matched by the list are
10510      * 0xA through 0xD; the second range contains only the single code point
10511      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10512      * are used to define each range (except if the final range extends to
10513      * infinity, only a single element is needed).  The array index of the
10514      * first element for the corresponding range is given in brackets. */
10515
10516     UV start, end;
10517     STRLEN count = 0;
10518
10519     PERL_ARGS_ASSERT__INVLIST_DUMP;
10520
10521     if (invlist_is_iterating(invlist)) {
10522         Perl_dump_indent(aTHX_ level, file,
10523              "%sCan't dump inversion list because is in middle of iterating\n",
10524              indent);
10525         return;
10526     }
10527
10528     invlist_iterinit(invlist);
10529     while (invlist_iternext(invlist, &start, &end)) {
10530         if (end == UV_MAX) {
10531             Perl_dump_indent(aTHX_ level, file,
10532                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n",
10533                                    indent, (UV)count, start);
10534         }
10535         else if (end != start) {
10536             Perl_dump_indent(aTHX_ level, file,
10537                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10538                                 indent, (UV)count, start,         end);
10539         }
10540         else {
10541             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10542                                             indent, (UV)count, start);
10543         }
10544         count += 2;
10545     }
10546 }
10547
10548 #endif
10549
10550 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10551 bool
10552 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10553 {
10554     /* Return a boolean as to if the two passed in inversion lists are
10555      * identical.  The final argument, if TRUE, says to take the complement of
10556      * the second inversion list before doing the comparison */
10557
10558     const UV len_a = _invlist_len(a);
10559     UV len_b = _invlist_len(b);
10560
10561     const UV* array_a = NULL;
10562     const UV* array_b = NULL;
10563
10564     PERL_ARGS_ASSERT__INVLISTEQ;
10565
10566     /* This code avoids accessing the arrays unless it knows the length is
10567      * non-zero */
10568
10569     if (len_a == 0) {
10570         if (len_b == 0) {
10571             return ! complement_b;
10572         }
10573     }
10574     else {
10575         array_a = invlist_array(a);
10576     }
10577
10578     if (len_b != 0) {
10579         array_b = invlist_array(b);
10580     }
10581
10582     /* If are to compare 'a' with the complement of b, set it
10583      * up so are looking at b's complement. */
10584     if (complement_b) {
10585
10586         /* The complement of nothing is everything, so <a> would have to have
10587          * just one element, starting at zero (ending at infinity) */
10588         if (len_b == 0) {
10589             return (len_a == 1 && array_a[0] == 0);
10590         }
10591         if (array_b[0] == 0) {
10592
10593             /* Otherwise, to complement, we invert.  Here, the first element is
10594              * 0, just remove it.  To do this, we just pretend the array starts
10595              * one later */
10596
10597             array_b++;
10598             len_b--;
10599         }
10600         else {
10601
10602             /* But if the first element is not zero, we pretend the list starts
10603              * at the 0 that is always stored immediately before the array. */
10604             array_b--;
10605             len_b++;
10606         }
10607     }
10608
10609     return    len_a == len_b
10610            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10611
10612 }
10613 #endif
10614
10615 /*
10616  * As best we can, determine the characters that can match the start of
10617  * the given EXACTF-ish node.  This is for use in creating ssc nodes, so there
10618  * can be false positive matches
10619  *
10620  * Returns the invlist as a new SV*; it is the caller's responsibility to
10621  * call SvREFCNT_dec() when done with it.
10622  */
10623 STATIC SV*
10624 S_make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10625 {
10626     const U8 * s = (U8*)STRING(node);
10627     SSize_t bytelen = STR_LEN(node);
10628     UV uc;
10629     /* Start out big enough for 2 separate code points */
10630     SV* invlist = _new_invlist(4);
10631
10632     PERL_ARGS_ASSERT_MAKE_EXACTF_INVLIST;
10633
10634     if (! UTF) {
10635         uc = *s;
10636
10637         /* We punt and assume can match anything if the node begins
10638          * with a multi-character fold.  Things are complicated.  For
10639          * example, /ffi/i could match any of:
10640          *  "\N{LATIN SMALL LIGATURE FFI}"
10641          *  "\N{LATIN SMALL LIGATURE FF}I"
10642          *  "F\N{LATIN SMALL LIGATURE FI}"
10643          *  plus several other things; and making sure we have all the
10644          *  possibilities is hard. */
10645         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10646             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10647         }
10648         else {
10649             /* Any Latin1 range character can potentially match any
10650              * other depending on the locale, and in Turkic locales, U+130 and
10651              * U+131 */
10652             if (OP(node) == EXACTFL) {
10653                 _invlist_union(invlist, PL_Latin1, &invlist);
10654                 invlist = add_cp_to_invlist(invlist,
10655                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10656                 invlist = add_cp_to_invlist(invlist,
10657                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10658             }
10659             else {
10660                 /* But otherwise, it matches at least itself.  We can
10661                  * quickly tell if it has a distinct fold, and if so,
10662                  * it matches that as well */
10663                 invlist = add_cp_to_invlist(invlist, uc);
10664                 if (IS_IN_SOME_FOLD_L1(uc))
10665                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10666             }
10667
10668             /* Some characters match above-Latin1 ones under /i.  This
10669              * is true of EXACTFL ones when the locale is UTF-8 */
10670             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10671                 && (! isASCII(uc) || ! inRANGE(OP(node), EXACTFAA,
10672                                                          EXACTFAA_NO_TRIE)))
10673             {
10674                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10675             }
10676         }
10677     }
10678     else {  /* Pattern is UTF-8 */
10679         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10680         const U8* e = s + bytelen;
10681         IV fc;
10682
10683         fc = uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10684
10685         /* The only code points that aren't folded in a UTF EXACTFish
10686          * node are the problematic ones in EXACTFL nodes */
10687         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10688             /* We need to check for the possibility that this EXACTFL
10689              * node begins with a multi-char fold.  Therefore we fold
10690              * the first few characters of it so that we can make that
10691              * check */
10692             U8 *d = folded;
10693             int i;
10694
10695             fc = -1;
10696             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10697                 if (isASCII(*s)) {
10698                     *(d++) = (U8) toFOLD(*s);
10699                     if (fc < 0) {       /* Save the first fold */
10700                         fc = *(d-1);
10701                     }
10702                     s++;
10703                 }
10704                 else {
10705                     STRLEN len;
10706                     UV fold = toFOLD_utf8_safe(s, e, d, &len);
10707                     if (fc < 0) {       /* Save the first fold */
10708                         fc = fold;
10709                     }
10710                     d += len;
10711                     s += UTF8SKIP(s);
10712                 }
10713             }
10714
10715             /* And set up so the code below that looks in this folded
10716              * buffer instead of the node's string */
10717             e = d;
10718             s = folded;
10719         }
10720
10721         /* When we reach here 's' points to the fold of the first
10722          * character(s) of the node; and 'e' points to far enough along
10723          * the folded string to be just past any possible multi-char
10724          * fold.
10725          *
10726          * Like the non-UTF case above, we punt if the node begins with a
10727          * multi-char fold  */
10728
10729         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10730             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10731         }
10732         else {  /* Single char fold */
10733             unsigned int k;
10734             U32 first_fold;
10735             const U32 * remaining_folds;
10736             Size_t folds_count;
10737
10738             /* It matches itself */
10739             invlist = add_cp_to_invlist(invlist, fc);
10740
10741             /* ... plus all the things that fold to it, which are found in
10742              * PL_utf8_foldclosures */
10743             folds_count = _inverse_folds(fc, &first_fold,
10744                                                 &remaining_folds);
10745             for (k = 0; k < folds_count; k++) {
10746                 UV c = (k == 0) ? first_fold : remaining_folds[k-1];
10747
10748                 /* /aa doesn't allow folds between ASCII and non- */
10749                 if (   inRANGE(OP(node), EXACTFAA, EXACTFAA_NO_TRIE)
10750                     && isASCII(c) != isASCII(fc))
10751                 {
10752                     continue;
10753                 }
10754
10755                 invlist = add_cp_to_invlist(invlist, c);
10756             }
10757
10758             if (OP(node) == EXACTFL) {
10759
10760                 /* If either [iI] are present in an EXACTFL node the above code
10761                  * should have added its normal case pair, but under a Turkish
10762                  * locale they could match instead the case pairs from it.  Add
10763                  * those as potential matches as well */
10764                 if (isALPHA_FOLD_EQ(fc, 'I')) {
10765                     invlist = add_cp_to_invlist(invlist,
10766                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10767                     invlist = add_cp_to_invlist(invlist,
10768                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10769                 }
10770                 else if (fc == LATIN_SMALL_LETTER_DOTLESS_I) {
10771                     invlist = add_cp_to_invlist(invlist, 'I');
10772                 }
10773                 else if (fc == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
10774                     invlist = add_cp_to_invlist(invlist, 'i');
10775                 }
10776             }
10777         }
10778     }
10779
10780     return invlist;
10781 }
10782
10783 #undef HEADER_LENGTH
10784 #undef TO_INTERNAL_SIZE
10785 #undef FROM_INTERNAL_SIZE
10786 #undef INVLIST_VERSION_ID
10787
10788 /* End of inversion list object */
10789
10790 STATIC void
10791 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10792 {
10793     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10794      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10795      * should point to the first flag; it is updated on output to point to the
10796      * final ')' or ':'.  There needs to be at least one flag, or this will
10797      * abort */
10798
10799     /* for (?g), (?gc), and (?o) warnings; warning
10800        about (?c) will warn about (?g) -- japhy    */
10801
10802 #define WASTED_O  0x01
10803 #define WASTED_G  0x02
10804 #define WASTED_C  0x04
10805 #define WASTED_GC (WASTED_G|WASTED_C)
10806     I32 wastedflags = 0x00;
10807     U32 posflags = 0, negflags = 0;
10808     U32 *flagsp = &posflags;
10809     char has_charset_modifier = '\0';
10810     regex_charset cs;
10811     bool has_use_defaults = FALSE;
10812     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10813     int x_mod_count = 0;
10814
10815     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10816
10817     /* '^' as an initial flag sets certain defaults */
10818     if (UCHARAT(RExC_parse) == '^') {
10819         RExC_parse++;
10820         has_use_defaults = TRUE;
10821         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10822         cs = (RExC_uni_semantics)
10823              ? REGEX_UNICODE_CHARSET
10824              : REGEX_DEPENDS_CHARSET;
10825         set_regex_charset(&RExC_flags, cs);
10826     }
10827     else {
10828         cs = get_regex_charset(RExC_flags);
10829         if (   cs == REGEX_DEPENDS_CHARSET
10830             && RExC_uni_semantics)
10831         {
10832             cs = REGEX_UNICODE_CHARSET;
10833         }
10834     }
10835
10836     while (RExC_parse < RExC_end) {
10837         /* && memCHRs("iogcmsx", *RExC_parse) */
10838         /* (?g), (?gc) and (?o) are useless here
10839            and must be globally applied -- japhy */
10840         if ((RExC_pm_flags & PMf_WILDCARD)) {
10841             if (flagsp == & negflags) {
10842                 if (*RExC_parse == 'm') {
10843                     RExC_parse++;
10844                     /* diag_listed_as: Use of %s is not allowed in Unicode
10845                        property wildcard subpatterns in regex; marked by <--
10846                        HERE in m/%s/ */
10847                     vFAIL("Use of modifier '-m' is not allowed in Unicode"
10848                           " property wildcard subpatterns");
10849                 }
10850             }
10851             else {
10852                 if (*RExC_parse == 's') {
10853                     goto modifier_illegal_in_wildcard;
10854                 }
10855             }
10856         }
10857
10858         switch (*RExC_parse) {
10859
10860             /* Code for the imsxn flags */
10861             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10862
10863             case LOCALE_PAT_MOD:
10864                 if (has_charset_modifier) {
10865                     goto excess_modifier;
10866                 }
10867                 else if (flagsp == &negflags) {
10868                     goto neg_modifier;
10869                 }
10870                 cs = REGEX_LOCALE_CHARSET;
10871                 has_charset_modifier = LOCALE_PAT_MOD;
10872                 break;
10873             case UNICODE_PAT_MOD:
10874                 if (has_charset_modifier) {
10875                     goto excess_modifier;
10876                 }
10877                 else if (flagsp == &negflags) {
10878                     goto neg_modifier;
10879                 }
10880                 cs = REGEX_UNICODE_CHARSET;
10881                 has_charset_modifier = UNICODE_PAT_MOD;
10882                 break;
10883             case ASCII_RESTRICT_PAT_MOD:
10884                 if (flagsp == &negflags) {
10885                     goto neg_modifier;
10886                 }
10887                 if (has_charset_modifier) {
10888                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10889                         goto excess_modifier;
10890                     }
10891                     /* Doubled modifier implies more restricted */
10892                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10893                 }
10894                 else {
10895                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10896                 }
10897                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10898                 break;
10899             case DEPENDS_PAT_MOD:
10900                 if (has_use_defaults) {
10901                     goto fail_modifiers;
10902                 }
10903                 else if (flagsp == &negflags) {
10904                     goto neg_modifier;
10905                 }
10906                 else if (has_charset_modifier) {
10907                     goto excess_modifier;
10908                 }
10909
10910                 /* The dual charset means unicode semantics if the
10911                  * pattern (or target, not known until runtime) are
10912                  * utf8, or something in the pattern indicates unicode
10913                  * semantics */
10914                 cs = (RExC_uni_semantics)
10915                      ? REGEX_UNICODE_CHARSET
10916                      : REGEX_DEPENDS_CHARSET;
10917                 has_charset_modifier = DEPENDS_PAT_MOD;
10918                 break;
10919               excess_modifier:
10920                 RExC_parse++;
10921                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10922                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10923                 }
10924                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10925                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10926                                         *(RExC_parse - 1));
10927                 }
10928                 else {
10929                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10930                 }
10931                 NOT_REACHED; /*NOTREACHED*/
10932               neg_modifier:
10933                 RExC_parse++;
10934                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10935                                     *(RExC_parse - 1));
10936                 NOT_REACHED; /*NOTREACHED*/
10937             case GLOBAL_PAT_MOD: /* 'g' */
10938                 if (RExC_pm_flags & PMf_WILDCARD) {
10939                     goto modifier_illegal_in_wildcard;
10940                 }
10941                 /*FALLTHROUGH*/
10942             case ONCE_PAT_MOD: /* 'o' */
10943                 if (ckWARN(WARN_REGEXP)) {
10944                     const I32 wflagbit = *RExC_parse == 'o'
10945                                          ? WASTED_O
10946                                          : WASTED_G;
10947                     if (! (wastedflags & wflagbit) ) {
10948                         wastedflags |= wflagbit;
10949                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10950                         vWARN5(
10951                             RExC_parse + 1,
10952                             "Useless (%s%c) - %suse /%c modifier",
10953                             flagsp == &negflags ? "?-" : "?",
10954                             *RExC_parse,
10955                             flagsp == &negflags ? "don't " : "",
10956                             *RExC_parse
10957                         );
10958                     }
10959                 }
10960                 break;
10961
10962             case CONTINUE_PAT_MOD: /* 'c' */
10963                 if (RExC_pm_flags & PMf_WILDCARD) {
10964                     goto modifier_illegal_in_wildcard;
10965                 }
10966                 if (ckWARN(WARN_REGEXP)) {
10967                     if (! (wastedflags & WASTED_C) ) {
10968                         wastedflags |= WASTED_GC;
10969                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10970                         vWARN3(
10971                             RExC_parse + 1,
10972                             "Useless (%sc) - %suse /gc modifier",
10973                             flagsp == &negflags ? "?-" : "?",
10974                             flagsp == &negflags ? "don't " : ""
10975                         );
10976                     }
10977                 }
10978                 break;
10979             case KEEPCOPY_PAT_MOD: /* 'p' */
10980                 if (RExC_pm_flags & PMf_WILDCARD) {
10981                     goto modifier_illegal_in_wildcard;
10982                 }
10983                 if (flagsp == &negflags) {
10984                     ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10985                 } else {
10986                     *flagsp |= RXf_PMf_KEEPCOPY;
10987                 }
10988                 break;
10989             case '-':
10990                 /* A flag is a default iff it is following a minus, so
10991                  * if there is a minus, it means will be trying to
10992                  * re-specify a default which is an error */
10993                 if (has_use_defaults || flagsp == &negflags) {
10994                     goto fail_modifiers;
10995                 }
10996                 flagsp = &negflags;
10997                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10998                 x_mod_count = 0;
10999                 break;
11000             case ':':
11001             case ')':
11002
11003                 if (  (RExC_pm_flags & PMf_WILDCARD)
11004                     && cs != REGEX_ASCII_MORE_RESTRICTED_CHARSET)
11005                 {
11006                     RExC_parse++;
11007                     /* diag_listed_as: Use of %s is not allowed in Unicode
11008                        property wildcard subpatterns in regex; marked by <--
11009                        HERE in m/%s/ */
11010                     vFAIL2("Use of modifier '%c' is not allowed in Unicode"
11011                            " property wildcard subpatterns",
11012                            has_charset_modifier);
11013                 }
11014
11015                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
11016                     negflags |= RXf_PMf_EXTENDED_MORE;
11017                 }
11018                 RExC_flags |= posflags;
11019
11020                 if (negflags & RXf_PMf_EXTENDED) {
11021                     negflags |= RXf_PMf_EXTENDED_MORE;
11022                 }
11023                 RExC_flags &= ~negflags;
11024                 set_regex_charset(&RExC_flags, cs);
11025
11026                 return;
11027             default:
11028               fail_modifiers:
11029                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11030                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11031                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
11032                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11033                 NOT_REACHED; /*NOTREACHED*/
11034         }
11035
11036         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11037     }
11038
11039     vFAIL("Sequence (?... not terminated");
11040
11041   modifier_illegal_in_wildcard:
11042     RExC_parse++;
11043     /* diag_listed_as: Use of %s is not allowed in Unicode property wildcard
11044        subpatterns in regex; marked by <-- HERE in m/%s/ */
11045     vFAIL2("Use of modifier '%c' is not allowed in Unicode property wildcard"
11046            " subpatterns", *(RExC_parse - 1));
11047 }
11048
11049 /*
11050  - reg - regular expression, i.e. main body or parenthesized thing
11051  *
11052  * Caller must absorb opening parenthesis.
11053  *
11054  * Combining parenthesis handling with the base level of regular expression
11055  * is a trifle forced, but the need to tie the tails of the branches to what
11056  * follows makes it hard to avoid.
11057  */
11058 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
11059 #ifdef DEBUGGING
11060 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
11061 #else
11062 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
11063 #endif
11064
11065 STATIC regnode_offset
11066 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
11067                              I32 *flagp,
11068                              char * parse_start,
11069                              char ch
11070                       )
11071 {
11072     regnode_offset ret;
11073     char* name_start = RExC_parse;
11074     U32 num = 0;
11075     SV *sv_dat = reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
11076     DECLARE_AND_GET_RE_DEBUG_FLAGS;
11077
11078     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
11079
11080     if (RExC_parse == name_start || *RExC_parse != ch) {
11081         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
11082         vFAIL2("Sequence %.3s... not terminated", parse_start);
11083     }
11084
11085     if (sv_dat) {
11086         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11087         RExC_rxi->data->data[num]=(void*)sv_dat;
11088         SvREFCNT_inc_simple_void_NN(sv_dat);
11089     }
11090     RExC_sawback = 1;
11091     ret = reganode(pRExC_state,
11092                    ((! FOLD)
11093                      ? REFN
11094                      : (ASCII_FOLD_RESTRICTED)
11095                        ? REFFAN
11096                        : (AT_LEAST_UNI_SEMANTICS)
11097                          ? REFFUN
11098                          : (LOC)
11099                            ? REFFLN
11100                            : REFFN),
11101                     num);
11102     *flagp |= HASWIDTH;
11103
11104     Set_Node_Offset(REGNODE_p(ret), parse_start+1);
11105     Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
11106
11107     nextchar(pRExC_state);
11108     return ret;
11109 }
11110
11111 /* On success, returns the offset at which any next node should be placed into
11112  * the regex engine program being compiled.
11113  *
11114  * Returns 0 otherwise, with *flagp set to indicate why:
11115  *  TRYAGAIN        at the end of (?) that only sets flags.
11116  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
11117  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
11118  *  Otherwise would only return 0 if regbranch() returns 0, which cannot
11119  *  happen.  */
11120 STATIC regnode_offset
11121 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
11122     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
11123      * 2 is like 1, but indicates that nextchar() has been called to advance
11124      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
11125      * this flag alerts us to the need to check for that */
11126 {
11127     regnode_offset ret = 0;    /* Will be the head of the group. */
11128     regnode_offset br;
11129     regnode_offset lastbr;
11130     regnode_offset ender = 0;
11131     I32 parno = 0;
11132     I32 flags;
11133     U32 oregflags = RExC_flags;
11134     bool have_branch = 0;
11135     bool is_open = 0;
11136     I32 freeze_paren = 0;
11137     I32 after_freeze = 0;
11138     I32 num; /* numeric backreferences */
11139     SV * max_open;  /* Max number of unclosed parens */
11140
11141     char * parse_start = RExC_parse; /* MJD */
11142     char * const oregcomp_parse = RExC_parse;
11143
11144     DECLARE_AND_GET_RE_DEBUG_FLAGS;
11145
11146     PERL_ARGS_ASSERT_REG;
11147     DEBUG_PARSE("reg ");
11148
11149     max_open = get_sv(RE_COMPILE_RECURSION_LIMIT, GV_ADD);
11150     assert(max_open);
11151     if (!SvIOK(max_open)) {
11152         sv_setiv(max_open, RE_COMPILE_RECURSION_INIT);
11153     }
11154     if (depth > 4 * (UV) SvIV(max_open)) { /* We increase depth by 4 for each
11155                                               open paren */
11156         vFAIL("Too many nested open parens");
11157     }
11158
11159     *flagp = 0;                         /* Initialize. */
11160
11161     if (RExC_in_lookbehind) {
11162         RExC_in_lookbehind++;
11163     }
11164     if (RExC_in_lookahead) {
11165         RExC_in_lookahead++;
11166     }
11167
11168     /* Having this true makes it feasible to have a lot fewer tests for the
11169      * parse pointer being in scope.  For example, we can write
11170      *      while(isFOO(*RExC_parse)) RExC_parse++;
11171      * instead of
11172      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
11173      */
11174     assert(*RExC_end == '\0');
11175
11176     /* Make an OPEN node, if parenthesized. */
11177     if (paren) {
11178
11179         /* Under /x, space and comments can be gobbled up between the '(' and
11180          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
11181          * intervening space, as the sequence is a token, and a token should be
11182          * indivisible */
11183         bool has_intervening_patws = (paren == 2)
11184                                   && *(RExC_parse - 1) != '(';
11185
11186         if (RExC_parse >= RExC_end) {
11187             vFAIL("Unmatched (");
11188         }
11189
11190         if (paren == 'r') {     /* Atomic script run */
11191             paren = '>';
11192             goto parse_rest;
11193         }
11194         else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
11195             char *start_verb = RExC_parse + 1;
11196             STRLEN verb_len;
11197             char *start_arg = NULL;
11198             unsigned char op = 0;
11199             int arg_required = 0;
11200             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
11201             bool has_upper = FALSE;
11202
11203             if (has_intervening_patws) {
11204                 RExC_parse++;   /* past the '*' */
11205
11206                 /* For strict backwards compatibility, don't change the message
11207                  * now that we also have lowercase operands */
11208                 if (isUPPER(*RExC_parse)) {
11209                     vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
11210                 }
11211                 else {
11212                     vFAIL("In '(*...)', the '(' and '*' must be adjacent");
11213                 }
11214             }
11215             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
11216                 if ( *RExC_parse == ':' ) {
11217                     start_arg = RExC_parse + 1;
11218                     break;
11219                 }
11220                 else if (! UTF) {
11221                     if (isUPPER(*RExC_parse)) {
11222                         has_upper = TRUE;
11223                     }
11224                     RExC_parse++;
11225                 }
11226                 else {
11227                     RExC_parse += UTF8SKIP(RExC_parse);
11228                 }
11229             }
11230             verb_len = RExC_parse - start_verb;
11231             if ( start_arg ) {
11232                 if (RExC_parse >= RExC_end) {
11233                     goto unterminated_verb_pattern;
11234                 }
11235
11236                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11237                 while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
11238                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11239                 }
11240                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11241                   unterminated_verb_pattern:
11242                     if (has_upper) {
11243                         vFAIL("Unterminated verb pattern argument");
11244                     }
11245                     else {
11246                         vFAIL("Unterminated '(*...' argument");
11247                     }
11248                 }
11249             } else {
11250                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11251                     if (has_upper) {
11252                         vFAIL("Unterminated verb pattern");
11253                     }
11254                     else {
11255                         vFAIL("Unterminated '(*...' construct");
11256                     }
11257                 }
11258             }
11259
11260             /* Here, we know that RExC_parse < RExC_end */
11261
11262             switch ( *start_verb ) {
11263             case 'A':  /* (*ACCEPT) */
11264                 if ( memEQs(start_verb, verb_len,"ACCEPT") ) {
11265                     op = ACCEPT;
11266                     internal_argval = RExC_nestroot;
11267                 }
11268                 break;
11269             case 'C':  /* (*COMMIT) */
11270                 if ( memEQs(start_verb, verb_len,"COMMIT") )
11271                     op = COMMIT;
11272                 break;
11273             case 'F':  /* (*FAIL) */
11274                 if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) {
11275                     op = OPFAIL;
11276                 }
11277                 break;
11278             case ':':  /* (*:NAME) */
11279             case 'M':  /* (*MARK:NAME) */
11280                 if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) {
11281                     op = MARKPOINT;
11282                     arg_required = 1;
11283                 }
11284                 break;
11285             case 'P':  /* (*PRUNE) */
11286                 if ( memEQs(start_verb, verb_len,"PRUNE") )
11287                     op = PRUNE;
11288                 break;
11289             case 'S':   /* (*SKIP) */
11290                 if ( memEQs(start_verb, verb_len,"SKIP") )
11291                     op = SKIP;
11292                 break;
11293             case 'T':  /* (*THEN) */
11294                 /* [19:06] <TimToady> :: is then */
11295                 if ( memEQs(start_verb, verb_len,"THEN") ) {
11296                     op = CUTGROUP;
11297                     RExC_seen |= REG_CUTGROUP_SEEN;
11298                 }
11299                 break;
11300             case 'a':
11301                 if (   memEQs(start_verb, verb_len, "asr")
11302                     || memEQs(start_verb, verb_len, "atomic_script_run"))
11303                 {
11304                     paren = 'r';        /* Mnemonic: recursed run */
11305                     goto script_run;
11306                 }
11307                 else if (memEQs(start_verb, verb_len, "atomic")) {
11308                     paren = 't';    /* AtOMIC */
11309                     goto alpha_assertions;
11310                 }
11311                 break;
11312             case 'p':
11313                 if (   memEQs(start_verb, verb_len, "plb")
11314                     || memEQs(start_verb, verb_len, "positive_lookbehind"))
11315                 {
11316                     paren = 'b';
11317                     goto lookbehind_alpha_assertions;
11318                 }
11319                 else if (   memEQs(start_verb, verb_len, "pla")
11320                          || memEQs(start_verb, verb_len, "positive_lookahead"))
11321                 {
11322                     paren = 'a';
11323                     goto alpha_assertions;
11324                 }
11325                 break;
11326             case 'n':
11327                 if (   memEQs(start_verb, verb_len, "nlb")
11328                     || memEQs(start_verb, verb_len, "negative_lookbehind"))
11329                 {
11330                     paren = 'B';
11331                     goto lookbehind_alpha_assertions;
11332                 }
11333                 else if (   memEQs(start_verb, verb_len, "nla")
11334                          || memEQs(start_verb, verb_len, "negative_lookahead"))
11335                 {
11336                     paren = 'A';
11337                     goto alpha_assertions;
11338                 }
11339                 break;
11340             case 's':
11341                 if (   memEQs(start_verb, verb_len, "sr")
11342                     || memEQs(start_verb, verb_len, "script_run"))
11343                 {
11344                     regnode_offset atomic;
11345
11346                     paren = 's';
11347
11348                    script_run:
11349
11350                     /* This indicates Unicode rules. */
11351                     REQUIRE_UNI_RULES(flagp, 0);
11352
11353                     if (! start_arg) {
11354                         goto no_colon;
11355                     }
11356
11357                     RExC_parse = start_arg;
11358
11359                     if (RExC_in_script_run) {
11360
11361                         /*  Nested script runs are treated as no-ops, because
11362                          *  if the nested one fails, the outer one must as
11363                          *  well.  It could fail sooner, and avoid (??{} with
11364                          *  side effects, but that is explicitly documented as
11365                          *  undefined behavior. */
11366
11367                         ret = 0;
11368
11369                         if (paren == 's') {
11370                             paren = ':';
11371                             goto parse_rest;
11372                         }
11373
11374                         /* But, the atomic part of a nested atomic script run
11375                          * isn't a no-op, but can be treated just like a '(?>'
11376                          * */
11377                         paren = '>';
11378                         goto parse_rest;
11379                     }
11380
11381                     if (paren == 's') {
11382                         /* Here, we're starting a new regular script run */
11383                         ret = reg_node(pRExC_state, SROPEN);
11384                         RExC_in_script_run = 1;
11385                         is_open = 1;
11386                         goto parse_rest;
11387                     }
11388
11389                     /* Here, we are starting an atomic script run.  This is
11390                      * handled by recursing to deal with the atomic portion
11391                      * separately, enclosed in SROPEN ... SRCLOSE nodes */
11392
11393                     ret = reg_node(pRExC_state, SROPEN);
11394
11395                     RExC_in_script_run = 1;
11396
11397                     atomic = reg(pRExC_state, 'r', &flags, depth);
11398                     if (flags & (RESTART_PARSE|NEED_UTF8)) {
11399                         *flagp = flags & (RESTART_PARSE|NEED_UTF8);
11400                         return 0;
11401                     }
11402
11403                     if (! REGTAIL(pRExC_state, ret, atomic)) {
11404                         REQUIRE_BRANCHJ(flagp, 0);
11405                     }
11406
11407                     if (! REGTAIL(pRExC_state, atomic, reg_node(pRExC_state,
11408                                                                 SRCLOSE)))
11409                     {
11410                         REQUIRE_BRANCHJ(flagp, 0);
11411                     }
11412
11413                     RExC_in_script_run = 0;
11414                     return ret;
11415                 }
11416
11417                 break;
11418
11419             lookbehind_alpha_assertions:
11420                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11421                 RExC_in_lookbehind++;
11422                 /*FALLTHROUGH*/
11423
11424             alpha_assertions:
11425
11426                 RExC_seen_zerolen++;
11427
11428                 if (! start_arg) {
11429                     goto no_colon;
11430                 }
11431
11432                 /* An empty negative lookahead assertion simply is failure */
11433                 if (paren == 'A' && RExC_parse == start_arg) {
11434                     ret=reganode(pRExC_state, OPFAIL, 0);
11435                     nextchar(pRExC_state);
11436                     return ret;
11437                 }
11438
11439                 RExC_parse = start_arg;
11440                 goto parse_rest;
11441
11442               no_colon:
11443                 vFAIL2utf8f(
11444                 "'(*%" UTF8f "' requires a terminating ':'",
11445                 UTF8fARG(UTF, verb_len, start_verb));
11446                 NOT_REACHED; /*NOTREACHED*/
11447
11448             } /* End of switch */
11449             if ( ! op ) {
11450                 RExC_parse += UTF
11451                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11452                               : 1;
11453                 if (has_upper || verb_len == 0) {
11454                     vFAIL2utf8f(
11455                     "Unknown verb pattern '%" UTF8f "'",
11456                     UTF8fARG(UTF, verb_len, start_verb));
11457                 }
11458                 else {
11459                     vFAIL2utf8f(
11460                     "Unknown '(*...)' construct '%" UTF8f "'",
11461                     UTF8fARG(UTF, verb_len, start_verb));
11462                 }
11463             }
11464             if ( RExC_parse == start_arg ) {
11465                 start_arg = NULL;
11466             }
11467             if ( arg_required && !start_arg ) {
11468                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
11469                     (int) verb_len, start_verb);
11470             }
11471             if (internal_argval == -1) {
11472                 ret = reganode(pRExC_state, op, 0);
11473             } else {
11474                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
11475             }
11476             RExC_seen |= REG_VERBARG_SEEN;
11477             if (start_arg) {
11478                 SV *sv = newSVpvn( start_arg,
11479                                     RExC_parse - start_arg);
11480                 ARG(REGNODE_p(ret)) = add_data( pRExC_state,
11481                                         STR_WITH_LEN("S"));
11482                 RExC_rxi->data->data[ARG(REGNODE_p(ret))]=(void*)sv;
11483                 FLAGS(REGNODE_p(ret)) = 1;
11484             } else {
11485                 FLAGS(REGNODE_p(ret)) = 0;
11486             }
11487             if ( internal_argval != -1 )
11488                 ARG2L_SET(REGNODE_p(ret), internal_argval);
11489             nextchar(pRExC_state);
11490             return ret;
11491         }
11492         else if (*RExC_parse == '?') { /* (?...) */
11493             bool is_logical = 0;
11494             const char * const seqstart = RExC_parse;
11495             const char * endptr;
11496             const char non_existent_group_msg[]
11497                                             = "Reference to nonexistent group";
11498             const char impossible_group[] = "Invalid reference to group";
11499
11500             if (has_intervening_patws) {
11501                 RExC_parse++;
11502                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
11503             }
11504
11505             RExC_parse++;           /* past the '?' */
11506             paren = *RExC_parse;    /* might be a trailing NUL, if not
11507                                        well-formed */
11508             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11509             if (RExC_parse > RExC_end) {
11510                 paren = '\0';
11511             }
11512             ret = 0;                    /* For look-ahead/behind. */
11513             switch (paren) {
11514
11515             case 'P':   /* (?P...) variants for those used to PCRE/Python */
11516                 paren = *RExC_parse;
11517                 if ( paren == '<') {    /* (?P<...>) named capture */
11518                     RExC_parse++;
11519                     if (RExC_parse >= RExC_end) {
11520                         vFAIL("Sequence (?P<... not terminated");
11521                     }
11522                     goto named_capture;
11523                 }
11524                 else if (paren == '>') {   /* (?P>name) named recursion */
11525                     RExC_parse++;
11526                     if (RExC_parse >= RExC_end) {
11527                         vFAIL("Sequence (?P>... not terminated");
11528                     }
11529                     goto named_recursion;
11530                 }
11531                 else if (paren == '=') {   /* (?P=...)  named backref */
11532                     RExC_parse++;
11533                     return handle_named_backref(pRExC_state, flagp,
11534                                                 parse_start, ')');
11535                 }
11536                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11537                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11538                 vFAIL3("Sequence (%.*s...) not recognized",
11539                                 (int) (RExC_parse - seqstart), seqstart);
11540                 NOT_REACHED; /*NOTREACHED*/
11541             case '<':           /* (?<...) */
11542                 /* If you want to support (?<*...), first reconcile with GH #17363 */
11543                 if (*RExC_parse == '!')
11544                     paren = ',';
11545                 else if (*RExC_parse != '=')
11546               named_capture:
11547                 {               /* (?<...>) */
11548                     char *name_start;
11549                     SV *svname;
11550                     paren= '>';
11551                 /* FALLTHROUGH */
11552             case '\'':          /* (?'...') */
11553                     name_start = RExC_parse;
11554                     svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME);
11555                     if (   RExC_parse == name_start
11556                         || RExC_parse >= RExC_end
11557                         || *RExC_parse != paren)
11558                     {
11559                         vFAIL2("Sequence (?%c... not terminated",
11560                             paren=='>' ? '<' : (char) paren);
11561                     }
11562                     {
11563                         HE *he_str;
11564                         SV *sv_dat = NULL;
11565                         if (!svname) /* shouldn't happen */
11566                             Perl_croak(aTHX_
11567                                 "panic: reg_scan_name returned NULL");
11568                         if (!RExC_paren_names) {
11569                             RExC_paren_names= newHV();
11570                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
11571 #ifdef DEBUGGING
11572                             RExC_paren_name_list= newAV();
11573                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
11574 #endif
11575                         }
11576                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
11577                         if ( he_str )
11578                             sv_dat = HeVAL(he_str);
11579                         if ( ! sv_dat ) {
11580                             /* croak baby croak */
11581                             Perl_croak(aTHX_
11582                                 "panic: paren_name hash element allocation failed");
11583                         } else if ( SvPOK(sv_dat) ) {
11584                             /* (?|...) can mean we have dupes so scan to check
11585                                its already been stored. Maybe a flag indicating
11586                                we are inside such a construct would be useful,
11587                                but the arrays are likely to be quite small, so
11588                                for now we punt -- dmq */
11589                             IV count = SvIV(sv_dat);
11590                             I32 *pv = (I32*)SvPVX(sv_dat);
11591                             IV i;
11592                             for ( i = 0 ; i < count ; i++ ) {
11593                                 if ( pv[i] == RExC_npar ) {
11594                                     count = 0;
11595                                     break;
11596                                 }
11597                             }
11598                             if ( count ) {
11599                                 pv = (I32*)SvGROW(sv_dat,
11600                                                 SvCUR(sv_dat) + sizeof(I32)+1);
11601                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
11602                                 pv[count] = RExC_npar;
11603                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
11604                             }
11605                         } else {
11606                             (void)SvUPGRADE(sv_dat, SVt_PVNV);
11607                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
11608                                                                 sizeof(I32));
11609                             SvIOK_on(sv_dat);
11610                             SvIV_set(sv_dat, 1);
11611                         }
11612 #ifdef DEBUGGING
11613                         /* Yes this does cause a memory leak in debugging Perls
11614                          * */
11615                         if (!av_store(RExC_paren_name_list,
11616                                       RExC_npar, SvREFCNT_inc_NN(svname)))
11617                             SvREFCNT_dec_NN(svname);
11618 #endif
11619
11620                         /*sv_dump(sv_dat);*/
11621                     }
11622                     nextchar(pRExC_state);
11623                     paren = 1;
11624                     goto capturing_parens;
11625                 }
11626
11627                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11628                 RExC_in_lookbehind++;
11629                 RExC_parse++;
11630                 if (RExC_parse >= RExC_end) {
11631                     vFAIL("Sequence (?... not terminated");
11632                 }
11633                 RExC_seen_zerolen++;
11634                 break;
11635             case '=':           /* (?=...) */
11636                 RExC_seen_zerolen++;
11637                 RExC_in_lookahead++;
11638                 break;
11639             case '!':           /* (?!...) */
11640                 RExC_seen_zerolen++;
11641                 /* check if we're really just a "FAIL" assertion */
11642                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11643                                         FALSE /* Don't force to /x */ );
11644                 if (*RExC_parse == ')') {
11645                     ret=reganode(pRExC_state, OPFAIL, 0);
11646                     nextchar(pRExC_state);
11647                     return ret;
11648                 }
11649                 break;
11650             case '|':           /* (?|...) */
11651                 /* branch reset, behave like a (?:...) except that
11652                    buffers in alternations share the same numbers */
11653                 paren = ':';
11654                 after_freeze = freeze_paren = RExC_npar;
11655
11656                 /* XXX This construct currently requires an extra pass.
11657                  * Investigation would be required to see if that could be
11658                  * changed */
11659                 REQUIRE_PARENS_PASS;
11660                 break;
11661             case ':':           /* (?:...) */
11662             case '>':           /* (?>...) */
11663                 break;
11664             case '$':           /* (?$...) */
11665             case '@':           /* (?@...) */
11666                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
11667                 break;
11668             case '0' :           /* (?0) */
11669             case 'R' :           /* (?R) */
11670                 if (RExC_parse == RExC_end || *RExC_parse != ')')
11671                     FAIL("Sequence (?R) not terminated");
11672                 num = 0;
11673                 RExC_seen |= REG_RECURSE_SEEN;
11674
11675                 /* XXX These constructs currently require an extra pass.
11676                  * It probably could be changed */
11677                 REQUIRE_PARENS_PASS;
11678
11679                 *flagp |= POSTPONED;
11680                 goto gen_recurse_regop;
11681                 /*notreached*/
11682             /* named and numeric backreferences */
11683             case '&':            /* (?&NAME) */
11684                 parse_start = RExC_parse - 1;
11685               named_recursion:
11686                 {
11687                     SV *sv_dat = reg_scan_name(pRExC_state,
11688                                                REG_RSN_RETURN_DATA);
11689                    num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
11690                 }
11691                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
11692                     vFAIL("Sequence (?&... not terminated");
11693                 goto gen_recurse_regop;
11694                 /* NOTREACHED */
11695             case '+':
11696                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11697                     RExC_parse++;
11698                     vFAIL("Illegal pattern");
11699                 }
11700                 goto parse_recursion;
11701                 /* NOTREACHED*/
11702             case '-': /* (?-1) */
11703                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11704                     RExC_parse--; /* rewind to let it be handled later */
11705                     goto parse_flags;
11706                 }
11707                 /* FALLTHROUGH */
11708             case '1': case '2': case '3': case '4': /* (?1) */
11709             case '5': case '6': case '7': case '8': case '9':
11710                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
11711               parse_recursion:
11712                 {
11713                     bool is_neg = FALSE;
11714                     UV unum;
11715                     parse_start = RExC_parse - 1; /* MJD */
11716                     if (*RExC_parse == '-') {
11717                         RExC_parse++;
11718                         is_neg = TRUE;
11719                     }
11720                     endptr = RExC_end;
11721                     if (grok_atoUV(RExC_parse, &unum, &endptr)
11722                         && unum <= I32_MAX
11723                     ) {
11724                         num = (I32)unum;
11725                         RExC_parse = (char*)endptr;
11726                     }
11727                     else {  /* Overflow, or something like that.  Position
11728                                beyond all digits for the message */
11729                         while (RExC_parse < RExC_end && isDIGIT(*RExC_parse))  {
11730                             RExC_parse++;
11731                         }
11732                         vFAIL(impossible_group);
11733                     }
11734                     if (is_neg) {
11735                         /* -num is always representable on 1 and 2's complement
11736                          * machines */
11737                         num = -num;
11738                     }
11739                 }
11740                 if (*RExC_parse!=')')
11741                     vFAIL("Expecting close bracket");
11742
11743               gen_recurse_regop:
11744                 if (paren == '-' || paren == '+') {
11745
11746                     /* Don't overflow */
11747                     if (UNLIKELY(I32_MAX - RExC_npar < num)) {
11748                         RExC_parse++;
11749                         vFAIL(impossible_group);
11750                     }
11751
11752                     /*
11753                     Diagram of capture buffer numbering.
11754                     Top line is the normal capture buffer numbers
11755                     Bottom line is the negative indexing as from
11756                     the X (the (?-2))
11757
11758                         1 2    3 4 5 X   Y      6 7
11759                        /(a(x)y)(a(b(c(?+2)d)e)f)(g(h))/
11760                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11761                     -   5 4    3 2 1 X   Y      x x
11762
11763                     Resolve to absolute group.  Recall that RExC_npar is +1 of
11764                     the actual parenthesis group number.  For lookahead, we
11765                     have to compensate for that.  Using the above example, when
11766                     we get to Y in the parse, num is 2 and RExC_npar is 6.  We
11767                     want 7 for +2, and 4 for -2.
11768                     */
11769                     if ( paren == '+' ) {
11770                         num--;
11771                     }
11772
11773                     num += RExC_npar;
11774
11775                     if (paren == '-' && num < 1) {
11776                         RExC_parse++;
11777                         vFAIL(non_existent_group_msg);
11778                     }
11779                 }
11780
11781                 if (num >= RExC_npar) {
11782
11783                     /* It might be a forward reference; we can't fail until we
11784                      * know, by completing the parse to get all the groups, and
11785                      * then reparsing */
11786                     if (ALL_PARENS_COUNTED)  {
11787                         if (num >= RExC_total_parens) {
11788                             RExC_parse++;
11789                             vFAIL(non_existent_group_msg);
11790                         }
11791                     }
11792                     else {
11793                         REQUIRE_PARENS_PASS;
11794                     }
11795                 }
11796
11797                 /* We keep track how many GOSUB items we have produced.
11798                    To start off the ARG2L() of the GOSUB holds its "id",
11799                    which is used later in conjunction with RExC_recurse
11800                    to calculate the offset we need to jump for the GOSUB,
11801                    which it will store in the final representation.
11802                    We have to defer the actual calculation until much later
11803                    as the regop may move.
11804                  */
11805                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11806                 RExC_recurse_count++;
11807                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11808                     "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11809                             22, "|    |", (int)(depth * 2 + 1), "",
11810                             (UV)ARG(REGNODE_p(ret)),
11811                             (IV)ARG2L(REGNODE_p(ret))));
11812                 RExC_seen |= REG_RECURSE_SEEN;
11813
11814                 Set_Node_Length(REGNODE_p(ret),
11815                                 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */
11816                 Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */
11817
11818                 *flagp |= POSTPONED;
11819                 assert(*RExC_parse == ')');
11820                 nextchar(pRExC_state);
11821                 return ret;
11822
11823             /* NOTREACHED */
11824
11825             case '?':           /* (??...) */
11826                 is_logical = 1;
11827                 if (*RExC_parse != '{') {
11828                     RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11829                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11830                     vFAIL2utf8f(
11831                         "Sequence (%" UTF8f "...) not recognized",
11832                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11833                     NOT_REACHED; /*NOTREACHED*/
11834                 }
11835                 *flagp |= POSTPONED;
11836                 paren = '{';
11837                 RExC_parse++;
11838                 /* FALLTHROUGH */
11839             case '{':           /* (?{...}) */
11840             {
11841                 U32 n = 0;
11842                 struct reg_code_block *cb;
11843                 OP * o;
11844
11845                 RExC_seen_zerolen++;
11846
11847                 if (   !pRExC_state->code_blocks
11848                     || pRExC_state->code_index
11849                                         >= pRExC_state->code_blocks->count
11850                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11851                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11852                             - RExC_start)
11853                 ) {
11854                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11855                         FAIL("panic: Sequence (?{...}): no code block found\n");
11856                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11857                 }
11858                 /* this is a pre-compiled code block (?{...}) */
11859                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11860                 RExC_parse = RExC_start + cb->end;
11861                 o = cb->block;
11862                 if (cb->src_regex) {
11863                     n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11864                     RExC_rxi->data->data[n] =
11865                         (void*)SvREFCNT_inc((SV*)cb->src_regex);
11866                     RExC_rxi->data->data[n+1] = (void*)o;
11867                 }
11868                 else {
11869                     n = add_data(pRExC_state,
11870                             (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11871                     RExC_rxi->data->data[n] = (void*)o;
11872                 }
11873                 pRExC_state->code_index++;
11874                 nextchar(pRExC_state);
11875
11876                 if (is_logical) {
11877                     regnode_offset eval;
11878                     ret = reg_node(pRExC_state, LOGICAL);
11879
11880                     eval = reg2Lanode(pRExC_state, EVAL,
11881                                        n,
11882
11883                                        /* for later propagation into (??{})
11884                                         * return value */
11885                                        RExC_flags & RXf_PMf_COMPILETIME
11886                                       );
11887                     FLAGS(REGNODE_p(ret)) = 2;
11888                     if (! REGTAIL(pRExC_state, ret, eval)) {
11889                         REQUIRE_BRANCHJ(flagp, 0);
11890                     }
11891                     /* deal with the length of this later - MJD */
11892                     return ret;
11893                 }
11894                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11895                 Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1);
11896                 Set_Node_Offset(REGNODE_p(ret), parse_start);
11897                 return ret;
11898             }
11899             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11900             {
11901                 int is_define= 0;
11902                 const int DEFINE_len = sizeof("DEFINE") - 1;
11903                 if (    RExC_parse < RExC_end - 1
11904                     && (   (       RExC_parse[0] == '?'        /* (?(?...)) */
11905                             && (   RExC_parse[1] == '='
11906                                 || RExC_parse[1] == '!'
11907                                 || RExC_parse[1] == '<'
11908                                 || RExC_parse[1] == '{'))
11909                         || (       RExC_parse[0] == '*'        /* (?(*...)) */
11910                             && (   memBEGINs(RExC_parse + 1,
11911                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11912                                          "pla:")
11913                                 || memBEGINs(RExC_parse + 1,
11914                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11915                                          "plb:")
11916                                 || memBEGINs(RExC_parse + 1,
11917                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11918                                          "nla:")
11919                                 || memBEGINs(RExC_parse + 1,
11920                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11921                                          "nlb:")
11922                                 || memBEGINs(RExC_parse + 1,
11923                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11924                                          "positive_lookahead:")
11925                                 || memBEGINs(RExC_parse + 1,
11926                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11927                                          "positive_lookbehind:")
11928                                 || memBEGINs(RExC_parse + 1,
11929                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11930                                          "negative_lookahead:")
11931                                 || memBEGINs(RExC_parse + 1,
11932                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11933                                          "negative_lookbehind:"))))
11934                 ) { /* Lookahead or eval. */
11935                     I32 flag;
11936                     regnode_offset tail;
11937
11938                     ret = reg_node(pRExC_state, LOGICAL);
11939                     FLAGS(REGNODE_p(ret)) = 1;
11940
11941                     tail = reg(pRExC_state, 1, &flag, depth+1);
11942                     RETURN_FAIL_ON_RESTART(flag, flagp);
11943                     if (! REGTAIL(pRExC_state, ret, tail)) {
11944                         REQUIRE_BRANCHJ(flagp, 0);
11945                     }
11946                     goto insert_if;
11947                 }
11948                 else if (   RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11949                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11950                 {
11951                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11952                     char *name_start= RExC_parse++;
11953                     U32 num = 0;
11954                     SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
11955                     if (   RExC_parse == name_start
11956                         || RExC_parse >= RExC_end
11957                         || *RExC_parse != ch)
11958                     {
11959                         vFAIL2("Sequence (?(%c... not terminated",
11960                             (ch == '>' ? '<' : ch));
11961                     }
11962                     RExC_parse++;
11963                     if (sv_dat) {
11964                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11965                         RExC_rxi->data->data[num]=(void*)sv_dat;
11966                         SvREFCNT_inc_simple_void_NN(sv_dat);
11967                     }
11968                     ret = reganode(pRExC_state, GROUPPN, num);
11969                     goto insert_if_check_paren;
11970                 }
11971                 else if (memBEGINs(RExC_parse,
11972                                    (STRLEN) (RExC_end - RExC_parse),
11973                                    "DEFINE"))
11974                 {
11975                     ret = reganode(pRExC_state, DEFINEP, 0);
11976                     RExC_parse += DEFINE_len;
11977                     is_define = 1;
11978                     goto insert_if_check_paren;
11979                 }
11980                 else if (RExC_parse[0] == 'R') {
11981                     RExC_parse++;
11982                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11983                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11984                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11985                      */
11986                     parno = 0;
11987                     if (RExC_parse[0] == '0') {
11988                         parno = 1;
11989                         RExC_parse++;
11990                     }
11991                     else if (inRANGE(RExC_parse[0], '1', '9')) {
11992                         UV uv;
11993                         endptr = RExC_end;
11994                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11995                             && uv <= I32_MAX
11996                         ) {
11997                             parno = (I32)uv + 1;
11998                             RExC_parse = (char*)endptr;
11999                         }
12000                         /* else "Switch condition not recognized" below */
12001                     } else if (RExC_parse[0] == '&') {
12002                         SV *sv_dat;
12003                         RExC_parse++;
12004                         sv_dat = reg_scan_name(pRExC_state,
12005                                                REG_RSN_RETURN_DATA);
12006                         if (sv_dat)
12007                             parno = 1 + *((I32 *)SvPVX(sv_dat));
12008                     }
12009                     ret = reganode(pRExC_state, INSUBP, parno);
12010                     goto insert_if_check_paren;
12011                 }
12012                 else if (inRANGE(RExC_parse[0], '1', '9')) {
12013                     /* (?(1)...) */
12014                     char c;
12015                     UV uv;
12016                     endptr = RExC_end;
12017                     if (grok_atoUV(RExC_parse, &uv, &endptr)
12018                         && uv <= I32_MAX
12019                     ) {
12020                         parno = (I32)uv;
12021                         RExC_parse = (char*)endptr;
12022                     }
12023                     else {
12024                         vFAIL("panic: grok_atoUV returned FALSE");
12025                     }
12026                     ret = reganode(pRExC_state, GROUPP, parno);
12027
12028                  insert_if_check_paren:
12029                     if (UCHARAT(RExC_parse) != ')') {
12030                         RExC_parse += UTF
12031                                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
12032                                       : 1;
12033                         vFAIL("Switch condition not recognized");
12034                     }
12035                     nextchar(pRExC_state);
12036                   insert_if:
12037                     if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state,
12038                                                              IFTHEN, 0)))
12039                     {
12040                         REQUIRE_BRANCHJ(flagp, 0);
12041                     }
12042                     br = regbranch(pRExC_state, &flags, 1, depth+1);
12043                     if (br == 0) {
12044                         RETURN_FAIL_ON_RESTART(flags,flagp);
12045                         FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
12046                               (UV) flags);
12047                     } else
12048                     if (! REGTAIL(pRExC_state, br, reganode(pRExC_state,
12049                                                              LONGJMP, 0)))
12050                     {
12051                         REQUIRE_BRANCHJ(flagp, 0);
12052                     }
12053                     c = UCHARAT(RExC_parse);
12054                     nextchar(pRExC_state);
12055                     if (flags&HASWIDTH)
12056                         *flagp |= HASWIDTH;
12057                     if (c == '|') {
12058                         if (is_define)
12059                             vFAIL("(?(DEFINE)....) does not allow branches");
12060
12061                         /* Fake one for optimizer.  */
12062                         lastbr = reganode(pRExC_state, IFTHEN, 0);
12063
12064                         if (!regbranch(pRExC_state, &flags, 1, depth+1)) {
12065                             RETURN_FAIL_ON_RESTART(flags, flagp);
12066                             FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
12067                                   (UV) flags);
12068                         }
12069                         if (! REGTAIL(pRExC_state, ret, lastbr)) {
12070                             REQUIRE_BRANCHJ(flagp, 0);
12071                         }
12072                         if (flags&HASWIDTH)
12073                             *flagp |= HASWIDTH;
12074                         c = UCHARAT(RExC_parse);
12075                         nextchar(pRExC_state);
12076                     }
12077                     else
12078                         lastbr = 0;
12079                     if (c != ')') {
12080                         if (RExC_parse >= RExC_end)
12081                             vFAIL("Switch (?(condition)... not terminated");
12082                         else
12083                             vFAIL("Switch (?(condition)... contains too many branches");
12084                     }
12085                     ender = reg_node(pRExC_state, TAIL);
12086                     if (! REGTAIL(pRExC_state, br, ender)) {
12087                         REQUIRE_BRANCHJ(flagp, 0);
12088                     }
12089                     if (lastbr) {
12090                         if (! REGTAIL(pRExC_state, lastbr, ender)) {
12091                             REQUIRE_BRANCHJ(flagp, 0);
12092                         }
12093                         if (! REGTAIL(pRExC_state,
12094                                       REGNODE_OFFSET(
12095                                                  NEXTOPER(
12096                                                  NEXTOPER(REGNODE_p(lastbr)))),
12097                                       ender))
12098                         {
12099                             REQUIRE_BRANCHJ(flagp, 0);
12100                         }
12101                     }
12102                     else
12103                         if (! REGTAIL(pRExC_state, ret, ender)) {
12104                             REQUIRE_BRANCHJ(flagp, 0);
12105                         }
12106 #if 0  /* Removing this doesn't cause failures in the test suite -- khw */
12107                     RExC_size++; /* XXX WHY do we need this?!!
12108                                     For large programs it seems to be required
12109                                     but I can't figure out why. -- dmq*/
12110 #endif
12111                     return ret;
12112                 }
12113                 RExC_parse += UTF
12114                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
12115                               : 1;
12116                 vFAIL("Unknown switch condition (?(...))");
12117             }
12118             case '[':           /* (?[ ... ]) */
12119                 return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
12120                                          oregcomp_parse);
12121             case 0: /* A NUL */
12122                 RExC_parse--; /* for vFAIL to print correctly */
12123                 vFAIL("Sequence (? incomplete");
12124                 break;
12125
12126             case ')':
12127                 if (RExC_strict) {  /* [perl #132851] */
12128                     ckWARNreg(RExC_parse, "Empty (?) without any modifiers");
12129                 }
12130                 /* FALLTHROUGH */
12131             case '*': /* If you want to support (?*...), first reconcile with GH #17363 */
12132             /* FALLTHROUGH */
12133             default: /* e.g., (?i) */
12134                 RExC_parse = (char *) seqstart + 1;
12135               parse_flags:
12136                 parse_lparen_question_flags(pRExC_state);
12137                 if (UCHARAT(RExC_parse) != ':') {
12138                     if (RExC_parse < RExC_end)
12139                         nextchar(pRExC_state);
12140                     *flagp = TRYAGAIN;
12141                     return 0;
12142                 }
12143                 paren = ':';
12144                 nextchar(pRExC_state);
12145                 ret = 0;
12146                 goto parse_rest;
12147             } /* end switch */
12148         }
12149         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
12150           capturing_parens:
12151             parno = RExC_npar;
12152             RExC_npar++;
12153             if (! ALL_PARENS_COUNTED) {
12154                 /* If we are in our first pass through (and maybe only pass),
12155                  * we  need to allocate memory for the capturing parentheses
12156                  * data structures.
12157                  */
12158
12159                 if (!RExC_parens_buf_size) {
12160                     /* first guess at number of parens we might encounter */
12161                     RExC_parens_buf_size = 10;
12162
12163                     /* setup RExC_open_parens, which holds the address of each
12164                      * OPEN tag, and to make things simpler for the 0 index the
12165                      * start of the program - this is used later for offsets */
12166                     Newxz(RExC_open_parens, RExC_parens_buf_size,
12167                             regnode_offset);
12168                     RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
12169
12170                     /* setup RExC_close_parens, which holds the address of each
12171                      * CLOSE tag, and to make things simpler for the 0 index
12172                      * the end of the program - this is used later for offsets
12173                      * */
12174                     Newxz(RExC_close_parens, RExC_parens_buf_size,
12175                             regnode_offset);
12176                     /* we dont know where end op starts yet, so we dont need to
12177                      * set RExC_close_parens[0] like we do RExC_open_parens[0]
12178                      * above */
12179                 }
12180                 else if (RExC_npar > RExC_parens_buf_size) {
12181                     I32 old_size = RExC_parens_buf_size;
12182
12183                     RExC_parens_buf_size *= 2;
12184
12185                     Renew(RExC_open_parens, RExC_parens_buf_size,
12186                             regnode_offset);
12187                     Zero(RExC_open_parens + old_size,
12188                             RExC_parens_buf_size - old_size, regnode_offset);
12189
12190                     Renew(RExC_close_parens, RExC_parens_buf_size,
12191                             regnode_offset);
12192                     Zero(RExC_close_parens + old_size,
12193                             RExC_parens_buf_size - old_size, regnode_offset);
12194                 }
12195             }
12196
12197             ret = reganode(pRExC_state, OPEN, parno);
12198             if (!RExC_nestroot)
12199                 RExC_nestroot = parno;
12200             if (RExC_open_parens && !RExC_open_parens[parno])
12201             {
12202                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12203                     "%*s%*s Setting open paren #%" IVdf " to %zu\n",
12204                     22, "|    |", (int)(depth * 2 + 1), "",
12205                     (IV)parno, ret));
12206                 RExC_open_parens[parno]= ret;
12207             }
12208
12209             Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
12210             Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */
12211             is_open = 1;
12212         } else {
12213             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
12214             paren = ':';
12215             ret = 0;
12216         }
12217     }
12218     else                        /* ! paren */
12219         ret = 0;
12220
12221    parse_rest:
12222     /* Pick up the branches, linking them together. */
12223     parse_start = RExC_parse;   /* MJD */
12224     br = regbranch(pRExC_state, &flags, 1, depth+1);
12225
12226     /*     branch_len = (paren != 0); */
12227
12228     if (br == 0) {
12229         RETURN_FAIL_ON_RESTART(flags, flagp);
12230         FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12231     }
12232     if (*RExC_parse == '|') {
12233         if (RExC_use_BRANCHJ) {
12234             reginsert(pRExC_state, BRANCHJ, br, depth+1);
12235         }
12236         else {                  /* MJD */
12237             reginsert(pRExC_state, BRANCH, br, depth+1);
12238             Set_Node_Length(REGNODE_p(br), paren != 0);
12239             Set_Node_Offset_To_R(br, parse_start-RExC_start);
12240         }
12241         have_branch = 1;
12242     }
12243     else if (paren == ':') {
12244         *flagp |= flags&SIMPLE;
12245     }
12246     if (is_open) {                              /* Starts with OPEN. */
12247         if (! REGTAIL(pRExC_state, ret, br)) {  /* OPEN -> first. */
12248             REQUIRE_BRANCHJ(flagp, 0);
12249         }
12250     }
12251     else if (paren != '?')              /* Not Conditional */
12252         ret = br;
12253     *flagp |= flags & (HASWIDTH | POSTPONED);
12254     lastbr = br;
12255     while (*RExC_parse == '|') {
12256         if (RExC_use_BRANCHJ) {
12257             bool shut_gcc_up;
12258
12259             ender = reganode(pRExC_state, LONGJMP, 0);
12260
12261             /* Append to the previous. */
12262             shut_gcc_up = REGTAIL(pRExC_state,
12263                          REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
12264                          ender);
12265             PERL_UNUSED_VAR(shut_gcc_up);
12266         }
12267         nextchar(pRExC_state);
12268         if (freeze_paren) {
12269             if (RExC_npar > after_freeze)
12270                 after_freeze = RExC_npar;
12271             RExC_npar = freeze_paren;
12272         }
12273         br = regbranch(pRExC_state, &flags, 0, depth+1);
12274
12275         if (br == 0) {
12276             RETURN_FAIL_ON_RESTART(flags, flagp);
12277             FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12278         }
12279         if (!  REGTAIL(pRExC_state, lastbr, br)) {  /* BRANCH -> BRANCH. */
12280             REQUIRE_BRANCHJ(flagp, 0);
12281         }
12282         lastbr = br;
12283         *flagp |= flags & (HASWIDTH | POSTPONED);
12284     }
12285
12286     if (have_branch || paren != ':') {
12287         regnode * br;
12288
12289         /* Make a closing node, and hook it on the end. */
12290         switch (paren) {
12291         case ':':
12292             ender = reg_node(pRExC_state, TAIL);
12293             break;
12294         case 1: case 2:
12295             ender = reganode(pRExC_state, CLOSE, parno);
12296             if ( RExC_close_parens ) {
12297                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12298                         "%*s%*s Setting close paren #%" IVdf " to %zu\n",
12299                         22, "|    |", (int)(depth * 2 + 1), "",
12300                         (IV)parno, ender));
12301                 RExC_close_parens[parno]= ender;
12302                 if (RExC_nestroot == parno)
12303                     RExC_nestroot = 0;
12304             }
12305             Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */
12306             Set_Node_Length(REGNODE_p(ender), 1); /* MJD */
12307             break;
12308         case 's':
12309             ender = reg_node(pRExC_state, SRCLOSE);
12310             RExC_in_script_run = 0;
12311             break;
12312         case '<':
12313         case 'a':
12314         case 'A':
12315         case 'b':
12316         case 'B':
12317         case ',':
12318         case '=':
12319         case '!':
12320             *flagp &= ~HASWIDTH;
12321             /* FALLTHROUGH */
12322         case 't':   /* aTomic */
12323         case '>':
12324             ender = reg_node(pRExC_state, SUCCEED);
12325             break;
12326         case 0:
12327             ender = reg_node(pRExC_state, END);
12328             assert(!RExC_end_op); /* there can only be one! */
12329             RExC_end_op = REGNODE_p(ender);
12330             if (RExC_close_parens) {
12331                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12332                     "%*s%*s Setting close paren #0 (END) to %zu\n",
12333                     22, "|    |", (int)(depth * 2 + 1), "",
12334                     ender));
12335
12336                 RExC_close_parens[0]= ender;
12337             }
12338             break;
12339         }
12340         DEBUG_PARSE_r({
12341             DEBUG_PARSE_MSG("lsbr");
12342             regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state);
12343             regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender), NULL, pRExC_state);
12344             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12345                           SvPV_nolen_const(RExC_mysv1),
12346                           (IV)lastbr,
12347                           SvPV_nolen_const(RExC_mysv2),
12348                           (IV)ender,
12349                           (IV)(ender - lastbr)
12350             );
12351         });
12352         if (! REGTAIL(pRExC_state, lastbr, ender)) {
12353             REQUIRE_BRANCHJ(flagp, 0);
12354         }
12355
12356         if (have_branch) {
12357             char is_nothing= 1;
12358             if (depth==1)
12359                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
12360
12361             /* Hook the tails of the branches to the closing node. */
12362             for (br = REGNODE_p(ret); br; br = regnext(br)) {
12363                 const U8 op = PL_regkind[OP(br)];
12364                 if (op == BRANCH) {
12365                     if (! REGTAIL_STUDY(pRExC_state,
12366                                         REGNODE_OFFSET(NEXTOPER(br)),
12367                                         ender))
12368                     {
12369                         REQUIRE_BRANCHJ(flagp, 0);
12370                     }
12371                     if ( OP(NEXTOPER(br)) != NOTHING
12372                          || regnext(NEXTOPER(br)) != REGNODE_p(ender))
12373                         is_nothing= 0;
12374                 }
12375                 else if (op == BRANCHJ) {
12376                     bool shut_gcc_up = REGTAIL_STUDY(pRExC_state,
12377                                         REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
12378                                         ender);
12379                     PERL_UNUSED_VAR(shut_gcc_up);
12380                     /* for now we always disable this optimisation * /
12381                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
12382                          || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
12383                     */
12384                         is_nothing= 0;
12385                 }
12386             }
12387             if (is_nothing) {
12388                 regnode * ret_as_regnode = REGNODE_p(ret);
12389                 br= PL_regkind[OP(ret_as_regnode)] != BRANCH
12390                                ? regnext(ret_as_regnode)
12391                                : ret_as_regnode;
12392                 DEBUG_PARSE_r({
12393                     DEBUG_PARSE_MSG("NADA");
12394                     regprop(RExC_rx, RExC_mysv1, ret_as_regnode,
12395                                      NULL, pRExC_state);
12396                     regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender),
12397                                      NULL, pRExC_state);
12398                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12399                                   SvPV_nolen_const(RExC_mysv1),
12400                                   (IV)REG_NODE_NUM(ret_as_regnode),
12401                                   SvPV_nolen_const(RExC_mysv2),
12402                                   (IV)ender,
12403                                   (IV)(ender - ret)
12404                     );
12405                 });
12406                 OP(br)= NOTHING;
12407                 if (OP(REGNODE_p(ender)) == TAIL) {
12408                     NEXT_OFF(br)= 0;
12409                     RExC_emit= REGNODE_OFFSET(br) + 1;
12410                 } else {
12411                     regnode *opt;
12412                     for ( opt= br + 1; opt < REGNODE_p(ender) ; opt++ )
12413                         OP(opt)= OPTIMIZED;
12414                     NEXT_OFF(br)= REGNODE_p(ender) - br;
12415                 }
12416             }
12417         }
12418     }
12419
12420     {
12421         const char *p;
12422          /* Even/odd or x=don't care: 010101x10x */
12423         static const char parens[] = "=!aA<,>Bbt";
12424          /* flag below is set to 0 up through 'A'; 1 for larger */
12425
12426         if (paren && (p = strchr(parens, paren))) {
12427             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
12428             int flag = (p - parens) > 3;
12429
12430             if (paren == '>' || paren == 't') {
12431                 node = SUSPEND, flag = 0;
12432             }
12433
12434             reginsert(pRExC_state, node, ret, depth+1);
12435             Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12436             Set_Node_Offset(REGNODE_p(ret), parse_start + 1);
12437             FLAGS(REGNODE_p(ret)) = flag;
12438             if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL)))
12439             {
12440                 REQUIRE_BRANCHJ(flagp, 0);
12441             }
12442         }
12443     }
12444
12445     /* Check for proper termination. */
12446     if (paren) {
12447         /* restore original flags, but keep (?p) and, if we've encountered
12448          * something in the parse that changes /d rules into /u, keep the /u */
12449         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
12450         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
12451             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
12452         }
12453         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
12454             RExC_parse = oregcomp_parse;
12455             vFAIL("Unmatched (");
12456         }
12457         nextchar(pRExC_state);
12458     }
12459     else if (!paren && RExC_parse < RExC_end) {
12460         if (*RExC_parse == ')') {
12461             RExC_parse++;
12462             vFAIL("Unmatched )");
12463         }
12464         else
12465             FAIL("Junk on end of regexp");      /* "Can't happen". */
12466         NOT_REACHED; /* NOTREACHED */
12467     }
12468
12469     if (RExC_in_lookbehind) {
12470         RExC_in_lookbehind--;
12471     }
12472     if (RExC_in_lookahead) {
12473         RExC_in_lookahead--;
12474     }
12475     if (after_freeze > RExC_npar)
12476         RExC_npar = after_freeze;
12477     return(ret);
12478 }
12479
12480 /*
12481  - regbranch - one alternative of an | operator
12482  *
12483  * Implements the concatenation operator.
12484  *
12485  * On success, returns the offset at which any next node should be placed into
12486  * the regex engine program being compiled.
12487  *
12488  * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
12489  * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
12490  * UTF-8
12491  */
12492 STATIC regnode_offset
12493 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
12494 {
12495     regnode_offset ret;
12496     regnode_offset chain = 0;
12497     regnode_offset latest;
12498     I32 flags = 0, c = 0;
12499     DECLARE_AND_GET_RE_DEBUG_FLAGS;
12500
12501     PERL_ARGS_ASSERT_REGBRANCH;
12502
12503     DEBUG_PARSE("brnc");
12504
12505     if (first)
12506         ret = 0;
12507     else {
12508         if (RExC_use_BRANCHJ)
12509             ret = reganode(pRExC_state, BRANCHJ, 0);
12510         else {
12511             ret = reg_node(pRExC_state, BRANCH);
12512             Set_Node_Length(REGNODE_p(ret), 1);
12513         }
12514     }
12515
12516     *flagp = 0;                 /* Initialize. */
12517
12518     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
12519                             FALSE /* Don't force to /x */ );
12520     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
12521         flags &= ~TRYAGAIN;
12522         latest = regpiece(pRExC_state, &flags, depth+1);
12523         if (latest == 0) {
12524             if (flags & TRYAGAIN)
12525                 continue;
12526             RETURN_FAIL_ON_RESTART(flags, flagp);
12527             FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags);
12528         }
12529         else if (ret == 0)
12530             ret = latest;
12531         *flagp |= flags&(HASWIDTH|POSTPONED);
12532         if (chain != 0) {
12533             /* FIXME adding one for every branch after the first is probably
12534              * excessive now we have TRIE support. (hv) */
12535             MARK_NAUGHTY(1);
12536             if (! REGTAIL(pRExC_state, chain, latest)) {
12537                 /* XXX We could just redo this branch, but figuring out what
12538                  * bookkeeping needs to be reset is a pain, and it's likely
12539                  * that other branches that goto END will also be too large */
12540                 REQUIRE_BRANCHJ(flagp, 0);
12541             }
12542         }
12543         chain = latest;
12544         c++;
12545     }
12546     if (chain == 0) {   /* Loop ran zero times. */
12547         chain = reg_node(pRExC_state, NOTHING);
12548         if (ret == 0)
12549             ret = chain;
12550     }
12551     if (c == 1) {
12552         *flagp |= flags&SIMPLE;
12553     }
12554
12555     return ret;
12556 }
12557
12558 /*
12559  - regpiece - something followed by possible quantifier * + ? {n,m}
12560  *
12561  * Note that the branching code sequences used for ? and the general cases
12562  * of * and + are somewhat optimized:  they use the same NOTHING node as
12563  * both the endmarker for their branch list and the body of the last branch.
12564  * It might seem that this node could be dispensed with entirely, but the
12565  * endmarker role is not redundant.
12566  *
12567  * On success, returns the offset at which any next node should be placed into
12568  * the regex engine program being compiled.
12569  *
12570  * Returns 0 otherwise, with *flagp set to indicate why:
12571  *  TRYAGAIN        if regatom() returns 0 with TRYAGAIN.
12572  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
12573  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
12574  */
12575 STATIC regnode_offset
12576 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12577 {
12578     regnode_offset ret;
12579     char op;
12580     char *next;
12581     I32 flags;
12582     const char * const origparse = RExC_parse;
12583     I32 min;
12584     I32 max = REG_INFTY;
12585 #ifdef RE_TRACK_PATTERN_OFFSETS
12586     char *parse_start;
12587 #endif
12588     const char *maxpos = NULL;
12589     UV uv;
12590
12591     /* Save the original in case we change the emitted regop to a FAIL. */
12592     const regnode_offset orig_emit = RExC_emit;
12593
12594     DECLARE_AND_GET_RE_DEBUG_FLAGS;
12595
12596     PERL_ARGS_ASSERT_REGPIECE;
12597
12598     DEBUG_PARSE("piec");
12599
12600     ret = regatom(pRExC_state, &flags, depth+1);
12601     if (ret == 0) {
12602         RETURN_FAIL_ON_RESTART_OR_FLAGS(flags, flagp, TRYAGAIN);
12603         FAIL2("panic: regatom returned failure, flags=%#" UVxf, (UV) flags);
12604     }
12605
12606 #ifdef RE_TRACK_PATTERN_OFFSETS
12607     parse_start = RExC_parse;
12608 #endif
12609
12610     op = *RExC_parse;
12611     switch (op) {
12612
12613       case '*':
12614         nextchar(pRExC_state);
12615         min = 0;
12616         break;
12617
12618       case '+':
12619         nextchar(pRExC_state);
12620         min = 1;
12621         break;
12622
12623       case '?':
12624         nextchar(pRExC_state);
12625         min = 0; max = 1;
12626         break;
12627
12628       case '{':  /* A '{' may or may not indicate a quantifier; call regcurly()
12629                     to determine which */
12630         if (regcurly(RExC_parse)) {
12631             const char* endptr;
12632
12633             /* Here is a quantifier, parse for min and max values */
12634             maxpos = NULL;
12635             next = RExC_parse + 1;
12636             while (isDIGIT(*next) || *next == ',') {
12637                 if (*next == ',') {
12638                     if (maxpos)
12639                         break;
12640                     else
12641                         maxpos = next;
12642                 }
12643                 next++;
12644             }
12645
12646             assert(*next == '}');
12647
12648             if (!maxpos)
12649                 maxpos = next;
12650             RExC_parse++;
12651             if (isDIGIT(*RExC_parse)) {
12652                 endptr = RExC_end;
12653                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
12654                     vFAIL("Invalid quantifier in {,}");
12655                 if (uv >= REG_INFTY)
12656                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12657                 min = (I32)uv;
12658             } else {
12659                 min = 0;
12660             }
12661             if (*maxpos == ',')
12662                 maxpos++;
12663             else
12664                 maxpos = RExC_parse;
12665             if (isDIGIT(*maxpos)) {
12666                 endptr = RExC_end;
12667                 if (!grok_atoUV(maxpos, &uv, &endptr))
12668                     vFAIL("Invalid quantifier in {,}");
12669                 if (uv >= REG_INFTY)
12670                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12671                 max = (I32)uv;
12672             } else {
12673                 max = REG_INFTY;            /* meaning "infinity" */
12674             }
12675
12676             RExC_parse = next;
12677             nextchar(pRExC_state);
12678             if (max < min) {    /* If can't match, warn and optimize to fail
12679                                    unconditionally */
12680                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
12681                 ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
12682                 NEXT_OFF(REGNODE_p(orig_emit)) =
12683                                     regarglen[OPFAIL] + NODE_STEP_REGNODE;
12684                 return ret;
12685             }
12686             else if (min == max && *RExC_parse == '?')
12687             {
12688                 ckWARN2reg(RExC_parse + 1,
12689                            "Useless use of greediness modifier '%c'",
12690                            *RExC_parse);
12691             }
12692
12693             break;
12694         } /* End of is regcurly() */
12695
12696         /* Here was a '{', but what followed it didn't form a quantifier. */
12697         /* FALLTHROUGH */
12698
12699       default:
12700         *flagp = flags;
12701         return(ret);
12702         NOT_REACHED; /*NOTREACHED*/
12703     }
12704
12705     /* Here we have a quantifier, and have calculated 'min' and 'max'.
12706      *
12707      * Check and possibly adjust a zero width operand */
12708     if (! (flags & (HASWIDTH|POSTPONED))) {
12709         if (max > REG_INFTY/3) {
12710             if (origparse[0] == '\\' && origparse[1] == 'K') {
12711                 vFAIL2utf8f(
12712                            "%" UTF8f " is forbidden - matches null string"
12713                            " many times",
12714                            UTF8fARG(UTF, (RExC_parse >= origparse
12715                                          ? RExC_parse - origparse
12716                                          : 0),
12717                            origparse));
12718             } else {
12719                 ckWARN2reg(RExC_parse,
12720                            "%" UTF8f " matches null string many times",
12721                            UTF8fARG(UTF, (RExC_parse >= origparse
12722                                          ? RExC_parse - origparse
12723                                          : 0),
12724                            origparse));
12725             }
12726         }
12727
12728         /* There's no point in trying to match something 0 length more than
12729          * once except for extra side effects, which we don't have here since
12730          * not POSTPONED */
12731         if (max > 1) {
12732             max = 1;
12733             if (min > max) {
12734                 min = max;
12735             }
12736         }
12737     }
12738
12739     /* If this is a code block pass it up */
12740     *flagp |= (flags & POSTPONED);
12741
12742     if (max > 0) {
12743         *flagp |= (flags & HASWIDTH);
12744         if (max == REG_INFTY)
12745             RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12746     }
12747
12748     /* 'SIMPLE' operands don't require full generality */
12749     if ((flags&SIMPLE)) {
12750         if (max == REG_INFTY) {
12751             if (min == 0) {
12752                 if (UNLIKELY(RExC_pm_flags & PMf_WILDCARD)) {
12753                     goto min0_maxINF_wildcard_forbidden;
12754                 }
12755
12756                 reginsert(pRExC_state, STAR, ret, depth+1);
12757                 MARK_NAUGHTY(4);
12758                 goto done_main_op;
12759             }
12760             else if (min == 1) {
12761                 reginsert(pRExC_state, PLUS, ret, depth+1);
12762                 MARK_NAUGHTY(3);
12763                 goto done_main_op;
12764             }
12765         }
12766
12767         /* Here, SIMPLE, but not the '*' and '+' special cases */
12768
12769         MARK_NAUGHTY_EXP(2, 2);
12770         reginsert(pRExC_state, CURLY, ret, depth+1);
12771         Set_Node_Offset(REGNODE_p(ret), parse_start+1); /* MJD */
12772         Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12773     }
12774     else {  /* not SIMPLE */
12775         const regnode_offset w = reg_node(pRExC_state, WHILEM);
12776
12777         FLAGS(REGNODE_p(w)) = 0;
12778         if (!  REGTAIL(pRExC_state, ret, w)) {
12779             REQUIRE_BRANCHJ(flagp, 0);
12780         }
12781         if (RExC_use_BRANCHJ) {
12782             reginsert(pRExC_state, LONGJMP, ret, depth+1);
12783             reginsert(pRExC_state, NOTHING, ret, depth+1);
12784             NEXT_OFF(REGNODE_p(ret)) = 3;        /* Go over LONGJMP. */
12785         }
12786         reginsert(pRExC_state, CURLYX, ret, depth+1);
12787                         /* MJD hk */
12788         Set_Node_Offset(REGNODE_p(ret), parse_start+1);
12789         Set_Node_Length(REGNODE_p(ret),
12790                         op == '{' ? (RExC_parse - parse_start) : 1);
12791
12792         if (RExC_use_BRANCHJ)
12793             NEXT_OFF(REGNODE_p(ret)) = 3;   /* Go over NOTHING to
12794                                                LONGJMP. */
12795         if (! REGTAIL(pRExC_state, ret, reg_node(pRExC_state,
12796                                                   NOTHING)))
12797         {
12798             REQUIRE_BRANCHJ(flagp, 0);
12799         }
12800         RExC_whilem_seen++;
12801         MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
12802     }
12803
12804     /* Finish up the CURLY/CURLYX case */
12805     FLAGS(REGNODE_p(ret)) = 0;
12806
12807     ARG1_SET(REGNODE_p(ret), (U16)min);
12808     ARG2_SET(REGNODE_p(ret), (U16)max);
12809
12810   done_main_op:
12811
12812     /* Process any greediness modifiers */
12813     if (*RExC_parse == '?') {
12814         nextchar(pRExC_state);
12815         reginsert(pRExC_state, MINMOD, ret, depth+1);
12816         if (! REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE)) {
12817             REQUIRE_BRANCHJ(flagp, 0);
12818         }
12819     }
12820     else if (*RExC_parse == '+') {
12821         regnode_offset ender;
12822         nextchar(pRExC_state);
12823         ender = reg_node(pRExC_state, SUCCEED);
12824         if (! REGTAIL(pRExC_state, ret, ender)) {
12825             REQUIRE_BRANCHJ(flagp, 0);
12826         }
12827         reginsert(pRExC_state, SUSPEND, ret, depth+1);
12828         ender = reg_node(pRExC_state, TAIL);
12829         if (! REGTAIL(pRExC_state, ret, ender)) {
12830             REQUIRE_BRANCHJ(flagp, 0);
12831         }
12832     }
12833
12834     /* Forbid extra quantifiers */
12835     if (ISMULT2(RExC_parse)) {
12836         RExC_parse++;
12837         vFAIL("Nested quantifiers");
12838     }
12839
12840     return(ret);
12841
12842   min0_maxINF_wildcard_forbidden:
12843
12844     /* Here we are in a wildcard match, and the minimum match length is 0, and
12845      * the max could be infinity.  This is currently forbidden.  The only
12846      * reason is to make it harder to write patterns that take a long long time
12847      * to halt, and because the use of this construct isn't necessary in
12848      * matching Unicode property values */
12849     RExC_parse++;
12850     /* diag_listed_as: Use of %s is not allowed in Unicode property wildcard
12851        subpatterns in regex; marked by <-- HERE in m/%s/
12852      */
12853     vFAIL("Use of quantifier '*' is not allowed in Unicode property wildcard"
12854           " subpatterns");
12855
12856     /* Note, don't need to worry about the input being '{0,}', as a '}' isn't
12857      * legal at all in wildcards, so can't get this far */
12858
12859     NOT_REACHED; /*NOTREACHED*/
12860 }
12861
12862 STATIC bool
12863 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
12864                 regnode_offset * node_p,
12865                 UV * code_point_p,
12866                 int * cp_count,
12867                 I32 * flagp,
12868                 const bool strict,
12869                 const U32 depth
12870     )
12871 {
12872  /* This routine teases apart the various meanings of \N and returns
12873   * accordingly.  The input parameters constrain which meaning(s) is/are valid
12874   * in the current context.
12875   *
12876   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
12877   *
12878   * If <code_point_p> is not NULL, the context is expecting the result to be a
12879   * single code point.  If this \N instance turns out to a single code point,
12880   * the function returns TRUE and sets *code_point_p to that code point.
12881   *
12882   * If <node_p> is not NULL, the context is expecting the result to be one of
12883   * the things representable by a regnode.  If this \N instance turns out to be
12884   * one such, the function generates the regnode, returns TRUE and sets *node_p
12885   * to point to the offset of that regnode into the regex engine program being
12886   * compiled.
12887   *
12888   * If this instance of \N isn't legal in any context, this function will
12889   * generate a fatal error and not return.
12890   *
12891   * On input, RExC_parse should point to the first char following the \N at the
12892   * time of the call.  On successful return, RExC_parse will have been updated
12893   * to point to just after the sequence identified by this routine.  Also
12894   * *flagp has been updated as needed.
12895   *
12896   * When there is some problem with the current context and this \N instance,
12897   * the function returns FALSE, without advancing RExC_parse, nor setting
12898   * *node_p, nor *code_point_p, nor *flagp.
12899   *
12900   * If <cp_count> is not NULL, the caller wants to know the length (in code
12901   * points) that this \N sequence matches.  This is set, and the input is
12902   * parsed for errors, even if the function returns FALSE, as detailed below.
12903   *
12904   * There are 6 possibilities here, as detailed in the next 6 paragraphs.
12905   *
12906   * Probably the most common case is for the \N to specify a single code point.
12907   * *cp_count will be set to 1, and *code_point_p will be set to that code
12908   * point.
12909   *
12910   * Another possibility is for the input to be an empty \N{}.  This is no
12911   * longer accepted, and will generate a fatal error.
12912   *
12913   * Another possibility is for a custom charnames handler to be in effect which
12914   * translates the input name to an empty string.  *cp_count will be set to 0.
12915   * *node_p will be set to a generated NOTHING node.
12916   *
12917   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
12918   * set to 0. *node_p will be set to a generated REG_ANY node.
12919   *
12920   * The fifth possibility is that \N resolves to a sequence of more than one
12921   * code points.  *cp_count will be set to the number of code points in the
12922   * sequence. *node_p will be set to a generated node returned by this
12923   * function calling S_reg().
12924   *
12925   * The final possibility is that it is premature to be calling this function;
12926   * the parse needs to be restarted.  This can happen when this changes from
12927   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
12928   * latter occurs only when the fifth possibility would otherwise be in
12929   * effect, and is because one of those code points requires the pattern to be
12930   * recompiled as UTF-8.  The function returns FALSE, and sets the
12931   * RESTART_PARSE and NEED_UTF8 flags in *flagp, as appropriate.  When this
12932   * happens, the caller needs to desist from continuing parsing, and return
12933   * this information to its caller.  This is not set for when there is only one
12934   * code point, as this can be called as part of an ANYOF node, and they can
12935   * store above-Latin1 code points without the pattern having to be in UTF-8.
12936   *
12937   * For non-single-quoted regexes, the tokenizer has resolved character and
12938   * sequence names inside \N{...} into their Unicode values, normalizing the
12939   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
12940   * hex-represented code points in the sequence.  This is done there because
12941   * the names can vary based on what charnames pragma is in scope at the time,
12942   * so we need a way to take a snapshot of what they resolve to at the time of
12943   * the original parse. [perl #56444].
12944   *
12945   * That parsing is skipped for single-quoted regexes, so here we may get
12946   * '\N{NAME}', which is parsed now.  If the single-quoted regex is something
12947   * like '\N{U+41}', that code point is Unicode, and has to be translated into
12948   * the native character set for non-ASCII platforms.  The other possibilities
12949   * are already native, so no translation is done. */
12950
12951     char * endbrace;    /* points to '}' following the name */
12952     char* p = RExC_parse; /* Temporary */
12953
12954     SV * substitute_parse = NULL;
12955     char *orig_end;
12956     char *save_start;
12957     I32 flags;
12958
12959     DECLARE_AND_GET_RE_DEBUG_FLAGS;
12960
12961     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12962
12963     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12964     assert(! (node_p && cp_count));               /* At most 1 should be set */
12965
12966     if (cp_count) {     /* Initialize return for the most common case */
12967         *cp_count = 1;
12968     }
12969
12970     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12971      * modifier.  The other meanings do not, so use a temporary until we find
12972      * out which we are being called with */
12973     skip_to_be_ignored_text(pRExC_state, &p,
12974                             FALSE /* Don't force to /x */ );
12975
12976     /* Disambiguate between \N meaning a named character versus \N meaning
12977      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12978      * quantifier, or if there is no '{' at all */
12979     if (*p != '{' || regcurly(p)) {
12980         RExC_parse = p;
12981         if (cp_count) {
12982             *cp_count = -1;
12983         }
12984
12985         if (! node_p) {
12986             return FALSE;
12987         }
12988
12989         *node_p = reg_node(pRExC_state, REG_ANY);
12990         *flagp |= HASWIDTH|SIMPLE;
12991         MARK_NAUGHTY(1);
12992         Set_Node_Length(REGNODE_p(*(node_p)), 1); /* MJD */
12993         return TRUE;
12994     }
12995
12996     /* The test above made sure that the next real character is a '{', but
12997      * under the /x modifier, it could be separated by space (or a comment and
12998      * \n) and this is not allowed (for consistency with \x{...} and the
12999      * tokenizer handling of \N{NAME}). */
13000     if (*RExC_parse != '{') {
13001         vFAIL("Missing braces on \\N{}");
13002     }
13003
13004     RExC_parse++;       /* Skip past the '{' */
13005
13006     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13007     if (! endbrace) { /* no trailing brace */
13008         vFAIL2("Missing right brace on \\%c{}", 'N');
13009     }
13010
13011     /* Here, we have decided it should be a named character or sequence.  These
13012      * imply Unicode semantics */
13013     REQUIRE_UNI_RULES(flagp, FALSE);
13014
13015     /* \N{_} is what toke.c returns to us to indicate a name that evaluates to
13016      * nothing at all (not allowed under strict) */
13017     if (endbrace - RExC_parse == 1 && *RExC_parse == '_') {
13018         RExC_parse = endbrace;
13019         if (strict) {
13020             RExC_parse++;   /* Position after the "}" */
13021             vFAIL("Zero length \\N{}");
13022         }
13023
13024         if (cp_count) {
13025             *cp_count = 0;
13026         }
13027         nextchar(pRExC_state);
13028         if (! node_p) {
13029             return FALSE;
13030         }
13031
13032         *node_p = reg_node(pRExC_state, NOTHING);
13033         return TRUE;
13034     }
13035
13036     if (endbrace - RExC_parse < 2 || ! strBEGINs(RExC_parse, "U+")) {
13037
13038         /* Here, the name isn't of the form  U+....  This can happen if the
13039          * pattern is single-quoted, so didn't get evaluated in toke.c.  Now
13040          * is the time to find out what the name means */
13041
13042         const STRLEN name_len = endbrace - RExC_parse;
13043         SV *  value_sv;     /* What does this name evaluate to */
13044         SV ** value_svp;
13045         const U8 * value;   /* string of name's value */
13046         STRLEN value_len;   /* and its length */
13047
13048         /*  RExC_unlexed_names is a hash of names that weren't evaluated by
13049          *  toke.c, and their values. Make sure is initialized */
13050         if (! RExC_unlexed_names) {
13051             RExC_unlexed_names = newHV();
13052         }
13053
13054         /* If we have already seen this name in this pattern, use that.  This
13055          * allows us to only call the charnames handler once per name per
13056          * pattern.  A broken or malicious handler could return something
13057          * different each time, which could cause the results to vary depending
13058          * on if something gets added or subtracted from the pattern that
13059          * causes the number of passes to change, for example */
13060         if ((value_svp = hv_fetch(RExC_unlexed_names, RExC_parse,
13061                                                       name_len, 0)))
13062         {
13063             value_sv = *value_svp;
13064         }
13065         else { /* Otherwise we have to go out and get the name */
13066             const char * error_msg = NULL;
13067             value_sv = get_and_check_backslash_N_name(RExC_parse, endbrace,
13068                                                       UTF,
13069                                                       &error_msg);
13070             if (error_msg) {
13071                 RExC_parse = endbrace;
13072                 vFAIL(error_msg);
13073             }
13074
13075             /* If no error message, should have gotten a valid return */
13076             assert (value_sv);
13077
13078             /* Save the name's meaning for later use */
13079             if (! hv_store(RExC_unlexed_names, RExC_parse, name_len,
13080                            value_sv, 0))
13081             {
13082                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
13083             }
13084         }
13085
13086         /* Here, we have the value the name evaluates to in 'value_sv' */
13087         value = (U8 *) SvPV(value_sv, value_len);
13088
13089         /* See if the result is one code point vs 0 or multiple */
13090         if (inRANGE(value_len, 1, ((UV) SvUTF8(value_sv)
13091                                   ? UTF8SKIP(value)
13092                                   : 1)))
13093         {
13094             /* Here, exactly one code point.  If that isn't what is wanted,
13095              * fail */
13096             if (! code_point_p) {
13097                 RExC_parse = p;
13098                 return FALSE;
13099             }
13100
13101             /* Convert from string to numeric code point */
13102             *code_point_p = (SvUTF8(value_sv))
13103                             ? valid_utf8_to_uvchr(value, NULL)
13104                             : *value;
13105
13106             /* Have parsed this entire single code point \N{...}.  *cp_count
13107              * has already been set to 1, so don't do it again. */
13108             RExC_parse = endbrace;
13109             nextchar(pRExC_state);
13110             return TRUE;
13111         } /* End of is a single code point */
13112
13113         /* Count the code points, if caller desires.  The API says to do this
13114          * even if we will later return FALSE */
13115         if (cp_count) {
13116             *cp_count = 0;
13117
13118             *cp_count = (SvUTF8(value_sv))
13119                         ? utf8_length(value, value + value_len)
13120                         : value_len;
13121         }
13122
13123         /* Fail if caller doesn't want to handle a multi-code-point sequence.
13124          * But don't back the pointer up if the caller wants to know how many
13125          * code points there are (they need to handle it themselves in this
13126          * case).  */
13127         if (! node_p) {
13128             if (! cp_count) {
13129                 RExC_parse = p;
13130             }
13131             return FALSE;
13132         }
13133
13134         /* Convert this to a sub-pattern of the form "(?: ... )", and then call
13135          * reg recursively to parse it.  That way, it retains its atomicness,
13136          * while not having to worry about any special handling that some code
13137          * points may have. */
13138
13139         substitute_parse = newSVpvs("?:");
13140         sv_catsv(substitute_parse, value_sv);
13141         sv_catpv(substitute_parse, ")");
13142
13143         /* The value should already be native, so no need to convert on EBCDIC
13144          * platforms.*/
13145         assert(! RExC_recode_x_to_native);
13146
13147     }
13148     else {   /* \N{U+...} */
13149         Size_t count = 0;   /* code point count kept internally */
13150
13151         /* We can get to here when the input is \N{U+...} or when toke.c has
13152          * converted a name to the \N{U+...} form.  This include changing a
13153          * name that evaluates to multiple code points to \N{U+c1.c2.c3 ...} */
13154
13155         RExC_parse += 2;    /* Skip past the 'U+' */
13156
13157         /* Code points are separated by dots.  The '}' terminates the whole
13158          * thing. */
13159
13160         do {    /* Loop until the ending brace */
13161             I32 flags = PERL_SCAN_SILENT_OVERFLOW
13162                       | PERL_SCAN_SILENT_ILLDIGIT
13163                       | PERL_SCAN_NOTIFY_ILLDIGIT
13164                       | PERL_SCAN_ALLOW_MEDIAL_UNDERSCORES
13165                       | PERL_SCAN_DISALLOW_PREFIX;
13166             STRLEN len = endbrace - RExC_parse;
13167             NV overflow_value;
13168             char * start_digit = RExC_parse;
13169             UV cp = grok_hex(RExC_parse, &len, &flags, &overflow_value);
13170
13171             if (len == 0) {
13172                 RExC_parse++;
13173               bad_NU:
13174                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
13175             }
13176
13177             RExC_parse += len;
13178
13179             if (cp > MAX_LEGAL_CP) {
13180                 vFAIL(form_cp_too_large_msg(16, start_digit, len, 0));
13181             }
13182
13183             if (RExC_parse >= endbrace) { /* Got to the closing '}' */
13184                 if (count) {
13185                     goto do_concat;
13186                 }
13187
13188                 /* Here, is a single code point; fail if doesn't want that */
13189                 if (! code_point_p) {
13190                     RExC_parse = p;
13191                     return FALSE;
13192                 }
13193
13194                 /* A single code point is easy to handle; just return it */
13195                 *code_point_p = UNI_TO_NATIVE(cp);
13196                 RExC_parse = endbrace;
13197                 nextchar(pRExC_state);
13198                 return TRUE;
13199             }
13200
13201             /* Here, the parse stopped bfore the ending brace.  This is legal
13202              * only if that character is a dot separating code points, like a
13203              * multiple character sequence (of the form "\N{U+c1.c2. ... }".
13204              * So the next character must be a dot (and the one after that
13205              * can't be the endbrace, or we'd have something like \N{U+100.} )
13206              * */
13207             if (*RExC_parse != '.' || RExC_parse + 1 >= endbrace) {
13208                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
13209                               ? UTF8SKIP(RExC_parse)
13210                               : 1;
13211                 RExC_parse = MIN(endbrace, RExC_parse);/* Guard against
13212                                                           malformed utf8 */
13213                 goto bad_NU;
13214             }
13215
13216             /* Here, looks like its really a multiple character sequence.  Fail
13217              * if that's not what the caller wants.  But continue with counting
13218              * and error checking if they still want a count */
13219             if (! node_p && ! cp_count) {
13220                 return FALSE;
13221             }
13222
13223             /* What is done here is to convert this to a sub-pattern of the
13224              * form \x{char1}\x{char2}...  and then call reg recursively to
13225              * parse it (enclosing in "(?: ... )" ).  That way, it retains its
13226              * atomicness, while not having to worry about special handling
13227              * that some code points may have.  We don't create a subpattern,
13228              * but go through the motions of code point counting and error
13229              * checking, if the caller doesn't want a node returned. */
13230
13231             if (node_p && ! substitute_parse) {
13232                 substitute_parse = newSVpvs("?:");
13233             }
13234
13235           do_concat:
13236
13237             if (node_p) {
13238                 /* Convert to notation the rest of the code understands */
13239                 sv_catpvs(substitute_parse, "\\x{");
13240                 sv_catpvn(substitute_parse, start_digit,
13241                                             RExC_parse - start_digit);
13242                 sv_catpvs(substitute_parse, "}");
13243             }
13244
13245             /* Move to after the dot (or ending brace the final time through.)
13246              * */
13247             RExC_parse++;
13248             count++;
13249
13250         } while (RExC_parse < endbrace);
13251
13252         if (! node_p) { /* Doesn't want the node */
13253             assert (cp_count);
13254
13255             *cp_count = count;
13256             return FALSE;
13257         }
13258
13259         sv_catpvs(substitute_parse, ")");
13260
13261         /* The values are Unicode, and therefore have to be converted to native
13262          * on a non-Unicode (meaning non-ASCII) platform. */
13263         SET_recode_x_to_native(1);
13264     }
13265
13266     /* Here, we have the string the name evaluates to, ready to be parsed,
13267      * stored in 'substitute_parse' as a series of valid "\x{...}\x{...}"
13268      * constructs.  This can be called from within a substitute parse already.
13269      * The error reporting mechanism doesn't work for 2 levels of this, but the
13270      * code above has validated this new construct, so there should be no
13271      * errors generated by the below.  And this isn' an exact copy, so the
13272      * mechanism to seamlessly deal with this won't work, so turn off warnings
13273      * during it */
13274     save_start = RExC_start;
13275     orig_end = RExC_end;
13276
13277     RExC_parse = RExC_start = SvPVX(substitute_parse);
13278     RExC_end = RExC_parse + SvCUR(substitute_parse);
13279     TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
13280
13281     *node_p = reg(pRExC_state, 1, &flags, depth+1);
13282
13283     /* Restore the saved values */
13284     RESTORE_WARNINGS;
13285     RExC_start = save_start;
13286     RExC_parse = endbrace;
13287     RExC_end = orig_end;
13288     SET_recode_x_to_native(0);
13289
13290     SvREFCNT_dec_NN(substitute_parse);
13291
13292     if (! *node_p) {
13293         RETURN_FAIL_ON_RESTART(flags, flagp);
13294         FAIL2("panic: reg returned failure to grok_bslash_N, flags=%#" UVxf,
13295             (UV) flags);
13296     }
13297     *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED);
13298
13299     nextchar(pRExC_state);
13300
13301     return TRUE;
13302 }
13303
13304
13305 STATIC U8
13306 S_compute_EXACTish(RExC_state_t *pRExC_state)
13307 {
13308     U8 op;
13309
13310     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
13311
13312     if (! FOLD) {
13313         return (LOC)
13314                 ? EXACTL
13315                 : EXACT;
13316     }
13317
13318     op = get_regex_charset(RExC_flags);
13319     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
13320         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
13321                  been, so there is no hole */
13322     }
13323
13324     return op + EXACTF;
13325 }
13326
13327 STATIC bool
13328 S_new_regcurly(const char *s, const char *e)
13329 {
13330     /* This is a temporary function designed to match the most lenient form of
13331      * a {m,n} quantifier we ever envision, with either number omitted, and
13332      * spaces anywhere between/before/after them.
13333      *
13334      * If this function fails, then the string it matches is very unlikely to
13335      * ever be considered a valid quantifier, so we can allow the '{' that
13336      * begins it to be considered as a literal */
13337
13338     bool has_min = FALSE;
13339     bool has_max = FALSE;
13340
13341     PERL_ARGS_ASSERT_NEW_REGCURLY;
13342
13343     if (s >= e || *s++ != '{')
13344         return FALSE;
13345
13346     while (s < e && isSPACE(*s)) {
13347         s++;
13348     }
13349     while (s < e && isDIGIT(*s)) {
13350         has_min = TRUE;
13351         s++;
13352     }
13353     while (s < e && isSPACE(*s)) {
13354         s++;
13355     }
13356
13357     if (*s == ',') {
13358         s++;
13359         while (s < e && isSPACE(*s)) {
13360             s++;
13361         }
13362         while (s < e && isDIGIT(*s)) {
13363             has_max = TRUE;
13364             s++;
13365         }
13366         while (s < e && isSPACE(*s)) {
13367             s++;
13368         }
13369     }
13370
13371     return s < e && *s == '}' && (has_min || has_max);
13372 }
13373
13374 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
13375  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
13376
13377 static I32
13378 S_backref_value(char *p, char *e)
13379 {
13380     const char* endptr = e;
13381     UV val;
13382     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
13383         return (I32)val;
13384     return I32_MAX;
13385 }
13386
13387
13388 /*
13389  - regatom - the lowest level
13390
13391    Try to identify anything special at the start of the current parse position.
13392    If there is, then handle it as required. This may involve generating a
13393    single regop, such as for an assertion; or it may involve recursing, such as
13394    to handle a () structure.
13395
13396    If the string doesn't start with something special then we gobble up
13397    as much literal text as we can.  If we encounter a quantifier, we have to
13398    back off the final literal character, as that quantifier applies to just it
13399    and not to the whole string of literals.
13400
13401    Once we have been able to handle whatever type of thing started the
13402    sequence, we return the offset into the regex engine program being compiled
13403    at which any  next regnode should be placed.
13404
13405    Returns 0, setting *flagp to TRYAGAIN if reg() returns 0 with TRYAGAIN.
13406    Returns 0, setting *flagp to RESTART_PARSE if the parse needs to be
13407    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
13408    Otherwise does not return 0.
13409
13410    Note: we have to be careful with escapes, as they can be both literal
13411    and special, and in the case of \10 and friends, context determines which.
13412
13413    A summary of the code structure is:
13414
13415    switch (first_byte) {
13416         cases for each special:
13417             handle this special;
13418             break;
13419         case '\\':
13420             switch (2nd byte) {
13421                 cases for each unambiguous special:
13422                     handle this special;
13423                     break;
13424                 cases for each ambigous special/literal:
13425                     disambiguate;
13426                     if (special)  handle here
13427                     else goto defchar;
13428                 default: // unambiguously literal:
13429                     goto defchar;
13430             }
13431         default:  // is a literal char
13432             // FALL THROUGH
13433         defchar:
13434             create EXACTish node for literal;
13435             while (more input and node isn't full) {
13436                 switch (input_byte) {
13437                    cases for each special;
13438                        make sure parse pointer is set so that the next call to
13439                            regatom will see this special first
13440                        goto loopdone; // EXACTish node terminated by prev. char
13441                    default:
13442                        append char to EXACTISH node;
13443                 }
13444                 get next input byte;
13445             }
13446         loopdone:
13447    }
13448    return the generated node;
13449
13450    Specifically there are two separate switches for handling
13451    escape sequences, with the one for handling literal escapes requiring
13452    a dummy entry for all of the special escapes that are actually handled
13453    by the other.
13454
13455 */
13456
13457 STATIC regnode_offset
13458 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
13459 {
13460     regnode_offset ret = 0;
13461     I32 flags = 0;
13462     char *parse_start;
13463     U8 op;
13464     int invert = 0;
13465
13466     DECLARE_AND_GET_RE_DEBUG_FLAGS;
13467
13468     *flagp = 0;         /* Initialize. */
13469
13470     DEBUG_PARSE("atom");
13471
13472     PERL_ARGS_ASSERT_REGATOM;
13473
13474   tryagain:
13475     parse_start = RExC_parse;
13476     assert(RExC_parse < RExC_end);
13477     switch ((U8)*RExC_parse) {
13478     case '^':
13479         RExC_seen_zerolen++;
13480         nextchar(pRExC_state);
13481         if (RExC_flags & RXf_PMf_MULTILINE)
13482             ret = reg_node(pRExC_state, MBOL);
13483         else
13484             ret = reg_node(pRExC_state, SBOL);
13485         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13486         break;
13487     case '$':
13488         nextchar(pRExC_state);
13489         if (*RExC_parse)
13490             RExC_seen_zerolen++;
13491         if (RExC_flags & RXf_PMf_MULTILINE)
13492             ret = reg_node(pRExC_state, MEOL);
13493         else
13494             ret = reg_node(pRExC_state, SEOL);
13495         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13496         break;
13497     case '.':
13498         nextchar(pRExC_state);
13499         if (RExC_flags & RXf_PMf_SINGLELINE)
13500             ret = reg_node(pRExC_state, SANY);
13501         else
13502             ret = reg_node(pRExC_state, REG_ANY);
13503         *flagp |= HASWIDTH|SIMPLE;
13504         MARK_NAUGHTY(1);
13505         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13506         break;
13507     case '[':
13508     {
13509         char * const oregcomp_parse = ++RExC_parse;
13510         ret = regclass(pRExC_state, flagp, depth+1,
13511                        FALSE, /* means parse the whole char class */
13512                        TRUE, /* allow multi-char folds */
13513                        FALSE, /* don't silence non-portable warnings. */
13514                        (bool) RExC_strict,
13515                        TRUE, /* Allow an optimized regnode result */
13516                        NULL);
13517         if (ret == 0) {
13518             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13519             FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13520                   (UV) *flagp);
13521         }
13522         if (*RExC_parse != ']') {
13523             RExC_parse = oregcomp_parse;
13524             vFAIL("Unmatched [");
13525         }
13526         nextchar(pRExC_state);
13527         Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */
13528         break;
13529     }
13530     case '(':
13531         nextchar(pRExC_state);
13532         ret = reg(pRExC_state, 2, &flags, depth+1);
13533         if (ret == 0) {
13534                 if (flags & TRYAGAIN) {
13535                     if (RExC_parse >= RExC_end) {
13536                          /* Make parent create an empty node if needed. */
13537                         *flagp |= TRYAGAIN;
13538                         return(0);
13539                     }
13540                     goto tryagain;
13541                 }
13542                 RETURN_FAIL_ON_RESTART(flags, flagp);
13543                 FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf,
13544                                                                  (UV) flags);
13545         }
13546         *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED);
13547         break;
13548     case '|':
13549     case ')':
13550         if (flags & TRYAGAIN) {
13551             *flagp |= TRYAGAIN;
13552             return 0;
13553         }
13554         vFAIL("Internal urp");
13555                                 /* Supposed to be caught earlier. */
13556         break;
13557     case '?':
13558     case '+':
13559     case '*':
13560         RExC_parse++;
13561         vFAIL("Quantifier follows nothing");
13562         break;
13563     case '\\':
13564         /* Special Escapes
13565
13566            This switch handles escape sequences that resolve to some kind
13567            of special regop and not to literal text. Escape sequences that
13568            resolve to literal text are handled below in the switch marked
13569            "Literal Escapes".
13570
13571            Every entry in this switch *must* have a corresponding entry
13572            in the literal escape switch. However, the opposite is not
13573            required, as the default for this switch is to jump to the
13574            literal text handling code.
13575         */
13576         RExC_parse++;
13577         switch ((U8)*RExC_parse) {
13578         /* Special Escapes */
13579         case 'A':
13580             RExC_seen_zerolen++;
13581             /* Under wildcards, this is changed to match \n; should be
13582              * invisible to the user, as they have to compile under /m */
13583             if (RExC_pm_flags & PMf_WILDCARD) {
13584                 ret = reg_node(pRExC_state, MBOL);
13585             }
13586             else {
13587                 ret = reg_node(pRExC_state, SBOL);
13588                 /* SBOL is shared with /^/ so we set the flags so we can tell
13589                  * /\A/ from /^/ in split. */
13590                 FLAGS(REGNODE_p(ret)) = 1;
13591             }
13592             goto finish_meta_pat;
13593         case 'G':
13594             if (RExC_pm_flags & PMf_WILDCARD) {
13595                 RExC_parse++;
13596                 /* diag_listed_as: Use of %s is not allowed in Unicode property
13597                    wildcard subpatterns in regex; marked by <-- HERE in m/%s/
13598                  */
13599                 vFAIL("Use of '\\G' is not allowed in Unicode property"
13600                       " wildcard subpatterns");
13601             }
13602             ret = reg_node(pRExC_state, GPOS);
13603             RExC_seen |= REG_GPOS_SEEN;
13604             goto finish_meta_pat;
13605         case 'K':
13606             if (!RExC_in_lookbehind && !RExC_in_lookahead) {
13607                 RExC_seen_zerolen++;
13608                 ret = reg_node(pRExC_state, KEEPS);
13609                 /* XXX:dmq : disabling in-place substitution seems to
13610                  * be necessary here to avoid cases of memory corruption, as
13611                  * with: C<$_="x" x 80; s/x\K/y/> -- rgs
13612                  */
13613                 RExC_seen |= REG_LOOKBEHIND_SEEN;
13614                 goto finish_meta_pat;
13615             }
13616             else {
13617                 ++RExC_parse; /* advance past the 'K' */
13618                 vFAIL("\\K not permitted in lookahead/lookbehind");
13619             }
13620         case 'Z':
13621             if (RExC_pm_flags & PMf_WILDCARD) {
13622                 /* See comment under \A above */
13623                 ret = reg_node(pRExC_state, MEOL);
13624             }
13625             else {
13626                 ret = reg_node(pRExC_state, SEOL);
13627             }
13628             RExC_seen_zerolen++;                /* Do not optimize RE away */
13629             goto finish_meta_pat;
13630         case 'z':
13631             if (RExC_pm_flags & PMf_WILDCARD) {
13632                 /* See comment under \A above */
13633                 ret = reg_node(pRExC_state, MEOL);
13634             }
13635             else {
13636                 ret = reg_node(pRExC_state, EOS);
13637             }
13638             RExC_seen_zerolen++;                /* Do not optimize RE away */
13639             goto finish_meta_pat;
13640         case 'C':
13641             vFAIL("\\C no longer supported");
13642         case 'X':
13643             ret = reg_node(pRExC_state, CLUMP);
13644             *flagp |= HASWIDTH;
13645             goto finish_meta_pat;
13646
13647         case 'B':
13648             invert = 1;
13649             /* FALLTHROUGH */
13650         case 'b':
13651           {
13652             U8 flags = 0;
13653             regex_charset charset = get_regex_charset(RExC_flags);
13654
13655             RExC_seen_zerolen++;
13656             RExC_seen |= REG_LOOKBEHIND_SEEN;
13657             op = BOUND + charset;
13658
13659             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
13660                 flags = TRADITIONAL_BOUND;
13661                 if (op > BOUNDA) {  /* /aa is same as /a */
13662                     op = BOUNDA;
13663                 }
13664             }
13665             else {
13666                 STRLEN length;
13667                 char name = *RExC_parse;
13668                 char * endbrace = NULL;
13669                 RExC_parse += 2;
13670                 endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13671
13672                 if (! endbrace) {
13673                     vFAIL2("Missing right brace on \\%c{}", name);
13674                 }
13675                 /* XXX Need to decide whether to take spaces or not.  Should be
13676                  * consistent with \p{}, but that currently is SPACE, which
13677                  * means vertical too, which seems wrong
13678                  * while (isBLANK(*RExC_parse)) {
13679                     RExC_parse++;
13680                 }*/
13681                 if (endbrace == RExC_parse) {
13682                     RExC_parse++;  /* After the '}' */
13683                     vFAIL2("Empty \\%c{}", name);
13684                 }
13685                 length = endbrace - RExC_parse;
13686                 /*while (isBLANK(*(RExC_parse + length - 1))) {
13687                     length--;
13688                 }*/
13689                 switch (*RExC_parse) {
13690                     case 'g':
13691                         if (    length != 1
13692                             && (memNEs(RExC_parse + 1, length - 1, "cb")))
13693                         {
13694                             goto bad_bound_type;
13695                         }
13696                         flags = GCB_BOUND;
13697                         break;
13698                     case 'l':
13699                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13700                             goto bad_bound_type;
13701                         }
13702                         flags = LB_BOUND;
13703                         break;
13704                     case 's':
13705                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13706                             goto bad_bound_type;
13707                         }
13708                         flags = SB_BOUND;
13709                         break;
13710                     case 'w':
13711                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13712                             goto bad_bound_type;
13713                         }
13714                         flags = WB_BOUND;
13715                         break;
13716                     default:
13717                       bad_bound_type:
13718                         RExC_parse = endbrace;
13719                         vFAIL2utf8f(
13720                             "'%" UTF8f "' is an unknown bound type",
13721                             UTF8fARG(UTF, length, endbrace - length));
13722                         NOT_REACHED; /*NOTREACHED*/
13723                 }
13724                 RExC_parse = endbrace;
13725                 REQUIRE_UNI_RULES(flagp, 0);
13726
13727                 if (op == BOUND) {
13728                     op = BOUNDU;
13729                 }
13730                 else if (op >= BOUNDA) {  /* /aa is same as /a */
13731                     op = BOUNDU;
13732                     length += 4;
13733
13734                     /* Don't have to worry about UTF-8, in this message because
13735                      * to get here the contents of the \b must be ASCII */
13736                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
13737                               "Using /u for '%.*s' instead of /%s",
13738                               (unsigned) length,
13739                               endbrace - length + 1,
13740                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
13741                               ? ASCII_RESTRICT_PAT_MODS
13742                               : ASCII_MORE_RESTRICT_PAT_MODS);
13743                 }
13744             }
13745
13746             if (op == BOUND) {
13747                 RExC_seen_d_op = TRUE;
13748             }
13749             else if (op == BOUNDL) {
13750                 RExC_contains_locale = 1;
13751             }
13752
13753             if (invert) {
13754                 op += NBOUND - BOUND;
13755             }
13756
13757             ret = reg_node(pRExC_state, op);
13758             FLAGS(REGNODE_p(ret)) = flags;
13759
13760             goto finish_meta_pat;
13761           }
13762
13763         case 'R':
13764             ret = reg_node(pRExC_state, LNBREAK);
13765             *flagp |= HASWIDTH|SIMPLE;
13766             goto finish_meta_pat;
13767
13768         case 'd':
13769         case 'D':
13770         case 'h':
13771         case 'H':
13772         case 'p':
13773         case 'P':
13774         case 's':
13775         case 'S':
13776         case 'v':
13777         case 'V':
13778         case 'w':
13779         case 'W':
13780             /* These all have the same meaning inside [brackets], and it knows
13781              * how to do the best optimizations for them.  So, pretend we found
13782              * these within brackets, and let it do the work */
13783             RExC_parse--;
13784
13785             ret = regclass(pRExC_state, flagp, depth+1,
13786                            TRUE, /* means just parse this element */
13787                            FALSE, /* don't allow multi-char folds */
13788                            FALSE, /* don't silence non-portable warnings.  It
13789                                      would be a bug if these returned
13790                                      non-portables */
13791                            (bool) RExC_strict,
13792                            TRUE, /* Allow an optimized regnode result */
13793                            NULL);
13794             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13795             /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
13796              * multi-char folds are allowed.  */
13797             if (!ret)
13798                 FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13799                       (UV) *flagp);
13800
13801             RExC_parse--;   /* regclass() leaves this one too far ahead */
13802
13803           finish_meta_pat:
13804                    /* The escapes above that don't take a parameter can't be
13805                     * followed by a '{'.  But 'pX', 'p{foo}' and
13806                     * correspondingly 'P' can be */
13807             if (   RExC_parse - parse_start == 1
13808                 && UCHARAT(RExC_parse + 1) == '{'
13809                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
13810             {
13811                 RExC_parse += 2;
13812                 vFAIL("Unescaped left brace in regex is illegal here");
13813             }
13814             Set_Node_Offset(REGNODE_p(ret), parse_start);
13815             Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); /* MJD */
13816             nextchar(pRExC_state);
13817             break;
13818         case 'N':
13819             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
13820              * \N{...} evaluates to a sequence of more than one code points).
13821              * The function call below returns a regnode, which is our result.
13822              * The parameters cause it to fail if the \N{} evaluates to a
13823              * single code point; we handle those like any other literal.  The
13824              * reason that the multicharacter case is handled here and not as
13825              * part of the EXACtish code is because of quantifiers.  In
13826              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
13827              * this way makes that Just Happen. dmq.
13828              * join_exact() will join this up with adjacent EXACTish nodes
13829              * later on, if appropriate. */
13830             ++RExC_parse;
13831             if (grok_bslash_N(pRExC_state,
13832                               &ret,     /* Want a regnode returned */
13833                               NULL,     /* Fail if evaluates to a single code
13834                                            point */
13835                               NULL,     /* Don't need a count of how many code
13836                                            points */
13837                               flagp,
13838                               RExC_strict,
13839                               depth)
13840             ) {
13841                 break;
13842             }
13843
13844             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13845
13846             /* Here, evaluates to a single code point.  Go get that */
13847             RExC_parse = parse_start;
13848             goto defchar;
13849
13850         case 'k':    /* Handle \k<NAME> and \k'NAME' */
13851       parse_named_seq:
13852         {
13853             char ch;
13854             if (   RExC_parse >= RExC_end - 1
13855                 || ((   ch = RExC_parse[1]) != '<'
13856                                       && ch != '\''
13857                                       && ch != '{'))
13858             {
13859                 RExC_parse++;
13860                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13861                 vFAIL2("Sequence %.2s... not terminated", parse_start);
13862             } else {
13863                 RExC_parse += 2;
13864                 ret = handle_named_backref(pRExC_state,
13865                                            flagp,
13866                                            parse_start,
13867                                            (ch == '<')
13868                                            ? '>'
13869                                            : (ch == '{')
13870                                              ? '}'
13871                                              : '\'');
13872             }
13873             break;
13874         }
13875         case 'g':
13876         case '1': case '2': case '3': case '4':
13877         case '5': case '6': case '7': case '8': case '9':
13878             {
13879                 I32 num;
13880                 bool hasbrace = 0;
13881
13882                 if (*RExC_parse == 'g') {
13883                     bool isrel = 0;
13884
13885                     RExC_parse++;
13886                     if (*RExC_parse == '{') {
13887                         RExC_parse++;
13888                         hasbrace = 1;
13889                     }
13890                     if (*RExC_parse == '-') {
13891                         RExC_parse++;
13892                         isrel = 1;
13893                     }
13894                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13895                         if (isrel) RExC_parse--;
13896                         RExC_parse -= 2;
13897                         goto parse_named_seq;
13898                     }
13899
13900                     if (RExC_parse >= RExC_end) {
13901                         goto unterminated_g;
13902                     }
13903                     num = S_backref_value(RExC_parse, RExC_end);
13904                     if (num == 0)
13905                         vFAIL("Reference to invalid group 0");
13906                     else if (num == I32_MAX) {
13907                          if (isDIGIT(*RExC_parse))
13908                             vFAIL("Reference to nonexistent group");
13909                         else
13910                           unterminated_g:
13911                             vFAIL("Unterminated \\g... pattern");
13912                     }
13913
13914                     if (isrel) {
13915                         num = RExC_npar - num;
13916                         if (num < 1)
13917                             vFAIL("Reference to nonexistent or unclosed group");
13918                     }
13919                 }
13920                 else {
13921                     num = S_backref_value(RExC_parse, RExC_end);
13922                     /* bare \NNN might be backref or octal - if it is larger
13923                      * than or equal RExC_npar then it is assumed to be an
13924                      * octal escape. Note RExC_npar is +1 from the actual
13925                      * number of parens. */
13926                     /* Note we do NOT check if num == I32_MAX here, as that is
13927                      * handled by the RExC_npar check */
13928
13929                     if (
13930                         /* any numeric escape < 10 is always a backref */
13931                         num > 9
13932                         /* any numeric escape < RExC_npar is a backref */
13933                         && num >= RExC_npar
13934                         /* cannot be an octal escape if it starts with [89] */
13935                         && ! inRANGE(*RExC_parse, '8', '9')
13936                     ) {
13937                         /* Probably not meant to be a backref, instead likely
13938                          * to be an octal character escape, e.g. \35 or \777.
13939                          * The above logic should make it obvious why using
13940                          * octal escapes in patterns is problematic. - Yves */
13941                         RExC_parse = parse_start;
13942                         goto defchar;
13943                     }
13944                 }
13945
13946                 /* At this point RExC_parse points at a numeric escape like
13947                  * \12 or \88 or something similar, which we should NOT treat
13948                  * as an octal escape. It may or may not be a valid backref
13949                  * escape. For instance \88888888 is unlikely to be a valid
13950                  * backref. */
13951                 while (isDIGIT(*RExC_parse))
13952                     RExC_parse++;
13953                 if (hasbrace) {
13954                     if (*RExC_parse != '}')
13955                         vFAIL("Unterminated \\g{...} pattern");
13956                     RExC_parse++;
13957                 }
13958                 if (num >= (I32)RExC_npar) {
13959
13960                     /* It might be a forward reference; we can't fail until we
13961                      * know, by completing the parse to get all the groups, and
13962                      * then reparsing */
13963                     if (ALL_PARENS_COUNTED)  {
13964                         if (num >= RExC_total_parens)  {
13965                             vFAIL("Reference to nonexistent group");
13966                         }
13967                     }
13968                     else {
13969                         REQUIRE_PARENS_PASS;
13970                     }
13971                 }
13972                 RExC_sawback = 1;
13973                 ret = reganode(pRExC_state,
13974                                ((! FOLD)
13975                                  ? REF
13976                                  : (ASCII_FOLD_RESTRICTED)
13977                                    ? REFFA
13978                                    : (AT_LEAST_UNI_SEMANTICS)
13979                                      ? REFFU
13980                                      : (LOC)
13981                                        ? REFFL
13982                                        : REFF),
13983                                 num);
13984                 if (OP(REGNODE_p(ret)) == REFF) {
13985                     RExC_seen_d_op = TRUE;
13986                 }
13987                 *flagp |= HASWIDTH;
13988
13989                 /* override incorrect value set in reganode MJD */
13990                 Set_Node_Offset(REGNODE_p(ret), parse_start);
13991                 Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1);
13992                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13993                                         FALSE /* Don't force to /x */ );
13994             }
13995             break;
13996         case '\0':
13997             if (RExC_parse >= RExC_end)
13998                 FAIL("Trailing \\");
13999             /* FALLTHROUGH */
14000         default:
14001             /* Do not generate "unrecognized" warnings here, we fall
14002                back into the quick-grab loop below */
14003             RExC_parse = parse_start;
14004             goto defchar;
14005         } /* end of switch on a \foo sequence */
14006         break;
14007
14008     case '#':
14009
14010         /* '#' comments should have been spaced over before this function was
14011          * called */
14012         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
14013         /*
14014         if (RExC_flags & RXf_PMf_EXTENDED) {
14015             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
14016             if (RExC_parse < RExC_end)
14017                 goto tryagain;
14018         }
14019         */
14020
14021         /* FALLTHROUGH */
14022
14023     default:
14024           defchar: {
14025
14026             /* Here, we have determined that the next thing is probably a
14027              * literal character.  RExC_parse points to the first byte of its
14028              * definition.  (It still may be an escape sequence that evaluates
14029              * to a single character) */
14030
14031             STRLEN len = 0;
14032             UV ender = 0;
14033             char *p;
14034             char *s, *old_s = NULL, *old_old_s = NULL;
14035             char *s0;
14036             U32 max_string_len = 255;
14037
14038             /* We may have to reparse the node, artificially stopping filling
14039              * it early, based on info gleaned in the first parse.  This
14040              * variable gives where we stop.  Make it above the normal stopping
14041              * place first time through; otherwise it would stop too early */
14042             U32 upper_fill = max_string_len + 1;
14043
14044             /* We start out as an EXACT node, even if under /i, until we find a
14045              * character which is in a fold.  The algorithm now segregates into
14046              * separate nodes, characters that fold from those that don't under
14047              * /i.  (This hopefully will create nodes that are fixed strings
14048              * even under /i, giving the optimizer something to grab on to.)
14049              * So, if a node has something in it and the next character is in
14050              * the opposite category, that node is closed up, and the function
14051              * returns.  Then regatom is called again, and a new node is
14052              * created for the new category. */
14053             U8 node_type = EXACT;
14054
14055             /* Assume the node will be fully used; the excess is given back at
14056              * the end.  Under /i, we may need to temporarily add the fold of
14057              * an extra character or two at the end to check for splitting
14058              * multi-char folds, so allocate extra space for that.   We can't
14059              * make any other length assumptions, as a byte input sequence
14060              * could shrink down. */
14061             Ptrdiff_t current_string_nodes = STR_SZ(max_string_len
14062                                                  + ((! FOLD)
14063                                                     ? 0
14064                                                     : 2 * ((UTF)
14065                                                            ? UTF8_MAXBYTES_CASE
14066                         /* Max non-UTF-8 expansion is 2 */ : 2)));
14067
14068             bool next_is_quantifier;
14069             char * oldp = NULL;
14070
14071             /* We can convert EXACTF nodes to EXACTFU if they contain only
14072              * characters that match identically regardless of the target
14073              * string's UTF8ness.  The reason to do this is that EXACTF is not
14074              * trie-able, EXACTFU is, and EXACTFU requires fewer operations at
14075              * runtime.
14076              *
14077              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
14078              * contain only above-Latin1 characters (hence must be in UTF8),
14079              * which don't participate in folds with Latin1-range characters,
14080              * as the latter's folds aren't known until runtime. */
14081             bool maybe_exactfu = FOLD && (DEPENDS_SEMANTICS || LOC);
14082
14083             /* Single-character EXACTish nodes are almost always SIMPLE.  This
14084              * allows us to override this as encountered */
14085             U8 maybe_SIMPLE = SIMPLE;
14086
14087             /* Does this node contain something that can't match unless the
14088              * target string is (also) in UTF-8 */
14089             bool requires_utf8_target = FALSE;
14090
14091             /* The sequence 'ss' is problematic in non-UTF-8 patterns. */
14092             bool has_ss = FALSE;
14093
14094             /* So is the MICRO SIGN */
14095             bool has_micro_sign = FALSE;
14096
14097             /* Set when we fill up the current node and there is still more
14098              * text to process */
14099             bool overflowed;
14100
14101             /* Allocate an EXACT node.  The node_type may change below to
14102              * another EXACTish node, but since the size of the node doesn't
14103              * change, it works */
14104             ret = regnode_guts(pRExC_state, node_type, current_string_nodes,
14105                                                                     "exact");
14106             FILL_NODE(ret, node_type);
14107             RExC_emit++;
14108
14109             s = STRING(REGNODE_p(ret));
14110
14111             s0 = s;
14112
14113           reparse:
14114
14115             p = RExC_parse;
14116             len = 0;
14117             s = s0;
14118             node_type = EXACT;
14119             oldp = NULL;
14120             maybe_exactfu = FOLD && (DEPENDS_SEMANTICS || LOC);
14121             maybe_SIMPLE = SIMPLE;
14122             requires_utf8_target = FALSE;
14123             has_ss = FALSE;
14124             has_micro_sign = FALSE;
14125
14126           continue_parse:
14127
14128             /* This breaks under rare circumstances.  If folding, we do not
14129              * want to split a node at a character that is a non-final in a
14130              * multi-char fold, as an input string could just happen to want to
14131              * match across the node boundary.  The code at the end of the loop
14132              * looks for this, and backs off until it finds not such a
14133              * character, but it is possible (though extremely, extremely
14134              * unlikely) for all characters in the node to be non-final fold
14135              * ones, in which case we just leave the node fully filled, and
14136              * hope that it doesn't match the string in just the wrong place */
14137
14138             assert( ! UTF     /* Is at the beginning of a character */
14139                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
14140                    || UTF8_IS_START(UCHARAT(RExC_parse)));
14141
14142             overflowed = FALSE;
14143
14144             /* Here, we have a literal character.  Find the maximal string of
14145              * them in the input that we can fit into a single EXACTish node.
14146              * We quit at the first non-literal or when the node gets full, or
14147              * under /i the categorization of folding/non-folding character
14148              * changes */
14149             while (p < RExC_end && len < upper_fill) {
14150
14151                 /* In most cases each iteration adds one byte to the output.
14152                  * The exceptions override this */
14153                 Size_t added_len = 1;
14154
14155                 oldp = p;
14156                 old_old_s = old_s;
14157                 old_s = s;
14158
14159                 /* White space has already been ignored */
14160                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
14161                        || ! is_PATWS_safe((p), RExC_end, UTF));
14162
14163                 switch ((U8)*p) {
14164                   const char* message;
14165                   U32 packed_warn;
14166                   U8 grok_c_char;
14167
14168                 case '^':
14169                 case '$':
14170                 case '.':
14171                 case '[':
14172                 case '(':
14173                 case ')':
14174                 case '|':
14175                     goto loopdone;
14176                 case '\\':
14177                     /* Literal Escapes Switch
14178
14179                        This switch is meant to handle escape sequences that
14180                        resolve to a literal character.
14181
14182                        Every escape sequence that represents something
14183                        else, like an assertion or a char class, is handled
14184                        in the switch marked 'Special Escapes' above in this
14185                        routine, but also has an entry here as anything that
14186                        isn't explicitly mentioned here will be treated as
14187                        an unescaped equivalent literal.
14188                     */
14189
14190                     switch ((U8)*++p) {
14191
14192                     /* These are all the special escapes. */
14193                     case 'A':             /* Start assertion */
14194                     case 'b': case 'B':   /* Word-boundary assertion*/
14195                     case 'C':             /* Single char !DANGEROUS! */
14196                     case 'd': case 'D':   /* digit class */
14197                     case 'g': case 'G':   /* generic-backref, pos assertion */
14198                     case 'h': case 'H':   /* HORIZWS */
14199                     case 'k': case 'K':   /* named backref, keep marker */
14200                     case 'p': case 'P':   /* Unicode property */
14201                               case 'R':   /* LNBREAK */
14202                     case 's': case 'S':   /* space class */
14203                     case 'v': case 'V':   /* VERTWS */
14204                     case 'w': case 'W':   /* word class */
14205                     case 'X':             /* eXtended Unicode "combining
14206                                              character sequence" */
14207                     case 'z': case 'Z':   /* End of line/string assertion */
14208                         --p;
14209                         goto loopdone;
14210
14211                     /* Anything after here is an escape that resolves to a
14212                        literal. (Except digits, which may or may not)
14213                      */
14214                     case 'n':
14215                         ender = '\n';
14216                         p++;
14217                         break;
14218                     case 'N': /* Handle a single-code point named character. */
14219                         RExC_parse = p + 1;
14220                         if (! grok_bslash_N(pRExC_state,
14221                                             NULL,   /* Fail if evaluates to
14222                                                        anything other than a
14223                                                        single code point */
14224                                             &ender, /* The returned single code
14225                                                        point */
14226                                             NULL,   /* Don't need a count of
14227                                                        how many code points */
14228                                             flagp,
14229                                             RExC_strict,
14230                                             depth)
14231                         ) {
14232                             if (*flagp & NEED_UTF8)
14233                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
14234                             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
14235
14236                             /* Here, it wasn't a single code point.  Go close
14237                              * up this EXACTish node.  The switch() prior to
14238                              * this switch handles the other cases */
14239                             RExC_parse = p = oldp;
14240                             goto loopdone;
14241                         }
14242                         p = RExC_parse;
14243                         RExC_parse = parse_start;
14244
14245                         /* The \N{} means the pattern, if previously /d,
14246                          * becomes /u.  That means it can't be an EXACTF node,
14247                          * but an EXACTFU */
14248                         if (node_type == EXACTF) {
14249                             node_type = EXACTFU;
14250
14251                             /* If the node already contains something that
14252                              * differs between EXACTF and EXACTFU, reparse it
14253                              * as EXACTFU */
14254                             if (! maybe_exactfu) {
14255                                 len = 0;
14256                                 s = s0;
14257                                 goto reparse;
14258                             }
14259                         }
14260
14261                         break;
14262                     case 'r':
14263                         ender = '\r';
14264                         p++;
14265                         break;
14266                     case 't':
14267                         ender = '\t';
14268                         p++;
14269                         break;
14270                     case 'f':
14271                         ender = '\f';
14272                         p++;
14273                         break;
14274                     case 'e':
14275                         ender = ESC_NATIVE;
14276                         p++;
14277                         break;
14278                     case 'a':
14279                         ender = '\a';
14280                         p++;
14281                         break;
14282                     case 'o':
14283                         if (! grok_bslash_o(&p,
14284                                             RExC_end,
14285                                             &ender,
14286                                             &message,
14287                                             &packed_warn,
14288                                             (bool) RExC_strict,
14289                                             FALSE, /* No illegal cp's */
14290                                             UTF))
14291                         {
14292                             RExC_parse = p; /* going to die anyway; point to
14293                                                exact spot of failure */
14294                             vFAIL(message);
14295                         }
14296
14297                         if (message && TO_OUTPUT_WARNINGS(p)) {
14298                             warn_non_literal_string(p, packed_warn, message);
14299                         }
14300                         break;
14301                     case 'x':
14302                         if (! grok_bslash_x(&p,
14303                                             RExC_end,
14304                                             &ender,
14305                                             &message,
14306                                             &packed_warn,
14307                                             (bool) RExC_strict,
14308                                             FALSE, /* No illegal cp's */
14309                                             UTF))
14310                         {
14311                             RExC_parse = p;     /* going to die anyway; point
14312                                                    to exact spot of failure */
14313                             vFAIL(message);
14314                         }
14315
14316                         if (message && TO_OUTPUT_WARNINGS(p)) {
14317                             warn_non_literal_string(p, packed_warn, message);
14318                         }
14319
14320 #ifdef EBCDIC
14321                         if (ender < 0x100) {
14322                             if (RExC_recode_x_to_native) {
14323                                 ender = LATIN1_TO_NATIVE(ender);
14324                             }
14325                         }
14326 #endif
14327                         break;
14328                     case 'c':
14329                         p++;
14330                         if (! grok_bslash_c(*p, &grok_c_char,
14331                                             &message, &packed_warn))
14332                         {
14333                             /* going to die anyway; point to exact spot of
14334                              * failure */
14335                             RExC_parse = p + ((UTF)
14336                                               ? UTF8_SAFE_SKIP(p, RExC_end)
14337                                               : 1);
14338                             vFAIL(message);
14339                         }
14340
14341                         ender = grok_c_char;
14342                         p++;
14343                         if (message && TO_OUTPUT_WARNINGS(p)) {
14344                             warn_non_literal_string(p, packed_warn, message);
14345                         }
14346
14347                         break;
14348                     case '8': case '9': /* must be a backreference */
14349                         --p;
14350                         /* we have an escape like \8 which cannot be an octal escape
14351                          * so we exit the loop, and let the outer loop handle this
14352                          * escape which may or may not be a legitimate backref. */
14353                         goto loopdone;
14354                     case '1': case '2': case '3':case '4':
14355                     case '5': case '6': case '7':
14356                         /* When we parse backslash escapes there is ambiguity
14357                          * between backreferences and octal escapes. Any escape
14358                          * from \1 - \9 is a backreference, any multi-digit
14359                          * escape which does not start with 0 and which when
14360                          * evaluated as decimal could refer to an already
14361                          * parsed capture buffer is a back reference. Anything
14362                          * else is octal.
14363                          *
14364                          * Note this implies that \118 could be interpreted as
14365                          * 118 OR as "\11" . "8" depending on whether there
14366                          * were 118 capture buffers defined already in the
14367                          * pattern.  */
14368
14369                         /* NOTE, RExC_npar is 1 more than the actual number of
14370                          * parens we have seen so far, hence the "<" as opposed
14371                          * to "<=" */
14372                         if ( !isDIGIT(p[1]) || S_backref_value(p, RExC_end) < RExC_npar)
14373                         {  /* Not to be treated as an octal constant, go
14374                                    find backref */
14375                             --p;
14376                             goto loopdone;
14377                         }
14378                         /* FALLTHROUGH */
14379                     case '0':
14380                         {
14381                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT
14382                                       | PERL_SCAN_NOTIFY_ILLDIGIT;
14383                             STRLEN numlen = 3;
14384                             ender = grok_oct(p, &numlen, &flags, NULL);
14385                             p += numlen;
14386                             if (  (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
14387                                 && isDIGIT(*p)  /* like \08, \178 */
14388                                 && ckWARN(WARN_REGEXP))
14389                             {
14390                                 reg_warn_non_literal_string(
14391                                      p + 1,
14392                                      form_alien_digit_msg(8, numlen, p,
14393                                                         RExC_end, UTF, FALSE));
14394                             }
14395                         }
14396                         break;
14397                     case '\0':
14398                         if (p >= RExC_end)
14399                             FAIL("Trailing \\");
14400                         /* FALLTHROUGH */
14401                     default:
14402                         if (isALPHANUMERIC(*p)) {
14403                             /* An alpha followed by '{' is going to fail next
14404                              * iteration, so don't output this warning in that
14405                              * case */
14406                             if (! isALPHA(*p) || *(p + 1) != '{') {
14407                                 ckWARN2reg(p + 1, "Unrecognized escape \\%.1s"
14408                                                   " passed through", p);
14409                             }
14410                         }
14411                         goto normal_default;
14412                     } /* End of switch on '\' */
14413                     break;
14414                 case '{':
14415                     /* Trying to gain new uses for '{' without breaking too
14416                      * much existing code is hard.  The solution currently
14417                      * adopted is:
14418                      *  1)  If there is no ambiguity that a '{' should always
14419                      *      be taken literally, at the start of a construct, we
14420                      *      just do so.
14421                      *  2)  If the literal '{' conflicts with our desired use
14422                      *      of it as a metacharacter, we die.  The deprecation
14423                      *      cycles for this have come and gone.
14424                      *  3)  If there is ambiguity, we raise a simple warning.
14425                      *      This could happen, for example, if the user
14426                      *      intended it to introduce a quantifier, but slightly
14427                      *      misspelled the quantifier.  Without this warning,
14428                      *      the quantifier would silently be taken as a literal
14429                      *      string of characters instead of a meta construct */
14430                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
14431                         if (      RExC_strict
14432                             || (  p > parse_start + 1
14433                                 && isALPHA_A(*(p - 1))
14434                                 && *(p - 2) == '\\')
14435                             || new_regcurly(p, RExC_end))
14436                         {
14437                             RExC_parse = p + 1;
14438                             vFAIL("Unescaped left brace in regex is "
14439                                   "illegal here");
14440                         }
14441                         ckWARNreg(p + 1, "Unescaped left brace in regex is"
14442                                          " passed through");
14443                     }
14444                     goto normal_default;
14445                 case '}':
14446                 case ']':
14447                     if (p > RExC_parse && RExC_strict) {
14448                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
14449                     }
14450                     /*FALLTHROUGH*/
14451                 default:    /* A literal character */
14452                   normal_default:
14453                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
14454                         STRLEN numlen;
14455                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
14456                                                &numlen, UTF8_ALLOW_DEFAULT);
14457                         p += numlen;
14458                     }
14459                     else
14460                         ender = (U8) *p++;
14461                     break;
14462                 } /* End of switch on the literal */
14463
14464                 /* Here, have looked at the literal character, and <ender>
14465                  * contains its ordinal; <p> points to the character after it.
14466                  * */
14467
14468                 if (ender > 255) {
14469                     REQUIRE_UTF8(flagp);
14470                     if (   UNICODE_IS_PERL_EXTENDED(ender)
14471                         && TO_OUTPUT_WARNINGS(p))
14472                     {
14473                         ckWARN2_non_literal_string(p,
14474                                                    packWARN(WARN_PORTABLE),
14475                                                    PL_extended_cp_format,
14476                                                    ender);
14477                     }
14478                 }
14479
14480                 /* We need to check if the next non-ignored thing is a
14481                  * quantifier.  Move <p> to after anything that should be
14482                  * ignored, which, as a side effect, positions <p> for the next
14483                  * loop iteration */
14484                 skip_to_be_ignored_text(pRExC_state, &p,
14485                                         FALSE /* Don't force to /x */ );
14486
14487                 /* If the next thing is a quantifier, it applies to this
14488                  * character only, which means that this character has to be in
14489                  * its own node and can't just be appended to the string in an
14490                  * existing node, so if there are already other characters in
14491                  * the node, close the node with just them, and set up to do
14492                  * this character again next time through, when it will be the
14493                  * only thing in its new node */
14494
14495                 next_is_quantifier =    LIKELY(p < RExC_end)
14496                                      && UNLIKELY(ISMULT2(p));
14497
14498                 if (next_is_quantifier && LIKELY(len)) {
14499                     p = oldp;
14500                     goto loopdone;
14501                 }
14502
14503                 /* Ready to add 'ender' to the node */
14504
14505                 if (! FOLD) {  /* The simple case, just append the literal */
14506                   not_fold_common:
14507
14508                     /* Don't output if it would overflow */
14509                     if (UNLIKELY(len > max_string_len - ((UTF)
14510                                                       ? UVCHR_SKIP(ender)
14511                                                       : 1)))
14512                     {
14513                         overflowed = TRUE;
14514                         break;
14515                     }
14516
14517                     if (UVCHR_IS_INVARIANT(ender) || ! UTF) {
14518                         *(s++) = (char) ender;
14519                     }
14520                     else {
14521                         U8 * new_s = uvchr_to_utf8((U8*)s, ender);
14522                         added_len = (char *) new_s - s;
14523                         s = (char *) new_s;
14524
14525                         if (ender > 255)  {
14526                             requires_utf8_target = TRUE;
14527                         }
14528                     }
14529                 }
14530                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
14531
14532                     /* Here are folding under /l, and the code point is
14533                      * problematic.  If this is the first character in the
14534                      * node, change the node type to folding.   Otherwise, if
14535                      * this is the first problematic character, close up the
14536                      * existing node, so can start a new node with this one */
14537                     if (! len) {
14538                         node_type = EXACTFL;
14539                         RExC_contains_locale = 1;
14540                     }
14541                     else if (node_type == EXACT) {
14542                         p = oldp;
14543                         goto loopdone;
14544                     }
14545
14546                     /* This problematic code point means we can't simplify
14547                      * things */
14548                     maybe_exactfu = FALSE;
14549
14550                     /* Although these two characters have folds that are
14551                      * locale-problematic, they also have folds to above Latin1
14552                      * that aren't a problem.  Doing these now helps at
14553                      * runtime. */
14554                     if (UNLIKELY(   ender == GREEK_CAPITAL_LETTER_MU
14555                                  || ender == LATIN_CAPITAL_LETTER_SHARP_S))
14556                     {
14557                         goto fold_anyway;
14558                     }
14559
14560                     /* Here, we are adding a problematic fold character.
14561                      * "Problematic" in this context means that its fold isn't
14562                      * known until runtime.  (The non-problematic code points
14563                      * are the above-Latin1 ones that fold to also all
14564                      * above-Latin1.  Their folds don't vary no matter what the
14565                      * locale is.) But here we have characters whose fold
14566                      * depends on the locale.  We just add in the unfolded
14567                      * character, and wait until runtime to fold it */
14568                     goto not_fold_common;
14569                 }
14570                 else /* regular fold; see if actually is in a fold */
14571                      if (   (ender < 256 && ! IS_IN_SOME_FOLD_L1(ender))
14572                          || (ender > 255
14573                             && ! _invlist_contains_cp(PL_in_some_fold, ender)))
14574                 {
14575                     /* Here, folding, but the character isn't in a fold.
14576                      *
14577                      * Start a new node if previous characters in the node were
14578                      * folded */
14579                     if (len && node_type != EXACT) {
14580                         p = oldp;
14581                         goto loopdone;
14582                     }
14583
14584                     /* Here, continuing a node with non-folded characters.  Add
14585                      * this one */
14586                     goto not_fold_common;
14587                 }
14588                 else {  /* Here, does participate in some fold */
14589
14590                     /* If this is the first character in the node, change its
14591                      * type to folding.  Otherwise, if this is the first
14592                      * folding character in the node, close up the existing
14593                      * node, so can start a new node with this one.  */
14594                     if (! len) {
14595                         node_type = compute_EXACTish(pRExC_state);
14596                     }
14597                     else if (node_type == EXACT) {
14598                         p = oldp;
14599                         goto loopdone;
14600                     }
14601
14602                     if (UTF) {  /* Alway use the folded value for UTF-8
14603                                    patterns */
14604                         if (UVCHR_IS_INVARIANT(ender)) {
14605                             if (UNLIKELY(len + 1 > max_string_len)) {
14606                                 overflowed = TRUE;
14607                                 break;
14608                             }
14609
14610                             *(s)++ = (U8) toFOLD(ender);
14611                         }
14612                         else {
14613                             UV folded;
14614
14615                           fold_anyway:
14616                             folded = _to_uni_fold_flags(
14617                                     ender,
14618                                     (U8 *) s,  /* We have allocated extra space
14619                                                   in 's' so can't run off the
14620                                                   end */
14621                                     &added_len,
14622                                     FOLD_FLAGS_FULL
14623                                   | ((   ASCII_FOLD_RESTRICTED
14624                                       || node_type == EXACTFL)
14625                                     ? FOLD_FLAGS_NOMIX_ASCII
14626                                     : 0));
14627                             if (UNLIKELY(len + added_len > max_string_len)) {
14628                                 overflowed = TRUE;
14629                                 break;
14630                             }
14631
14632                             s += added_len;
14633
14634                             if (   folded > 255
14635                                 && LIKELY(folded != GREEK_SMALL_LETTER_MU))
14636                             {
14637                                 /* U+B5 folds to the MU, so its possible for a
14638                                  * non-UTF-8 target to match it */
14639                                 requires_utf8_target = TRUE;
14640                             }
14641                         }
14642                     }
14643                     else { /* Here is non-UTF8. */
14644
14645                         /* The fold will be one or (rarely) two characters.
14646                          * Check that there's room for at least a single one
14647                          * before setting any flags, etc.  Because otherwise an
14648                          * overflowing character could cause a flag to be set
14649                          * even though it doesn't end up in this node.  (For
14650                          * the two character fold, we check again, before
14651                          * setting any flags) */
14652                         if (UNLIKELY(len + 1 > max_string_len)) {
14653                             overflowed = TRUE;
14654                             break;
14655                         }
14656
14657 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
14658    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
14659                                       || UNICODE_DOT_DOT_VERSION > 0)
14660
14661                         /* On non-ancient Unicodes, check for the only possible
14662                          * multi-char fold  */
14663                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
14664
14665                             /* This potential multi-char fold means the node
14666                              * can't be simple (because it could match more
14667                              * than a single char).  And in some cases it will
14668                              * match 'ss', so set that flag */
14669                             maybe_SIMPLE = 0;
14670                             has_ss = TRUE;
14671
14672                             /* It can't change to be an EXACTFU (unless already
14673                              * is one).  We fold it iff under /u rules. */
14674                             if (node_type != EXACTFU) {
14675                                 maybe_exactfu = FALSE;
14676                             }
14677                             else {
14678                                 if (UNLIKELY(len + 2 > max_string_len)) {
14679                                     overflowed = TRUE;
14680                                     break;
14681                                 }
14682
14683                                 *(s++) = 's';
14684                                 *(s++) = 's';
14685                                 added_len = 2;
14686
14687                                 goto done_with_this_char;
14688                             }
14689                         }
14690                         else if (   UNLIKELY(isALPHA_FOLD_EQ(ender, 's'))
14691                                  && LIKELY(len > 0)
14692                                  && UNLIKELY(isALPHA_FOLD_EQ(*(s-1), 's')))
14693                         {
14694                             /* Also, the sequence 'ss' is special when not
14695                              * under /u.  If the target string is UTF-8, it
14696                              * should match SHARP S; otherwise it won't.  So,
14697                              * here we have to exclude the possibility of this
14698                              * node moving to /u.*/
14699                             has_ss = TRUE;
14700                             maybe_exactfu = FALSE;
14701                         }
14702 #endif
14703                         /* Here, the fold will be a single character */
14704
14705                         if (UNLIKELY(ender == MICRO_SIGN)) {
14706                             has_micro_sign = TRUE;
14707                         }
14708                         else if (PL_fold[ender] != PL_fold_latin1[ender]) {
14709
14710                             /* If the character's fold differs between /d and
14711                              * /u, this can't change to be an EXACTFU node */
14712                             maybe_exactfu = FALSE;
14713                         }
14714
14715                         *(s++) = (DEPENDS_SEMANTICS)
14716                                  ? (char) toFOLD(ender)
14717
14718                                    /* Under /u, the fold of any character in
14719                                     * the 0-255 range happens to be its
14720                                     * lowercase equivalent, except for LATIN
14721                                     * SMALL LETTER SHARP S, which was handled
14722                                     * above, and the MICRO SIGN, whose fold
14723                                     * requires UTF-8 to represent.  */
14724                                  : (char) toLOWER_L1(ender);
14725                     }
14726                 } /* End of adding current character to the node */
14727
14728               done_with_this_char:
14729
14730                 len += added_len;
14731
14732                 if (next_is_quantifier) {
14733
14734                     /* Here, the next input is a quantifier, and to get here,
14735                      * the current character is the only one in the node. */
14736                     goto loopdone;
14737                 }
14738
14739             } /* End of loop through literal characters */
14740
14741             /* Here we have either exhausted the input or run out of room in
14742              * the node.  If the former, we are done.  (If we encountered a
14743              * character that can't be in the node, transfer is made directly
14744              * to <loopdone>, and so we wouldn't have fallen off the end of the
14745              * loop.)  */
14746             if (LIKELY(! overflowed)) {
14747                 goto loopdone;
14748             }
14749
14750             /* Here we have run out of room.  We can grow plain EXACT and
14751              * LEXACT nodes.  If the pattern is gigantic enough, though,
14752              * eventually we'll have to artificially chunk the pattern into
14753              * multiple nodes. */
14754             if (! LOC && (node_type == EXACT || node_type == LEXACT)) {
14755                 Size_t overhead = 1 + regarglen[OP(REGNODE_p(ret))];
14756                 Size_t overhead_expansion = 0;
14757                 char temp[256];
14758                 Size_t max_nodes_for_string;
14759                 Size_t achievable;
14760                 SSize_t delta;
14761
14762                 /* Here we couldn't fit the final character in the current
14763                  * node, so it will have to be reparsed, no matter what else we
14764                  * do */
14765                 p = oldp;
14766
14767                 /* If would have overflowed a regular EXACT node, switch
14768                  * instead to an LEXACT.  The code below is structured so that
14769                  * the actual growing code is common to changing from an EXACT
14770                  * or just increasing the LEXACT size.  This means that we have
14771                  * to save the string in the EXACT case before growing, and
14772                  * then copy it afterwards to its new location */
14773                 if (node_type == EXACT) {
14774                     overhead_expansion = regarglen[LEXACT] - regarglen[EXACT];
14775                     RExC_emit += overhead_expansion;
14776                     Copy(s0, temp, len, char);
14777                 }
14778
14779                 /* Ready to grow.  If it was a plain EXACT, the string was
14780                  * saved, and the first few bytes of it overwritten by adding
14781                  * an argument field.  We assume, as we do elsewhere in this
14782                  * file, that one byte of remaining input will translate into
14783                  * one byte of output, and if that's too small, we grow again,
14784                  * if too large the excess memory is freed at the end */
14785
14786                 max_nodes_for_string = U16_MAX - overhead - overhead_expansion;
14787                 achievable = MIN(max_nodes_for_string,
14788                                  current_string_nodes + STR_SZ(RExC_end - p));
14789                 delta = achievable - current_string_nodes;
14790
14791                 /* If there is just no more room, go finish up this chunk of
14792                  * the pattern. */
14793                 if (delta <= 0) {
14794                     goto loopdone;
14795                 }
14796
14797                 change_engine_size(pRExC_state, delta + overhead_expansion);
14798                 current_string_nodes += delta;
14799                 max_string_len
14800                            = sizeof(struct regnode) * current_string_nodes;
14801                 upper_fill = max_string_len + 1;
14802
14803                 /* If the length was small, we know this was originally an
14804                  * EXACT node now converted to LEXACT, and the string has to be
14805                  * restored.  Otherwise the string was untouched.  260 is just
14806                  * a number safely above 255 so don't have to worry about
14807                  * getting it precise */
14808                 if (len < 260) {
14809                     node_type = LEXACT;
14810                     FILL_NODE(ret, node_type);
14811                     s0 = STRING(REGNODE_p(ret));
14812                     Copy(temp, s0, len, char);
14813                     s = s0 + len;
14814                 }
14815
14816                 goto continue_parse;
14817             }
14818             else if (FOLD) {
14819                 bool splittable = FALSE;
14820                 bool backed_up = FALSE;
14821                 char * e;       /* should this be U8? */
14822                 char * s_start; /* should this be U8? */
14823
14824                 /* Here is /i.  Running out of room creates a problem if we are
14825                  * folding, and the split happens in the middle of a
14826                  * multi-character fold, as a match that should have occurred,
14827                  * won't, due to the way nodes are matched, and our artificial
14828                  * boundary.  So back off until we aren't splitting such a
14829                  * fold.  If there is no such place to back off to, we end up
14830                  * taking the entire node as-is.  This can happen if the node
14831                  * consists entirely of 'f' or entirely of 's' characters (or
14832                  * things that fold to them) as 'ff' and 'ss' are
14833                  * multi-character folds.
14834                  *
14835                  * The Unicode standard says that multi character folds consist
14836                  * of either two or three characters.  That means we would be
14837                  * splitting one if the final character in the node is at the
14838                  * beginning of either type, or is the second of a three
14839                  * character fold.
14840                  *
14841                  * At this point:
14842                  *  ender     is the code point of the character that won't fit
14843                  *            in the node
14844                  *  s         points to just beyond the final byte in the node.
14845                  *            It's where we would place ender if there were
14846                  *            room, and where in fact we do place ender's fold
14847                  *            in the code below, as we've over-allocated space
14848                  *            for s0 (hence s) to allow for this
14849                  *  e         starts at 's' and advances as we append things.
14850                  *  old_s     is the same as 's'.  (If ender had fit, 's' would
14851                  *            have been advanced to beyond it).
14852                  *  old_old_s points to the beginning byte of the final
14853                  *            character in the node
14854                  *  p         points to the beginning byte in the input of the
14855                  *            character beyond 'ender'.
14856                  *  oldp      points to the beginning byte in the input of
14857                  *            'ender'.
14858                  *
14859                  * In the case of /il, we haven't folded anything that could be
14860                  * affected by the locale.  That means only above-Latin1
14861                  * characters that fold to other above-latin1 characters get
14862                  * folded at compile time.  To check where a good place to
14863                  * split nodes is, everything in it will have to be folded.
14864                  * The boolean 'maybe_exactfu' keeps track in /il if there are
14865                  * any unfolded characters in the node. */
14866                 bool need_to_fold_loc = LOC && ! maybe_exactfu;
14867
14868                 /* If we do need to fold the node, we need a place to store the
14869                  * folded copy, and a way to map back to the unfolded original
14870                  * */
14871                 char * locfold_buf = NULL;
14872                 Size_t * loc_correspondence = NULL;
14873
14874                 if (! need_to_fold_loc) {   /* The normal case.  Just
14875                                                initialize to the actual node */
14876                     e = s;
14877                     s_start = s0;
14878                     s = old_old_s;  /* Point to the beginning of the final char
14879                                        that fits in the node */
14880                 }
14881                 else {
14882
14883                     /* Here, we have filled a /il node, and there are unfolded
14884                      * characters in it.  If the runtime locale turns out to be
14885                      * UTF-8, there are possible multi-character folds, just
14886                      * like when not under /l.  The node hence can't terminate
14887                      * in the middle of such a fold.  To determine this, we
14888                      * have to create a folded copy of this node.  That means
14889                      * reparsing the node, folding everything assuming a UTF-8
14890                      * locale.  (If at runtime it isn't such a locale, the
14891                      * actions here wouldn't have been necessary, but we have
14892                      * to assume the worst case.)  If we find we need to back
14893                      * off the folded string, we do so, and then map that
14894                      * position back to the original unfolded node, which then
14895                      * gets output, truncated at that spot */
14896
14897                     char * redo_p = RExC_parse;
14898                     char * redo_e;
14899                     char * old_redo_e;
14900
14901                     /* Allow enough space assuming a single byte input folds to
14902                      * a single byte output, plus assume that the two unparsed
14903                      * characters (that we may need) fold to the largest number
14904                      * of bytes possible, plus extra for one more worst case
14905                      * scenario.  In the loop below, if we start eating into
14906                      * that final spare space, we enlarge this initial space */
14907                     Size_t size = max_string_len + (3 * UTF8_MAXBYTES_CASE) + 1;
14908
14909                     Newxz(locfold_buf, size, char);
14910                     Newxz(loc_correspondence, size, Size_t);
14911
14912                     /* Redo this node's parse, folding into 'locfold_buf' */
14913                     redo_p = RExC_parse;
14914                     old_redo_e = redo_e = locfold_buf;
14915                     while (redo_p <= oldp) {
14916
14917                         old_redo_e = redo_e;
14918                         loc_correspondence[redo_e - locfold_buf]
14919                                                         = redo_p - RExC_parse;
14920
14921                         if (UTF) {
14922                             Size_t added_len;
14923
14924                             (void) _to_utf8_fold_flags((U8 *) redo_p,
14925                                                        (U8 *) RExC_end,
14926                                                        (U8 *) redo_e,
14927                                                        &added_len,
14928                                                        FOLD_FLAGS_FULL);
14929                             redo_e += added_len;
14930                             redo_p += UTF8SKIP(redo_p);
14931                         }
14932                         else {
14933
14934                             /* Note that if this code is run on some ancient
14935                              * Unicode versions, SHARP S doesn't fold to 'ss',
14936                              * but rather than clutter the code with #ifdef's,
14937                              * as is done above, we ignore that possibility.
14938                              * This is ok because this code doesn't affect what
14939                              * gets matched, but merely where the node gets
14940                              * split */
14941                             if (UCHARAT(redo_p) != LATIN_SMALL_LETTER_SHARP_S) {
14942                                 *redo_e++ = toLOWER_L1(UCHARAT(redo_p));
14943                             }
14944                             else {
14945                                 *redo_e++ = 's';
14946                                 *redo_e++ = 's';
14947                             }
14948                             redo_p++;
14949                         }
14950
14951
14952                         /* If we're getting so close to the end that a
14953                          * worst-case fold in the next character would cause us
14954                          * to overflow, increase, assuming one byte output byte
14955                          * per one byte input one, plus room for another worst
14956                          * case fold */
14957                         if (   redo_p <= oldp
14958                             && redo_e > locfold_buf + size
14959                                                     - (UTF8_MAXBYTES_CASE + 1))
14960                         {
14961                             Size_t new_size = size
14962                                             + (oldp - redo_p)
14963                                             + UTF8_MAXBYTES_CASE + 1;
14964                             Ptrdiff_t e_offset = redo_e - locfold_buf;
14965
14966                             Renew(locfold_buf, new_size, char);
14967                             Renew(loc_correspondence, new_size, Size_t);
14968                             size = new_size;
14969
14970                             redo_e = locfold_buf + e_offset;
14971                         }
14972                     }
14973
14974                     /* Set so that things are in terms of the folded, temporary
14975                      * string */
14976                     s = old_redo_e;
14977                     s_start = locfold_buf;
14978                     e = redo_e;
14979
14980                 }
14981
14982                 /* Here, we have 's', 's_start' and 'e' set up to point to the
14983                  * input that goes into the node, folded.
14984                  *
14985                  * If the final character of the node and the fold of ender
14986                  * form the first two characters of a three character fold, we
14987                  * need to peek ahead at the next (unparsed) character in the
14988                  * input to determine if the three actually do form such a
14989                  * fold.  Just looking at that character is not generally
14990                  * sufficient, as it could be, for example, an escape sequence
14991                  * that evaluates to something else, and it needs to be folded.
14992                  *
14993                  * khw originally thought to just go through the parse loop one
14994                  * extra time, but that doesn't work easily as that iteration
14995                  * could cause things to think that the parse is over and to
14996                  * goto loopdone.  The character could be a '$' for example, or
14997                  * the character beyond could be a quantifier, and other
14998                  * glitches as well.
14999                  *
15000                  * The solution used here for peeking ahead is to look at that
15001                  * next character.  If it isn't ASCII punctuation, then it will
15002                  * be something that would continue on in an EXACTish node if
15003                  * there were space.  We append the fold of it to s, having
15004                  * reserved enough room in s0 for the purpose.  If we can't
15005                  * reasonably peek ahead, we instead assume the worst case:
15006                  * that it is something that would form the completion of a
15007                  * multi-char fold.
15008                  *
15009                  * If we can't split between s and ender, we work backwards
15010                  * character-by-character down to s0.  At each current point
15011                  * see if we are at the beginning of a multi-char fold.  If so,
15012                  * that means we would be splitting the fold across nodes, and
15013                  * so we back up one and try again.
15014                  *
15015                  * If we're not at the beginning, we still could be at the
15016                  * final two characters of a (rare) three character fold.  We
15017                  * check if the sequence starting at the character before the
15018                  * current position (and including the current and next
15019                  * characters) is a three character fold.  If not, the node can
15020                  * be split here.  If it is, we have to backup two characters
15021                  * and try again.
15022                  *
15023                  * Otherwise, the node can be split at the current position.
15024                  *
15025                  * The same logic is used for UTF-8 patterns and not */
15026                 if (UTF) {
15027                     Size_t added_len;
15028
15029                     /* Append the fold of ender */
15030                     (void) _to_uni_fold_flags(
15031                         ender,
15032                         (U8 *) e,
15033                         &added_len,
15034                         FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
15035                                         ? FOLD_FLAGS_NOMIX_ASCII
15036                                         : 0));
15037                     e += added_len;
15038
15039                     /* 's' and the character folded to by ender may be the
15040                      * first two of a three-character fold, in which case the
15041                      * node should not be split here.  That may mean examining
15042                      * the so-far unparsed character starting at 'p'.  But if
15043                      * ender folded to more than one character, we already have
15044                      * three characters to look at.  Also, we first check if
15045                      * the sequence consisting of s and the next character form
15046                      * the first two of some three character fold.  If not,
15047                      * there's no need to peek ahead. */
15048                     if (   added_len <= UTF8SKIP(e - added_len)
15049                         && UNLIKELY(is_THREE_CHAR_FOLD_HEAD_utf8_safe(s, e)))
15050                     {
15051                         /* Here, the two do form the beginning of a potential
15052                          * three character fold.  The unexamined character may
15053                          * or may not complete it.  Peek at it.  It might be
15054                          * something that ends the node or an escape sequence,
15055                          * in which case we don't know without a lot of work
15056                          * what it evaluates to, so we have to assume the worst
15057                          * case: that it does complete the fold, and so we
15058                          * can't split here.  All such instances  will have
15059                          * that character be an ASCII punctuation character,
15060                          * like a backslash.  So, for that case, backup one and
15061                          * drop down to try at that position */
15062                         if (isPUNCT(*p)) {
15063                             s = (char *) utf8_hop_back((U8 *) s, -1,
15064                                        (U8 *) s_start);
15065                             backed_up = TRUE;
15066                         }
15067                         else {
15068                             /* Here, since it's not punctuation, it must be a
15069                              * real character, and we can append its fold to
15070                              * 'e' (having deliberately reserved enough space
15071                              * for this eventuality) and drop down to check if
15072                              * the three actually do form a folded sequence */
15073                             (void) _to_utf8_fold_flags(
15074                                 (U8 *) p, (U8 *) RExC_end,
15075                                 (U8 *) e,
15076                                 &added_len,
15077                                 FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
15078                                                 ? FOLD_FLAGS_NOMIX_ASCII
15079                                                 : 0));
15080                             e += added_len;
15081                         }
15082                     }
15083
15084                     /* Here, we either have three characters available in
15085                      * sequence starting at 's', or we have two characters and
15086                      * know that the following one can't possibly be part of a
15087                      * three character fold.  We go through the node backwards
15088                      * until we find a place where we can split it without
15089                      * breaking apart a multi-character fold.  At any given
15090                      * point we have to worry about if such a fold begins at
15091                      * the current 's', and also if a three-character fold
15092                      * begins at s-1, (containing s and s+1).  Splitting in
15093                      * either case would break apart a fold */
15094                     do {
15095                         char *prev_s = (char *) utf8_hop_back((U8 *) s, -1,
15096                                                             (U8 *) s_start);
15097
15098                         /* If is a multi-char fold, can't split here.  Backup
15099                          * one char and try again */
15100                         if (UNLIKELY(is_MULTI_CHAR_FOLD_utf8_safe(s, e))) {
15101                             s = prev_s;
15102                             backed_up = TRUE;
15103                             continue;
15104                         }
15105
15106                         /* If the two characters beginning at 's' are part of a
15107                          * three character fold starting at the character
15108                          * before s, we can't split either before or after s.
15109                          * Backup two chars and try again */
15110                         if (   LIKELY(s > s_start)
15111                             && UNLIKELY(is_THREE_CHAR_FOLD_utf8_safe(prev_s, e)))
15112                         {
15113                             s = prev_s;
15114                             s = (char *) utf8_hop_back((U8 *) s, -1, (U8 *) s_start);
15115                             backed_up = TRUE;
15116                             continue;
15117                         }
15118
15119                         /* Here there's no multi-char fold between s and the
15120                          * next character following it.  We can split */
15121                         splittable = TRUE;
15122                         break;
15123
15124                     } while (s > s_start); /* End of loops backing up through the node */
15125
15126                     /* Here we either couldn't find a place to split the node,
15127                      * or else we broke out of the loop setting 'splittable' to
15128                      * true.  In the latter case, the place to split is between
15129                      * the first and second characters in the sequence starting
15130                      * at 's' */
15131                     if (splittable) {
15132                         s += UTF8SKIP(s);
15133                     }
15134                 }
15135                 else {  /* Pattern not UTF-8 */
15136                     if (   ender != LATIN_SMALL_LETTER_SHARP_S
15137                         || ASCII_FOLD_RESTRICTED)
15138                     {
15139                         assert( toLOWER_L1(ender) < 256 );
15140                         *e++ = (char)(toLOWER_L1(ender)); /* should e and the cast be U8? */
15141                     }
15142                     else {
15143                         *e++ = 's';
15144                         *e++ = 's';
15145                     }
15146
15147                     if (   e - s  <= 1
15148                         && UNLIKELY(is_THREE_CHAR_FOLD_HEAD_latin1_safe(s, e)))
15149                     {
15150                         if (isPUNCT(*p)) {
15151                             s--;
15152                             backed_up = TRUE;
15153                         }
15154                         else {
15155                             if (   UCHARAT(p) != LATIN_SMALL_LETTER_SHARP_S
15156                                 || ASCII_FOLD_RESTRICTED)
15157                             {
15158                                 assert( toLOWER_L1(ender) < 256 );
15159                                 *e++ = (char)(toLOWER_L1(ender)); /* should e and the cast be U8? */
15160                             }
15161                             else {
15162                                 *e++ = 's';
15163                                 *e++ = 's';
15164                             }
15165                         }
15166                     }
15167
15168                     do {
15169                         if (UNLIKELY(is_MULTI_CHAR_FOLD_latin1_safe(s, e))) {
15170                             s--;
15171                             backed_up = TRUE;
15172                             continue;
15173                         }
15174
15175                         if (   LIKELY(s > s_start)
15176                             && UNLIKELY(is_THREE_CHAR_FOLD_latin1_safe(s - 1, e)))
15177                         {
15178                             s -= 2;
15179                             backed_up = TRUE;
15180                             continue;
15181                         }
15182
15183                         splittable = TRUE;
15184                         break;
15185
15186                     } while (s > s_start);
15187
15188                     if (splittable) {
15189                         s++;
15190                     }
15191                 }
15192
15193                 /* Here, we are done backing up.  If we didn't backup at all
15194                  * (the likely case), just proceed */
15195                 if (backed_up) {
15196
15197                    /* If we did find a place to split, reparse the entire node
15198                     * stopping where we have calculated. */
15199                     if (splittable) {
15200
15201                        /* If we created a temporary folded string under /l, we
15202                         * have to map that back to the original */
15203                         if (need_to_fold_loc) {
15204                             upper_fill = loc_correspondence[s - s_start];
15205                             if (upper_fill == 0) {
15206                                 FAIL2("panic: loc_correspondence[%d] is 0",
15207                                       (int) (s - s_start));
15208                             }
15209                             Safefree(locfold_buf);
15210                             Safefree(loc_correspondence);
15211                         }
15212                         else {
15213                             upper_fill = s - s0;
15214                         }
15215                         goto reparse;
15216                     }
15217
15218                     /* Here the node consists entirely of non-final multi-char
15219                      * folds.  (Likely it is all 'f's or all 's's.)  There's no
15220                      * decent place to split it, so give up and just take the
15221                      * whole thing */
15222                     len = old_s - s0;
15223                 }
15224
15225                 if (need_to_fold_loc) {
15226                     Safefree(locfold_buf);
15227                     Safefree(loc_correspondence);
15228                 }
15229             }   /* End of verifying node ends with an appropriate char */
15230
15231             /* We need to start the next node at the character that didn't fit
15232              * in this one */
15233             p = oldp;
15234
15235           loopdone:   /* Jumped to when encounters something that shouldn't be
15236                          in the node */
15237
15238             /* Free up any over-allocated space; cast is to silence bogus
15239              * warning in MS VC */
15240             change_engine_size(pRExC_state,
15241                         - (Ptrdiff_t) (current_string_nodes - STR_SZ(len)));
15242
15243             /* I (khw) don't know if you can get here with zero length, but the
15244              * old code handled this situation by creating a zero-length EXACT
15245              * node.  Might as well be NOTHING instead */
15246             if (len == 0) {
15247                 OP(REGNODE_p(ret)) = NOTHING;
15248             }
15249             else {
15250
15251                 /* If the node type is EXACT here, check to see if it
15252                  * should be EXACTL, or EXACT_REQ8. */
15253                 if (node_type == EXACT) {
15254                     if (LOC) {
15255                         node_type = EXACTL;
15256                     }
15257                     else if (requires_utf8_target) {
15258                         node_type = EXACT_REQ8;
15259                     }
15260                 }
15261                 else if (node_type == LEXACT) {
15262                     if (requires_utf8_target) {
15263                         node_type = LEXACT_REQ8;
15264                     }
15265                 }
15266                 else if (FOLD) {
15267                     if (    UNLIKELY(has_micro_sign || has_ss)
15268                         && (node_type == EXACTFU || (   node_type == EXACTF
15269                                                      && maybe_exactfu)))
15270                     {   /* These two conditions are problematic in non-UTF-8
15271                            EXACTFU nodes. */
15272                         assert(! UTF);
15273                         node_type = EXACTFUP;
15274                     }
15275                     else if (node_type == EXACTFL) {
15276
15277                         /* 'maybe_exactfu' is deliberately set above to
15278                          * indicate this node type, where all code points in it
15279                          * are above 255 */
15280                         if (maybe_exactfu) {
15281                             node_type = EXACTFLU8;
15282                         }
15283                         else if (UNLIKELY(
15284                              _invlist_contains_cp(PL_HasMultiCharFold, ender)))
15285                         {
15286                             /* A character that folds to more than one will
15287                              * match multiple characters, so can't be SIMPLE.
15288                              * We don't have to worry about this with EXACTFLU8
15289                              * nodes just above, as they have already been
15290                              * folded (since the fold doesn't vary at run
15291                              * time).  Here, if the final character in the node
15292                              * folds to multiple, it can't be simple.  (This
15293                              * only has an effect if the node has only a single
15294                              * character, hence the final one, as elsewhere we
15295                              * turn off simple for nodes whose length > 1 */
15296                             maybe_SIMPLE = 0;
15297                         }
15298                     }
15299                     else if (node_type == EXACTF) {  /* Means is /di */
15300
15301                         /* This intermediate variable is needed solely because
15302                          * the asserts in the macro where used exceed Win32's
15303                          * literal string capacity */
15304                         char first_char = * STRING(REGNODE_p(ret));
15305
15306                         /* If 'maybe_exactfu' is clear, then we need to stay
15307                          * /di.  If it is set, it means there are no code
15308                          * points that match differently depending on UTF8ness
15309                          * of the target string, so it can become an EXACTFU
15310                          * node */
15311                         if (! maybe_exactfu) {
15312                             RExC_seen_d_op = TRUE;
15313                         }
15314                         else if (   isALPHA_FOLD_EQ(first_char, 's')
15315                                  || isALPHA_FOLD_EQ(ender, 's'))
15316                         {
15317                             /* But, if the node begins or ends in an 's' we
15318                              * have to defer changing it into an EXACTFU, as
15319                              * the node could later get joined with another one
15320                              * that ends or begins with 's' creating an 'ss'
15321                              * sequence which would then wrongly match the
15322                              * sharp s without the target being UTF-8.  We
15323                              * create a special node that we resolve later when
15324                              * we join nodes together */
15325
15326                             node_type = EXACTFU_S_EDGE;
15327                         }
15328                         else {
15329                             node_type = EXACTFU;
15330                         }
15331                     }
15332
15333                     if (requires_utf8_target && node_type == EXACTFU) {
15334                         node_type = EXACTFU_REQ8;
15335                     }
15336                 }
15337
15338                 OP(REGNODE_p(ret)) = node_type;
15339                 setSTR_LEN(REGNODE_p(ret), len);
15340                 RExC_emit += STR_SZ(len);
15341
15342                 /* If the node isn't a single character, it can't be SIMPLE */
15343                 if (len > (Size_t) ((UTF) ? UTF8SKIP(STRING(REGNODE_p(ret))) : 1)) {
15344                     maybe_SIMPLE = 0;
15345                 }
15346
15347                 *flagp |= HASWIDTH | maybe_SIMPLE;
15348             }
15349
15350             Set_Node_Length(REGNODE_p(ret), p - parse_start - 1);
15351             RExC_parse = p;
15352
15353             {
15354                 /* len is STRLEN which is unsigned, need to copy to signed */
15355                 IV iv = len;
15356                 if (iv < 0)
15357                     vFAIL("Internal disaster");
15358             }
15359
15360         } /* End of label 'defchar:' */
15361         break;
15362     } /* End of giant switch on input character */
15363
15364     /* Position parse to next real character */
15365     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15366                                             FALSE /* Don't force to /x */ );
15367     if (   *RExC_parse == '{'
15368         && OP(REGNODE_p(ret)) != SBOL && ! regcurly(RExC_parse))
15369     {
15370         if (RExC_strict || new_regcurly(RExC_parse, RExC_end)) {
15371             RExC_parse++;
15372             vFAIL("Unescaped left brace in regex is illegal here");
15373         }
15374         ckWARNreg(RExC_parse + 1, "Unescaped left brace in regex is"
15375                                   " passed through");
15376     }
15377
15378     return(ret);
15379 }
15380
15381
15382 STATIC void
15383 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
15384 {
15385     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
15386      * sets up the bitmap and any flags, removing those code points from the
15387      * inversion list, setting it to NULL should it become completely empty */
15388
15389
15390     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
15391     assert(PL_regkind[OP(node)] == ANYOF);
15392
15393     /* There is no bitmap for this node type */
15394     if (inRANGE(OP(node), ANYOFH, ANYOFRb)) {
15395         return;
15396     }
15397
15398     ANYOF_BITMAP_ZERO(node);
15399     if (*invlist_ptr) {
15400
15401         /* This gets set if we actually need to modify things */
15402         bool change_invlist = FALSE;
15403
15404         UV start, end;
15405
15406         /* Start looking through *invlist_ptr */
15407         invlist_iterinit(*invlist_ptr);
15408         while (invlist_iternext(*invlist_ptr, &start, &end)) {
15409             UV high;
15410             int i;
15411
15412             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
15413                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
15414             }
15415
15416             /* Quit if are above what we should change */
15417             if (start >= NUM_ANYOF_CODE_POINTS) {
15418                 break;
15419             }
15420
15421             change_invlist = TRUE;
15422
15423             /* Set all the bits in the range, up to the max that we are doing */
15424             high = (end < NUM_ANYOF_CODE_POINTS - 1)
15425                    ? end
15426                    : NUM_ANYOF_CODE_POINTS - 1;
15427             for (i = start; i <= (int) high; i++) {
15428                 ANYOF_BITMAP_SET(node, i);
15429             }
15430         }
15431         invlist_iterfinish(*invlist_ptr);
15432
15433         /* Done with loop; remove any code points that are in the bitmap from
15434          * *invlist_ptr; similarly for code points above the bitmap if we have
15435          * a flag to match all of them anyways */
15436         if (change_invlist) {
15437             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
15438         }
15439         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
15440             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
15441         }
15442
15443         /* If have completely emptied it, remove it completely */
15444         if (_invlist_len(*invlist_ptr) == 0) {
15445             SvREFCNT_dec_NN(*invlist_ptr);
15446             *invlist_ptr = NULL;
15447         }
15448     }
15449 }
15450
15451 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
15452    Character classes ([:foo:]) can also be negated ([:^foo:]).
15453    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
15454    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
15455    but trigger failures because they are currently unimplemented. */
15456
15457 #define POSIXCC_DONE(c)   ((c) == ':')
15458 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
15459 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
15460 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
15461
15462 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
15463 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
15464 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
15465
15466 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
15467
15468 /* 'posix_warnings' and 'warn_text' are names of variables in the following
15469  * routine. q.v. */
15470 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
15471         if (posix_warnings) {                                               \
15472             if (! RExC_warn_text ) RExC_warn_text =                         \
15473                                          (AV *) sv_2mortal((SV *) newAV()); \
15474             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                     \
15475                                              WARNING_PREFIX                 \
15476                                              text                           \
15477                                              REPORT_LOCATION,               \
15478                                              REPORT_LOCATION_ARGS(p)));     \
15479         }                                                                   \
15480     } STMT_END
15481 #define CLEAR_POSIX_WARNINGS()                                              \
15482     STMT_START {                                                            \
15483         if (posix_warnings && RExC_warn_text)                               \
15484             av_clear(RExC_warn_text);                                       \
15485     } STMT_END
15486
15487 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
15488     STMT_START {                                                            \
15489         CLEAR_POSIX_WARNINGS();                                             \
15490         return ret;                                                         \
15491     } STMT_END
15492
15493 STATIC int
15494 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
15495
15496     const char * const s,      /* Where the putative posix class begins.
15497                                   Normally, this is one past the '['.  This
15498                                   parameter exists so it can be somewhere
15499                                   besides RExC_parse. */
15500     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
15501                                   NULL */
15502     AV ** posix_warnings,      /* Where to place any generated warnings, or
15503                                   NULL */
15504     const bool check_only      /* Don't die if error */
15505 )
15506 {
15507     /* This parses what the caller thinks may be one of the three POSIX
15508      * constructs:
15509      *  1) a character class, like [:blank:]
15510      *  2) a collating symbol, like [. .]
15511      *  3) an equivalence class, like [= =]
15512      * In the latter two cases, it croaks if it finds a syntactically legal
15513      * one, as these are not handled by Perl.
15514      *
15515      * The main purpose is to look for a POSIX character class.  It returns:
15516      *  a) the class number
15517      *      if it is a completely syntactically and semantically legal class.
15518      *      'updated_parse_ptr', if not NULL, is set to point to just after the
15519      *      closing ']' of the class
15520      *  b) OOB_NAMEDCLASS
15521      *      if it appears that one of the three POSIX constructs was meant, but
15522      *      its specification was somehow defective.  'updated_parse_ptr', if
15523      *      not NULL, is set to point to the character just after the end
15524      *      character of the class.  See below for handling of warnings.
15525      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
15526      *      if it  doesn't appear that a POSIX construct was intended.
15527      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
15528      *      raised.
15529      *
15530      * In b) there may be errors or warnings generated.  If 'check_only' is
15531      * TRUE, then any errors are discarded.  Warnings are returned to the
15532      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
15533      * instead it is NULL, warnings are suppressed.
15534      *
15535      * The reason for this function, and its complexity is that a bracketed
15536      * character class can contain just about anything.  But it's easy to
15537      * mistype the very specific posix class syntax but yielding a valid
15538      * regular bracketed class, so it silently gets compiled into something
15539      * quite unintended.
15540      *
15541      * The solution adopted here maintains backward compatibility except that
15542      * it adds a warning if it looks like a posix class was intended but
15543      * improperly specified.  The warning is not raised unless what is input
15544      * very closely resembles one of the 14 legal posix classes.  To do this,
15545      * it uses fuzzy parsing.  It calculates how many single-character edits it
15546      * would take to transform what was input into a legal posix class.  Only
15547      * if that number is quite small does it think that the intention was a
15548      * posix class.  Obviously these are heuristics, and there will be cases
15549      * where it errs on one side or another, and they can be tweaked as
15550      * experience informs.
15551      *
15552      * The syntax for a legal posix class is:
15553      *
15554      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
15555      *
15556      * What this routine considers syntactically to be an intended posix class
15557      * is this (the comments indicate some restrictions that the pattern
15558      * doesn't show):
15559      *
15560      *  qr/(?x: \[?                         # The left bracket, possibly
15561      *                                      # omitted
15562      *          \h*                         # possibly followed by blanks
15563      *          (?: \^ \h* )?               # possibly a misplaced caret
15564      *          [:;]?                       # The opening class character,
15565      *                                      # possibly omitted.  A typo
15566      *                                      # semi-colon can also be used.
15567      *          \h*
15568      *          \^?                         # possibly a correctly placed
15569      *                                      # caret, but not if there was also
15570      *                                      # a misplaced one
15571      *          \h*
15572      *          .{3,15}                     # The class name.  If there are
15573      *                                      # deviations from the legal syntax,
15574      *                                      # its edit distance must be close
15575      *                                      # to a real class name in order
15576      *                                      # for it to be considered to be
15577      *                                      # an intended posix class.
15578      *          \h*
15579      *          [[:punct:]]?                # The closing class character,
15580      *                                      # possibly omitted.  If not a colon
15581      *                                      # nor semi colon, the class name
15582      *                                      # must be even closer to a valid
15583      *                                      # one
15584      *          \h*
15585      *          \]?                         # The right bracket, possibly
15586      *                                      # omitted.
15587      *     )/
15588      *
15589      * In the above, \h must be ASCII-only.
15590      *
15591      * These are heuristics, and can be tweaked as field experience dictates.
15592      * There will be cases when someone didn't intend to specify a posix class
15593      * that this warns as being so.  The goal is to minimize these, while
15594      * maximizing the catching of things intended to be a posix class that
15595      * aren't parsed as such.
15596      */
15597
15598     const char* p             = s;
15599     const char * const e      = RExC_end;
15600     unsigned complement       = 0;      /* If to complement the class */
15601     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
15602     bool has_opening_bracket  = FALSE;
15603     bool has_opening_colon    = FALSE;
15604     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
15605                                                    valid class */
15606     const char * possible_end = NULL;   /* used for a 2nd parse pass */
15607     const char* name_start;             /* ptr to class name first char */
15608
15609     /* If the number of single-character typos the input name is away from a
15610      * legal name is no more than this number, it is considered to have meant
15611      * the legal name */
15612     int max_distance          = 2;
15613
15614     /* to store the name.  The size determines the maximum length before we
15615      * decide that no posix class was intended.  Should be at least
15616      * sizeof("alphanumeric") */
15617     UV input_text[15];
15618     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
15619
15620     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
15621
15622     CLEAR_POSIX_WARNINGS();
15623
15624     if (p >= e) {
15625         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
15626     }
15627
15628     if (*(p - 1) != '[') {
15629         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
15630         found_problem = TRUE;
15631     }
15632     else {
15633         has_opening_bracket = TRUE;
15634     }
15635
15636     /* They could be confused and think you can put spaces between the
15637      * components */
15638     if (isBLANK(*p)) {
15639         found_problem = TRUE;
15640
15641         do {
15642             p++;
15643         } while (p < e && isBLANK(*p));
15644
15645         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15646     }
15647
15648     /* For [. .] and [= =].  These are quite different internally from [: :],
15649      * so they are handled separately.  */
15650     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
15651                                             and 1 for at least one char in it
15652                                           */
15653     {
15654         const char open_char  = *p;
15655         const char * temp_ptr = p + 1;
15656
15657         /* These two constructs are not handled by perl, and if we find a
15658          * syntactically valid one, we croak.  khw, who wrote this code, finds
15659          * this explanation of them very unclear:
15660          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
15661          * And searching the rest of the internet wasn't very helpful either.
15662          * It looks like just about any byte can be in these constructs,
15663          * depending on the locale.  But unless the pattern is being compiled
15664          * under /l, which is very rare, Perl runs under the C or POSIX locale.
15665          * In that case, it looks like [= =] isn't allowed at all, and that
15666          * [. .] could be any single code point, but for longer strings the
15667          * constituent characters would have to be the ASCII alphabetics plus
15668          * the minus-hyphen.  Any sensible locale definition would limit itself
15669          * to these.  And any portable one definitely should.  Trying to parse
15670          * the general case is a nightmare (see [perl #127604]).  So, this code
15671          * looks only for interiors of these constructs that match:
15672          *      qr/.|[-\w]{2,}/
15673          * Using \w relaxes the apparent rules a little, without adding much
15674          * danger of mistaking something else for one of these constructs.
15675          *
15676          * [. .] in some implementations described on the internet is usable to
15677          * escape a character that otherwise is special in bracketed character
15678          * classes.  For example [.].] means a literal right bracket instead of
15679          * the ending of the class
15680          *
15681          * [= =] can legitimately contain a [. .] construct, but we don't
15682          * handle this case, as that [. .] construct will later get parsed
15683          * itself and croak then.  And [= =] is checked for even when not under
15684          * /l, as Perl has long done so.
15685          *
15686          * The code below relies on there being a trailing NUL, so it doesn't
15687          * have to keep checking if the parse ptr < e.
15688          */
15689         if (temp_ptr[1] == open_char) {
15690             temp_ptr++;
15691         }
15692         else while (    temp_ptr < e
15693                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
15694         {
15695             temp_ptr++;
15696         }
15697
15698         if (*temp_ptr == open_char) {
15699             temp_ptr++;
15700             if (*temp_ptr == ']') {
15701                 temp_ptr++;
15702                 if (! found_problem && ! check_only) {
15703                     RExC_parse = (char *) temp_ptr;
15704                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
15705                             "extensions", open_char, open_char);
15706                 }
15707
15708                 /* Here, the syntax wasn't completely valid, or else the call
15709                  * is to check-only */
15710                 if (updated_parse_ptr) {
15711                     *updated_parse_ptr = (char *) temp_ptr;
15712                 }
15713
15714                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
15715             }
15716         }
15717
15718         /* If we find something that started out to look like one of these
15719          * constructs, but isn't, we continue below so that it can be checked
15720          * for being a class name with a typo of '.' or '=' instead of a colon.
15721          * */
15722     }
15723
15724     /* Here, we think there is a possibility that a [: :] class was meant, and
15725      * we have the first real character.  It could be they think the '^' comes
15726      * first */
15727     if (*p == '^') {
15728         found_problem = TRUE;
15729         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
15730         complement = 1;
15731         p++;
15732
15733         if (isBLANK(*p)) {
15734             found_problem = TRUE;
15735
15736             do {
15737                 p++;
15738             } while (p < e && isBLANK(*p));
15739
15740             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15741         }
15742     }
15743
15744     /* But the first character should be a colon, which they could have easily
15745      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
15746      * distinguish from a colon, so treat that as a colon).  */
15747     if (*p == ':') {
15748         p++;
15749         has_opening_colon = TRUE;
15750     }
15751     else if (*p == ';') {
15752         found_problem = TRUE;
15753         p++;
15754         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15755         has_opening_colon = TRUE;
15756     }
15757     else {
15758         found_problem = TRUE;
15759         ADD_POSIX_WARNING(p, "there must be a starting ':'");
15760
15761         /* Consider an initial punctuation (not one of the recognized ones) to
15762          * be a left terminator */
15763         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
15764             p++;
15765         }
15766     }
15767
15768     /* They may think that you can put spaces between the components */
15769     if (isBLANK(*p)) {
15770         found_problem = TRUE;
15771
15772         do {
15773             p++;
15774         } while (p < e && isBLANK(*p));
15775
15776         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15777     }
15778
15779     if (*p == '^') {
15780
15781         /* We consider something like [^:^alnum:]] to not have been intended to
15782          * be a posix class, but XXX maybe we should */
15783         if (complement) {
15784             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15785         }
15786
15787         complement = 1;
15788         p++;
15789     }
15790
15791     /* Again, they may think that you can put spaces between the components */
15792     if (isBLANK(*p)) {
15793         found_problem = TRUE;
15794
15795         do {
15796             p++;
15797         } while (p < e && isBLANK(*p));
15798
15799         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15800     }
15801
15802     if (*p == ']') {
15803
15804         /* XXX This ']' may be a typo, and something else was meant.  But
15805          * treating it as such creates enough complications, that that
15806          * possibility isn't currently considered here.  So we assume that the
15807          * ']' is what is intended, and if we've already found an initial '[',
15808          * this leaves this construct looking like [:] or [:^], which almost
15809          * certainly weren't intended to be posix classes */
15810         if (has_opening_bracket) {
15811             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15812         }
15813
15814         /* But this function can be called when we parse the colon for
15815          * something like qr/[alpha:]]/, so we back up to look for the
15816          * beginning */
15817         p--;
15818
15819         if (*p == ';') {
15820             found_problem = TRUE;
15821             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15822         }
15823         else if (*p != ':') {
15824
15825             /* XXX We are currently very restrictive here, so this code doesn't
15826              * consider the possibility that, say, /[alpha.]]/ was intended to
15827              * be a posix class. */
15828             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15829         }
15830
15831         /* Here we have something like 'foo:]'.  There was no initial colon,
15832          * and we back up over 'foo.  XXX Unlike the going forward case, we
15833          * don't handle typos of non-word chars in the middle */
15834         has_opening_colon = FALSE;
15835         p--;
15836
15837         while (p > RExC_start && isWORDCHAR(*p)) {
15838             p--;
15839         }
15840         p++;
15841
15842         /* Here, we have positioned ourselves to where we think the first
15843          * character in the potential class is */
15844     }
15845
15846     /* Now the interior really starts.  There are certain key characters that
15847      * can end the interior, or these could just be typos.  To catch both
15848      * cases, we may have to do two passes.  In the first pass, we keep on
15849      * going unless we come to a sequence that matches
15850      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
15851      * This means it takes a sequence to end the pass, so two typos in a row if
15852      * that wasn't what was intended.  If the class is perfectly formed, just
15853      * this one pass is needed.  We also stop if there are too many characters
15854      * being accumulated, but this number is deliberately set higher than any
15855      * real class.  It is set high enough so that someone who thinks that
15856      * 'alphanumeric' is a correct name would get warned that it wasn't.
15857      * While doing the pass, we keep track of where the key characters were in
15858      * it.  If we don't find an end to the class, and one of the key characters
15859      * was found, we redo the pass, but stop when we get to that character.
15860      * Thus the key character was considered a typo in the first pass, but a
15861      * terminator in the second.  If two key characters are found, we stop at
15862      * the second one in the first pass.  Again this can miss two typos, but
15863      * catches a single one
15864      *
15865      * In the first pass, 'possible_end' starts as NULL, and then gets set to
15866      * point to the first key character.  For the second pass, it starts as -1.
15867      * */
15868
15869     name_start = p;
15870   parse_name:
15871     {
15872         bool has_blank               = FALSE;
15873         bool has_upper               = FALSE;
15874         bool has_terminating_colon   = FALSE;
15875         bool has_terminating_bracket = FALSE;
15876         bool has_semi_colon          = FALSE;
15877         unsigned int name_len        = 0;
15878         int punct_count              = 0;
15879
15880         while (p < e) {
15881
15882             /* Squeeze out blanks when looking up the class name below */
15883             if (isBLANK(*p) ) {
15884                 has_blank = TRUE;
15885                 found_problem = TRUE;
15886                 p++;
15887                 continue;
15888             }
15889
15890             /* The name will end with a punctuation */
15891             if (isPUNCT(*p)) {
15892                 const char * peek = p + 1;
15893
15894                 /* Treat any non-']' punctuation followed by a ']' (possibly
15895                  * with intervening blanks) as trying to terminate the class.
15896                  * ']]' is very likely to mean a class was intended (but
15897                  * missing the colon), but the warning message that gets
15898                  * generated shows the error position better if we exit the
15899                  * loop at the bottom (eventually), so skip it here. */
15900                 if (*p != ']') {
15901                     if (peek < e && isBLANK(*peek)) {
15902                         has_blank = TRUE;
15903                         found_problem = TRUE;
15904                         do {
15905                             peek++;
15906                         } while (peek < e && isBLANK(*peek));
15907                     }
15908
15909                     if (peek < e && *peek == ']') {
15910                         has_terminating_bracket = TRUE;
15911                         if (*p == ':') {
15912                             has_terminating_colon = TRUE;
15913                         }
15914                         else if (*p == ';') {
15915                             has_semi_colon = TRUE;
15916                             has_terminating_colon = TRUE;
15917                         }
15918                         else {
15919                             found_problem = TRUE;
15920                         }
15921                         p = peek + 1;
15922                         goto try_posix;
15923                     }
15924                 }
15925
15926                 /* Here we have punctuation we thought didn't end the class.
15927                  * Keep track of the position of the key characters that are
15928                  * more likely to have been class-enders */
15929                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
15930
15931                     /* Allow just one such possible class-ender not actually
15932                      * ending the class. */
15933                     if (possible_end) {
15934                         break;
15935                     }
15936                     possible_end = p;
15937                 }
15938
15939                 /* If we have too many punctuation characters, no use in
15940                  * keeping going */
15941                 if (++punct_count > max_distance) {
15942                     break;
15943                 }
15944
15945                 /* Treat the punctuation as a typo. */
15946                 input_text[name_len++] = *p;
15947                 p++;
15948             }
15949             else if (isUPPER(*p)) { /* Use lowercase for lookup */
15950                 input_text[name_len++] = toLOWER(*p);
15951                 has_upper = TRUE;
15952                 found_problem = TRUE;
15953                 p++;
15954             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
15955                 input_text[name_len++] = *p;
15956                 p++;
15957             }
15958             else {
15959                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
15960                 p+= UTF8SKIP(p);
15961             }
15962
15963             /* The declaration of 'input_text' is how long we allow a potential
15964              * class name to be, before saying they didn't mean a class name at
15965              * all */
15966             if (name_len >= C_ARRAY_LENGTH(input_text)) {
15967                 break;
15968             }
15969         }
15970
15971         /* We get to here when the possible class name hasn't been properly
15972          * terminated before:
15973          *   1) we ran off the end of the pattern; or
15974          *   2) found two characters, each of which might have been intended to
15975          *      be the name's terminator
15976          *   3) found so many punctuation characters in the purported name,
15977          *      that the edit distance to a valid one is exceeded
15978          *   4) we decided it was more characters than anyone could have
15979          *      intended to be one. */
15980
15981         found_problem = TRUE;
15982
15983         /* In the final two cases, we know that looking up what we've
15984          * accumulated won't lead to a match, even a fuzzy one. */
15985         if (   name_len >= C_ARRAY_LENGTH(input_text)
15986             || punct_count > max_distance)
15987         {
15988             /* If there was an intermediate key character that could have been
15989              * an intended end, redo the parse, but stop there */
15990             if (possible_end && possible_end != (char *) -1) {
15991                 possible_end = (char *) -1; /* Special signal value to say
15992                                                we've done a first pass */
15993                 p = name_start;
15994                 goto parse_name;
15995             }
15996
15997             /* Otherwise, it can't have meant to have been a class */
15998             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15999         }
16000
16001         /* If we ran off the end, and the final character was a punctuation
16002          * one, back up one, to look at that final one just below.  Later, we
16003          * will restore the parse pointer if appropriate */
16004         if (name_len && p == e && isPUNCT(*(p-1))) {
16005             p--;
16006             name_len--;
16007         }
16008
16009         if (p < e && isPUNCT(*p)) {
16010             if (*p == ']') {
16011                 has_terminating_bracket = TRUE;
16012
16013                 /* If this is a 2nd ']', and the first one is just below this
16014                  * one, consider that to be the real terminator.  This gives a
16015                  * uniform and better positioning for the warning message  */
16016                 if (   possible_end
16017                     && possible_end != (char *) -1
16018                     && *possible_end == ']'
16019                     && name_len && input_text[name_len - 1] == ']')
16020                 {
16021                     name_len--;
16022                     p = possible_end;
16023
16024                     /* And this is actually equivalent to having done the 2nd
16025                      * pass now, so set it to not try again */
16026                     possible_end = (char *) -1;
16027                 }
16028             }
16029             else {
16030                 if (*p == ':') {
16031                     has_terminating_colon = TRUE;
16032                 }
16033                 else if (*p == ';') {
16034                     has_semi_colon = TRUE;
16035                     has_terminating_colon = TRUE;
16036                 }
16037                 p++;
16038             }
16039         }
16040
16041     try_posix:
16042
16043         /* Here, we have a class name to look up.  We can short circuit the
16044          * stuff below for short names that can't possibly be meant to be a
16045          * class name.  (We can do this on the first pass, as any second pass
16046          * will yield an even shorter name) */
16047         if (name_len < 3) {
16048             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
16049         }
16050
16051         /* Find which class it is.  Initially switch on the length of the name.
16052          * */
16053         switch (name_len) {
16054             case 4:
16055                 if (memEQs(name_start, 4, "word")) {
16056                     /* this is not POSIX, this is the Perl \w */
16057                     class_number = ANYOF_WORDCHAR;
16058                 }
16059                 break;
16060             case 5:
16061                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
16062                  *                        graph lower print punct space upper
16063                  * Offset 4 gives the best switch position.  */
16064                 switch (name_start[4]) {
16065                     case 'a':
16066                         if (memBEGINs(name_start, 5, "alph")) /* alpha */
16067                             class_number = ANYOF_ALPHA;
16068                         break;
16069                     case 'e':
16070                         if (memBEGINs(name_start, 5, "spac")) /* space */
16071                             class_number = ANYOF_SPACE;
16072                         break;
16073                     case 'h':
16074                         if (memBEGINs(name_start, 5, "grap")) /* graph */
16075                             class_number = ANYOF_GRAPH;
16076                         break;
16077                     case 'i':
16078                         if (memBEGINs(name_start, 5, "asci")) /* ascii */
16079                             class_number = ANYOF_ASCII;
16080                         break;
16081                     case 'k':
16082                         if (memBEGINs(name_start, 5, "blan")) /* blank */
16083                             class_number = ANYOF_BLANK;
16084                         break;
16085                     case 'l':
16086                         if (memBEGINs(name_start, 5, "cntr")) /* cntrl */
16087                             class_number = ANYOF_CNTRL;
16088                         break;
16089                     case 'm':
16090                         if (memBEGINs(name_start, 5, "alnu")) /* alnum */
16091                             class_number = ANYOF_ALPHANUMERIC;
16092                         break;
16093                     case 'r':
16094                         if (memBEGINs(name_start, 5, "lowe")) /* lower */
16095                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
16096                         else if (memBEGINs(name_start, 5, "uppe")) /* upper */
16097                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
16098                         break;
16099                     case 't':
16100                         if (memBEGINs(name_start, 5, "digi")) /* digit */
16101                             class_number = ANYOF_DIGIT;
16102                         else if (memBEGINs(name_start, 5, "prin")) /* print */
16103                             class_number = ANYOF_PRINT;
16104                         else if (memBEGINs(name_start, 5, "punc")) /* punct */
16105                             class_number = ANYOF_PUNCT;
16106                         break;
16107                 }
16108                 break;
16109             case 6:
16110                 if (memEQs(name_start, 6, "xdigit"))
16111                     class_number = ANYOF_XDIGIT;
16112                 break;
16113         }
16114
16115         /* If the name exactly matches a posix class name the class number will
16116          * here be set to it, and the input almost certainly was meant to be a
16117          * posix class, so we can skip further checking.  If instead the syntax
16118          * is exactly correct, but the name isn't one of the legal ones, we
16119          * will return that as an error below.  But if neither of these apply,
16120          * it could be that no posix class was intended at all, or that one
16121          * was, but there was a typo.  We tease these apart by doing fuzzy
16122          * matching on the name */
16123         if (class_number == OOB_NAMEDCLASS && found_problem) {
16124             const UV posix_names[][6] = {
16125                                                 { 'a', 'l', 'n', 'u', 'm' },
16126                                                 { 'a', 'l', 'p', 'h', 'a' },
16127                                                 { 'a', 's', 'c', 'i', 'i' },
16128                                                 { 'b', 'l', 'a', 'n', 'k' },
16129                                                 { 'c', 'n', 't', 'r', 'l' },
16130                                                 { 'd', 'i', 'g', 'i', 't' },
16131                                                 { 'g', 'r', 'a', 'p', 'h' },
16132                                                 { 'l', 'o', 'w', 'e', 'r' },
16133                                                 { 'p', 'r', 'i', 'n', 't' },
16134                                                 { 'p', 'u', 'n', 'c', 't' },
16135                                                 { 's', 'p', 'a', 'c', 'e' },
16136                                                 { 'u', 'p', 'p', 'e', 'r' },
16137                                                 { 'w', 'o', 'r', 'd' },
16138                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
16139                                             };
16140             /* The names of the above all have added NULs to make them the same
16141              * size, so we need to also have the real lengths */
16142             const UV posix_name_lengths[] = {
16143                                                 sizeof("alnum") - 1,
16144                                                 sizeof("alpha") - 1,
16145                                                 sizeof("ascii") - 1,
16146                                                 sizeof("blank") - 1,
16147                                                 sizeof("cntrl") - 1,
16148                                                 sizeof("digit") - 1,
16149                                                 sizeof("graph") - 1,
16150                                                 sizeof("lower") - 1,
16151                                                 sizeof("print") - 1,
16152                                                 sizeof("punct") - 1,
16153                                                 sizeof("space") - 1,
16154                                                 sizeof("upper") - 1,
16155                                                 sizeof("word")  - 1,
16156                                                 sizeof("xdigit")- 1
16157                                             };
16158             unsigned int i;
16159             int temp_max = max_distance;    /* Use a temporary, so if we
16160                                                reparse, we haven't changed the
16161                                                outer one */
16162
16163             /* Use a smaller max edit distance if we are missing one of the
16164              * delimiters */
16165             if (   has_opening_bracket + has_opening_colon < 2
16166                 || has_terminating_bracket + has_terminating_colon < 2)
16167             {
16168                 temp_max--;
16169             }
16170
16171             /* See if the input name is close to a legal one */
16172             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
16173
16174                 /* Short circuit call if the lengths are too far apart to be
16175                  * able to match */
16176                 if (abs( (int) (name_len - posix_name_lengths[i]))
16177                     > temp_max)
16178                 {
16179                     continue;
16180                 }
16181
16182                 if (edit_distance(input_text,
16183                                   posix_names[i],
16184                                   name_len,
16185                                   posix_name_lengths[i],
16186                                   temp_max
16187                                  )
16188                     > -1)
16189                 { /* If it is close, it probably was intended to be a class */
16190                     goto probably_meant_to_be;
16191                 }
16192             }
16193
16194             /* Here the input name is not close enough to a valid class name
16195              * for us to consider it to be intended to be a posix class.  If
16196              * we haven't already done so, and the parse found a character that
16197              * could have been terminators for the name, but which we absorbed
16198              * as typos during the first pass, repeat the parse, signalling it
16199              * to stop at that character */
16200             if (possible_end && possible_end != (char *) -1) {
16201                 possible_end = (char *) -1;
16202                 p = name_start;
16203                 goto parse_name;
16204             }
16205
16206             /* Here neither pass found a close-enough class name */
16207             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
16208         }
16209
16210     probably_meant_to_be:
16211
16212         /* Here we think that a posix specification was intended.  Update any
16213          * parse pointer */
16214         if (updated_parse_ptr) {
16215             *updated_parse_ptr = (char *) p;
16216         }
16217
16218         /* If a posix class name was intended but incorrectly specified, we
16219          * output or return the warnings */
16220         if (found_problem) {
16221
16222             /* We set flags for these issues in the parse loop above instead of
16223              * adding them to the list of warnings, because we can parse it
16224              * twice, and we only want one warning instance */
16225             if (has_upper) {
16226                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
16227             }
16228             if (has_blank) {
16229                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
16230             }
16231             if (has_semi_colon) {
16232                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
16233             }
16234             else if (! has_terminating_colon) {
16235                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
16236             }
16237             if (! has_terminating_bracket) {
16238                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
16239             }
16240
16241             if (   posix_warnings
16242                 && RExC_warn_text
16243                 && av_count(RExC_warn_text) > 0)
16244             {
16245                 *posix_warnings = RExC_warn_text;
16246             }
16247         }
16248         else if (class_number != OOB_NAMEDCLASS) {
16249             /* If it is a known class, return the class.  The class number
16250              * #defines are structured so each complement is +1 to the normal
16251              * one */
16252             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
16253         }
16254         else if (! check_only) {
16255
16256             /* Here, it is an unrecognized class.  This is an error (unless the
16257             * call is to check only, which we've already handled above) */
16258             const char * const complement_string = (complement)
16259                                                    ? "^"
16260                                                    : "";
16261             RExC_parse = (char *) p;
16262             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
16263                         complement_string,
16264                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
16265         }
16266     }
16267
16268     return OOB_NAMEDCLASS;
16269 }
16270 #undef ADD_POSIX_WARNING
16271
16272 STATIC unsigned  int
16273 S_regex_set_precedence(const U8 my_operator) {
16274
16275     /* Returns the precedence in the (?[...]) construct of the input operator,
16276      * specified by its character representation.  The precedence follows
16277      * general Perl rules, but it extends this so that ')' and ']' have (low)
16278      * precedence even though they aren't really operators */
16279
16280     switch (my_operator) {
16281         case '!':
16282             return 5;
16283         case '&':
16284             return 4;
16285         case '^':
16286         case '|':
16287         case '+':
16288         case '-':
16289             return 3;
16290         case ')':
16291             return 2;
16292         case ']':
16293             return 1;
16294     }
16295
16296     NOT_REACHED; /* NOTREACHED */
16297     return 0;   /* Silence compiler warning */
16298 }
16299
16300 STATIC regnode_offset
16301 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
16302                     I32 *flagp, U32 depth,
16303                     char * const oregcomp_parse)
16304 {
16305     /* Handle the (?[...]) construct to do set operations */
16306
16307     U8 curchar;                     /* Current character being parsed */
16308     UV start, end;                  /* End points of code point ranges */
16309     SV* final = NULL;               /* The end result inversion list */
16310     SV* result_string;              /* 'final' stringified */
16311     AV* stack;                      /* stack of operators and operands not yet
16312                                        resolved */
16313     AV* fence_stack = NULL;         /* A stack containing the positions in
16314                                        'stack' of where the undealt-with left
16315                                        parens would be if they were actually
16316                                        put there */
16317     /* The 'volatile' is a workaround for an optimiser bug
16318      * in Solaris Studio 12.3. See RT #127455 */
16319     volatile IV fence = 0;          /* Position of where most recent undealt-
16320                                        with left paren in stack is; -1 if none.
16321                                      */
16322     STRLEN len;                     /* Temporary */
16323     regnode_offset node;            /* Temporary, and final regnode returned by
16324                                        this function */
16325     const bool save_fold = FOLD;    /* Temporary */
16326     char *save_end, *save_parse;    /* Temporaries */
16327     const bool in_locale = LOC;     /* we turn off /l during processing */
16328
16329     DECLARE_AND_GET_RE_DEBUG_FLAGS;
16330
16331     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
16332     PERL_UNUSED_ARG(oregcomp_parse); /* Only for Set_Node_Length */
16333
16334     DEBUG_PARSE("xcls");
16335
16336     if (in_locale) {
16337         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
16338     }
16339
16340     /* The use of this operator implies /u.  This is required so that the
16341      * compile time values are valid in all runtime cases */
16342     REQUIRE_UNI_RULES(flagp, 0);
16343
16344     ckWARNexperimental(RExC_parse,
16345                        WARN_EXPERIMENTAL__REGEX_SETS,
16346                        "The regex_sets feature is experimental");
16347
16348     /* Everything in this construct is a metacharacter.  Operands begin with
16349      * either a '\' (for an escape sequence), or a '[' for a bracketed
16350      * character class.  Any other character should be an operator, or
16351      * parenthesis for grouping.  Both types of operands are handled by calling
16352      * regclass() to parse them.  It is called with a parameter to indicate to
16353      * return the computed inversion list.  The parsing here is implemented via
16354      * a stack.  Each entry on the stack is a single character representing one
16355      * of the operators; or else a pointer to an operand inversion list. */
16356
16357 #define IS_OPERATOR(a) SvIOK(a)
16358 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
16359
16360     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
16361      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
16362      * with pronouncing it called it Reverse Polish instead, but now that YOU
16363      * know how to pronounce it you can use the correct term, thus giving due
16364      * credit to the person who invented it, and impressing your geek friends.
16365      * Wikipedia says that the pronounciation of "Ł" has been changing so that
16366      * it is now more like an English initial W (as in wonk) than an L.)
16367      *
16368      * This means that, for example, 'a | b & c' is stored on the stack as
16369      *
16370      * c  [4]
16371      * b  [3]
16372      * &  [2]
16373      * a  [1]
16374      * |  [0]
16375      *
16376      * where the numbers in brackets give the stack [array] element number.
16377      * In this implementation, parentheses are not stored on the stack.
16378      * Instead a '(' creates a "fence" so that the part of the stack below the
16379      * fence is invisible except to the corresponding ')' (this allows us to
16380      * replace testing for parens, by using instead subtraction of the fence
16381      * position).  As new operands are processed they are pushed onto the stack
16382      * (except as noted in the next paragraph).  New operators of higher
16383      * precedence than the current final one are inserted on the stack before
16384      * the lhs operand (so that when the rhs is pushed next, everything will be
16385      * in the correct positions shown above.  When an operator of equal or
16386      * lower precedence is encountered in parsing, all the stacked operations
16387      * of equal or higher precedence are evaluated, leaving the result as the
16388      * top entry on the stack.  This makes higher precedence operations
16389      * evaluate before lower precedence ones, and causes operations of equal
16390      * precedence to left associate.
16391      *
16392      * The only unary operator '!' is immediately pushed onto the stack when
16393      * encountered.  When an operand is encountered, if the top of the stack is
16394      * a '!", the complement is immediately performed, and the '!' popped.  The
16395      * resulting value is treated as a new operand, and the logic in the
16396      * previous paragraph is executed.  Thus in the expression
16397      *      [a] + ! [b]
16398      * the stack looks like
16399      *
16400      * !
16401      * a
16402      * +
16403      *
16404      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
16405      * becomes
16406      *
16407      * !b
16408      * a
16409      * +
16410      *
16411      * A ')' is treated as an operator with lower precedence than all the
16412      * aforementioned ones, which causes all operations on the stack above the
16413      * corresponding '(' to be evaluated down to a single resultant operand.
16414      * Then the fence for the '(' is removed, and the operand goes through the
16415      * algorithm above, without the fence.
16416      *
16417      * A separate stack is kept of the fence positions, so that the position of
16418      * the latest so-far unbalanced '(' is at the top of it.
16419      *
16420      * The ']' ending the construct is treated as the lowest operator of all,
16421      * so that everything gets evaluated down to a single operand, which is the
16422      * result */
16423
16424     sv_2mortal((SV *)(stack = newAV()));
16425     sv_2mortal((SV *)(fence_stack = newAV()));
16426
16427     while (RExC_parse < RExC_end) {
16428         I32 top_index;              /* Index of top-most element in 'stack' */
16429         SV** top_ptr;               /* Pointer to top 'stack' element */
16430         SV* current = NULL;         /* To contain the current inversion list
16431                                        operand */
16432         SV* only_to_avoid_leaks;
16433
16434         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
16435                                 TRUE /* Force /x */ );
16436         if (RExC_parse >= RExC_end) {   /* Fail */
16437             break;
16438         }
16439
16440         curchar = UCHARAT(RExC_parse);
16441
16442 redo_curchar:
16443
16444 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16445                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
16446         DEBUG_U(dump_regex_sets_structures(pRExC_state,
16447                                            stack, fence, fence_stack));
16448 #endif
16449
16450         top_index = av_tindex_skip_len_mg(stack);
16451
16452         switch (curchar) {
16453             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
16454             char stacked_operator;  /* The topmost operator on the 'stack'. */
16455             SV* lhs;                /* Operand to the left of the operator */
16456             SV* rhs;                /* Operand to the right of the operator */
16457             SV* fence_ptr;          /* Pointer to top element of the fence
16458                                        stack */
16459             case '(':
16460
16461                 if (   RExC_parse < RExC_end - 2
16462                     && UCHARAT(RExC_parse + 1) == '?'
16463                     && UCHARAT(RExC_parse + 2) == '^')
16464                 {
16465                     const regnode_offset orig_emit = RExC_emit;
16466                     SV * resultant_invlist;
16467
16468                     /* If is a '(?^', could be an embedded '(?^flags:(?[...])'.
16469                      * This happens when we have some thing like
16470                      *
16471                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
16472                      *   ...
16473                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
16474                      *
16475                      * Here we would be handling the interpolated
16476                      * '$thai_or_lao'.  We handle this by a recursive call to
16477                      * reg which returns the inversion list the
16478                      * interpolated expression evaluates to.  Actually, the
16479                      * return is a special regnode containing a pointer to that
16480                      * inversion list.  If the return isn't that regnode alone,
16481                      * we know that this wasn't such an interpolation, which is
16482                      * an error: we need to get a single inversion list back
16483                      * from the recursion */
16484
16485                     RExC_parse++;
16486                     RExC_sets_depth++;
16487
16488                     node = reg(pRExC_state, 2, flagp, depth+1);
16489                     RETURN_FAIL_ON_RESTART(*flagp, flagp);
16490
16491                     if (   OP(REGNODE_p(node)) != REGEX_SET
16492                            /* If more than a single node returned, the nested
16493                             * parens evaluated to more than just a (?[...]),
16494                             * which isn't legal */
16495                         || RExC_emit != orig_emit
16496                                       + NODE_STEP_REGNODE
16497                                       + regarglen[REGEX_SET])
16498                     {
16499                         vFAIL("Expecting interpolated extended charclass");
16500                     }
16501                     resultant_invlist = (SV *) ARGp(REGNODE_p(node));
16502                     current = invlist_clone(resultant_invlist, NULL);
16503                     SvREFCNT_dec(resultant_invlist);
16504
16505                     RExC_sets_depth--;
16506                     RExC_emit = orig_emit;
16507                     goto handle_operand;
16508                 }
16509
16510                 /* A regular '('.  Look behind for illegal syntax */
16511                 if (top_index - fence >= 0) {
16512                     /* If the top entry on the stack is an operator, it had
16513                      * better be a '!', otherwise the entry below the top
16514                      * operand should be an operator */
16515                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
16516                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
16517                         || (   IS_OPERAND(*top_ptr)
16518                             && (   top_index - fence < 1
16519                                 || ! (stacked_ptr = av_fetch(stack,
16520                                                              top_index - 1,
16521                                                              FALSE))
16522                                 || ! IS_OPERATOR(*stacked_ptr))))
16523                     {
16524                         RExC_parse++;
16525                         vFAIL("Unexpected '(' with no preceding operator");
16526                     }
16527                 }
16528
16529                 /* Stack the position of this undealt-with left paren */
16530                 av_push(fence_stack, newSViv(fence));
16531                 fence = top_index + 1;
16532                 break;
16533
16534             case '\\':
16535                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
16536                  * multi-char folds are allowed.  */
16537                 if (!regclass(pRExC_state, flagp, depth+1,
16538                               TRUE, /* means parse just the next thing */
16539                               FALSE, /* don't allow multi-char folds */
16540                               FALSE, /* don't silence non-portable warnings.  */
16541                               TRUE,  /* strict */
16542                               FALSE, /* Require return to be an ANYOF */
16543                               &current))
16544                 {
16545                     RETURN_FAIL_ON_RESTART(*flagp, flagp);
16546                     goto regclass_failed;
16547                 }
16548
16549                 assert(current);
16550
16551                 /* regclass() will return with parsing just the \ sequence,
16552                  * leaving the parse pointer at the next thing to parse */
16553                 RExC_parse--;
16554                 goto handle_operand;
16555
16556             case '[':   /* Is a bracketed character class */
16557             {
16558                 /* See if this is a [:posix:] class. */
16559                 bool is_posix_class = (OOB_NAMEDCLASS
16560                             < handle_possible_posix(pRExC_state,
16561                                                 RExC_parse + 1,
16562                                                 NULL,
16563                                                 NULL,
16564                                                 TRUE /* checking only */));
16565                 /* If it is a posix class, leave the parse pointer at the '['
16566                  * to fool regclass() into thinking it is part of a
16567                  * '[[:posix:]]'. */
16568                 if (! is_posix_class) {
16569                     RExC_parse++;
16570                 }
16571
16572                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
16573                  * multi-char folds are allowed.  */
16574                 if (!regclass(pRExC_state, flagp, depth+1,
16575                                 is_posix_class, /* parse the whole char
16576                                                     class only if not a
16577                                                     posix class */
16578                                 FALSE, /* don't allow multi-char folds */
16579                                 TRUE, /* silence non-portable warnings. */
16580                                 TRUE, /* strict */
16581                                 FALSE, /* Require return to be an ANYOF */
16582                                 &current))
16583                 {
16584                     RETURN_FAIL_ON_RESTART(*flagp, flagp);
16585                     goto regclass_failed;
16586                 }
16587
16588                 assert(current);
16589
16590                 /* function call leaves parse pointing to the ']', except if we
16591                  * faked it */
16592                 if (is_posix_class) {
16593                     RExC_parse--;
16594                 }
16595
16596                 goto handle_operand;
16597             }
16598
16599             case ']':
16600                 if (top_index >= 1) {
16601                     goto join_operators;
16602                 }
16603
16604                 /* Only a single operand on the stack: are done */
16605                 goto done;
16606
16607             case ')':
16608                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
16609                     if (UCHARAT(RExC_parse - 1) == ']')  {
16610                         break;
16611                     }
16612                     RExC_parse++;
16613                     vFAIL("Unexpected ')'");
16614                 }
16615
16616                 /* If nothing after the fence, is missing an operand */
16617                 if (top_index - fence < 0) {
16618                     RExC_parse++;
16619                     goto bad_syntax;
16620                 }
16621                 /* If at least two things on the stack, treat this as an
16622                   * operator */
16623                 if (top_index - fence >= 1) {
16624                     goto join_operators;
16625                 }
16626
16627                 /* Here only a single thing on the fenced stack, and there is a
16628                  * fence.  Get rid of it */
16629                 fence_ptr = av_pop(fence_stack);
16630                 assert(fence_ptr);
16631                 fence = SvIV(fence_ptr);
16632                 SvREFCNT_dec_NN(fence_ptr);
16633                 fence_ptr = NULL;
16634
16635                 if (fence < 0) {
16636                     fence = 0;
16637                 }
16638
16639                 /* Having gotten rid of the fence, we pop the operand at the
16640                  * stack top and process it as a newly encountered operand */
16641                 current = av_pop(stack);
16642                 if (IS_OPERAND(current)) {
16643                     goto handle_operand;
16644                 }
16645
16646                 RExC_parse++;
16647                 goto bad_syntax;
16648
16649             case '&':
16650             case '|':
16651             case '+':
16652             case '-':
16653             case '^':
16654
16655                 /* These binary operators should have a left operand already
16656                  * parsed */
16657                 if (   top_index - fence < 0
16658                     || top_index - fence == 1
16659                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
16660                     || ! IS_OPERAND(*top_ptr))
16661                 {
16662                     goto unexpected_binary;
16663                 }
16664
16665                 /* If only the one operand is on the part of the stack visible
16666                  * to us, we just place this operator in the proper position */
16667                 if (top_index - fence < 2) {
16668
16669                     /* Place the operator before the operand */
16670
16671                     SV* lhs = av_pop(stack);
16672                     av_push(stack, newSVuv(curchar));
16673                     av_push(stack, lhs);
16674                     break;
16675                 }
16676
16677                 /* But if there is something else on the stack, we need to
16678                  * process it before this new operator if and only if the
16679                  * stacked operation has equal or higher precedence than the
16680                  * new one */
16681
16682              join_operators:
16683
16684                 /* The operator on the stack is supposed to be below both its
16685                  * operands */
16686                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
16687                     || IS_OPERAND(*stacked_ptr))
16688                 {
16689                     /* But if not, it's legal and indicates we are completely
16690                      * done if and only if we're currently processing a ']',
16691                      * which should be the final thing in the expression */
16692                     if (curchar == ']') {
16693                         goto done;
16694                     }
16695
16696                   unexpected_binary:
16697                     RExC_parse++;
16698                     vFAIL2("Unexpected binary operator '%c' with no "
16699                            "preceding operand", curchar);
16700                 }
16701                 stacked_operator = (char) SvUV(*stacked_ptr);
16702
16703                 if (regex_set_precedence(curchar)
16704                     > regex_set_precedence(stacked_operator))
16705                 {
16706                     /* Here, the new operator has higher precedence than the
16707                      * stacked one.  This means we need to add the new one to
16708                      * the stack to await its rhs operand (and maybe more
16709                      * stuff).  We put it before the lhs operand, leaving
16710                      * untouched the stacked operator and everything below it
16711                      * */
16712                     lhs = av_pop(stack);
16713                     assert(IS_OPERAND(lhs));
16714
16715                     av_push(stack, newSVuv(curchar));
16716                     av_push(stack, lhs);
16717                     break;
16718                 }
16719
16720                 /* Here, the new operator has equal or lower precedence than
16721                  * what's already there.  This means the operation already
16722                  * there should be performed now, before the new one. */
16723
16724                 rhs = av_pop(stack);
16725                 if (! IS_OPERAND(rhs)) {
16726
16727                     /* This can happen when a ! is not followed by an operand,
16728                      * like in /(?[\t &!])/ */
16729                     goto bad_syntax;
16730                 }
16731
16732                 lhs = av_pop(stack);
16733
16734                 if (! IS_OPERAND(lhs)) {
16735
16736                     /* This can happen when there is an empty (), like in
16737                      * /(?[[0]+()+])/ */
16738                     goto bad_syntax;
16739                 }
16740
16741                 switch (stacked_operator) {
16742                     case '&':
16743                         _invlist_intersection(lhs, rhs, &rhs);
16744                         break;
16745
16746                     case '|':
16747                     case '+':
16748                         _invlist_union(lhs, rhs, &rhs);
16749                         break;
16750
16751                     case '-':
16752                         _invlist_subtract(lhs, rhs, &rhs);
16753                         break;
16754
16755                     case '^':   /* The union minus the intersection */
16756                     {
16757                         SV* i = NULL;
16758                         SV* u = NULL;
16759
16760                         _invlist_union(lhs, rhs, &u);
16761                         _invlist_intersection(lhs, rhs, &i);
16762                         _invlist_subtract(u, i, &rhs);
16763                         SvREFCNT_dec_NN(i);
16764                         SvREFCNT_dec_NN(u);
16765                         break;
16766                     }
16767                 }
16768                 SvREFCNT_dec(lhs);
16769
16770                 /* Here, the higher precedence operation has been done, and the
16771                  * result is in 'rhs'.  We overwrite the stacked operator with
16772                  * the result.  Then we redo this code to either push the new
16773                  * operator onto the stack or perform any higher precedence
16774                  * stacked operation */
16775                 only_to_avoid_leaks = av_pop(stack);
16776                 SvREFCNT_dec(only_to_avoid_leaks);
16777                 av_push(stack, rhs);
16778                 goto redo_curchar;
16779
16780             case '!':   /* Highest priority, right associative */
16781
16782                 /* If what's already at the top of the stack is another '!",
16783                  * they just cancel each other out */
16784                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
16785                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
16786                 {
16787                     only_to_avoid_leaks = av_pop(stack);
16788                     SvREFCNT_dec(only_to_avoid_leaks);
16789                 }
16790                 else { /* Otherwise, since it's right associative, just push
16791                           onto the stack */
16792                     av_push(stack, newSVuv(curchar));
16793                 }
16794                 break;
16795
16796             default:
16797                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16798                 if (RExC_parse >= RExC_end) {
16799                     break;
16800                 }
16801                 vFAIL("Unexpected character");
16802
16803           handle_operand:
16804
16805             /* Here 'current' is the operand.  If something is already on the
16806              * stack, we have to check if it is a !.  But first, the code above
16807              * may have altered the stack in the time since we earlier set
16808              * 'top_index'.  */
16809
16810             top_index = av_tindex_skip_len_mg(stack);
16811             if (top_index - fence >= 0) {
16812                 /* If the top entry on the stack is an operator, it had better
16813                  * be a '!', otherwise the entry below the top operand should
16814                  * be an operator */
16815                 top_ptr = av_fetch(stack, top_index, FALSE);
16816                 assert(top_ptr);
16817                 if (IS_OPERATOR(*top_ptr)) {
16818
16819                     /* The only permissible operator at the top of the stack is
16820                      * '!', which is applied immediately to this operand. */
16821                     curchar = (char) SvUV(*top_ptr);
16822                     if (curchar != '!') {
16823                         SvREFCNT_dec(current);
16824                         vFAIL2("Unexpected binary operator '%c' with no "
16825                                 "preceding operand", curchar);
16826                     }
16827
16828                     _invlist_invert(current);
16829
16830                     only_to_avoid_leaks = av_pop(stack);
16831                     SvREFCNT_dec(only_to_avoid_leaks);
16832
16833                     /* And we redo with the inverted operand.  This allows
16834                      * handling multiple ! in a row */
16835                     goto handle_operand;
16836                 }
16837                           /* Single operand is ok only for the non-binary ')'
16838                            * operator */
16839                 else if ((top_index - fence == 0 && curchar != ')')
16840                          || (top_index - fence > 0
16841                              && (! (stacked_ptr = av_fetch(stack,
16842                                                            top_index - 1,
16843                                                            FALSE))
16844                                  || IS_OPERAND(*stacked_ptr))))
16845                 {
16846                     SvREFCNT_dec(current);
16847                     vFAIL("Operand with no preceding operator");
16848                 }
16849             }
16850
16851             /* Here there was nothing on the stack or the top element was
16852              * another operand.  Just add this new one */
16853             av_push(stack, current);
16854
16855         } /* End of switch on next parse token */
16856
16857         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16858     } /* End of loop parsing through the construct */
16859
16860     vFAIL("Syntax error in (?[...])");
16861
16862   done:
16863
16864     if (RExC_parse >= RExC_end || RExC_parse[1] != ')') {
16865         if (RExC_parse < RExC_end) {
16866             RExC_parse++;
16867         }
16868
16869         vFAIL("Unexpected ']' with no following ')' in (?[...");
16870     }
16871
16872     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
16873         vFAIL("Unmatched (");
16874     }
16875
16876     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
16877         || ((final = av_pop(stack)) == NULL)
16878         || ! IS_OPERAND(final)
16879         || ! is_invlist(final)
16880         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
16881     {
16882       bad_syntax:
16883         SvREFCNT_dec(final);
16884         vFAIL("Incomplete expression within '(?[ ])'");
16885     }
16886
16887     /* Here, 'final' is the resultant inversion list from evaluating the
16888      * expression.  Return it if so requested */
16889     if (return_invlist) {
16890         *return_invlist = final;
16891         return END;
16892     }
16893
16894     if (RExC_sets_depth) {  /* If within a recursive call, return in a special
16895                                regnode */
16896         RExC_parse++;
16897         node = regpnode(pRExC_state, REGEX_SET, final);
16898     }
16899     else {
16900
16901         /* Otherwise generate a resultant node, based on 'final'.  regclass()
16902          * is expecting a string of ranges and individual code points */
16903         invlist_iterinit(final);
16904         result_string = newSVpvs("");
16905         while (invlist_iternext(final, &start, &end)) {
16906             if (start == end) {
16907                 Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
16908             }
16909             else {
16910                 Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%"
16911                                                         UVXf "}", start, end);
16912             }
16913         }
16914
16915         /* About to generate an ANYOF (or similar) node from the inversion list
16916          * we have calculated */
16917         save_parse = RExC_parse;
16918         RExC_parse = SvPV(result_string, len);
16919         save_end = RExC_end;
16920         RExC_end = RExC_parse + len;
16921         TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
16922
16923         /* We turn off folding around the call, as the class we have
16924          * constructed already has all folding taken into consideration, and we
16925          * don't want regclass() to add to that */
16926         RExC_flags &= ~RXf_PMf_FOLD;
16927         /* regclass() can only return RESTART_PARSE and NEED_UTF8 if multi-char
16928          * folds are allowed.  */
16929         node = regclass(pRExC_state, flagp, depth+1,
16930                         FALSE, /* means parse the whole char class */
16931                         FALSE, /* don't allow multi-char folds */
16932                         TRUE, /* silence non-portable warnings.  The above may
16933                                  very well have generated non-portable code
16934                                  points, but they're valid on this machine */
16935                         FALSE, /* similarly, no need for strict */
16936
16937                         /* We can optimize into something besides an ANYOF,
16938                          * except under /l, which needs to be ANYOF because of
16939                          * runtime checks for locale sanity, etc */
16940                     ! in_locale,
16941                         NULL
16942                     );
16943
16944         RESTORE_WARNINGS;
16945         RExC_parse = save_parse + 1;
16946         RExC_end = save_end;
16947         SvREFCNT_dec_NN(final);
16948         SvREFCNT_dec_NN(result_string);
16949
16950         if (save_fold) {
16951             RExC_flags |= RXf_PMf_FOLD;
16952         }
16953
16954         if (!node) {
16955             RETURN_FAIL_ON_RESTART(*flagp, flagp);
16956             goto regclass_failed;
16957         }
16958
16959         /* Fix up the node type if we are in locale.  (We have pretended we are
16960          * under /u for the purposes of regclass(), as this construct will only
16961          * work under UTF-8 locales.  But now we change the opcode to be ANYOFL
16962          * (so as to cause any warnings about bad locales to be output in
16963          * regexec.c), and add the flag that indicates to check if not in a
16964          * UTF-8 locale.  The reason we above forbid optimization into
16965          * something other than an ANYOF node is simply to minimize the number
16966          * of code changes in regexec.c.  Otherwise we would have to create new
16967          * EXACTish node types and deal with them.  This decision could be
16968          * revisited should this construct become popular.
16969          *
16970          * (One might think we could look at the resulting ANYOF node and
16971          * suppress the flag if everything is above 255, as those would be
16972          * UTF-8 only, but this isn't true, as the components that led to that
16973          * result could have been locale-affected, and just happen to cancel
16974          * each other out under UTF-8 locales.) */
16975         if (in_locale) {
16976             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
16977
16978             assert(OP(REGNODE_p(node)) == ANYOF);
16979
16980             OP(REGNODE_p(node)) = ANYOFL;
16981             ANYOF_FLAGS(REGNODE_p(node))
16982                     |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
16983         }
16984     }
16985
16986     nextchar(pRExC_state);
16987     Set_Node_Length(REGNODE_p(node), RExC_parse - oregcomp_parse + 1); /* MJD */
16988     return node;
16989
16990   regclass_failed:
16991     FAIL2("panic: regclass returned failure to handle_sets, " "flags=%#" UVxf,
16992                                                                 (UV) *flagp);
16993 }
16994
16995 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16996
16997 STATIC void
16998 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
16999                              AV * stack, const IV fence, AV * fence_stack)
17000 {   /* Dumps the stacks in handle_regex_sets() */
17001
17002     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
17003     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
17004     SSize_t i;
17005
17006     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
17007
17008     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
17009
17010     if (stack_top < 0) {
17011         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
17012     }
17013     else {
17014         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
17015         for (i = stack_top; i >= 0; i--) {
17016             SV ** element_ptr = av_fetch(stack, i, FALSE);
17017             if (! element_ptr) {
17018             }
17019
17020             if (IS_OPERATOR(*element_ptr)) {
17021                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
17022                                             (int) i, (int) SvIV(*element_ptr));
17023             }
17024             else {
17025                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
17026                 sv_dump(*element_ptr);
17027             }
17028         }
17029     }
17030
17031     if (fence_stack_top < 0) {
17032         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
17033     }
17034     else {
17035         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
17036         for (i = fence_stack_top; i >= 0; i--) {
17037             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
17038             if (! element_ptr) {
17039             }
17040
17041             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
17042                                             (int) i, (int) SvIV(*element_ptr));
17043         }
17044     }
17045 }
17046
17047 #endif
17048
17049 #undef IS_OPERATOR
17050 #undef IS_OPERAND
17051
17052 STATIC void
17053 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
17054 {
17055     /* This adds the Latin1/above-Latin1 folding rules.
17056      *
17057      * This should be called only for a Latin1-range code points, cp, which is
17058      * known to be involved in a simple fold with other code points above
17059      * Latin1.  It would give false results if /aa has been specified.
17060      * Multi-char folds are outside the scope of this, and must be handled
17061      * specially. */
17062
17063     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
17064
17065     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
17066
17067     /* The rules that are valid for all Unicode versions are hard-coded in */
17068     switch (cp) {
17069         case 'k':
17070         case 'K':
17071           *invlist =
17072              add_cp_to_invlist(*invlist, KELVIN_SIGN);
17073             break;
17074         case 's':
17075         case 'S':
17076           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
17077             break;
17078         case MICRO_SIGN:
17079           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
17080           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
17081             break;
17082         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
17083         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
17084           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
17085             break;
17086         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
17087           *invlist = add_cp_to_invlist(*invlist,
17088                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
17089             break;
17090
17091         default:    /* Other code points are checked against the data for the
17092                        current Unicode version */
17093           {
17094             Size_t folds_count;
17095             U32 first_fold;
17096             const U32 * remaining_folds;
17097             UV folded_cp;
17098
17099             if (isASCII(cp)) {
17100                 folded_cp = toFOLD(cp);
17101             }
17102             else {
17103                 U8 dummy_fold[UTF8_MAXBYTES_CASE+1];
17104                 Size_t dummy_len;
17105                 folded_cp = _to_fold_latin1(cp, dummy_fold, &dummy_len, 0);
17106             }
17107
17108             if (folded_cp > 255) {
17109                 *invlist = add_cp_to_invlist(*invlist, folded_cp);
17110             }
17111
17112             folds_count = _inverse_folds(folded_cp, &first_fold,
17113                                                     &remaining_folds);
17114             if (folds_count == 0) {
17115
17116                 /* Use deprecated warning to increase the chances of this being
17117                  * output */
17118                 ckWARN2reg_d(RExC_parse,
17119                         "Perl folding rules are not up-to-date for 0x%02X;"
17120                         " please use the perlbug utility to report;", cp);
17121             }
17122             else {
17123                 unsigned int i;
17124
17125                 if (first_fold > 255) {
17126                     *invlist = add_cp_to_invlist(*invlist, first_fold);
17127                 }
17128                 for (i = 0; i < folds_count - 1; i++) {
17129                     if (remaining_folds[i] > 255) {
17130                         *invlist = add_cp_to_invlist(*invlist,
17131                                                     remaining_folds[i]);
17132                     }
17133                 }
17134             }
17135             break;
17136          }
17137     }
17138 }
17139
17140 STATIC void
17141 S_output_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings)
17142 {
17143     /* Output the elements of the array given by '*posix_warnings' as REGEXP
17144      * warnings. */
17145
17146     SV * msg;
17147     const bool first_is_fatal = ckDEAD(packWARN(WARN_REGEXP));
17148
17149     PERL_ARGS_ASSERT_OUTPUT_POSIX_WARNINGS;
17150
17151     if (! TO_OUTPUT_WARNINGS(RExC_parse)) {
17152         CLEAR_POSIX_WARNINGS();
17153         return;
17154     }
17155
17156     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
17157         if (first_is_fatal) {           /* Avoid leaking this */
17158             av_undef(posix_warnings);   /* This isn't necessary if the
17159                                             array is mortal, but is a
17160                                             fail-safe */
17161             (void) sv_2mortal(msg);
17162             PREPARE_TO_DIE;
17163         }
17164         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
17165         SvREFCNT_dec_NN(msg);
17166     }
17167
17168     UPDATE_WARNINGS_LOC(RExC_parse);
17169 }
17170
17171 PERL_STATIC_INLINE Size_t
17172 S_find_first_differing_byte_pos(const U8 * s1, const U8 * s2, const Size_t max)
17173 {
17174     const U8 * const start = s1;
17175     const U8 * const send = start + max;
17176
17177     PERL_ARGS_ASSERT_FIND_FIRST_DIFFERING_BYTE_POS;
17178
17179     while (s1 < send && *s1  == *s2) {
17180         s1++; s2++;
17181     }
17182
17183     return s1 - start;
17184 }
17185
17186
17187 STATIC AV *
17188 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
17189 {
17190     /* This adds the string scalar <multi_string> to the array
17191      * <multi_char_matches>.  <multi_string> is known to have exactly
17192      * <cp_count> code points in it.  This is used when constructing a
17193      * bracketed character class and we find something that needs to match more
17194      * than a single character.
17195      *
17196      * <multi_char_matches> is actually an array of arrays.  Each top-level
17197      * element is an array that contains all the strings known so far that are
17198      * the same length.  And that length (in number of code points) is the same
17199      * as the index of the top-level array.  Hence, the [2] element is an
17200      * array, each element thereof is a string containing TWO code points;
17201      * while element [3] is for strings of THREE characters, and so on.  Since
17202      * this is for multi-char strings there can never be a [0] nor [1] element.
17203      *
17204      * When we rewrite the character class below, we will do so such that the
17205      * longest strings are written first, so that it prefers the longest
17206      * matching strings first.  This is done even if it turns out that any
17207      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
17208      * Christiansen has agreed that this is ok.  This makes the test for the
17209      * ligature 'ffi' come before the test for 'ff', for example */
17210
17211     AV* this_array;
17212     AV** this_array_ptr;
17213
17214     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
17215
17216     if (! multi_char_matches) {
17217         multi_char_matches = newAV();
17218     }
17219
17220     if (av_exists(multi_char_matches, cp_count)) {
17221         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
17222         this_array = *this_array_ptr;
17223     }
17224     else {
17225         this_array = newAV();
17226         av_store(multi_char_matches, cp_count,
17227                  (SV*) this_array);
17228     }
17229     av_push(this_array, multi_string);
17230
17231     return multi_char_matches;
17232 }
17233
17234 /* The names of properties whose definitions are not known at compile time are
17235  * stored in this SV, after a constant heading.  So if the length has been
17236  * changed since initialization, then there is a run-time definition. */
17237 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
17238                                         (SvCUR(listsv) != initial_listsv_len)
17239
17240 /* There is a restricted set of white space characters that are legal when
17241  * ignoring white space in a bracketed character class.  This generates the
17242  * code to skip them.
17243  *
17244  * There is a line below that uses the same white space criteria but is outside
17245  * this macro.  Both here and there must use the same definition */
17246 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p, stop_p)                  \
17247     STMT_START {                                                        \
17248         if (do_skip) {                                                  \
17249             while (p < stop_p && isBLANK_A(UCHARAT(p)))                 \
17250             {                                                           \
17251                 p++;                                                    \
17252             }                                                           \
17253         }                                                               \
17254     } STMT_END
17255
17256 STATIC regnode_offset
17257 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
17258                  const bool stop_at_1,  /* Just parse the next thing, don't
17259                                            look for a full character class */
17260                  bool allow_mutiple_chars,
17261                  const bool silence_non_portable,   /* Don't output warnings
17262                                                        about too large
17263                                                        characters */
17264                  const bool strict,
17265                  bool optimizable,                  /* ? Allow a non-ANYOF return
17266                                                        node */
17267                  SV** ret_invlist  /* Return an inversion list, not a node */
17268           )
17269 {
17270     /* parse a bracketed class specification.  Most of these will produce an
17271      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
17272      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
17273      * under /i with multi-character folds: it will be rewritten following the
17274      * paradigm of this example, where the <multi-fold>s are characters which
17275      * fold to multiple character sequences:
17276      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
17277      * gets effectively rewritten as:
17278      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
17279      * reg() gets called (recursively) on the rewritten version, and this
17280      * function will return what it constructs.  (Actually the <multi-fold>s
17281      * aren't physically removed from the [abcdefghi], it's just that they are
17282      * ignored in the recursion by means of a flag:
17283      * <RExC_in_multi_char_class>.)
17284      *
17285      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
17286      * characters, with the corresponding bit set if that character is in the
17287      * list.  For characters above this, an inversion list is used.  There
17288      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
17289      * determinable at compile time
17290      *
17291      * On success, returns the offset at which any next node should be placed
17292      * into the regex engine program being compiled.
17293      *
17294      * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
17295      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
17296      * UTF-8
17297      */
17298
17299     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
17300     IV range = 0;
17301     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
17302     regnode_offset ret = -1;    /* Initialized to an illegal value */
17303     STRLEN numlen;
17304     int namedclass = OOB_NAMEDCLASS;
17305     char *rangebegin = NULL;
17306     SV *listsv = NULL;      /* List of \p{user-defined} whose definitions
17307                                aren't available at the time this was called */
17308     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
17309                                       than just initialized.  */
17310     SV* properties = NULL;    /* Code points that match \p{} \P{} */
17311     SV* posixes = NULL;     /* Code points that match classes like [:word:],
17312                                extended beyond the Latin1 range.  These have to
17313                                be kept separate from other code points for much
17314                                of this function because their handling  is
17315                                different under /i, and for most classes under
17316                                /d as well */
17317     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
17318                                separate for a while from the non-complemented
17319                                versions because of complications with /d
17320                                matching */
17321     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
17322                                   treated more simply than the general case,
17323                                   leading to less compilation and execution
17324                                   work */
17325     UV element_count = 0;   /* Number of distinct elements in the class.
17326                                Optimizations may be possible if this is tiny */
17327     AV * multi_char_matches = NULL; /* Code points that fold to more than one
17328                                        character; used under /i */
17329     UV n;
17330     char * stop_ptr = RExC_end;    /* where to stop parsing */
17331
17332     /* ignore unescaped whitespace? */
17333     const bool skip_white = cBOOL(   ret_invlist
17334                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
17335
17336     /* inversion list of code points this node matches only when the target
17337      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
17338      * /d) */
17339     SV* upper_latin1_only_utf8_matches = NULL;
17340
17341     /* Inversion list of code points this node matches regardless of things
17342      * like locale, folding, utf8ness of the target string */
17343     SV* cp_list = NULL;
17344
17345     /* Like cp_list, but code points on this list need to be checked for things
17346      * that fold to/from them under /i */
17347     SV* cp_foldable_list = NULL;
17348
17349     /* Like cp_list, but code points on this list are valid only when the
17350      * runtime locale is UTF-8 */
17351     SV* only_utf8_locale_list = NULL;
17352
17353     /* In a range, if one of the endpoints is non-character-set portable,
17354      * meaning that it hard-codes a code point that may mean a different
17355      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
17356      * mnemonic '\t' which each mean the same character no matter which
17357      * character set the platform is on. */
17358     unsigned int non_portable_endpoint = 0;
17359
17360     /* Is the range unicode? which means on a platform that isn't 1-1 native
17361      * to Unicode (i.e. non-ASCII), each code point in it should be considered
17362      * to be a Unicode value.  */
17363     bool unicode_range = FALSE;
17364     bool invert = FALSE;    /* Is this class to be complemented */
17365
17366     bool warn_super = ALWAYS_WARN_SUPER;
17367
17368     const char * orig_parse = RExC_parse;
17369
17370     /* This variable is used to mark where the end in the input is of something
17371      * that looks like a POSIX construct but isn't.  During the parse, when
17372      * something looks like it could be such a construct is encountered, it is
17373      * checked for being one, but not if we've already checked this area of the
17374      * input.  Only after this position is reached do we check again */
17375     char *not_posix_region_end = RExC_parse - 1;
17376
17377     AV* posix_warnings = NULL;
17378     const bool do_posix_warnings = ckWARN(WARN_REGEXP);
17379     U8 op = END;    /* The returned node-type, initialized to an impossible
17380                        one.  */
17381     U8 anyof_flags = 0;   /* flag bits if the node is an ANYOF-type */
17382     U32 posixl = 0;       /* bit field of posix classes matched under /l */
17383
17384
17385 /* Flags as to what things aren't knowable until runtime.  (Note that these are
17386  * mutually exclusive.) */
17387 #define HAS_USER_DEFINED_PROPERTY 0x01   /* /u any user-defined properties that
17388                                             haven't been defined as of yet */
17389 #define HAS_D_RUNTIME_DEPENDENCY  0x02   /* /d if the target being matched is
17390                                             UTF-8 or not */
17391 #define HAS_L_RUNTIME_DEPENDENCY   0x04 /* /l what the posix classes match and
17392                                             what gets folded */
17393     U32 has_runtime_dependency = 0;     /* OR of the above flags */
17394
17395     DECLARE_AND_GET_RE_DEBUG_FLAGS;
17396
17397     PERL_ARGS_ASSERT_REGCLASS;
17398 #ifndef DEBUGGING
17399     PERL_UNUSED_ARG(depth);
17400 #endif
17401
17402     assert(! (ret_invlist && allow_mutiple_chars));
17403
17404     /* If wants an inversion list returned, we can't optimize to something
17405      * else. */
17406     if (ret_invlist) {
17407         optimizable = FALSE;
17408     }
17409
17410     DEBUG_PARSE("clas");
17411
17412 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
17413     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
17414                                    && UNICODE_DOT_DOT_VERSION == 0)
17415     allow_mutiple_chars = FALSE;
17416 #endif
17417
17418     /* We include the /i status at the beginning of this so that we can
17419      * know it at runtime */
17420     listsv = sv_2mortal(Perl_newSVpvf(aTHX_ "#%d\n", cBOOL(FOLD)));
17421     initial_listsv_len = SvCUR(listsv);
17422     SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
17423
17424     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end);
17425
17426     assert(RExC_parse <= RExC_end);
17427
17428     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
17429         RExC_parse++;
17430         invert = TRUE;
17431         allow_mutiple_chars = FALSE;
17432         MARK_NAUGHTY(1);
17433         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end);
17434     }
17435
17436     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
17437     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
17438         int maybe_class = handle_possible_posix(pRExC_state,
17439                                                 RExC_parse,
17440                                                 &not_posix_region_end,
17441                                                 NULL,
17442                                                 TRUE /* checking only */);
17443         if (maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
17444             ckWARN4reg(not_posix_region_end,
17445                     "POSIX syntax [%c %c] belongs inside character classes%s",
17446                     *RExC_parse, *RExC_parse,
17447                     (maybe_class == OOB_NAMEDCLASS)
17448                     ? ((POSIXCC_NOTYET(*RExC_parse))
17449                         ? " (but this one isn't implemented)"
17450                         : " (but this one isn't fully valid)")
17451                     : ""
17452                     );
17453         }
17454     }
17455
17456     /* If the caller wants us to just parse a single element, accomplish this
17457      * by faking the loop ending condition */
17458     if (stop_at_1 && RExC_end > RExC_parse) {
17459         stop_ptr = RExC_parse + 1;
17460     }
17461
17462     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
17463     if (UCHARAT(RExC_parse) == ']')
17464         goto charclassloop;
17465
17466     while (1) {
17467
17468         if (   posix_warnings
17469             && av_tindex_skip_len_mg(posix_warnings) >= 0
17470             && RExC_parse > not_posix_region_end)
17471         {
17472             /* Warnings about posix class issues are considered tentative until
17473              * we are far enough along in the parse that we can no longer
17474              * change our mind, at which point we output them.  This is done
17475              * each time through the loop so that a later class won't zap them
17476              * before they have been dealt with. */
17477             output_posix_warnings(pRExC_state, posix_warnings);
17478         }
17479
17480         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end);
17481
17482         if  (RExC_parse >= stop_ptr) {
17483             break;
17484         }
17485
17486         if  (UCHARAT(RExC_parse) == ']') {
17487             break;
17488         }
17489
17490       charclassloop:
17491
17492         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
17493         save_value = value;
17494         save_prevvalue = prevvalue;
17495
17496         if (!range) {
17497             rangebegin = RExC_parse;
17498             element_count++;
17499             non_portable_endpoint = 0;
17500         }
17501         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
17502             value = utf8n_to_uvchr((U8*)RExC_parse,
17503                                    RExC_end - RExC_parse,
17504                                    &numlen, UTF8_ALLOW_DEFAULT);
17505             RExC_parse += numlen;
17506         }
17507         else
17508             value = UCHARAT(RExC_parse++);
17509
17510         if (value == '[') {
17511             char * posix_class_end;
17512             namedclass = handle_possible_posix(pRExC_state,
17513                                                RExC_parse,
17514                                                &posix_class_end,
17515                                                do_posix_warnings ? &posix_warnings : NULL,
17516                                                FALSE    /* die if error */);
17517             if (namedclass > OOB_NAMEDCLASS) {
17518
17519                 /* If there was an earlier attempt to parse this particular
17520                  * posix class, and it failed, it was a false alarm, as this
17521                  * successful one proves */
17522                 if (   posix_warnings
17523                     && av_tindex_skip_len_mg(posix_warnings) >= 0
17524                     && not_posix_region_end >= RExC_parse
17525                     && not_posix_region_end <= posix_class_end)
17526                 {
17527                     av_undef(posix_warnings);
17528                 }
17529
17530                 RExC_parse = posix_class_end;
17531             }
17532             else if (namedclass == OOB_NAMEDCLASS) {
17533                 not_posix_region_end = posix_class_end;
17534             }
17535             else {
17536                 namedclass = OOB_NAMEDCLASS;
17537             }
17538         }
17539         else if (   RExC_parse - 1 > not_posix_region_end
17540                  && MAYBE_POSIXCC(value))
17541         {
17542             (void) handle_possible_posix(
17543                         pRExC_state,
17544                         RExC_parse - 1,  /* -1 because parse has already been
17545                                             advanced */
17546                         &not_posix_region_end,
17547                         do_posix_warnings ? &posix_warnings : NULL,
17548                         TRUE /* checking only */);
17549         }
17550         else if (  strict && ! skip_white
17551                  && (   _generic_isCC(value, _CC_VERTSPACE)
17552                      || is_VERTWS_cp_high(value)))
17553         {
17554             vFAIL("Literal vertical space in [] is illegal except under /x");
17555         }
17556         else if (value == '\\') {
17557             /* Is a backslash; get the code point of the char after it */
17558
17559             if (RExC_parse >= RExC_end) {
17560                 vFAIL("Unmatched [");
17561             }
17562
17563             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
17564                 value = utf8n_to_uvchr((U8*)RExC_parse,
17565                                    RExC_end - RExC_parse,
17566                                    &numlen, UTF8_ALLOW_DEFAULT);
17567                 RExC_parse += numlen;
17568             }
17569             else
17570                 value = UCHARAT(RExC_parse++);
17571
17572             /* Some compilers cannot handle switching on 64-bit integer
17573              * values, therefore value cannot be an UV.  Yes, this will
17574              * be a problem later if we want switch on Unicode.
17575              * A similar issue a little bit later when switching on
17576              * namedclass. --jhi */
17577
17578             /* If the \ is escaping white space when white space is being
17579              * skipped, it means that that white space is wanted literally, and
17580              * is already in 'value'.  Otherwise, need to translate the escape
17581              * into what it signifies. */
17582             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
17583                 const char * message;
17584                 U32 packed_warn;
17585                 U8 grok_c_char;
17586
17587             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
17588             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
17589             case 's':   namedclass = ANYOF_SPACE;       break;
17590             case 'S':   namedclass = ANYOF_NSPACE;      break;
17591             case 'd':   namedclass = ANYOF_DIGIT;       break;
17592             case 'D':   namedclass = ANYOF_NDIGIT;      break;
17593             case 'v':   namedclass = ANYOF_VERTWS;      break;
17594             case 'V':   namedclass = ANYOF_NVERTWS;     break;
17595             case 'h':   namedclass = ANYOF_HORIZWS;     break;
17596             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
17597             case 'N':  /* Handle \N{NAME} in class */
17598                 {
17599                     const char * const backslash_N_beg = RExC_parse - 2;
17600                     int cp_count;
17601
17602                     if (! grok_bslash_N(pRExC_state,
17603                                         NULL,      /* No regnode */
17604                                         &value,    /* Yes single value */
17605                                         &cp_count, /* Multiple code pt count */
17606                                         flagp,
17607                                         strict,
17608                                         depth)
17609                     ) {
17610
17611                         if (*flagp & NEED_UTF8)
17612                             FAIL("panic: grok_bslash_N set NEED_UTF8");
17613
17614                         RETURN_FAIL_ON_RESTART_FLAGP(flagp);
17615
17616                         if (cp_count < 0) {
17617                             vFAIL("\\N in a character class must be a named character: \\N{...}");
17618                         }
17619                         else if (cp_count == 0) {
17620                             ckWARNreg(RExC_parse,
17621                               "Ignoring zero length \\N{} in character class");
17622                         }
17623                         else { /* cp_count > 1 */
17624                             assert(cp_count > 1);
17625                             if (! RExC_in_multi_char_class) {
17626                                 if ( ! allow_mutiple_chars
17627                                     || invert
17628                                     || range
17629                                     || *RExC_parse == '-')
17630                                 {
17631                                     if (strict) {
17632                                         RExC_parse--;
17633                                         vFAIL("\\N{} here is restricted to one character");
17634                                     }
17635                                     ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
17636                                     break; /* <value> contains the first code
17637                                               point. Drop out of the switch to
17638                                               process it */
17639                                 }
17640                                 else {
17641                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
17642                                                  RExC_parse - backslash_N_beg);
17643                                     multi_char_matches
17644                                         = add_multi_match(multi_char_matches,
17645                                                           multi_char_N,
17646                                                           cp_count);
17647                                 }
17648                             }
17649                         } /* End of cp_count != 1 */
17650
17651                         /* This element should not be processed further in this
17652                          * class */
17653                         element_count--;
17654                         value = save_value;
17655                         prevvalue = save_prevvalue;
17656                         continue;   /* Back to top of loop to get next char */
17657                     }
17658
17659                     /* Here, is a single code point, and <value> contains it */
17660                     unicode_range = TRUE;   /* \N{} are Unicode */
17661                 }
17662                 break;
17663             case 'p':
17664             case 'P':
17665                 {
17666                 char *e;
17667
17668                 if (RExC_pm_flags & PMf_WILDCARD) {
17669                     RExC_parse++;
17670                     /* diag_listed_as: Use of %s is not allowed in Unicode
17671                        property wildcard subpatterns in regex; marked by <--
17672                        HERE in m/%s/ */
17673                     vFAIL3("Use of '\\%c%c' is not allowed in Unicode property"
17674                            " wildcard subpatterns", (char) value, *(RExC_parse - 1));
17675                 }
17676
17677                 /* \p means they want Unicode semantics */
17678                 REQUIRE_UNI_RULES(flagp, 0);
17679
17680                 if (RExC_parse >= RExC_end)
17681                     vFAIL2("Empty \\%c", (U8)value);
17682                 if (*RExC_parse == '{') {
17683                     const U8 c = (U8)value;
17684                     e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
17685                     if (!e) {
17686                         RExC_parse++;
17687                         vFAIL2("Missing right brace on \\%c{}", c);
17688                     }
17689
17690                     RExC_parse++;
17691
17692                     /* White space is allowed adjacent to the braces and after
17693                      * any '^', even when not under /x */
17694                     while (isSPACE(*RExC_parse)) {
17695                          RExC_parse++;
17696                     }
17697
17698                     if (UCHARAT(RExC_parse) == '^') {
17699
17700                         /* toggle.  (The rhs xor gets the single bit that
17701                          * differs between P and p; the other xor inverts just
17702                          * that bit) */
17703                         value ^= 'P' ^ 'p';
17704
17705                         RExC_parse++;
17706                         while (isSPACE(*RExC_parse)) {
17707                             RExC_parse++;
17708                         }
17709                     }
17710
17711                     if (e == RExC_parse)
17712                         vFAIL2("Empty \\%c{}", c);
17713
17714                     n = e - RExC_parse;
17715                     while (isSPACE(*(RExC_parse + n - 1)))
17716                         n--;
17717
17718                 }   /* The \p isn't immediately followed by a '{' */
17719                 else if (! isALPHA(*RExC_parse)) {
17720                     RExC_parse += (UTF)
17721                                   ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17722                                   : 1;
17723                     vFAIL2("Character following \\%c must be '{' or a "
17724                            "single-character Unicode property name",
17725                            (U8) value);
17726                 }
17727                 else {
17728                     e = RExC_parse;
17729                     n = 1;
17730                 }
17731                 {
17732                     char* name = RExC_parse;
17733
17734                     /* Any message returned about expanding the definition */
17735                     SV* msg = newSVpvs_flags("", SVs_TEMP);
17736
17737                     /* If set TRUE, the property is user-defined as opposed to
17738                      * official Unicode */
17739                     bool user_defined = FALSE;
17740                     AV * strings = NULL;
17741
17742                     SV * prop_definition = parse_uniprop_string(
17743                                             name, n, UTF, FOLD,
17744                                             FALSE, /* This is compile-time */
17745
17746                                             /* We can't defer this defn when
17747                                              * the full result is required in
17748                                              * this call */
17749                                             ! cBOOL(ret_invlist),
17750
17751                                             &strings,
17752                                             &user_defined,
17753                                             msg,
17754                                             0 /* Base level */
17755                                            );
17756                     if (SvCUR(msg)) {   /* Assumes any error causes a msg */
17757                         assert(prop_definition == NULL);
17758                         RExC_parse = e + 1;
17759                         if (SvUTF8(msg)) {  /* msg being UTF-8 makes the whole
17760                                                thing so, or else the display is
17761                                                mojibake */
17762                             RExC_utf8 = TRUE;
17763                         }
17764                         /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
17765                         vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg),
17766                                     SvCUR(msg), SvPVX(msg)));
17767                     }
17768
17769                     assert(prop_definition || strings);
17770
17771                     if (strings) {
17772                         if (ret_invlist) {
17773                             if (! prop_definition) {
17774                                 RExC_parse = e + 1;
17775                                 vFAIL("Unicode string properties are not implemented in (?[...])");
17776                             }
17777                             else {
17778                                 ckWARNreg(e + 1,
17779                                     "Using just the single character results"
17780                                     " returned by \\p{} in (?[...])");
17781                             }
17782                         }
17783                         else if (! RExC_in_multi_char_class) {
17784                             if (invert ^ (value == 'P')) {
17785                                 RExC_parse = e + 1;
17786                                 vFAIL("Inverting a character class which contains"
17787                                     " a multi-character sequence is illegal");
17788                             }
17789
17790                             /* For each multi-character string ... */
17791                             while (av_count(strings) > 0) {
17792                                 /* ... Each entry is itself an array of code
17793                                 * points. */
17794                                 AV * this_string = (AV *) av_shift( strings);
17795                                 STRLEN cp_count = av_count(this_string);
17796                                 SV * final = newSV(cp_count * 4);
17797                                 SvPVCLEAR(final);
17798
17799                                 /* Create another string of sequences of \x{...} */
17800                                 while (av_count(this_string) > 0) {
17801                                     SV * character = av_shift(this_string);
17802                                     UV cp = SvUV(character);
17803
17804                                     if (cp > 255) {
17805                                         REQUIRE_UTF8(flagp);
17806                                     }
17807                                     Perl_sv_catpvf(aTHX_ final, "\\x{%" UVXf "}",
17808                                                                         cp);
17809                                     SvREFCNT_dec_NN(character);
17810                                 }
17811                                 SvREFCNT_dec_NN(this_string);
17812
17813                                 /* And add that to the list of such things */
17814                                 multi_char_matches
17815                                             = add_multi_match(multi_char_matches,
17816                                                             final,
17817                                                             cp_count);
17818                             }
17819                         }
17820                         SvREFCNT_dec_NN(strings);
17821                     }
17822
17823                     if (! prop_definition) {    /* If we got only a string,
17824                                                    this iteration didn't really
17825                                                    find a character */
17826                         element_count--;
17827                     }
17828                     else if (! is_invlist(prop_definition)) {
17829
17830                         /* Here, the definition isn't known, so we have gotten
17831                          * returned a string that will be evaluated if and when
17832                          * encountered at runtime.  We add it to the list of
17833                          * such properties, along with whether it should be
17834                          * complemented or not */
17835                         if (value == 'P') {
17836                             sv_catpvs(listsv, "!");
17837                         }
17838                         else {
17839                             sv_catpvs(listsv, "+");
17840                         }
17841                         sv_catsv(listsv, prop_definition);
17842
17843                         has_runtime_dependency |= HAS_USER_DEFINED_PROPERTY;
17844
17845                         /* We don't know yet what this matches, so have to flag
17846                          * it */
17847                         anyof_flags |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17848                     }
17849                     else {
17850                         assert (prop_definition && is_invlist(prop_definition));
17851
17852                         /* Here we do have the complete property definition
17853                          *
17854                          * Temporary workaround for [perl #133136].  For this
17855                          * precise input that is in the .t that is failing,
17856                          * load utf8.pm, which is what the test wants, so that
17857                          * that .t passes */
17858                         if (     memEQs(RExC_start, e + 1 - RExC_start,
17859                                         "foo\\p{Alnum}")
17860                             && ! hv_common(GvHVn(PL_incgv),
17861                                            NULL,
17862                                            "utf8.pm", sizeof("utf8.pm") - 1,
17863                                            0, HV_FETCH_ISEXISTS, NULL, 0))
17864                         {
17865                             require_pv("utf8.pm");
17866                         }
17867
17868                         if (! user_defined &&
17869                             /* We warn on matching an above-Unicode code point
17870                              * if the match would return true, except don't
17871                              * warn for \p{All}, which has exactly one element
17872                              * = 0 */
17873                             (_invlist_contains_cp(prop_definition, 0x110000)
17874                                 && (! (_invlist_len(prop_definition) == 1
17875                                        && *invlist_array(prop_definition) == 0))))
17876                         {
17877                             warn_super = TRUE;
17878                         }
17879
17880                         /* Invert if asking for the complement */
17881                         if (value == 'P') {
17882                             _invlist_union_complement_2nd(properties,
17883                                                           prop_definition,
17884                                                           &properties);
17885                         }
17886                         else {
17887                             _invlist_union(properties, prop_definition, &properties);
17888                         }
17889                     }
17890                 }
17891
17892                 RExC_parse = e + 1;
17893                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
17894                                                 named */
17895                 }
17896                 break;
17897             case 'n':   value = '\n';                   break;
17898             case 'r':   value = '\r';                   break;
17899             case 't':   value = '\t';                   break;
17900             case 'f':   value = '\f';                   break;
17901             case 'b':   value = '\b';                   break;
17902             case 'e':   value = ESC_NATIVE;             break;
17903             case 'a':   value = '\a';                   break;
17904             case 'o':
17905                 RExC_parse--;   /* function expects to be pointed at the 'o' */
17906                 if (! grok_bslash_o(&RExC_parse,
17907                                             RExC_end,
17908                                             &value,
17909                                             &message,
17910                                             &packed_warn,
17911                                             strict,
17912                                             cBOOL(range), /* MAX_UV allowed for range
17913                                                       upper limit */
17914                                             UTF))
17915                 {
17916                     vFAIL(message);
17917                 }
17918                 else if (message && TO_OUTPUT_WARNINGS(RExC_parse)) {
17919                     warn_non_literal_string(RExC_parse, packed_warn, message);
17920                 }
17921
17922                 if (value < 256) {
17923                     non_portable_endpoint++;
17924                 }
17925                 break;
17926             case 'x':
17927                 RExC_parse--;   /* function expects to be pointed at the 'x' */
17928                 if (!  grok_bslash_x(&RExC_parse,
17929                                             RExC_end,
17930                                             &value,
17931                                             &message,
17932                                             &packed_warn,
17933                                             strict,
17934                                             cBOOL(range), /* MAX_UV allowed for range
17935                                                       upper limit */
17936                                             UTF))
17937                 {
17938                     vFAIL(message);
17939                 }
17940                 else if (message && TO_OUTPUT_WARNINGS(RExC_parse)) {
17941                     warn_non_literal_string(RExC_parse, packed_warn, message);
17942                 }
17943
17944                 if (value < 256) {
17945                     non_portable_endpoint++;
17946                 }
17947                 break;
17948             case 'c':
17949                 if (! grok_bslash_c(*RExC_parse, &grok_c_char, &message,
17950                                                                 &packed_warn))
17951                 {
17952                     /* going to die anyway; point to exact spot of
17953                         * failure */
17954                     RExC_parse += (UTF)
17955                                   ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17956                                   : 1;
17957                     vFAIL(message);
17958                 }
17959
17960                 value = grok_c_char;
17961                 RExC_parse++;
17962                 if (message && TO_OUTPUT_WARNINGS(RExC_parse)) {
17963                     warn_non_literal_string(RExC_parse, packed_warn, message);
17964                 }
17965
17966                 non_portable_endpoint++;
17967                 break;
17968             case '0': case '1': case '2': case '3': case '4':
17969             case '5': case '6': case '7':
17970                 {
17971                     /* Take 1-3 octal digits */
17972                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT
17973                               | PERL_SCAN_NOTIFY_ILLDIGIT;
17974                     numlen = (strict) ? 4 : 3;
17975                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
17976                     RExC_parse += numlen;
17977                     if (numlen != 3) {
17978                         if (strict) {
17979                             RExC_parse += (UTF)
17980                                           ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17981                                           : 1;
17982                             vFAIL("Need exactly 3 octal digits");
17983                         }
17984                         else if (  (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
17985                                  && RExC_parse < RExC_end
17986                                  && isDIGIT(*RExC_parse)
17987                                  && ckWARN(WARN_REGEXP))
17988                         {
17989                             reg_warn_non_literal_string(
17990                                  RExC_parse + 1,
17991                                  form_alien_digit_msg(8, numlen, RExC_parse,
17992                                                         RExC_end, UTF, FALSE));
17993                         }
17994                     }
17995                     if (value < 256) {
17996                         non_portable_endpoint++;
17997                     }
17998                     break;
17999                 }
18000             default:
18001                 /* Allow \_ to not give an error */
18002                 if (isWORDCHAR(value) && value != '_') {
18003                     if (strict) {
18004                         vFAIL2("Unrecognized escape \\%c in character class",
18005                                (int)value);
18006                     }
18007                     else {
18008                         ckWARN2reg(RExC_parse,
18009                             "Unrecognized escape \\%c in character class passed through",
18010                             (int)value);
18011                     }
18012                 }
18013                 break;
18014             }   /* End of switch on char following backslash */
18015         } /* end of handling backslash escape sequences */
18016
18017         /* Here, we have the current token in 'value' */
18018
18019         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
18020             U8 classnum;
18021
18022             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
18023              * literal, as is the character that began the false range, i.e.
18024              * the 'a' in the examples */
18025             if (range) {
18026                 const int w = (RExC_parse >= rangebegin)
18027                                 ? RExC_parse - rangebegin
18028                                 : 0;
18029                 if (strict) {
18030                     vFAIL2utf8f(
18031                         "False [] range \"%" UTF8f "\"",
18032                         UTF8fARG(UTF, w, rangebegin));
18033                 }
18034                 else {
18035                     ckWARN2reg(RExC_parse,
18036                         "False [] range \"%" UTF8f "\"",
18037                         UTF8fARG(UTF, w, rangebegin));
18038                     cp_list = add_cp_to_invlist(cp_list, '-');
18039                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
18040                                                             prevvalue);
18041                 }
18042
18043                 range = 0; /* this was not a true range */
18044                 element_count += 2; /* So counts for three values */
18045             }
18046
18047             classnum = namedclass_to_classnum(namedclass);
18048
18049             if (LOC && namedclass < ANYOF_POSIXL_MAX
18050 #ifndef HAS_ISASCII
18051                 && classnum != _CC_ASCII
18052 #endif
18053             ) {
18054                 SV* scratch_list = NULL;
18055
18056                 /* What the Posix classes (like \w, [:space:]) match isn't
18057                  * generally knowable under locale until actual match time.  A
18058                  * special node is used for these which has extra space for a
18059                  * bitmap, with a bit reserved for each named class that is to
18060                  * be matched against.  (This isn't needed for \p{} and
18061                  * pseudo-classes, as they are not affected by locale, and
18062                  * hence are dealt with separately.)  However, if a named class
18063                  * and its complement are both present, then it matches
18064                  * everything, and there is no runtime dependency.  Odd numbers
18065                  * are the complements of the next lower number, so xor works.
18066                  * (Note that something like [\w\D] should match everything,
18067                  * because \d should be a proper subset of \w.  But rather than
18068                  * trust that the locale is well behaved, we leave this to
18069                  * runtime to sort out) */
18070                 if (POSIXL_TEST(posixl, namedclass ^ 1)) {
18071                     cp_list = _add_range_to_invlist(cp_list, 0, UV_MAX);
18072                     POSIXL_ZERO(posixl);
18073                     has_runtime_dependency &= ~HAS_L_RUNTIME_DEPENDENCY;
18074                     anyof_flags &= ~ANYOF_MATCHES_POSIXL;
18075                     continue;   /* We could ignore the rest of the class, but
18076                                    best to parse it for any errors */
18077                 }
18078                 else { /* Here, isn't the complement of any already parsed
18079                           class */
18080                     POSIXL_SET(posixl, namedclass);
18081                     has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18082                     anyof_flags |= ANYOF_MATCHES_POSIXL;
18083
18084                     /* The above-Latin1 characters are not subject to locale
18085                      * rules.  Just add them to the unconditionally-matched
18086                      * list */
18087
18088                     /* Get the list of the above-Latin1 code points this
18089                      * matches */
18090                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
18091                                             PL_XPosix_ptrs[classnum],
18092
18093                                             /* Odd numbers are complements,
18094                                              * like NDIGIT, NASCII, ... */
18095                                             namedclass % 2 != 0,
18096                                             &scratch_list);
18097                     /* Checking if 'cp_list' is NULL first saves an extra
18098                      * clone.  Its reference count will be decremented at the
18099                      * next union, etc, or if this is the only instance, at the
18100                      * end of the routine */
18101                     if (! cp_list) {
18102                         cp_list = scratch_list;
18103                     }
18104                     else {
18105                         _invlist_union(cp_list, scratch_list, &cp_list);
18106                         SvREFCNT_dec_NN(scratch_list);
18107                     }
18108                     continue;   /* Go get next character */
18109                 }
18110             }
18111             else {
18112
18113                 /* Here, is not /l, or is a POSIX class for which /l doesn't
18114                  * matter (or is a Unicode property, which is skipped here). */
18115                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
18116                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
18117
18118                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
18119                          * nor /l make a difference in what these match,
18120                          * therefore we just add what they match to cp_list. */
18121                         if (classnum != _CC_VERTSPACE) {
18122                             assert(   namedclass == ANYOF_HORIZWS
18123                                    || namedclass == ANYOF_NHORIZWS);
18124
18125                             /* It turns out that \h is just a synonym for
18126                              * XPosixBlank */
18127                             classnum = _CC_BLANK;
18128                         }
18129
18130                         _invlist_union_maybe_complement_2nd(
18131                                 cp_list,
18132                                 PL_XPosix_ptrs[classnum],
18133                                 namedclass % 2 != 0,    /* Complement if odd
18134                                                           (NHORIZWS, NVERTWS)
18135                                                         */
18136                                 &cp_list);
18137                     }
18138                 }
18139                 else if (   AT_LEAST_UNI_SEMANTICS
18140                          || classnum == _CC_ASCII
18141                          || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
18142                                                    || classnum == _CC_XDIGIT)))
18143                 {
18144                     /* We usually have to worry about /d affecting what POSIX
18145                      * classes match, with special code needed because we won't
18146                      * know until runtime what all matches.  But there is no
18147                      * extra work needed under /u and /a; and [:ascii:] is
18148                      * unaffected by /d; and :digit: and :xdigit: don't have
18149                      * runtime differences under /d.  So we can special case
18150                      * these, and avoid some extra work below, and at runtime.
18151                      * */
18152                     _invlist_union_maybe_complement_2nd(
18153                                                      simple_posixes,
18154                                                       ((AT_LEAST_ASCII_RESTRICTED)
18155                                                        ? PL_Posix_ptrs[classnum]
18156                                                        : PL_XPosix_ptrs[classnum]),
18157                                                      namedclass % 2 != 0,
18158                                                      &simple_posixes);
18159                 }
18160                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
18161                            complement and use nposixes */
18162                     SV** posixes_ptr = namedclass % 2 == 0
18163                                        ? &posixes
18164                                        : &nposixes;
18165                     _invlist_union_maybe_complement_2nd(
18166                                                      *posixes_ptr,
18167                                                      PL_XPosix_ptrs[classnum],
18168                                                      namedclass % 2 != 0,
18169                                                      posixes_ptr);
18170                 }
18171             }
18172         } /* end of namedclass \blah */
18173
18174         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end);
18175
18176         /* If 'range' is set, 'value' is the ending of a range--check its
18177          * validity.  (If value isn't a single code point in the case of a
18178          * range, we should have figured that out above in the code that
18179          * catches false ranges).  Later, we will handle each individual code
18180          * point in the range.  If 'range' isn't set, this could be the
18181          * beginning of a range, so check for that by looking ahead to see if
18182          * the next real character to be processed is the range indicator--the
18183          * minus sign */
18184
18185         if (range) {
18186 #ifdef EBCDIC
18187             /* For unicode ranges, we have to test that the Unicode as opposed
18188              * to the native values are not decreasing.  (Above 255, there is
18189              * no difference between native and Unicode) */
18190             if (unicode_range && prevvalue < 255 && value < 255) {
18191                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
18192                     goto backwards_range;
18193                 }
18194             }
18195             else
18196 #endif
18197             if (prevvalue > value) /* b-a */ {
18198                 int w;
18199 #ifdef EBCDIC
18200               backwards_range:
18201 #endif
18202                 w = RExC_parse - rangebegin;
18203                 vFAIL2utf8f(
18204                     "Invalid [] range \"%" UTF8f "\"",
18205                     UTF8fARG(UTF, w, rangebegin));
18206                 NOT_REACHED; /* NOTREACHED */
18207             }
18208         }
18209         else {
18210             prevvalue = value; /* save the beginning of the potential range */
18211             if (! stop_at_1     /* Can't be a range if parsing just one thing */
18212                 && *RExC_parse == '-')
18213             {
18214                 char* next_char_ptr = RExC_parse + 1;
18215
18216                 /* Get the next real char after the '-' */
18217                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr, RExC_end);
18218
18219                 /* If the '-' is at the end of the class (just before the ']',
18220                  * it is a literal minus; otherwise it is a range */
18221                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
18222                     RExC_parse = next_char_ptr;
18223
18224                     /* a bad range like \w-, [:word:]- ? */
18225                     if (namedclass > OOB_NAMEDCLASS) {
18226                         if (strict || ckWARN(WARN_REGEXP)) {
18227                             const int w = RExC_parse >= rangebegin
18228                                           ?  RExC_parse - rangebegin
18229                                           : 0;
18230                             if (strict) {
18231                                 vFAIL4("False [] range \"%*.*s\"",
18232                                     w, w, rangebegin);
18233                             }
18234                             else {
18235                                 vWARN4(RExC_parse,
18236                                     "False [] range \"%*.*s\"",
18237                                     w, w, rangebegin);
18238                             }
18239                         }
18240                         cp_list = add_cp_to_invlist(cp_list, '-');
18241                         element_count++;
18242                     } else
18243                         range = 1;      /* yeah, it's a range! */
18244                     continue;   /* but do it the next time */
18245                 }
18246             }
18247         }
18248
18249         if (namedclass > OOB_NAMEDCLASS) {
18250             continue;
18251         }
18252
18253         /* Here, we have a single value this time through the loop, and
18254          * <prevvalue> is the beginning of the range, if any; or <value> if
18255          * not. */
18256
18257         /* non-Latin1 code point implies unicode semantics. */
18258         if (value > 255) {
18259             if (value > MAX_LEGAL_CP && (   value != UV_MAX
18260                                          || prevvalue > MAX_LEGAL_CP))
18261             {
18262                 vFAIL(form_cp_too_large_msg(16, NULL, 0, value));
18263             }
18264             REQUIRE_UNI_RULES(flagp, 0);
18265             if (  ! silence_non_portable
18266                 &&  UNICODE_IS_PERL_EXTENDED(value)
18267                 &&  TO_OUTPUT_WARNINGS(RExC_parse))
18268             {
18269                 ckWARN2_non_literal_string(RExC_parse,
18270                                            packWARN(WARN_PORTABLE),
18271                                            PL_extended_cp_format,
18272                                            value);
18273             }
18274         }
18275
18276         /* Ready to process either the single value, or the completed range.
18277          * For single-valued non-inverted ranges, we consider the possibility
18278          * of multi-char folds.  (We made a conscious decision to not do this
18279          * for the other cases because it can often lead to non-intuitive
18280          * results.  For example, you have the peculiar case that:
18281          *  "s s" =~ /^[^\xDF]+$/i => Y
18282          *  "ss"  =~ /^[^\xDF]+$/i => N
18283          *
18284          * See [perl #89750] */
18285         if (FOLD && allow_mutiple_chars && value == prevvalue) {
18286             if (    value == LATIN_SMALL_LETTER_SHARP_S
18287                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
18288                                                         value)))
18289             {
18290                 /* Here <value> is indeed a multi-char fold.  Get what it is */
18291
18292                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
18293                 STRLEN foldlen;
18294
18295                 UV folded = _to_uni_fold_flags(
18296                                 value,
18297                                 foldbuf,
18298                                 &foldlen,
18299                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
18300                                                    ? FOLD_FLAGS_NOMIX_ASCII
18301                                                    : 0)
18302                                 );
18303
18304                 /* Here, <folded> should be the first character of the
18305                  * multi-char fold of <value>, with <foldbuf> containing the
18306                  * whole thing.  But, if this fold is not allowed (because of
18307                  * the flags), <fold> will be the same as <value>, and should
18308                  * be processed like any other character, so skip the special
18309                  * handling */
18310                 if (folded != value) {
18311
18312                     /* Skip if we are recursed, currently parsing the class
18313                      * again.  Otherwise add this character to the list of
18314                      * multi-char folds. */
18315                     if (! RExC_in_multi_char_class) {
18316                         STRLEN cp_count = utf8_length(foldbuf,
18317                                                       foldbuf + foldlen);
18318                         SV* multi_fold = sv_2mortal(newSVpvs(""));
18319
18320                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
18321
18322                         multi_char_matches
18323                                         = add_multi_match(multi_char_matches,
18324                                                           multi_fold,
18325                                                           cp_count);
18326
18327                     }
18328
18329                     /* This element should not be processed further in this
18330                      * class */
18331                     element_count--;
18332                     value = save_value;
18333                     prevvalue = save_prevvalue;
18334                     continue;
18335                 }
18336             }
18337         }
18338
18339         if (strict && ckWARN(WARN_REGEXP)) {
18340             if (range) {
18341
18342                 /* If the range starts above 255, everything is portable and
18343                  * likely to be so for any forseeable character set, so don't
18344                  * warn. */
18345                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
18346                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
18347                 }
18348                 else if (prevvalue != value) {
18349
18350                     /* Under strict, ranges that stop and/or end in an ASCII
18351                      * printable should have each end point be a portable value
18352                      * for it (preferably like 'A', but we don't warn if it is
18353                      * a (portable) Unicode name or code point), and the range
18354                      * must be all digits or all letters of the same case.
18355                      * Otherwise, the range is non-portable and unclear as to
18356                      * what it contains */
18357                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
18358                         && (          non_portable_endpoint
18359                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
18360                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
18361                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
18362                     ))) {
18363                         vWARN(RExC_parse, "Ranges of ASCII printables should"
18364                                           " be some subset of \"0-9\","
18365                                           " \"A-Z\", or \"a-z\"");
18366                     }
18367                     else if (prevvalue >= FIRST_NON_ASCII_DECIMAL_DIGIT) {
18368                         SSize_t index_start;
18369                         SSize_t index_final;
18370
18371                         /* But the nature of Unicode and languages mean we
18372                          * can't do the same checks for above-ASCII ranges,
18373                          * except in the case of digit ones.  These should
18374                          * contain only digits from the same group of 10.  The
18375                          * ASCII case is handled just above.  Hence here, the
18376                          * range could be a range of digits.  First some
18377                          * unlikely special cases.  Grandfather in that a range
18378                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
18379                          * if its starting value is one of the 10 digits prior
18380                          * to it.  This is because it is an alternate way of
18381                          * writing 19D1, and some people may expect it to be in
18382                          * that group.  But it is bad, because it won't give
18383                          * the expected results.  In Unicode 5.2 it was
18384                          * considered to be in that group (of 11, hence), but
18385                          * this was fixed in the next version */
18386
18387                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
18388                             goto warn_bad_digit_range;
18389                         }
18390                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
18391                                           &&     value <= 0x1D7FF))
18392                         {
18393                             /* This is the only other case currently in Unicode
18394                              * where the algorithm below fails.  The code
18395                              * points just above are the end points of a single
18396                              * range containing only decimal digits.  It is 5
18397                              * different series of 0-9.  All other ranges of
18398                              * digits currently in Unicode are just a single
18399                              * series.  (And mktables will notify us if a later
18400                              * Unicode version breaks this.)
18401                              *
18402                              * If the range being checked is at most 9 long,
18403                              * and the digit values represented are in
18404                              * numerical order, they are from the same series.
18405                              * */
18406                             if (         value - prevvalue > 9
18407                                 ||    (((    value - 0x1D7CE) % 10)
18408                                      <= (prevvalue - 0x1D7CE) % 10))
18409                             {
18410                                 goto warn_bad_digit_range;
18411                             }
18412                         }
18413                         else {
18414
18415                             /* For all other ranges of digits in Unicode, the
18416                              * algorithm is just to check if both end points
18417                              * are in the same series, which is the same range.
18418                              * */
18419                             index_start = _invlist_search(
18420                                                     PL_XPosix_ptrs[_CC_DIGIT],
18421                                                     prevvalue);
18422
18423                             /* Warn if the range starts and ends with a digit,
18424                              * and they are not in the same group of 10. */
18425                             if (   index_start >= 0
18426                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
18427                                 && (index_final =
18428                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
18429                                                     value)) != index_start
18430                                 && index_final >= 0
18431                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
18432                             {
18433                               warn_bad_digit_range:
18434                                 vWARN(RExC_parse, "Ranges of digits should be"
18435                                                   " from the same group of"
18436                                                   " 10");
18437                             }
18438                         }
18439                     }
18440                 }
18441             }
18442             if ((! range || prevvalue == value) && non_portable_endpoint) {
18443                 if (isPRINT_A(value)) {
18444                     char literal[3];
18445                     unsigned d = 0;
18446                     if (isBACKSLASHED_PUNCT(value)) {
18447                         literal[d++] = '\\';
18448                     }
18449                     literal[d++] = (char) value;
18450                     literal[d++] = '\0';
18451
18452                     vWARN4(RExC_parse,
18453                            "\"%.*s\" is more clearly written simply as \"%s\"",
18454                            (int) (RExC_parse - rangebegin),
18455                            rangebegin,
18456                            literal
18457                         );
18458                 }
18459                 else if (isMNEMONIC_CNTRL(value)) {
18460                     vWARN4(RExC_parse,
18461                            "\"%.*s\" is more clearly written simply as \"%s\"",
18462                            (int) (RExC_parse - rangebegin),
18463                            rangebegin,
18464                            cntrl_to_mnemonic((U8) value)
18465                         );
18466                 }
18467             }
18468         }
18469
18470         /* Deal with this element of the class */
18471
18472 #ifndef EBCDIC
18473         cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
18474                                                     prevvalue, value);
18475 #else
18476         /* On non-ASCII platforms, for ranges that span all of 0..255, and ones
18477          * that don't require special handling, we can just add the range like
18478          * we do for ASCII platforms */
18479         if ((UNLIKELY(prevvalue == 0) && value >= 255)
18480             || ! (prevvalue < 256
18481                     && (unicode_range
18482                         || (! non_portable_endpoint
18483                             && ((isLOWER_A(prevvalue) && isLOWER_A(value))
18484                                 || (isUPPER_A(prevvalue)
18485                                     && isUPPER_A(value)))))))
18486         {
18487             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
18488                                                         prevvalue, value);
18489         }
18490         else {
18491             /* Here, requires special handling.  This can be because it is a
18492              * range whose code points are considered to be Unicode, and so
18493              * must be individually translated into native, or because its a
18494              * subrange of 'A-Z' or 'a-z' which each aren't contiguous in
18495              * EBCDIC, but we have defined them to include only the "expected"
18496              * upper or lower case ASCII alphabetics.  Subranges above 255 are
18497              * the same in native and Unicode, so can be added as a range */
18498             U8 start = NATIVE_TO_LATIN1(prevvalue);
18499             unsigned j;
18500             U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
18501             for (j = start; j <= end; j++) {
18502                 cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
18503             }
18504             if (value > 255) {
18505                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
18506                                                             256, value);
18507             }
18508         }
18509 #endif
18510
18511         range = 0; /* this range (if it was one) is done now */
18512     } /* End of loop through all the text within the brackets */
18513
18514     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
18515         output_posix_warnings(pRExC_state, posix_warnings);
18516     }
18517
18518     /* If anything in the class expands to more than one character, we have to
18519      * deal with them by building up a substitute parse string, and recursively
18520      * calling reg() on it, instead of proceeding */
18521     if (multi_char_matches) {
18522         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
18523         I32 cp_count;
18524         STRLEN len;
18525         char *save_end = RExC_end;
18526         char *save_parse = RExC_parse;
18527         char *save_start = RExC_start;
18528         Size_t constructed_prefix_len = 0; /* This gives the length of the
18529                                               constructed portion of the
18530                                               substitute parse. */
18531         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
18532                                        a "|" */
18533         I32 reg_flags;
18534
18535         assert(! invert);
18536         /* Only one level of recursion allowed */
18537         assert(RExC_copy_start_in_constructed == RExC_precomp);
18538
18539 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
18540            because too confusing */
18541         if (invert) {
18542             sv_catpvs(substitute_parse, "(?:");
18543         }
18544 #endif
18545
18546         /* Look at the longest strings first */
18547         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
18548                         cp_count > 0;
18549                         cp_count--)
18550         {
18551
18552             if (av_exists(multi_char_matches, cp_count)) {
18553                 AV** this_array_ptr;
18554                 SV* this_sequence;
18555
18556                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
18557                                                  cp_count, FALSE);
18558                 while ((this_sequence = av_pop(*this_array_ptr)) !=
18559                                                                 &PL_sv_undef)
18560                 {
18561                     if (! first_time) {
18562                         sv_catpvs(substitute_parse, "|");
18563                     }
18564                     first_time = FALSE;
18565
18566                     sv_catpv(substitute_parse, SvPVX(this_sequence));
18567                 }
18568             }
18569         }
18570
18571         /* If the character class contains anything else besides these
18572          * multi-character strings, have to include it in recursive parsing */
18573         if (element_count) {
18574             bool has_l_bracket = orig_parse > RExC_start && *(orig_parse - 1) == '[';
18575
18576             sv_catpvs(substitute_parse, "|");
18577             if (has_l_bracket) {    /* Add an [ if the original had one */
18578                 sv_catpvs(substitute_parse, "[");
18579             }
18580             constructed_prefix_len = SvCUR(substitute_parse);
18581             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
18582
18583             /* Put in a closing ']' to match any opening one, but not if going
18584              * off the end, as otherwise we are adding something that really
18585              * isn't there */
18586             if (has_l_bracket && RExC_parse < RExC_end) {
18587                 sv_catpvs(substitute_parse, "]");
18588             }
18589         }
18590
18591         sv_catpvs(substitute_parse, ")");
18592 #if 0
18593         if (invert) {
18594             /* This is a way to get the parse to skip forward a whole named
18595              * sequence instead of matching the 2nd character when it fails the
18596              * first */
18597             sv_catpvs(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
18598         }
18599 #endif
18600
18601         /* Set up the data structure so that any errors will be properly
18602          * reported.  See the comments at the definition of
18603          * REPORT_LOCATION_ARGS for details */
18604         RExC_copy_start_in_input = (char *) orig_parse;
18605         RExC_start = RExC_parse = SvPV(substitute_parse, len);
18606         RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len;
18607         RExC_end = RExC_parse + len;
18608         RExC_in_multi_char_class = 1;
18609
18610         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
18611
18612         *flagp |= reg_flags & (HASWIDTH|SIMPLE|POSTPONED|RESTART_PARSE|NEED_UTF8);
18613
18614         /* And restore so can parse the rest of the pattern */
18615         RExC_parse = save_parse;
18616         RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start;
18617         RExC_end = save_end;
18618         RExC_in_multi_char_class = 0;
18619         SvREFCNT_dec_NN(multi_char_matches);
18620         return ret;
18621     }
18622
18623     /* If folding, we calculate all characters that could fold to or from the
18624      * ones already on the list */
18625     if (cp_foldable_list) {
18626         if (FOLD) {
18627             UV start, end;      /* End points of code point ranges */
18628
18629             SV* fold_intersection = NULL;
18630             SV** use_list;
18631
18632             /* Our calculated list will be for Unicode rules.  For locale
18633              * matching, we have to keep a separate list that is consulted at
18634              * runtime only when the locale indicates Unicode rules (and we
18635              * don't include potential matches in the ASCII/Latin1 range, as
18636              * any code point could fold to any other, based on the run-time
18637              * locale).   For non-locale, we just use the general list */
18638             if (LOC) {
18639                 use_list = &only_utf8_locale_list;
18640             }
18641             else {
18642                 use_list = &cp_list;
18643             }
18644
18645             /* Only the characters in this class that participate in folds need
18646              * be checked.  Get the intersection of this class and all the
18647              * possible characters that are foldable.  This can quickly narrow
18648              * down a large class */
18649             _invlist_intersection(PL_in_some_fold, cp_foldable_list,
18650                                   &fold_intersection);
18651
18652             /* Now look at the foldable characters in this class individually */
18653             invlist_iterinit(fold_intersection);
18654             while (invlist_iternext(fold_intersection, &start, &end)) {
18655                 UV j;
18656                 UV folded;
18657
18658                 /* Look at every character in the range */
18659                 for (j = start; j <= end; j++) {
18660                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
18661                     STRLEN foldlen;
18662                     unsigned int k;
18663                     Size_t folds_count;
18664                     U32 first_fold;
18665                     const U32 * remaining_folds;
18666
18667                     if (j < 256) {
18668
18669                         /* Under /l, we don't know what code points below 256
18670                          * fold to, except we do know the MICRO SIGN folds to
18671                          * an above-255 character if the locale is UTF-8, so we
18672                          * add it to the special list (in *use_list)  Otherwise
18673                          * we know now what things can match, though some folds
18674                          * are valid under /d only if the target is UTF-8.
18675                          * Those go in a separate list */
18676                         if (      IS_IN_SOME_FOLD_L1(j)
18677                             && ! (LOC && j != MICRO_SIGN))
18678                         {
18679
18680                             /* ASCII is always matched; non-ASCII is matched
18681                              * only under Unicode rules (which could happen
18682                              * under /l if the locale is a UTF-8 one */
18683                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
18684                                 *use_list = add_cp_to_invlist(*use_list,
18685                                                             PL_fold_latin1[j]);
18686                             }
18687                             else if (j != PL_fold_latin1[j]) {
18688                                 upper_latin1_only_utf8_matches
18689                                         = add_cp_to_invlist(
18690                                                 upper_latin1_only_utf8_matches,
18691                                                 PL_fold_latin1[j]);
18692                             }
18693                         }
18694
18695                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
18696                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
18697                         {
18698                             add_above_Latin1_folds(pRExC_state,
18699                                                    (U8) j,
18700                                                    use_list);
18701                         }
18702                         continue;
18703                     }
18704
18705                     /* Here is an above Latin1 character.  We don't have the
18706                      * rules hard-coded for it.  First, get its fold.  This is
18707                      * the simple fold, as the multi-character folds have been
18708                      * handled earlier and separated out */
18709                     folded = _to_uni_fold_flags(j, foldbuf, &foldlen,
18710                                                         (ASCII_FOLD_RESTRICTED)
18711                                                         ? FOLD_FLAGS_NOMIX_ASCII
18712                                                         : 0);
18713
18714                     /* Single character fold of above Latin1.  Add everything
18715                      * in its fold closure to the list that this node should
18716                      * match. */
18717                     folds_count = _inverse_folds(folded, &first_fold,
18718                                                     &remaining_folds);
18719                     for (k = 0; k <= folds_count; k++) {
18720                         UV c = (k == 0)     /* First time through use itself */
18721                                 ? folded
18722                                 : (k == 1)  /* 2nd time use, the first fold */
18723                                    ? first_fold
18724
18725                                      /* Then the remaining ones */
18726                                    : remaining_folds[k-2];
18727
18728                         /* /aa doesn't allow folds between ASCII and non- */
18729                         if ((   ASCII_FOLD_RESTRICTED
18730                             && (isASCII(c) != isASCII(j))))
18731                         {
18732                             continue;
18733                         }
18734
18735                         /* Folds under /l which cross the 255/256 boundary are
18736                          * added to a separate list.  (These are valid only
18737                          * when the locale is UTF-8.) */
18738                         if (c < 256 && LOC) {
18739                             *use_list = add_cp_to_invlist(*use_list, c);
18740                             continue;
18741                         }
18742
18743                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
18744                         {
18745                             cp_list = add_cp_to_invlist(cp_list, c);
18746                         }
18747                         else {
18748                             /* Similarly folds involving non-ascii Latin1
18749                              * characters under /d are added to their list */
18750                             upper_latin1_only_utf8_matches
18751                                     = add_cp_to_invlist(
18752                                                 upper_latin1_only_utf8_matches,
18753                                                 c);
18754                         }
18755                     }
18756                 }
18757             }
18758             SvREFCNT_dec_NN(fold_intersection);
18759         }
18760
18761         /* Now that we have finished adding all the folds, there is no reason
18762          * to keep the foldable list separate */
18763         _invlist_union(cp_list, cp_foldable_list, &cp_list);
18764         SvREFCNT_dec_NN(cp_foldable_list);
18765     }
18766
18767     /* And combine the result (if any) with any inversion lists from posix
18768      * classes.  The lists are kept separate up to now because we don't want to
18769      * fold the classes */
18770     if (simple_posixes) {   /* These are the classes known to be unaffected by
18771                                /a, /aa, and /d */
18772         if (cp_list) {
18773             _invlist_union(cp_list, simple_posixes, &cp_list);
18774             SvREFCNT_dec_NN(simple_posixes);
18775         }
18776         else {
18777             cp_list = simple_posixes;
18778         }
18779     }
18780     if (posixes || nposixes) {
18781         if (! DEPENDS_SEMANTICS) {
18782
18783             /* For everything but /d, we can just add the current 'posixes' and
18784              * 'nposixes' to the main list */
18785             if (posixes) {
18786                 if (cp_list) {
18787                     _invlist_union(cp_list, posixes, &cp_list);
18788                     SvREFCNT_dec_NN(posixes);
18789                 }
18790                 else {
18791                     cp_list = posixes;
18792                 }
18793             }
18794             if (nposixes) {
18795                 if (cp_list) {
18796                     _invlist_union(cp_list, nposixes, &cp_list);
18797                     SvREFCNT_dec_NN(nposixes);
18798                 }
18799                 else {
18800                     cp_list = nposixes;
18801                 }
18802             }
18803         }
18804         else {
18805             /* Under /d, things like \w match upper Latin1 characters only if
18806              * the target string is in UTF-8.  But things like \W match all the
18807              * upper Latin1 characters if the target string is not in UTF-8.
18808              *
18809              * Handle the case with something like \W separately */
18810             if (nposixes) {
18811                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1, NULL);
18812
18813                 /* A complemented posix class matches all upper Latin1
18814                  * characters if not in UTF-8.  And it matches just certain
18815                  * ones when in UTF-8.  That means those certain ones are
18816                  * matched regardless, so can just be added to the
18817                  * unconditional list */
18818                 if (cp_list) {
18819                     _invlist_union(cp_list, nposixes, &cp_list);
18820                     SvREFCNT_dec_NN(nposixes);
18821                     nposixes = NULL;
18822                 }
18823                 else {
18824                     cp_list = nposixes;
18825                 }
18826
18827                 /* Likewise for 'posixes' */
18828                 _invlist_union(posixes, cp_list, &cp_list);
18829                 SvREFCNT_dec(posixes);
18830
18831                 /* Likewise for anything else in the range that matched only
18832                  * under UTF-8 */
18833                 if (upper_latin1_only_utf8_matches) {
18834                     _invlist_union(cp_list,
18835                                    upper_latin1_only_utf8_matches,
18836                                    &cp_list);
18837                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18838                     upper_latin1_only_utf8_matches = NULL;
18839                 }
18840
18841                 /* If we don't match all the upper Latin1 characters regardless
18842                  * of UTF-8ness, we have to set a flag to match the rest when
18843                  * not in UTF-8 */
18844                 _invlist_subtract(only_non_utf8_list, cp_list,
18845                                   &only_non_utf8_list);
18846                 if (_invlist_len(only_non_utf8_list) != 0) {
18847                     anyof_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18848                 }
18849                 SvREFCNT_dec_NN(only_non_utf8_list);
18850             }
18851             else {
18852                 /* Here there were no complemented posix classes.  That means
18853                  * the upper Latin1 characters in 'posixes' match only when the
18854                  * target string is in UTF-8.  So we have to add them to the
18855                  * list of those types of code points, while adding the
18856                  * remainder to the unconditional list.
18857                  *
18858                  * First calculate what they are */
18859                 SV* nonascii_but_latin1_properties = NULL;
18860                 _invlist_intersection(posixes, PL_UpperLatin1,
18861                                       &nonascii_but_latin1_properties);
18862
18863                 /* And add them to the final list of such characters. */
18864                 _invlist_union(upper_latin1_only_utf8_matches,
18865                                nonascii_but_latin1_properties,
18866                                &upper_latin1_only_utf8_matches);
18867
18868                 /* Remove them from what now becomes the unconditional list */
18869                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
18870                                   &posixes);
18871
18872                 /* And add those unconditional ones to the final list */
18873                 if (cp_list) {
18874                     _invlist_union(cp_list, posixes, &cp_list);
18875                     SvREFCNT_dec_NN(posixes);
18876                     posixes = NULL;
18877                 }
18878                 else {
18879                     cp_list = posixes;
18880                 }
18881
18882                 SvREFCNT_dec(nonascii_but_latin1_properties);
18883
18884                 /* Get rid of any characters from the conditional list that we
18885                  * now know are matched unconditionally, which may make that
18886                  * list empty */
18887                 _invlist_subtract(upper_latin1_only_utf8_matches,
18888                                   cp_list,
18889                                   &upper_latin1_only_utf8_matches);
18890                 if (_invlist_len(upper_latin1_only_utf8_matches) == 0) {
18891                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18892                     upper_latin1_only_utf8_matches = NULL;
18893                 }
18894             }
18895         }
18896     }
18897
18898     /* And combine the result (if any) with any inversion list from properties.
18899      * The lists are kept separate up to now so that we can distinguish the two
18900      * in regards to matching above-Unicode.  A run-time warning is generated
18901      * if a Unicode property is matched against a non-Unicode code point. But,
18902      * we allow user-defined properties to match anything, without any warning,
18903      * and we also suppress the warning if there is a portion of the character
18904      * class that isn't a Unicode property, and which matches above Unicode, \W
18905      * or [\x{110000}] for example.
18906      * (Note that in this case, unlike the Posix one above, there is no
18907      * <upper_latin1_only_utf8_matches>, because having a Unicode property
18908      * forces Unicode semantics */
18909     if (properties) {
18910         if (cp_list) {
18911
18912             /* If it matters to the final outcome, see if a non-property
18913              * component of the class matches above Unicode.  If so, the
18914              * warning gets suppressed.  This is true even if just a single
18915              * such code point is specified, as, though not strictly correct if
18916              * another such code point is matched against, the fact that they
18917              * are using above-Unicode code points indicates they should know
18918              * the issues involved */
18919             if (warn_super) {
18920                 warn_super = ! (invert
18921                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
18922             }
18923
18924             _invlist_union(properties, cp_list, &cp_list);
18925             SvREFCNT_dec_NN(properties);
18926         }
18927         else {
18928             cp_list = properties;
18929         }
18930
18931         if (warn_super) {
18932             anyof_flags
18933              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18934
18935             /* Because an ANYOF node is the only one that warns, this node
18936              * can't be optimized into something else */
18937             optimizable = FALSE;
18938         }
18939     }
18940
18941     /* Here, we have calculated what code points should be in the character
18942      * class.
18943      *
18944      * Now we can see about various optimizations.  Fold calculation (which we
18945      * did above) needs to take place before inversion.  Otherwise /[^k]/i
18946      * would invert to include K, which under /i would match k, which it
18947      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
18948      * folded until runtime */
18949
18950     /* If we didn't do folding, it's because some information isn't available
18951      * until runtime; set the run-time fold flag for these  We know to set the
18952      * flag if we have a non-NULL list for UTF-8 locales, or the class matches
18953      * at least one 0-255 range code point */
18954     if (LOC && FOLD) {
18955
18956         /* Some things on the list might be unconditionally included because of
18957          * other components.  Remove them, and clean up the list if it goes to
18958          * 0 elements */
18959         if (only_utf8_locale_list && cp_list) {
18960             _invlist_subtract(only_utf8_locale_list, cp_list,
18961                               &only_utf8_locale_list);
18962
18963             if (_invlist_len(only_utf8_locale_list) == 0) {
18964                 SvREFCNT_dec_NN(only_utf8_locale_list);
18965                 only_utf8_locale_list = NULL;
18966             }
18967         }
18968         if (    only_utf8_locale_list
18969             || (cp_list && (   _invlist_contains_cp(cp_list, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
18970                             || _invlist_contains_cp(cp_list, LATIN_SMALL_LETTER_DOTLESS_I))))
18971         {
18972             has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18973             anyof_flags
18974                  |= ANYOFL_FOLD
18975                  |  ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
18976         }
18977         else if (cp_list && invlist_lowest(cp_list) < 256) {
18978             /* If nothing is below 256, has no locale dependency; otherwise it
18979              * does */
18980             anyof_flags |= ANYOFL_FOLD;
18981             has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18982         }
18983     }
18984     else if (   DEPENDS_SEMANTICS
18985              && (    upper_latin1_only_utf8_matches
18986                  || (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
18987     {
18988         RExC_seen_d_op = TRUE;
18989         has_runtime_dependency |= HAS_D_RUNTIME_DEPENDENCY;
18990     }
18991
18992     /* Optimize inverted patterns (e.g. [^a-z]) when everything is known at
18993      * compile time. */
18994     if (     cp_list
18995         &&   invert
18996         && ! has_runtime_dependency)
18997     {
18998         _invlist_invert(cp_list);
18999
19000         /* Clear the invert flag since have just done it here */
19001         invert = FALSE;
19002     }
19003
19004     /* All possible optimizations below still have these characteristics.
19005      * (Multi-char folds aren't SIMPLE, but they don't get this far in this
19006      * routine) */
19007     *flagp |= HASWIDTH|SIMPLE;
19008
19009     if (ret_invlist) {
19010         *ret_invlist = cp_list;
19011
19012         return (cp_list) ? RExC_emit : 0;
19013     }
19014
19015     if (anyof_flags & ANYOF_LOCALE_FLAGS) {
19016         RExC_contains_locale = 1;
19017     }
19018
19019     /* Some character classes are equivalent to other nodes.  Such nodes take
19020      * up less room, and some nodes require fewer operations to execute, than
19021      * ANYOF nodes.  EXACTish nodes may be joinable with adjacent nodes to
19022      * improve efficiency. */
19023
19024     if (optimizable) {
19025         PERL_UINT_FAST8_T i;
19026         UV partial_cp_count = 0;
19027         UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
19028         UV   end[MAX_FOLD_FROMS+1] = { 0 };
19029         bool single_range = FALSE;
19030
19031         if (cp_list) { /* Count the code points in enough ranges that we would
19032                           see all the ones possible in any fold in this version
19033                           of Unicode */
19034
19035             invlist_iterinit(cp_list);
19036             for (i = 0; i <= MAX_FOLD_FROMS; i++) {
19037                 if (! invlist_iternext(cp_list, &start[i], &end[i])) {
19038                     break;
19039                 }
19040                 partial_cp_count += end[i] - start[i] + 1;
19041             }
19042
19043             if (i == 1) {
19044                 single_range = TRUE;
19045             }
19046             invlist_iterfinish(cp_list);
19047         }
19048
19049         /* If we know at compile time that this matches every possible code
19050          * point, any run-time dependencies don't matter */
19051         if (start[0] == 0 && end[0] == UV_MAX) {
19052             if (invert) {
19053                 ret = reganode(pRExC_state, OPFAIL, 0);
19054             }
19055             else {
19056                 ret = reg_node(pRExC_state, SANY);
19057                 MARK_NAUGHTY(1);
19058             }
19059             goto not_anyof;
19060         }
19061
19062         /* Similarly, for /l posix classes, if both a class and its
19063          * complement match, any run-time dependencies don't matter */
19064         if (posixl) {
19065             for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX;
19066                                                         namedclass += 2)
19067             {
19068                 if (   POSIXL_TEST(posixl, namedclass)      /* class */
19069                     && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
19070                 {
19071                     if (invert) {
19072                         ret = reganode(pRExC_state, OPFAIL, 0);
19073                     }
19074                     else {
19075                         ret = reg_node(pRExC_state, SANY);
19076                         MARK_NAUGHTY(1);
19077                     }
19078                     goto not_anyof;
19079                 }
19080             }
19081
19082             /* For well-behaved locales, some classes are subsets of others,
19083              * so complementing the subset and including the non-complemented
19084              * superset should match everything, like [\D[:alnum:]], and
19085              * [[:^alpha:][:alnum:]], but some implementations of locales are
19086              * buggy, and khw thinks its a bad idea to have optimization change
19087              * behavior, even if it avoids an OS bug in a given case */
19088
19089 #define isSINGLE_BIT_SET(n) isPOWER_OF_2(n)
19090
19091             /* If is a single posix /l class, can optimize to just that op.
19092              * Such a node will not match anything in the Latin1 range, as that
19093              * is not determinable until runtime, but will match whatever the
19094              * class does outside that range.  (Note that some classes won't
19095              * match anything outside the range, like [:ascii:]) */
19096             if (    isSINGLE_BIT_SET(posixl)
19097                 && (partial_cp_count == 0 || start[0] > 255))
19098             {
19099                 U8 classnum;
19100                 SV * class_above_latin1 = NULL;
19101                 bool already_inverted;
19102                 bool are_equivalent;
19103
19104                 /* Compute which bit is set, which is the same thing as, e.g.,
19105                  * ANYOF_CNTRL.  From
19106                  * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn
19107                  * */
19108                 static const int MultiplyDeBruijnBitPosition2[32] =
19109                     {
19110                     0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
19111                     31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
19112                     };
19113
19114                 namedclass = MultiplyDeBruijnBitPosition2[(posixl
19115                                                           * 0x077CB531U) >> 27];
19116                 classnum = namedclass_to_classnum(namedclass);
19117
19118                 /* The named classes are such that the inverted number is one
19119                  * larger than the non-inverted one */
19120                 already_inverted = namedclass
19121                                  - classnum_to_namedclass(classnum);
19122
19123                 /* Create an inversion list of the official property, inverted
19124                  * if the constructed node list is inverted, and restricted to
19125                  * only the above latin1 code points, which are the only ones
19126                  * known at compile time */
19127                 _invlist_intersection_maybe_complement_2nd(
19128                                                     PL_AboveLatin1,
19129                                                     PL_XPosix_ptrs[classnum],
19130                                                     already_inverted,
19131                                                     &class_above_latin1);
19132                 are_equivalent = _invlistEQ(class_above_latin1, cp_list,
19133                                                                         FALSE);
19134                 SvREFCNT_dec_NN(class_above_latin1);
19135
19136                 if (are_equivalent) {
19137
19138                     /* Resolve the run-time inversion flag with this possibly
19139                      * inverted class */
19140                     invert = invert ^ already_inverted;
19141
19142                     ret = reg_node(pRExC_state,
19143                                    POSIXL + invert * (NPOSIXL - POSIXL));
19144                     FLAGS(REGNODE_p(ret)) = classnum;
19145                     goto not_anyof;
19146                 }
19147             }
19148         }
19149
19150         /* khw can't think of any other possible transformation involving
19151          * these. */
19152         if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
19153             goto is_anyof;
19154         }
19155
19156         if (! has_runtime_dependency) {
19157
19158             /* If the list is empty, nothing matches.  This happens, for
19159              * example, when a Unicode property that doesn't match anything is
19160              * the only element in the character class (perluniprops.pod notes
19161              * such properties). */
19162             if (partial_cp_count == 0) {
19163                 if (invert) {
19164                     ret = reg_node(pRExC_state, SANY);
19165                 }
19166                 else {
19167                     ret = reganode(pRExC_state, OPFAIL, 0);
19168                 }
19169
19170                 goto not_anyof;
19171             }
19172
19173             /* If matches everything but \n */
19174             if (   start[0] == 0 && end[0] == '\n' - 1
19175                 && start[1] == '\n' + 1 && end[1] == UV_MAX)
19176             {
19177                 assert (! invert);
19178                 ret = reg_node(pRExC_state, REG_ANY);
19179                 MARK_NAUGHTY(1);
19180                 goto not_anyof;
19181             }
19182         }
19183
19184         /* Next see if can optimize classes that contain just a few code points
19185          * into an EXACTish node.  The reason to do this is to let the
19186          * optimizer join this node with adjacent EXACTish ones, and ANYOF
19187          * nodes require conversion to code point from UTF-8.
19188          *
19189          * An EXACTFish node can be generated even if not under /i, and vice
19190          * versa.  But care must be taken.  An EXACTFish node has to be such
19191          * that it only matches precisely the code points in the class, but we
19192          * want to generate the least restrictive one that does that, to
19193          * increase the odds of being able to join with an adjacent node.  For
19194          * example, if the class contains [kK], we have to make it an EXACTFAA
19195          * node to prevent the KELVIN SIGN from matching.  Whether we are under
19196          * /i or not is irrelevant in this case.  Less obvious is the pattern
19197          * qr/[\x{02BC}]n/i.  U+02BC is MODIFIER LETTER APOSTROPHE. That is
19198          * supposed to match the single character U+0149 LATIN SMALL LETTER N
19199          * PRECEDED BY APOSTROPHE.  And so even though there is no simple fold
19200          * that includes \X{02BC}, there is a multi-char fold that does, and so
19201          * the node generated for it must be an EXACTFish one.  On the other
19202          * hand qr/:/i should generate a plain EXACT node since the colon
19203          * participates in no fold whatsoever, and having it EXACT tells the
19204          * optimizer the target string cannot match unless it has a colon in
19205          * it.
19206          */
19207         if (   ! posixl
19208             && ! invert
19209
19210                 /* Only try if there are no more code points in the class than
19211                  * in the max possible fold */
19212             &&   inRANGE(partial_cp_count, 1, MAX_FOLD_FROMS + 1))
19213         {
19214             if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches)
19215             {
19216                 /* We can always make a single code point class into an
19217                  * EXACTish node. */
19218
19219                 if (LOC) {
19220
19221                     /* Here is /l:  Use EXACTL, except if there is a fold not
19222                      * known until runtime so shows as only a single code point
19223                      * here.  For code points above 255, we know which can
19224                      * cause problems by having a potential fold to the Latin1
19225                      * range. */
19226                     if (  ! FOLD
19227                         || (     start[0] > 255
19228                             && ! is_PROBLEMATIC_LOCALE_FOLD_cp(start[0])))
19229                     {
19230                         op = EXACTL;
19231                     }
19232                     else {
19233                         op = EXACTFL;
19234                     }
19235                 }
19236                 else if (! FOLD) { /* Not /l and not /i */
19237                     op = (start[0] < 256) ? EXACT : EXACT_REQ8;
19238                 }
19239                 else if (start[0] < 256) { /* /i, not /l, and the code point is
19240                                               small */
19241
19242                     /* Under /i, it gets a little tricky.  A code point that
19243                      * doesn't participate in a fold should be an EXACT node.
19244                      * We know this one isn't the result of a simple fold, or
19245                      * there'd be more than one code point in the list, but it
19246                      * could be part of a multi- character fold.  In that case
19247                      * we better not create an EXACT node, as we would wrongly
19248                      * be telling the optimizer that this code point must be in
19249                      * the target string, and that is wrong.  This is because
19250                      * if the sequence around this code point forms a
19251                      * multi-char fold, what needs to be in the string could be
19252                      * the code point that folds to the sequence.
19253                      *
19254                      * This handles the case of below-255 code points, as we
19255                      * have an easy look up for those.  The next clause handles
19256                      * the above-256 one */
19257                     op = IS_IN_SOME_FOLD_L1(start[0])
19258                          ? EXACTFU
19259                          : EXACT;
19260                 }
19261                 else {  /* /i, larger code point.  Since we are under /i, and
19262                            have just this code point, we know that it can't
19263                            fold to something else, so PL_InMultiCharFold
19264                            applies to it */
19265                     op = _invlist_contains_cp(PL_InMultiCharFold,
19266                                               start[0])
19267                          ? EXACTFU_REQ8
19268                          : EXACT_REQ8;
19269                 }
19270
19271                 value = start[0];
19272             }
19273             else if (  ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
19274                      && _invlist_contains_cp(PL_in_some_fold, start[0]))
19275             {
19276                 /* Here, the only runtime dependency, if any, is from /d, and
19277                  * the class matches more than one code point, and the lowest
19278                  * code point participates in some fold.  It might be that the
19279                  * other code points are /i equivalent to this one, and hence
19280                  * they would representable by an EXACTFish node.  Above, we
19281                  * eliminated classes that contain too many code points to be
19282                  * EXACTFish, with the test for MAX_FOLD_FROMS
19283                  *
19284                  * First, special case the ASCII fold pairs, like 'B' and 'b'.
19285                  * We do this because we have EXACTFAA at our disposal for the
19286                  * ASCII range */
19287                 if (partial_cp_count == 2 && isASCII(start[0])) {
19288
19289                     /* The only ASCII characters that participate in folds are
19290                      * alphabetics */
19291                     assert(isALPHA(start[0]));
19292                     if (   end[0] == start[0]   /* First range is a single
19293                                                    character, so 2nd exists */
19294                         && isALPHA_FOLD_EQ(start[0], start[1]))
19295                     {
19296
19297                         /* Here, is part of an ASCII fold pair */
19298
19299                         if (   ASCII_FOLD_RESTRICTED
19300                             || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(start[0]))
19301                         {
19302                             /* If the second clause just above was true, it
19303                              * means we can't be under /i, or else the list
19304                              * would have included more than this fold pair.
19305                              * Therefore we have to exclude the possibility of
19306                              * whatever else it is that folds to these, by
19307                              * using EXACTFAA */
19308                             op = EXACTFAA;
19309                         }
19310                         else if (HAS_NONLATIN1_FOLD_CLOSURE(start[0])) {
19311
19312                             /* Here, there's no simple fold that start[0] is part
19313                              * of, but there is a multi-character one.  If we
19314                              * are not under /i, we want to exclude that
19315                              * possibility; if under /i, we want to include it
19316                              * */
19317                             op = (FOLD) ? EXACTFU : EXACTFAA;
19318                         }
19319                         else {
19320
19321                             /* Here, the only possible fold start[0] particpates in
19322                              * is with start[1].  /i or not isn't relevant */
19323                             op = EXACTFU;
19324                         }
19325
19326                         value = toFOLD(start[0]);
19327                     }
19328                 }
19329                 else if (  ! upper_latin1_only_utf8_matches
19330                          || (   _invlist_len(upper_latin1_only_utf8_matches)
19331                                                                           == 2
19332                              && PL_fold_latin1[
19333                                invlist_highest(upper_latin1_only_utf8_matches)]
19334                              == start[0]))
19335                 {
19336                     /* Here, the smallest character is non-ascii or there are
19337                      * more than 2 code points matched by this node.  Also, we
19338                      * either don't have /d UTF-8 dependent matches, or if we
19339                      * do, they look like they could be a single character that
19340                      * is the fold of the lowest one in the always-match list.
19341                      * This test quickly excludes most of the false positives
19342                      * when there are /d UTF-8 depdendent matches.  These are
19343                      * like LATIN CAPITAL LETTER A WITH GRAVE matching LATIN
19344                      * SMALL LETTER A WITH GRAVE iff the target string is
19345                      * UTF-8.  (We don't have to worry above about exceeding
19346                      * the array bounds of PL_fold_latin1[] because any code
19347                      * point in 'upper_latin1_only_utf8_matches' is below 256.)
19348                      *
19349                      * EXACTFAA would apply only to pairs (hence exactly 2 code
19350                      * points) in the ASCII range, so we can't use it here to
19351                      * artificially restrict the fold domain, so we check if
19352                      * the class does or does not match some EXACTFish node.
19353                      * Further, if we aren't under /i, and the folded-to
19354                      * character is part of a multi-character fold, we can't do
19355                      * this optimization, as the sequence around it could be
19356                      * that multi-character fold, and we don't here know the
19357                      * context, so we have to assume it is that multi-char
19358                      * fold, to prevent potential bugs.
19359                      *
19360                      * To do the general case, we first find the fold of the
19361                      * lowest code point (which may be higher than the lowest
19362                      * one), then find everything that folds to it.  (The data
19363                      * structure we have only maps from the folded code points,
19364                      * so we have to do the earlier step.) */
19365
19366                     Size_t foldlen;
19367                     U8 foldbuf[UTF8_MAXBYTES_CASE];
19368                     UV folded = _to_uni_fold_flags(start[0],
19369                                                         foldbuf, &foldlen, 0);
19370                     U32 first_fold;
19371                     const U32 * remaining_folds;
19372                     Size_t folds_to_this_cp_count = _inverse_folds(
19373                                                             folded,
19374                                                             &first_fold,
19375                                                             &remaining_folds);
19376                     Size_t folds_count = folds_to_this_cp_count + 1;
19377                     SV * fold_list = _new_invlist(folds_count);
19378                     unsigned int i;
19379
19380                     /* If there are UTF-8 dependent matches, create a temporary
19381                      * list of what this node matches, including them. */
19382                     SV * all_cp_list = NULL;
19383                     SV ** use_this_list = &cp_list;
19384
19385                     if (upper_latin1_only_utf8_matches) {
19386                         all_cp_list = _new_invlist(0);
19387                         use_this_list = &all_cp_list;
19388                         _invlist_union(cp_list,
19389                                        upper_latin1_only_utf8_matches,
19390                                        use_this_list);
19391                     }
19392
19393                     /* Having gotten everything that participates in the fold
19394                      * containing the lowest code point, we turn that into an
19395                      * inversion list, making sure everything is included. */
19396                     fold_list = add_cp_to_invlist(fold_list, start[0]);
19397                     fold_list = add_cp_to_invlist(fold_list, folded);
19398                     if (folds_to_this_cp_count > 0) {
19399                         fold_list = add_cp_to_invlist(fold_list, first_fold);
19400                         for (i = 0; i + 1 < folds_to_this_cp_count; i++) {
19401                             fold_list = add_cp_to_invlist(fold_list,
19402                                                         remaining_folds[i]);
19403                         }
19404                     }
19405
19406                     /* If the fold list is identical to what's in this ANYOF
19407                      * node, the node can be represented by an EXACTFish one
19408                      * instead */
19409                     if (_invlistEQ(*use_this_list, fold_list,
19410                                    0 /* Don't complement */ )
19411                     ) {
19412
19413                         /* But, we have to be careful, as mentioned above.
19414                          * Just the right sequence of characters could match
19415                          * this if it is part of a multi-character fold.  That
19416                          * IS what we want if we are under /i.  But it ISN'T
19417                          * what we want if not under /i, as it could match when
19418                          * it shouldn't.  So, when we aren't under /i and this
19419                          * character participates in a multi-char fold, we
19420                          * don't optimize into an EXACTFish node.  So, for each
19421                          * case below we have to check if we are folding
19422                          * and if not, if it is not part of a multi-char fold.
19423                          * */
19424                         if (start[0] > 255) {    /* Highish code point */
19425                             if (FOLD || ! _invlist_contains_cp(
19426                                             PL_InMultiCharFold, folded))
19427                             {
19428                                 op = (LOC)
19429                                      ? EXACTFLU8
19430                                      : (ASCII_FOLD_RESTRICTED)
19431                                        ? EXACTFAA
19432                                        : EXACTFU_REQ8;
19433                                 value = folded;
19434                             }
19435                         }   /* Below, the lowest code point < 256 */
19436                         else if (    FOLD
19437                                  &&  folded == 's'
19438                                  &&  DEPENDS_SEMANTICS)
19439                         {   /* An EXACTF node containing a single character
19440                                 's', can be an EXACTFU if it doesn't get
19441                                 joined with an adjacent 's' */
19442                             op = EXACTFU_S_EDGE;
19443                             value = folded;
19444                         }
19445                         else if (    FOLD
19446                                 || ! HAS_NONLATIN1_FOLD_CLOSURE(start[0]))
19447                         {
19448                             if (upper_latin1_only_utf8_matches) {
19449                                 op = EXACTF;
19450
19451                                 /* We can't use the fold, as that only matches
19452                                  * under UTF-8 */
19453                                 value = start[0];
19454                             }
19455                             else if (     UNLIKELY(start[0] == MICRO_SIGN)
19456                                      && ! UTF)
19457                             {   /* EXACTFUP is a special node for this
19458                                    character */
19459                                 op = (ASCII_FOLD_RESTRICTED)
19460                                      ? EXACTFAA
19461                                      : EXACTFUP;
19462                                 value = MICRO_SIGN;
19463                             }
19464                             else if (     ASCII_FOLD_RESTRICTED
19465                                      && ! isASCII(start[0]))
19466                             {   /* For ASCII under /iaa, we can use EXACTFU
19467                                    below */
19468                                 op = EXACTFAA;
19469                                 value = folded;
19470                             }
19471                             else {
19472                                 op = EXACTFU;
19473                                 value = folded;
19474                             }
19475                         }
19476                     }
19477
19478                     SvREFCNT_dec_NN(fold_list);
19479                     SvREFCNT_dec(all_cp_list);
19480                 }
19481             }
19482
19483             if (op != END) {
19484                 U8 len;
19485
19486                 /* Here, we have calculated what EXACTish node to use.  Have to
19487                  * convert to UTF-8 if not already there */
19488                 if (value > 255) {
19489                     if (! UTF) {
19490                         SvREFCNT_dec(cp_list);;
19491                         REQUIRE_UTF8(flagp);
19492                     }
19493
19494                     /* This is a kludge to the special casing issues with this
19495                      * ligature under /aa.  FB05 should fold to FB06, but the
19496                      * call above to _to_uni_fold_flags() didn't find this, as
19497                      * it didn't use the /aa restriction in order to not miss
19498                      * other folds that would be affected.  This is the only
19499                      * instance likely to ever be a problem in all of Unicode.
19500                      * So special case it. */
19501                     if (   value == LATIN_SMALL_LIGATURE_LONG_S_T
19502                         && ASCII_FOLD_RESTRICTED)
19503                     {
19504                         value = LATIN_SMALL_LIGATURE_ST;
19505                     }
19506                 }
19507
19508                 len = (UTF) ? UVCHR_SKIP(value) : 1;
19509
19510                 ret = regnode_guts(pRExC_state, op, len, "exact");
19511                 FILL_NODE(ret, op);
19512                 RExC_emit += 1 + STR_SZ(len);
19513                 setSTR_LEN(REGNODE_p(ret), len);
19514                 if (len == 1) {
19515                     *STRINGs(REGNODE_p(ret)) = (U8) value;
19516                 }
19517                 else {
19518                     uvchr_to_utf8((U8 *) STRINGs(REGNODE_p(ret)), value);
19519                 }
19520                 goto not_anyof;
19521             }
19522         }
19523
19524         if (! has_runtime_dependency) {
19525
19526             /* See if this can be turned into an ANYOFM node.  Think about the
19527              * bit patterns in two different bytes.  In some positions, the
19528              * bits in each will be 1; and in other positions both will be 0;
19529              * and in some positions the bit will be 1 in one byte, and 0 in
19530              * the other.  Let 'n' be the number of positions where the bits
19531              * differ.  We create a mask which has exactly 'n' 0 bits, each in
19532              * a position where the two bytes differ.  Now take the set of all
19533              * bytes that when ANDed with the mask yield the same result.  That
19534              * set has 2**n elements, and is representable by just two 8 bit
19535              * numbers: the result and the mask.  Importantly, matching the set
19536              * can be vectorized by creating a word full of the result bytes,
19537              * and a word full of the mask bytes, yielding a significant speed
19538              * up.  Here, see if this node matches such a set.  As a concrete
19539              * example consider [01], and the byte representing '0' which is
19540              * 0x30 on ASCII machines.  It has the bits 0011 0000.  Take the
19541              * mask 1111 1110.  If we AND 0x31 and 0x30 with that mask we get
19542              * 0x30.  Any other bytes ANDed yield something else.  So [01],
19543              * which is a common usage, is optimizable into ANYOFM, and can
19544              * benefit from the speed up.  We can only do this on UTF-8
19545              * invariant bytes, because they have the same bit patterns under
19546              * UTF-8 as not. */
19547             PERL_UINT_FAST8_T inverted = 0;
19548 #ifdef EBCDIC
19549             const PERL_UINT_FAST8_T max_permissible = 0xFF;
19550 #else
19551             const PERL_UINT_FAST8_T max_permissible = 0x7F;
19552 #endif
19553             /* If doesn't fit the criteria for ANYOFM, invert and try again.
19554              * If that works we will instead later generate an NANYOFM, and
19555              * invert back when through */
19556             if (invlist_highest(cp_list) > max_permissible) {
19557                 _invlist_invert(cp_list);
19558                 inverted = 1;
19559             }
19560
19561             if (invlist_highest(cp_list) <= max_permissible) {
19562                 UV this_start, this_end;
19563                 UV lowest_cp = UV_MAX;  /* init'ed to suppress compiler warn */
19564                 U8 bits_differing = 0;
19565                 Size_t full_cp_count = 0;
19566                 bool first_time = TRUE;
19567
19568                 /* Go through the bytes and find the bit positions that differ
19569                  * */
19570                 invlist_iterinit(cp_list);
19571                 while (invlist_iternext(cp_list, &this_start, &this_end)) {
19572                     unsigned int i = this_start;
19573
19574                     if (first_time) {
19575                         if (! UVCHR_IS_INVARIANT(i)) {
19576                             goto done_anyofm;
19577                         }
19578
19579                         first_time = FALSE;
19580                         lowest_cp = this_start;
19581
19582                         /* We have set up the code point to compare with.
19583                          * Don't compare it with itself */
19584                         i++;
19585                     }
19586
19587                     /* Find the bit positions that differ from the lowest code
19588                      * point in the node.  Keep track of all such positions by
19589                      * OR'ing */
19590                     for (; i <= this_end; i++) {
19591                         if (! UVCHR_IS_INVARIANT(i)) {
19592                             goto done_anyofm;
19593                         }
19594
19595                         bits_differing  |= i ^ lowest_cp;
19596                     }
19597
19598                     full_cp_count += this_end - this_start + 1;
19599                 }
19600
19601                 /* At the end of the loop, we count how many bits differ from
19602                  * the bits in lowest code point, call the count 'd'.  If the
19603                  * set we found contains 2**d elements, it is the closure of
19604                  * all code points that differ only in those bit positions.  To
19605                  * convince yourself of that, first note that the number in the
19606                  * closure must be a power of 2, which we test for.  The only
19607                  * way we could have that count and it be some differing set,
19608                  * is if we got some code points that don't differ from the
19609                  * lowest code point in any position, but do differ from each
19610                  * other in some other position.  That means one code point has
19611                  * a 1 in that position, and another has a 0.  But that would
19612                  * mean that one of them differs from the lowest code point in
19613                  * that position, which possibility we've already excluded.  */
19614                 if (  (inverted || full_cp_count > 1)
19615                     && full_cp_count == 1U << PL_bitcount[bits_differing])
19616                 {
19617                     U8 ANYOFM_mask;
19618
19619                     op = ANYOFM + inverted;;
19620
19621                     /* We need to make the bits that differ be 0's */
19622                     ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
19623
19624                     /* The argument is the lowest code point */
19625                     ret = reganode(pRExC_state, op, lowest_cp);
19626                     FLAGS(REGNODE_p(ret)) = ANYOFM_mask;
19627                 }
19628
19629               done_anyofm:
19630                 invlist_iterfinish(cp_list);
19631             }
19632
19633             if (inverted) {
19634                 _invlist_invert(cp_list);
19635             }
19636
19637             if (op != END) {
19638                 goto not_anyof;
19639             }
19640
19641             /* XXX We could create an ANYOFR_LOW node here if we saved above if
19642              * all were invariants, it wasn't inverted, and there is a single
19643              * range.  This would be faster than some of the posix nodes we
19644              * create below like /\d/a, but would be twice the size.  Without
19645              * having actually measured the gain, khw doesn't think the
19646              * tradeoff is really worth it */
19647         }
19648
19649         if (! (anyof_flags & ANYOF_LOCALE_FLAGS)) {
19650             PERL_UINT_FAST8_T type;
19651             SV * intersection = NULL;
19652             SV* d_invlist = NULL;
19653
19654             /* See if this matches any of the POSIX classes.  The POSIXA and
19655              * POSIXD ones are about the same speed as ANYOF ops, but take less
19656              * room; the ones that have above-Latin1 code point matches are
19657              * somewhat faster than ANYOF.  */
19658
19659             for (type = POSIXA; type >= POSIXD; type--) {
19660                 int posix_class;
19661
19662                 if (type == POSIXL) {   /* But not /l posix classes */
19663                     continue;
19664                 }
19665
19666                 for (posix_class = 0;
19667                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
19668                      posix_class++)
19669                 {
19670                     SV** our_code_points = &cp_list;
19671                     SV** official_code_points;
19672                     int try_inverted;
19673
19674                     if (type == POSIXA) {
19675                         official_code_points = &PL_Posix_ptrs[posix_class];
19676                     }
19677                     else {
19678                         official_code_points = &PL_XPosix_ptrs[posix_class];
19679                     }
19680
19681                     /* Skip non-existent classes of this type.  e.g. \v only
19682                      * has an entry in PL_XPosix_ptrs */
19683                     if (! *official_code_points) {
19684                         continue;
19685                     }
19686
19687                     /* Try both the regular class, and its inversion */
19688                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
19689                         bool this_inverted = invert ^ try_inverted;
19690
19691                         if (type != POSIXD) {
19692
19693                             /* This class that isn't /d can't match if we have
19694                              * /d dependencies */
19695                             if (has_runtime_dependency
19696                                                     & HAS_D_RUNTIME_DEPENDENCY)
19697                             {
19698                                 continue;
19699                             }
19700                         }
19701                         else /* is /d */ if (! this_inverted) {
19702
19703                             /* /d classes don't match anything non-ASCII below
19704                              * 256 unconditionally (which cp_list contains) */
19705                             _invlist_intersection(cp_list, PL_UpperLatin1,
19706                                                            &intersection);
19707                             if (_invlist_len(intersection) != 0) {
19708                                 continue;
19709                             }
19710
19711                             SvREFCNT_dec(d_invlist);
19712                             d_invlist = invlist_clone(cp_list, NULL);
19713
19714                             /* But under UTF-8 it turns into using /u rules.
19715                              * Add the things it matches under these conditions
19716                              * so that we check below that these are identical
19717                              * to what the tested class should match */
19718                             if (upper_latin1_only_utf8_matches) {
19719                                 _invlist_union(
19720                                             d_invlist,
19721                                             upper_latin1_only_utf8_matches,
19722                                             &d_invlist);
19723                             }
19724                             our_code_points = &d_invlist;
19725                         }
19726                         else {  /* POSIXD, inverted.  If this doesn't have this
19727                                    flag set, it isn't /d. */
19728                             if (! (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
19729                             {
19730                                 continue;
19731                             }
19732                             our_code_points = &cp_list;
19733                         }
19734
19735                         /* Here, have weeded out some things.  We want to see
19736                          * if the list of characters this node contains
19737                          * ('*our_code_points') precisely matches those of the
19738                          * class we are currently checking against
19739                          * ('*official_code_points'). */
19740                         if (_invlistEQ(*our_code_points,
19741                                        *official_code_points,
19742                                        try_inverted))
19743                         {
19744                             /* Here, they precisely match.  Optimize this ANYOF
19745                              * node into its equivalent POSIX one of the
19746                              * correct type, possibly inverted */
19747                             ret = reg_node(pRExC_state, (try_inverted)
19748                                                         ? type + NPOSIXA
19749                                                                 - POSIXA
19750                                                         : type);
19751                             FLAGS(REGNODE_p(ret)) = posix_class;
19752                             SvREFCNT_dec(d_invlist);
19753                             SvREFCNT_dec(intersection);
19754                             goto not_anyof;
19755                         }
19756                     }
19757                 }
19758             }
19759             SvREFCNT_dec(d_invlist);
19760             SvREFCNT_dec(intersection);
19761         }
19762
19763         /* If it is a single contiguous range, ANYOFR is an efficient regnode,
19764          * both in size and speed.  Currently, a 20 bit range base (smallest
19765          * code point in the range), and a 12 bit maximum delta are packed into
19766          * a 32 bit word.  This allows for using it on all of the Unicode code
19767          * points except for the highest plane, which is only for private use
19768          * code points.  khw doubts that a bigger delta is likely in real world
19769          * applications */
19770         if (     single_range
19771             && ! has_runtime_dependency
19772             &&   anyof_flags == 0
19773             &&   start[0] < (1 << ANYOFR_BASE_BITS)
19774             &&   end[0] - start[0]
19775                     < ((1U << (sizeof(((struct regnode_1 *)NULL)->arg1)
19776                                    * CHARBITS - ANYOFR_BASE_BITS))))
19777
19778         {
19779             U8 low_utf8[UTF8_MAXBYTES+1];
19780             U8 high_utf8[UTF8_MAXBYTES+1];
19781
19782             ret = reganode(pRExC_state, ANYOFR,
19783                         (start[0] | (end[0] - start[0]) << ANYOFR_BASE_BITS));
19784
19785             /* Place the lowest UTF-8 start byte in the flags field, so as to
19786              * allow efficient ruling out at run time of many possible inputs.
19787              * */
19788             (void) uvchr_to_utf8(low_utf8, start[0]);
19789             (void) uvchr_to_utf8(high_utf8, end[0]);
19790
19791             /* If all code points share the same first byte, this can be an
19792              * ANYOFRb.  Otherwise store the lowest UTF-8 start byte which can
19793              * quickly rule out many inputs at run-time without having to
19794              * compute the code point from UTF-8.  For EBCDIC, we use I8, as
19795              * not doing that transformation would not rule out nearly so many
19796              * things */
19797             if (low_utf8[0] == high_utf8[0]) {
19798                 OP(REGNODE_p(ret)) = ANYOFRb;
19799                 ANYOF_FLAGS(REGNODE_p(ret)) = low_utf8[0];
19800             }
19801             else {
19802                 ANYOF_FLAGS(REGNODE_p(ret))
19803                                     = NATIVE_UTF8_TO_I8(low_utf8[0]);
19804             }
19805
19806             goto not_anyof;
19807         }
19808
19809         /* If didn't find an optimization and there is no need for a bitmap,
19810          * optimize to indicate that */
19811         if (     start[0] >= NUM_ANYOF_CODE_POINTS
19812             && ! LOC
19813             && ! upper_latin1_only_utf8_matches
19814             &&   anyof_flags == 0)
19815         {
19816             U8 low_utf8[UTF8_MAXBYTES+1];
19817             UV highest_cp = invlist_highest(cp_list);
19818
19819             /* Currently the maximum allowed code point by the system is
19820              * IV_MAX.  Higher ones are reserved for future internal use.  This
19821              * particular regnode can be used for higher ones, but we can't
19822              * calculate the code point of those.  IV_MAX suffices though, as
19823              * it will be a large first byte */
19824             Size_t low_len = uvchr_to_utf8(low_utf8, MIN(start[0], IV_MAX))
19825                            - low_utf8;
19826
19827             /* We store the lowest possible first byte of the UTF-8
19828              * representation, using the flags field.  This allows for quick
19829              * ruling out of some inputs without having to convert from UTF-8
19830              * to code point.  For EBCDIC, we use I8, as not doing that
19831              * transformation would not rule out nearly so many things */
19832             anyof_flags = NATIVE_UTF8_TO_I8(low_utf8[0]);
19833
19834             op = ANYOFH;
19835
19836             /* If the first UTF-8 start byte for the highest code point in the
19837              * range is suitably small, we may be able to get an upper bound as
19838              * well */
19839             if (highest_cp <= IV_MAX) {
19840                 U8 high_utf8[UTF8_MAXBYTES+1];
19841                 Size_t high_len = uvchr_to_utf8(high_utf8, highest_cp)
19842                                 - high_utf8;
19843
19844                 /* If the lowest and highest are the same, we can get an exact
19845                  * first byte instead of a just minimum or even a sequence of
19846                  * exact leading bytes.  We signal these with different
19847                  * regnodes */
19848                 if (low_utf8[0] == high_utf8[0]) {
19849                     Size_t len = find_first_differing_byte_pos(low_utf8,
19850                                                                high_utf8,
19851                                                        MIN(low_len, high_len));
19852
19853                     if (len == 1) {
19854
19855                         /* No need to convert to I8 for EBCDIC as this is an
19856                          * exact match */
19857                         anyof_flags = low_utf8[0];
19858                         op = ANYOFHb;
19859                     }
19860                     else {
19861                         op = ANYOFHs;
19862                         ret = regnode_guts(pRExC_state, op,
19863                                            regarglen[op] + STR_SZ(len),
19864                                            "anyofhs");
19865                         FILL_NODE(ret, op);
19866                         ((struct regnode_anyofhs *) REGNODE_p(ret))->str_len
19867                                                                         = len;
19868                         Copy(low_utf8,  /* Add the common bytes */
19869                            ((struct regnode_anyofhs *) REGNODE_p(ret))->string,
19870                            len, U8);
19871                         RExC_emit += NODE_SZ_STR(REGNODE_p(ret));
19872                         set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
19873                                                   NULL, only_utf8_locale_list);
19874                         goto not_anyof;
19875                     }
19876                 }
19877                 else if (NATIVE_UTF8_TO_I8(high_utf8[0]) <= MAX_ANYOF_HRx_BYTE)
19878                 {
19879
19880                     /* Here, the high byte is not the same as the low, but is
19881                      * small enough that its reasonable to have a loose upper
19882                      * bound, which is packed in with the strict lower bound.
19883                      * See comments at the definition of MAX_ANYOF_HRx_BYTE.
19884                      * On EBCDIC platforms, I8 is used.  On ASCII platforms I8
19885                      * is the same thing as UTF-8 */
19886
19887                     U8 bits = 0;
19888                     U8 max_range_diff = MAX_ANYOF_HRx_BYTE - anyof_flags;
19889                     U8 range_diff = NATIVE_UTF8_TO_I8(high_utf8[0])
19890                                   - anyof_flags;
19891
19892                     if (range_diff <= max_range_diff / 8) {
19893                         bits = 3;
19894                     }
19895                     else if (range_diff <= max_range_diff / 4) {
19896                         bits = 2;
19897                     }
19898                     else if (range_diff <= max_range_diff / 2) {
19899                         bits = 1;
19900                     }
19901                     anyof_flags = (anyof_flags - 0xC0) << 2 | bits;
19902                     op = ANYOFHr;
19903                 }
19904             }
19905
19906             goto done_finding_op;
19907         }
19908     }   /* End of seeing if can optimize it into a different node */
19909
19910   is_anyof: /* It's going to be an ANYOF node. */
19911     op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
19912          ? ANYOFD
19913          : ((posixl)
19914             ? ANYOFPOSIXL
19915             : ((LOC)
19916                ? ANYOFL
19917                : ANYOF));
19918
19919   done_finding_op:
19920
19921     ret = regnode_guts(pRExC_state, op, regarglen[op], "anyof");
19922     FILL_NODE(ret, op);        /* We set the argument later */
19923     RExC_emit += 1 + regarglen[op];
19924     ANYOF_FLAGS(REGNODE_p(ret)) = anyof_flags;
19925
19926     /* Here, <cp_list> contains all the code points we can determine at
19927      * compile time that match under all conditions.  Go through it, and
19928      * for things that belong in the bitmap, put them there, and delete from
19929      * <cp_list>.  While we are at it, see if everything above 255 is in the
19930      * list, and if so, set a flag to speed up execution */
19931
19932     populate_ANYOF_from_invlist(REGNODE_p(ret), &cp_list);
19933
19934     if (posixl) {
19935         ANYOF_POSIXL_SET_TO_BITMAP(REGNODE_p(ret), posixl);
19936     }
19937
19938     if (invert) {
19939         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_INVERT;
19940     }
19941
19942     /* Here, the bitmap has been populated with all the Latin1 code points that
19943      * always match.  Can now add to the overall list those that match only
19944      * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>).
19945      * */
19946     if (upper_latin1_only_utf8_matches) {
19947         if (cp_list) {
19948             _invlist_union(cp_list,
19949                            upper_latin1_only_utf8_matches,
19950                            &cp_list);
19951             SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
19952         }
19953         else {
19954             cp_list = upper_latin1_only_utf8_matches;
19955         }
19956         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
19957     }
19958
19959     set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
19960                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
19961                    ? listsv
19962                    : NULL,
19963                   only_utf8_locale_list);
19964     SvREFCNT_dec(cp_list);;
19965     SvREFCNT_dec(only_utf8_locale_list);
19966     return ret;
19967
19968   not_anyof:
19969
19970     /* Here, the node is getting optimized into something that's not an ANYOF
19971      * one.  Finish up. */
19972
19973     Set_Node_Offset_Length(REGNODE_p(ret), orig_parse - RExC_start,
19974                                            RExC_parse - orig_parse);;
19975     SvREFCNT_dec(cp_list);;
19976     SvREFCNT_dec(only_utf8_locale_list);
19977     return ret;
19978 }
19979
19980 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
19981
19982 STATIC void
19983 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
19984                 regnode* const node,
19985                 SV* const cp_list,
19986                 SV* const runtime_defns,
19987                 SV* const only_utf8_locale_list)
19988 {
19989     /* Sets the arg field of an ANYOF-type node 'node', using information about
19990      * the node passed-in.  If there is nothing outside the node's bitmap, the
19991      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
19992      * the count returned by add_data(), having allocated and stored an array,
19993      * av, as follows:
19994      *
19995      *  av[0] stores the inversion list defining this class as far as known at
19996      *        this time, or PL_sv_undef if nothing definite is now known.
19997      *  av[1] stores the inversion list of code points that match only if the
19998      *        current locale is UTF-8, or if none, PL_sv_undef if there is an
19999      *        av[2], or no entry otherwise.
20000      *  av[2] stores the list of user-defined properties whose subroutine
20001      *        definitions aren't known at this time, or no entry if none. */
20002
20003     UV n;
20004
20005     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
20006
20007     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
20008         assert(! (ANYOF_FLAGS(node)
20009                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
20010         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
20011     }
20012     else {
20013         AV * const av = newAV();
20014         SV *rv;
20015
20016         if (cp_list) {
20017             av_store(av, INVLIST_INDEX, SvREFCNT_inc_NN(cp_list));
20018         }
20019
20020         /* (Note that if any of this changes, the size calculations in
20021          * S_optimize_regclass() might need to be updated.) */
20022
20023         if (only_utf8_locale_list) {
20024             av_store(av, ONLY_LOCALE_MATCHES_INDEX,
20025                                      SvREFCNT_inc_NN(only_utf8_locale_list));
20026         }
20027
20028         if (runtime_defns) {
20029             av_store(av, DEFERRED_USER_DEFINED_INDEX,
20030                          SvREFCNT_inc_NN(runtime_defns));
20031         }
20032
20033         rv = newRV_noinc(MUTABLE_SV(av));
20034         n = add_data(pRExC_state, STR_WITH_LEN("s"));
20035         RExC_rxi->data->data[n] = (void*)rv;
20036         ARG_SET(node, n);
20037     }
20038 }
20039
20040 SV *
20041
20042 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
20043 Perl_get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
20044 #else
20045 Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV** only_utf8_locale_ptr, SV** output_invlist)
20046 #endif
20047
20048 {
20049     /* For internal core use only.
20050      * Returns the inversion list for the input 'node' in the regex 'prog'.
20051      * If <doinit> is 'true', will attempt to create the inversion list if not
20052      *    already done.
20053      * If <listsvp> is non-null, will return the printable contents of the
20054      *    property definition.  This can be used to get debugging information
20055      *    even before the inversion list exists, by calling this function with
20056      *    'doinit' set to false, in which case the components that will be used
20057      *    to eventually create the inversion list are returned  (in a printable
20058      *    form).
20059      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
20060      *    store an inversion list of code points that should match only if the
20061      *    execution-time locale is a UTF-8 one.
20062      * If <output_invlist> is not NULL, it is where this routine is to store an
20063      *    inversion list of the code points that would be instead returned in
20064      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
20065      *    when this parameter is used, is just the non-code point data that
20066      *    will go into creating the inversion list.  This currently should be just
20067      *    user-defined properties whose definitions were not known at compile
20068      *    time.  Using this parameter allows for easier manipulation of the
20069      *    inversion list's data by the caller.  It is illegal to call this
20070      *    function with this parameter set, but not <listsvp>
20071      *
20072      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
20073      * that, in spite of this function's name, the inversion list it returns
20074      * may include the bitmap data as well */
20075
20076     SV *si  = NULL;         /* Input initialization string */
20077     SV* invlist = NULL;
20078
20079     RXi_GET_DECL(prog, progi);
20080     const struct reg_data * const data = prog ? progi->data : NULL;
20081
20082 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
20083     PERL_ARGS_ASSERT_GET_REGCLASS_NONBITMAP_DATA;
20084 #else
20085     PERL_ARGS_ASSERT_GET_RE_GCLASS_NONBITMAP_DATA;
20086 #endif
20087     assert(! output_invlist || listsvp);
20088
20089     if (data && data->count) {
20090         const U32 n = ARG(node);
20091
20092         if (data->what[n] == 's') {
20093             SV * const rv = MUTABLE_SV(data->data[n]);
20094             AV * const av = MUTABLE_AV(SvRV(rv));
20095             SV **const ary = AvARRAY(av);
20096
20097             invlist = ary[INVLIST_INDEX];
20098
20099             if (av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX) {
20100                 *only_utf8_locale_ptr = ary[ONLY_LOCALE_MATCHES_INDEX];
20101             }
20102
20103             if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
20104                 si = ary[DEFERRED_USER_DEFINED_INDEX];
20105             }
20106
20107             if (doinit && (si || invlist)) {
20108                 if (si) {
20109                     bool user_defined;
20110                     SV * msg = newSVpvs_flags("", SVs_TEMP);
20111
20112                     SV * prop_definition = handle_user_defined_property(
20113                             "", 0, FALSE,   /* There is no \p{}, \P{} */
20114                             SvPVX_const(si)[1] - '0',   /* /i or not has been
20115                                                            stored here for just
20116                                                            this occasion */
20117                             TRUE,           /* run time */
20118                             FALSE,          /* This call must find the defn */
20119                             si,             /* The property definition  */
20120                             &user_defined,
20121                             msg,
20122                             0               /* base level call */
20123                            );
20124
20125                     if (SvCUR(msg)) {
20126                         assert(prop_definition == NULL);
20127
20128                         Perl_croak(aTHX_ "%" UTF8f,
20129                                 UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg)));
20130                     }
20131
20132                     if (invlist) {
20133                         _invlist_union(invlist, prop_definition, &invlist);
20134                         SvREFCNT_dec_NN(prop_definition);
20135                     }
20136                     else {
20137                         invlist = prop_definition;
20138                     }
20139
20140                     STATIC_ASSERT_STMT(ONLY_LOCALE_MATCHES_INDEX == 1 + INVLIST_INDEX);
20141                     STATIC_ASSERT_STMT(DEFERRED_USER_DEFINED_INDEX == 1 + ONLY_LOCALE_MATCHES_INDEX);
20142
20143                     ary[INVLIST_INDEX] = invlist;
20144                     av_fill(av, (ary[ONLY_LOCALE_MATCHES_INDEX])
20145                                  ? ONLY_LOCALE_MATCHES_INDEX
20146                                  : INVLIST_INDEX);
20147                     si = NULL;
20148                 }
20149             }
20150         }
20151     }
20152
20153     /* If requested, return a printable version of what this ANYOF node matches
20154      * */
20155     if (listsvp) {
20156         SV* matches_string = NULL;
20157
20158         /* This function can be called at compile-time, before everything gets
20159          * resolved, in which case we return the currently best available
20160          * information, which is the string that will eventually be used to do
20161          * that resolving, 'si' */
20162         if (si) {
20163             /* Here, we only have 'si' (and possibly some passed-in data in
20164              * 'invlist', which is handled below)  If the caller only wants
20165              * 'si', use that.  */
20166             if (! output_invlist) {
20167                 matches_string = newSVsv(si);
20168             }
20169             else {
20170                 /* But if the caller wants an inversion list of the node, we
20171                  * need to parse 'si' and place as much as possible in the
20172                  * desired output inversion list, making 'matches_string' only
20173                  * contain the currently unresolvable things */
20174                 const char *si_string = SvPVX(si);
20175                 STRLEN remaining = SvCUR(si);
20176                 UV prev_cp = 0;
20177                 U8 count = 0;
20178
20179                 /* Ignore everything before and including the first new-line */
20180                 si_string = (const char *) memchr(si_string, '\n', SvCUR(si));
20181                 assert (si_string != NULL);
20182                 si_string++;
20183                 remaining = SvPVX(si) + SvCUR(si) - si_string;
20184
20185                 while (remaining > 0) {
20186
20187                     /* The data consists of just strings defining user-defined
20188                      * property names, but in prior incarnations, and perhaps
20189                      * somehow from pluggable regex engines, it could still
20190                      * hold hex code point definitions, all of which should be
20191                      * legal (or it wouldn't have gotten this far).  Each
20192                      * component of a range would be separated by a tab, and
20193                      * each range by a new-line.  If these are found, instead
20194                      * add them to the inversion list */
20195                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
20196                                      |PERL_SCAN_SILENT_NON_PORTABLE;
20197                     STRLEN len = remaining;
20198                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
20199
20200                     /* If the hex decode routine found something, it should go
20201                      * up to the next \n */
20202                     if (   *(si_string + len) == '\n') {
20203                         if (count) {    /* 2nd code point on line */
20204                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
20205                         }
20206                         else {
20207                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
20208                         }
20209                         count = 0;
20210                         goto prepare_for_next_iteration;
20211                     }
20212
20213                     /* If the hex decode was instead for the lower range limit,
20214                      * save it, and go parse the upper range limit */
20215                     if (*(si_string + len) == '\t') {
20216                         assert(count == 0);
20217
20218                         prev_cp = cp;
20219                         count = 1;
20220                       prepare_for_next_iteration:
20221                         si_string += len + 1;
20222                         remaining -= len + 1;
20223                         continue;
20224                     }
20225
20226                     /* Here, didn't find a legal hex number.  Just add the text
20227                      * from here up to the next \n, omitting any trailing
20228                      * markers. */
20229
20230                     remaining -= len;
20231                     len = strcspn(si_string,
20232                                         DEFERRED_COULD_BE_OFFICIAL_MARKERs "\n");
20233                     remaining -= len;
20234                     if (matches_string) {
20235                         sv_catpvn(matches_string, si_string, len);
20236                     }
20237                     else {
20238                         matches_string = newSVpvn(si_string, len);
20239                     }
20240                     sv_catpvs(matches_string, " ");
20241
20242                     si_string += len;
20243                     if (   remaining
20244                         && UCHARAT(si_string)
20245                                             == DEFERRED_COULD_BE_OFFICIAL_MARKERc)
20246                     {
20247                         si_string++;
20248                         remaining--;
20249                     }
20250                     if (remaining && UCHARAT(si_string) == '\n') {
20251                         si_string++;
20252                         remaining--;
20253                     }
20254                 } /* end of loop through the text */
20255
20256                 assert(matches_string);
20257                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
20258                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
20259                 }
20260             } /* end of has an 'si' */
20261         }
20262
20263         /* Add the stuff that's already known */
20264         if (invlist) {
20265
20266             /* Again, if the caller doesn't want the output inversion list, put
20267              * everything in 'matches-string' */
20268             if (! output_invlist) {
20269                 if ( ! matches_string) {
20270                     matches_string = newSVpvs("\n");
20271                 }
20272                 sv_catsv(matches_string, invlist_contents(invlist,
20273                                                   TRUE /* traditional style */
20274                                                   ));
20275             }
20276             else if (! *output_invlist) {
20277                 *output_invlist = invlist_clone(invlist, NULL);
20278             }
20279             else {
20280                 _invlist_union(*output_invlist, invlist, output_invlist);
20281             }
20282         }
20283
20284         *listsvp = matches_string;
20285     }
20286
20287     return invlist;
20288 }
20289
20290 /* reg_skipcomment()
20291
20292    Absorbs an /x style # comment from the input stream,
20293    returning a pointer to the first character beyond the comment, or if the
20294    comment terminates the pattern without anything following it, this returns
20295    one past the final character of the pattern (in other words, RExC_end) and
20296    sets the REG_RUN_ON_COMMENT_SEEN flag.
20297
20298    Note it's the callers responsibility to ensure that we are
20299    actually in /x mode
20300
20301 */
20302
20303 PERL_STATIC_INLINE char*
20304 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
20305 {
20306     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
20307
20308     assert(*p == '#');
20309
20310     while (p < RExC_end) {
20311         if (*(++p) == '\n') {
20312             return p+1;
20313         }
20314     }
20315
20316     /* we ran off the end of the pattern without ending the comment, so we have
20317      * to add an \n when wrapping */
20318     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
20319     return p;
20320 }
20321
20322 STATIC void
20323 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
20324                                 char ** p,
20325                                 const bool force_to_xmod
20326                          )
20327 {
20328     /* If the text at the current parse position '*p' is a '(?#...)' comment,
20329      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
20330      * is /x whitespace, advance '*p' so that on exit it points to the first
20331      * byte past all such white space and comments */
20332
20333     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
20334
20335     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
20336
20337     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
20338
20339     for (;;) {
20340         if (RExC_end - (*p) >= 3
20341             && *(*p)     == '('
20342             && *(*p + 1) == '?'
20343             && *(*p + 2) == '#')
20344         {
20345             while (*(*p) != ')') {
20346                 if ((*p) == RExC_end)
20347                     FAIL("Sequence (?#... not terminated");
20348                 (*p)++;
20349             }
20350             (*p)++;
20351             continue;
20352         }
20353
20354         if (use_xmod) {
20355             const char * save_p = *p;
20356             while ((*p) < RExC_end) {
20357                 STRLEN len;
20358                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
20359                     (*p) += len;
20360                 }
20361                 else if (*(*p) == '#') {
20362                     (*p) = reg_skipcomment(pRExC_state, (*p));
20363                 }
20364                 else {
20365                     break;
20366                 }
20367             }
20368             if (*p != save_p) {
20369                 continue;
20370             }
20371         }
20372
20373         break;
20374     }
20375
20376     return;
20377 }
20378
20379 /* nextchar()
20380
20381    Advances the parse position by one byte, unless that byte is the beginning
20382    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
20383    those two cases, the parse position is advanced beyond all such comments and
20384    white space.
20385
20386    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
20387 */
20388
20389 STATIC void
20390 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
20391 {
20392     PERL_ARGS_ASSERT_NEXTCHAR;
20393
20394     if (RExC_parse < RExC_end) {
20395         assert(   ! UTF
20396                || UTF8_IS_INVARIANT(*RExC_parse)
20397                || UTF8_IS_START(*RExC_parse));
20398
20399         RExC_parse += (UTF)
20400                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
20401                       : 1;
20402
20403         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
20404                                 FALSE /* Don't force /x */ );
20405     }
20406 }
20407
20408 STATIC void
20409 S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const Ptrdiff_t size)
20410 {
20411     /* 'size' is the delta number of smallest regnode equivalents to add or
20412      * subtract from the current memory allocated to the regex engine being
20413      * constructed. */
20414
20415     PERL_ARGS_ASSERT_CHANGE_ENGINE_SIZE;
20416
20417     RExC_size += size;
20418
20419     Renewc(RExC_rxi,
20420            sizeof(regexp_internal) + (RExC_size + 1) * sizeof(regnode),
20421                                                 /* +1 for REG_MAGIC */
20422            char,
20423            regexp_internal);
20424     if ( RExC_rxi == NULL )
20425         FAIL("Regexp out of space");
20426     RXi_SET(RExC_rx, RExC_rxi);
20427
20428     RExC_emit_start = RExC_rxi->program;
20429     if (size > 0) {
20430         Zero(REGNODE_p(RExC_emit), size, regnode);
20431     }
20432
20433 #ifdef RE_TRACK_PATTERN_OFFSETS
20434     Renew(RExC_offsets, 2*RExC_size+1, U32);
20435     if (size > 0) {
20436         Zero(RExC_offsets + 2*(RExC_size - size) + 1, 2 * size, U32);
20437     }
20438     RExC_offsets[0] = RExC_size;
20439 #endif
20440 }
20441
20442 STATIC regnode_offset
20443 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
20444 {
20445     /* Allocate a regnode for 'op', with 'extra_size' extra (smallest) regnode
20446      * equivalents space.  It aligns and increments RExC_size
20447      *
20448      * It returns the regnode's offset into the regex engine program */
20449
20450     const regnode_offset ret = RExC_emit;
20451
20452     DECLARE_AND_GET_RE_DEBUG_FLAGS;
20453
20454     PERL_ARGS_ASSERT_REGNODE_GUTS;
20455
20456     SIZE_ALIGN(RExC_size);
20457     change_engine_size(pRExC_state, (Ptrdiff_t) 1 + extra_size);
20458     NODE_ALIGN_FILL(REGNODE_p(ret));
20459 #ifndef RE_TRACK_PATTERN_OFFSETS
20460     PERL_UNUSED_ARG(name);
20461     PERL_UNUSED_ARG(op);
20462 #else
20463     assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF);
20464
20465     if (RExC_offsets) {         /* MJD */
20466         MJD_OFFSET_DEBUG(
20467               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
20468               name, __LINE__,
20469               PL_reg_name[op],
20470               (UV)(RExC_emit) > RExC_offsets[0]
20471                 ? "Overwriting end of array!\n" : "OK",
20472               (UV)(RExC_emit),
20473               (UV)(RExC_parse - RExC_start),
20474               (UV)RExC_offsets[0]));
20475         Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END));
20476     }
20477 #endif
20478     return(ret);
20479 }
20480
20481 /*
20482 - reg_node - emit a node
20483 */
20484 STATIC regnode_offset /* Location. */
20485 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
20486 {
20487     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
20488     regnode_offset ptr = ret;
20489
20490     PERL_ARGS_ASSERT_REG_NODE;
20491
20492     assert(regarglen[op] == 0);
20493
20494     FILL_ADVANCE_NODE(ptr, op);
20495     RExC_emit = ptr;
20496     return(ret);
20497 }
20498
20499 /*
20500 - reganode - emit a node with an argument
20501 */
20502 STATIC regnode_offset /* Location. */
20503 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
20504 {
20505     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
20506     regnode_offset ptr = ret;
20507
20508     PERL_ARGS_ASSERT_REGANODE;
20509
20510     /* ANYOF are special cased to allow non-length 1 args */
20511     assert(regarglen[op] == 1);
20512
20513     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
20514     RExC_emit = ptr;
20515     return(ret);
20516 }
20517
20518 /*
20519 - regpnode - emit a temporary node with a SV* argument
20520 */
20521 STATIC regnode_offset /* Location. */
20522 S_regpnode(pTHX_ RExC_state_t *pRExC_state, U8 op, SV * arg)
20523 {
20524     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "regpnode");
20525     regnode_offset ptr = ret;
20526
20527     PERL_ARGS_ASSERT_REGPNODE;
20528
20529     FILL_ADVANCE_NODE_ARGp(ptr, op, arg);
20530     RExC_emit = ptr;
20531     return(ret);
20532 }
20533
20534 STATIC regnode_offset
20535 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
20536 {
20537     /* emit a node with U32 and I32 arguments */
20538
20539     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
20540     regnode_offset ptr = ret;
20541
20542     PERL_ARGS_ASSERT_REG2LANODE;
20543
20544     assert(regarglen[op] == 2);
20545
20546     FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
20547     RExC_emit = ptr;
20548     return(ret);
20549 }
20550
20551 /*
20552 - reginsert - insert an operator in front of already-emitted operand
20553 *
20554 * That means that on exit 'operand' is the offset of the newly inserted
20555 * operator, and the original operand has been relocated.
20556 *
20557 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
20558 * set up NEXT_OFF() of the inserted node if needed. Something like this:
20559 *
20560 *   reginsert(pRExC, OPFAIL, orig_emit, depth+1);
20561 *   NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
20562 *
20563 * ALSO NOTE - FLAGS(newly-inserted-operator) will be set to 0 as well.
20564 */
20565 STATIC void
20566 S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op,
20567                   const regnode_offset operand, const U32 depth)
20568 {
20569     regnode *src;
20570     regnode *dst;
20571     regnode *place;
20572     const int offset = regarglen[(U8)op];
20573     const int size = NODE_STEP_REGNODE + offset;
20574     DECLARE_AND_GET_RE_DEBUG_FLAGS;
20575
20576     PERL_ARGS_ASSERT_REGINSERT;
20577     PERL_UNUSED_CONTEXT;
20578     PERL_UNUSED_ARG(depth);
20579 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
20580     DEBUG_PARSE_FMT("inst"," - %s", PL_reg_name[op]);
20581     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
20582                                     studying. If this is wrong then we need to adjust RExC_recurse
20583                                     below like we do with RExC_open_parens/RExC_close_parens. */
20584     change_engine_size(pRExC_state, (Ptrdiff_t) size);
20585     src = REGNODE_p(RExC_emit);
20586     RExC_emit += size;
20587     dst = REGNODE_p(RExC_emit);
20588
20589     /* If we are in a "count the parentheses" pass, the numbers are unreliable,
20590      * and [perl #133871] shows this can lead to problems, so skip this
20591      * realignment of parens until a later pass when they are reliable */
20592     if (! IN_PARENS_PASS && RExC_open_parens) {
20593         int paren;
20594         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
20595         /* remember that RExC_npar is rex->nparens + 1,
20596          * iow it is 1 more than the number of parens seen in
20597          * the pattern so far. */
20598         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
20599             /* note, RExC_open_parens[0] is the start of the
20600              * regex, it can't move. RExC_close_parens[0] is the end
20601              * of the regex, it *can* move. */
20602             if ( paren && RExC_open_parens[paren] >= operand ) {
20603                 /*DEBUG_PARSE_FMT("open"," - %d", size);*/
20604                 RExC_open_parens[paren] += size;
20605             } else {
20606                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
20607             }
20608             if ( RExC_close_parens[paren] >= operand ) {
20609                 /*DEBUG_PARSE_FMT("close"," - %d", size);*/
20610                 RExC_close_parens[paren] += size;
20611             } else {
20612                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
20613             }
20614         }
20615     }
20616     if (RExC_end_op)
20617         RExC_end_op += size;
20618
20619     while (src > REGNODE_p(operand)) {
20620         StructCopy(--src, --dst, regnode);
20621 #ifdef RE_TRACK_PATTERN_OFFSETS
20622         if (RExC_offsets) {     /* MJD 20010112 */
20623             MJD_OFFSET_DEBUG(
20624                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
20625                   "reginsert",
20626                   __LINE__,
20627                   PL_reg_name[op],
20628                   (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0]
20629                     ? "Overwriting end of array!\n" : "OK",
20630                   (UV)REGNODE_OFFSET(src),
20631                   (UV)REGNODE_OFFSET(dst),
20632                   (UV)RExC_offsets[0]));
20633             Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src));
20634             Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src));
20635         }
20636 #endif
20637     }
20638
20639     place = REGNODE_p(operand); /* Op node, where operand used to be. */
20640 #ifdef RE_TRACK_PATTERN_OFFSETS
20641     if (RExC_offsets) {         /* MJD */
20642         MJD_OFFSET_DEBUG(
20643               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
20644               "reginsert",
20645               __LINE__,
20646               PL_reg_name[op],
20647               (UV)REGNODE_OFFSET(place) > RExC_offsets[0]
20648               ? "Overwriting end of array!\n" : "OK",
20649               (UV)REGNODE_OFFSET(place),
20650               (UV)(RExC_parse - RExC_start),
20651               (UV)RExC_offsets[0]));
20652         Set_Node_Offset(place, RExC_parse);
20653         Set_Node_Length(place, 1);
20654     }
20655 #endif
20656     src = NEXTOPER(place);
20657     FLAGS(place) = 0;
20658     FILL_NODE(operand, op);
20659
20660     /* Zero out any arguments in the new node */
20661     Zero(src, offset, regnode);
20662 }
20663
20664 /*
20665 - regtail - set the next-pointer at the end of a node chain of p to val.  If
20666             that value won't fit in the space available, instead returns FALSE.
20667             (Except asserts if we can't fit in the largest space the regex
20668             engine is designed for.)
20669 - SEE ALSO: regtail_study
20670 */
20671 STATIC bool
20672 S_regtail(pTHX_ RExC_state_t * pRExC_state,
20673                 const regnode_offset p,
20674                 const regnode_offset val,
20675                 const U32 depth)
20676 {
20677     regnode_offset scan;
20678     DECLARE_AND_GET_RE_DEBUG_FLAGS;
20679
20680     PERL_ARGS_ASSERT_REGTAIL;
20681 #ifndef DEBUGGING
20682     PERL_UNUSED_ARG(depth);
20683 #endif
20684
20685     /* The final node in the chain is the first one with a nonzero next pointer
20686      * */
20687     scan = (regnode_offset) p;
20688     for (;;) {
20689         regnode * const temp = regnext(REGNODE_p(scan));
20690         DEBUG_PARSE_r({
20691             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
20692             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
20693             Perl_re_printf( aTHX_  "~ %s (%zu) %s %s\n",
20694                 SvPV_nolen_const(RExC_mysv), scan,
20695                     (temp == NULL ? "->" : ""),
20696                     (temp == NULL ? PL_reg_name[OP(REGNODE_p(val))] : "")
20697             );
20698         });
20699         if (temp == NULL)
20700             break;
20701         scan = REGNODE_OFFSET(temp);
20702     }
20703
20704     /* Populate this node's next pointer */
20705     assert(val >= scan);
20706     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
20707         assert((UV) (val - scan) <= U32_MAX);
20708         ARG_SET(REGNODE_p(scan), val - scan);
20709     }
20710     else {
20711         if (val - scan > U16_MAX) {
20712             /* Populate this with something that won't loop and will likely
20713              * lead to a crash if the caller ignores the failure return, and
20714              * execution continues */
20715             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
20716             return FALSE;
20717         }
20718         NEXT_OFF(REGNODE_p(scan)) = val - scan;
20719     }
20720
20721     return TRUE;
20722 }
20723
20724 #ifdef DEBUGGING
20725 /*
20726 - regtail_study - set the next-pointer at the end of a node chain of p to val.
20727 - Look for optimizable sequences at the same time.
20728 - currently only looks for EXACT chains.
20729
20730 This is experimental code. The idea is to use this routine to perform
20731 in place optimizations on branches and groups as they are constructed,
20732 with the long term intention of removing optimization from study_chunk so
20733 that it is purely analytical.
20734
20735 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
20736 to control which is which.
20737
20738 This used to return a value that was ignored.  It was a problem that it is
20739 #ifdef'd to be another function that didn't return a value.  khw has changed it
20740 so both currently return a pass/fail return.
20741
20742 */
20743 /* TODO: All four parms should be const */
20744
20745 STATIC bool
20746 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
20747                       const regnode_offset val, U32 depth)
20748 {
20749     regnode_offset scan;
20750     U8 exact = PSEUDO;
20751 #ifdef EXPERIMENTAL_INPLACESCAN
20752     I32 min = 0;
20753 #endif
20754     DECLARE_AND_GET_RE_DEBUG_FLAGS;
20755
20756     PERL_ARGS_ASSERT_REGTAIL_STUDY;
20757
20758
20759     /* Find last node. */
20760
20761     scan = p;
20762     for (;;) {
20763         regnode * const temp = regnext(REGNODE_p(scan));
20764 #ifdef EXPERIMENTAL_INPLACESCAN
20765         if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
20766             bool unfolded_multi_char;   /* Unexamined in this routine */
20767             if (join_exact(pRExC_state, scan, &min,
20768                            &unfolded_multi_char, 1, REGNODE_p(val), depth+1))
20769                 return TRUE; /* Was return EXACT */
20770         }
20771 #endif
20772         if ( exact ) {
20773             if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
20774                 if (exact == PSEUDO )
20775                     exact= OP(REGNODE_p(scan));
20776                 else if (exact != OP(REGNODE_p(scan)) )
20777                     exact= 0;
20778             }
20779             else if (OP(REGNODE_p(scan)) != NOTHING) {
20780                 exact= 0;
20781             }
20782         }
20783         DEBUG_PARSE_r({
20784             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
20785             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
20786             Perl_re_printf( aTHX_  "~ %s (%zu) -> %s\n",
20787                 SvPV_nolen_const(RExC_mysv),
20788                 scan,
20789                 PL_reg_name[exact]);
20790         });
20791         if (temp == NULL)
20792             break;
20793         scan = REGNODE_OFFSET(temp);
20794     }
20795     DEBUG_PARSE_r({
20796         DEBUG_PARSE_MSG("");
20797         regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state);
20798         Perl_re_printf( aTHX_
20799                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
20800                       SvPV_nolen_const(RExC_mysv),
20801                       (IV)val,
20802                       (IV)(val - scan)
20803         );
20804     });
20805     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
20806         assert((UV) (val - scan) <= U32_MAX);
20807         ARG_SET(REGNODE_p(scan), val - scan);
20808     }
20809     else {
20810         if (val - scan > U16_MAX) {
20811             /* Populate this with something that won't loop and will likely
20812              * lead to a crash if the caller ignores the failure return, and
20813              * execution continues */
20814             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
20815             return FALSE;
20816         }
20817         NEXT_OFF(REGNODE_p(scan)) = val - scan;
20818     }
20819
20820     return TRUE; /* Was 'return exact' */
20821 }
20822 #endif
20823
20824 STATIC SV*
20825 S_get_ANYOFM_contents(pTHX_ const regnode * n) {
20826
20827     /* Returns an inversion list of all the code points matched by the
20828      * ANYOFM/NANYOFM node 'n' */
20829
20830     SV * cp_list = _new_invlist(-1);
20831     const U8 lowest = (U8) ARG(n);
20832     unsigned int i;
20833     U8 count = 0;
20834     U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
20835
20836     PERL_ARGS_ASSERT_GET_ANYOFM_CONTENTS;
20837
20838     /* Starting with the lowest code point, any code point that ANDed with the
20839      * mask yields the lowest code point is in the set */
20840     for (i = lowest; i <= 0xFF; i++) {
20841         if ((i & FLAGS(n)) == ARG(n)) {
20842             cp_list = add_cp_to_invlist(cp_list, i);
20843             count++;
20844
20845             /* We know how many code points (a power of two) that are in the
20846              * set.  No use looking once we've got that number */
20847             if (count >= needed) break;
20848         }
20849     }
20850
20851     if (OP(n) == NANYOFM) {
20852         _invlist_invert(cp_list);
20853     }
20854     return cp_list;
20855 }
20856
20857 /*
20858  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
20859  */
20860 #ifdef DEBUGGING
20861
20862 static void
20863 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
20864 {
20865     int bit;
20866     int set=0;
20867
20868     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
20869
20870     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
20871         if (flags & (1<<bit)) {
20872             if (!set++ && lead)
20873                 Perl_re_printf( aTHX_  "%s", lead);
20874             Perl_re_printf( aTHX_  "%s ", PL_reg_intflags_name[bit]);
20875         }
20876     }
20877     if (lead)  {
20878         if (set)
20879             Perl_re_printf( aTHX_  "\n");
20880         else
20881             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20882     }
20883 }
20884
20885 static void
20886 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
20887 {
20888     int bit;
20889     int set=0;
20890     regex_charset cs;
20891
20892     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
20893
20894     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
20895         if (flags & (1<<bit)) {
20896             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
20897                 continue;
20898             }
20899             if (!set++ && lead)
20900                 Perl_re_printf( aTHX_  "%s", lead);
20901             Perl_re_printf( aTHX_  "%s ", PL_reg_extflags_name[bit]);
20902         }
20903     }
20904     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
20905             if (!set++ && lead) {
20906                 Perl_re_printf( aTHX_  "%s", lead);
20907             }
20908             switch (cs) {
20909                 case REGEX_UNICODE_CHARSET:
20910                     Perl_re_printf( aTHX_  "UNICODE");
20911                     break;
20912                 case REGEX_LOCALE_CHARSET:
20913                     Perl_re_printf( aTHX_  "LOCALE");
20914                     break;
20915                 case REGEX_ASCII_RESTRICTED_CHARSET:
20916                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
20917                     break;
20918                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
20919                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
20920                     break;
20921                 default:
20922                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
20923                     break;
20924             }
20925     }
20926     if (lead)  {
20927         if (set)
20928             Perl_re_printf( aTHX_  "\n");
20929         else
20930             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20931     }
20932 }
20933 #endif
20934
20935 void
20936 Perl_regdump(pTHX_ const regexp *r)
20937 {
20938 #ifdef DEBUGGING
20939     int i;
20940     SV * const sv = sv_newmortal();
20941     SV *dsv= sv_newmortal();
20942     RXi_GET_DECL(r, ri);
20943     DECLARE_AND_GET_RE_DEBUG_FLAGS;
20944
20945     PERL_ARGS_ASSERT_REGDUMP;
20946
20947     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
20948
20949     /* Header fields of interest. */
20950     for (i = 0; i < 2; i++) {
20951         if (r->substrs->data[i].substr) {
20952             RE_PV_QUOTED_DECL(s, 0, dsv,
20953                             SvPVX_const(r->substrs->data[i].substr),
20954                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
20955                             PL_dump_re_max_len);
20956             Perl_re_printf( aTHX_
20957                           "%s %s%s at %" IVdf "..%" UVuf " ",
20958                           i ? "floating" : "anchored",
20959                           s,
20960                           RE_SV_TAIL(r->substrs->data[i].substr),
20961                           (IV)r->substrs->data[i].min_offset,
20962                           (UV)r->substrs->data[i].max_offset);
20963         }
20964         else if (r->substrs->data[i].utf8_substr) {
20965             RE_PV_QUOTED_DECL(s, 1, dsv,
20966                             SvPVX_const(r->substrs->data[i].utf8_substr),
20967                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
20968                             30);
20969             Perl_re_printf( aTHX_
20970                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
20971                           i ? "floating" : "anchored",
20972                           s,
20973                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
20974                           (IV)r->substrs->data[i].min_offset,
20975                           (UV)r->substrs->data[i].max_offset);
20976         }
20977     }
20978
20979     if (r->check_substr || r->check_utf8)
20980         Perl_re_printf( aTHX_
20981                       (const char *)
20982                       (   r->check_substr == r->substrs->data[1].substr
20983                        && r->check_utf8   == r->substrs->data[1].utf8_substr
20984                        ? "(checking floating" : "(checking anchored"));
20985     if (r->intflags & PREGf_NOSCAN)
20986         Perl_re_printf( aTHX_  " noscan");
20987     if (r->extflags & RXf_CHECK_ALL)
20988         Perl_re_printf( aTHX_  " isall");
20989     if (r->check_substr || r->check_utf8)
20990         Perl_re_printf( aTHX_  ") ");
20991
20992     if (ri->regstclass) {
20993         regprop(r, sv, ri->regstclass, NULL, NULL);
20994         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
20995     }
20996     if (r->intflags & PREGf_ANCH) {
20997         Perl_re_printf( aTHX_  "anchored");
20998         if (r->intflags & PREGf_ANCH_MBOL)
20999             Perl_re_printf( aTHX_  "(MBOL)");
21000         if (r->intflags & PREGf_ANCH_SBOL)
21001             Perl_re_printf( aTHX_  "(SBOL)");
21002         if (r->intflags & PREGf_ANCH_GPOS)
21003             Perl_re_printf( aTHX_  "(GPOS)");
21004         Perl_re_printf( aTHX_ " ");
21005     }
21006     if (r->intflags & PREGf_GPOS_SEEN)
21007         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
21008     if (r->intflags & PREGf_SKIP)
21009         Perl_re_printf( aTHX_  "plus ");
21010     if (r->intflags & PREGf_IMPLICIT)
21011         Perl_re_printf( aTHX_  "implicit ");
21012     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
21013     if (r->extflags & RXf_EVAL_SEEN)
21014         Perl_re_printf( aTHX_  "with eval ");
21015     Perl_re_printf( aTHX_  "\n");
21016     DEBUG_FLAGS_r({
21017         regdump_extflags("r->extflags: ", r->extflags);
21018         regdump_intflags("r->intflags: ", r->intflags);
21019     });
21020 #else
21021     PERL_ARGS_ASSERT_REGDUMP;
21022     PERL_UNUSED_CONTEXT;
21023     PERL_UNUSED_ARG(r);
21024 #endif  /* DEBUGGING */
21025 }
21026
21027 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
21028 #ifdef DEBUGGING
21029
21030 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
21031      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
21032      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
21033      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
21034      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
21035      || _CC_VERTSPACE != 15
21036 #   error Need to adjust order of anyofs[]
21037 #  endif
21038 static const char * const anyofs[] = {
21039     "\\w",
21040     "\\W",
21041     "\\d",
21042     "\\D",
21043     "[:alpha:]",
21044     "[:^alpha:]",
21045     "[:lower:]",
21046     "[:^lower:]",
21047     "[:upper:]",
21048     "[:^upper:]",
21049     "[:punct:]",
21050     "[:^punct:]",
21051     "[:print:]",
21052     "[:^print:]",
21053     "[:alnum:]",
21054     "[:^alnum:]",
21055     "[:graph:]",
21056     "[:^graph:]",
21057     "[:cased:]",
21058     "[:^cased:]",
21059     "\\s",
21060     "\\S",
21061     "[:blank:]",
21062     "[:^blank:]",
21063     "[:xdigit:]",
21064     "[:^xdigit:]",
21065     "[:cntrl:]",
21066     "[:^cntrl:]",
21067     "[:ascii:]",
21068     "[:^ascii:]",
21069     "\\v",
21070     "\\V"
21071 };
21072 #endif
21073
21074 /*
21075 - regprop - printable representation of opcode, with run time support
21076 */
21077
21078 void
21079 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
21080 {
21081 #ifdef DEBUGGING
21082     int k;
21083     RXi_GET_DECL(prog, progi);
21084     DECLARE_AND_GET_RE_DEBUG_FLAGS;
21085
21086     PERL_ARGS_ASSERT_REGPROP;
21087
21088     SvPVCLEAR(sv);
21089
21090     if (OP(o) > REGNODE_MAX) {          /* regnode.type is unsigned */
21091         if (pRExC_state) {  /* This gives more info, if we have it */
21092             FAIL3("panic: corrupted regexp opcode %d > %d",
21093                   (int)OP(o), (int)REGNODE_MAX);
21094         }
21095         else {
21096             Perl_croak(aTHX_ "panic: corrupted regexp opcode %d > %d",
21097                              (int)OP(o), (int)REGNODE_MAX);
21098         }
21099     }
21100     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
21101
21102     k = PL_regkind[OP(o)];
21103
21104     if (k == EXACT) {
21105         sv_catpvs(sv, " ");
21106         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
21107          * is a crude hack but it may be the best for now since
21108          * we have no flag "this EXACTish node was UTF-8"
21109          * --jhi */
21110         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
21111                   PL_colors[0], PL_colors[1],
21112                   PERL_PV_ESCAPE_UNI_DETECT |
21113                   PERL_PV_ESCAPE_NONASCII   |
21114                   PERL_PV_PRETTY_ELLIPSES   |
21115                   PERL_PV_PRETTY_LTGT       |
21116                   PERL_PV_PRETTY_NOCLEAR
21117                   );
21118     } else if (k == TRIE) {
21119         /* print the details of the trie in dumpuntil instead, as
21120          * progi->data isn't available here */
21121         const char op = OP(o);
21122         const U32 n = ARG(o);
21123         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
21124                (reg_ac_data *)progi->data->data[n] :
21125                NULL;
21126         const reg_trie_data * const trie
21127             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
21128
21129         Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]);
21130         DEBUG_TRIE_COMPILE_r({
21131           if (trie->jump)
21132             sv_catpvs(sv, "(JUMP)");
21133           Perl_sv_catpvf(aTHX_ sv,
21134             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
21135             (UV)trie->startstate,
21136             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
21137             (UV)trie->wordcount,
21138             (UV)trie->minlen,
21139             (UV)trie->maxlen,
21140             (UV)TRIE_CHARCOUNT(trie),
21141             (UV)trie->uniquecharcount
21142           );
21143         });
21144         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
21145             sv_catpvs(sv, "[");
21146             (void) put_charclass_bitmap_innards(sv,
21147                                                 ((IS_ANYOF_TRIE(op))
21148                                                  ? ANYOF_BITMAP(o)
21149                                                  : TRIE_BITMAP(trie)),
21150                                                 NULL,
21151                                                 NULL,
21152                                                 NULL,
21153                                                 0,
21154                                                 FALSE
21155                                                );
21156             sv_catpvs(sv, "]");
21157         }
21158     } else if (k == CURLY) {
21159         U32 lo = ARG1(o), hi = ARG2(o);
21160         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
21161             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
21162         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
21163         if (hi == REG_INFTY)
21164             sv_catpvs(sv, "INFTY");
21165         else
21166             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
21167         sv_catpvs(sv, "}");
21168     }
21169     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
21170         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
21171     else if (k == REF || k == OPEN || k == CLOSE
21172              || k == GROUPP || OP(o)==ACCEPT)
21173     {
21174         AV *name_list= NULL;
21175         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
21176         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
21177         if ( RXp_PAREN_NAMES(prog) ) {
21178             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
21179         } else if ( pRExC_state ) {
21180             name_list= RExC_paren_name_list;
21181         }
21182         if (name_list) {
21183             if ( k != REF || (OP(o) < REFN)) {
21184                 SV **name= av_fetch(name_list, parno, 0 );
21185                 if (name)
21186                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
21187             }
21188             else {
21189                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
21190                 I32 *nums=(I32*)SvPVX(sv_dat);
21191                 SV **name= av_fetch(name_list, nums[0], 0 );
21192                 I32 n;
21193                 if (name) {
21194                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
21195                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
21196                                     (n ? "," : ""), (IV)nums[n]);
21197                     }
21198                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
21199                 }
21200             }
21201         }
21202         if ( k == REF && reginfo) {
21203             U32 n = ARG(o);  /* which paren pair */
21204             I32 ln = prog->offs[n].start;
21205             if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
21206                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
21207             else if (ln == prog->offs[n].end)
21208                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
21209             else {
21210                 const char *s = reginfo->strbeg + ln;
21211                 Perl_sv_catpvf(aTHX_ sv, ": ");
21212                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
21213                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
21214             }
21215         }
21216     } else if (k == GOSUB) {
21217         AV *name_list= NULL;
21218         if ( RXp_PAREN_NAMES(prog) ) {
21219             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
21220         } else if ( pRExC_state ) {
21221             name_list= RExC_paren_name_list;
21222         }
21223
21224         /* Paren and offset */
21225         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
21226                 (int)((o + (int)ARG2L(o)) - progi->program) );
21227         if (name_list) {
21228             SV **name= av_fetch(name_list, ARG(o), 0 );
21229             if (name)
21230                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
21231         }
21232     }
21233     else if (k == LOGICAL)
21234         /* 2: embedded, otherwise 1 */
21235         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
21236     else if (k == ANYOF || k == ANYOFR) {
21237         U8 flags;
21238         char * bitmap;
21239         U32 arg;
21240         bool do_sep = FALSE;    /* Do we need to separate various components of
21241                                    the output? */
21242         /* Set if there is still an unresolved user-defined property */
21243         SV *unresolved                = NULL;
21244
21245         /* Things that are ignored except when the runtime locale is UTF-8 */
21246         SV *only_utf8_locale_invlist = NULL;
21247
21248         /* Code points that don't fit in the bitmap */
21249         SV *nonbitmap_invlist = NULL;
21250
21251         /* And things that aren't in the bitmap, but are small enough to be */
21252         SV* bitmap_range_not_in_bitmap = NULL;
21253
21254         bool inverted;
21255
21256         if (inRANGE(OP(o), ANYOFH, ANYOFRb)) {
21257             flags = 0;
21258             bitmap = NULL;
21259             arg = 0;
21260         }
21261         else {
21262             flags = ANYOF_FLAGS(o);
21263             bitmap = ANYOF_BITMAP(o);
21264             arg = ARG(o);
21265         }
21266
21267         if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) {
21268             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
21269                 sv_catpvs(sv, "{utf8-locale-reqd}");
21270             }
21271             if (flags & ANYOFL_FOLD) {
21272                 sv_catpvs(sv, "{i}");
21273             }
21274         }
21275
21276         inverted = flags & ANYOF_INVERT;
21277
21278         /* If there is stuff outside the bitmap, get it */
21279         if (arg != ANYOF_ONLY_HAS_BITMAP) {
21280             if (inRANGE(OP(o), ANYOFR, ANYOFRb)) {
21281                 nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
21282                                             ANYOFRbase(o),
21283                                             ANYOFRbase(o) + ANYOFRdelta(o));
21284             }
21285             else {
21286 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
21287                 (void) get_regclass_nonbitmap_data(prog, o, FALSE,
21288                                                 &unresolved,
21289                                                 &only_utf8_locale_invlist,
21290                                                 &nonbitmap_invlist);
21291 #else
21292                 (void) get_re_gclass_nonbitmap_data(prog, o, FALSE,
21293                                                 &unresolved,
21294                                                 &only_utf8_locale_invlist,
21295                                                 &nonbitmap_invlist);
21296 #endif
21297             }
21298
21299             /* The non-bitmap data may contain stuff that could fit in the
21300              * bitmap.  This could come from a user-defined property being
21301              * finally resolved when this call was done; or much more likely
21302              * because there are matches that require UTF-8 to be valid, and so
21303              * aren't in the bitmap (or ANYOFR).  This is teased apart later */
21304             _invlist_intersection(nonbitmap_invlist,
21305                                   PL_InBitmap,
21306                                   &bitmap_range_not_in_bitmap);
21307             /* Leave just the things that don't fit into the bitmap */
21308             _invlist_subtract(nonbitmap_invlist,
21309                               PL_InBitmap,
21310                               &nonbitmap_invlist);
21311         }
21312
21313         /* Obey this flag to add all above-the-bitmap code points */
21314         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
21315             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
21316                                                       NUM_ANYOF_CODE_POINTS,
21317                                                       UV_MAX);
21318         }
21319
21320         /* Ready to start outputting.  First, the initial left bracket */
21321         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
21322
21323         /* ANYOFH by definition doesn't have anything that will fit inside the
21324          * bitmap;  ANYOFR may or may not. */
21325         if (  ! inRANGE(OP(o), ANYOFH, ANYOFHr)
21326             && (   ! inRANGE(OP(o), ANYOFR, ANYOFRb)
21327                 ||   ANYOFRbase(o) < NUM_ANYOF_CODE_POINTS))
21328         {
21329             /* Then all the things that could fit in the bitmap */
21330             do_sep = put_charclass_bitmap_innards(sv,
21331                                                   bitmap,
21332                                                   bitmap_range_not_in_bitmap,
21333                                                   only_utf8_locale_invlist,
21334                                                   o,
21335                                                   flags,
21336
21337                                                   /* Can't try inverting for a
21338                                                    * better display if there
21339                                                    * are things that haven't
21340                                                    * been resolved */
21341                                                   unresolved != NULL
21342                                             || inRANGE(OP(o), ANYOFR, ANYOFRb));
21343             SvREFCNT_dec(bitmap_range_not_in_bitmap);
21344
21345             /* If there are user-defined properties which haven't been defined
21346              * yet, output them.  If the result is not to be inverted, it is
21347              * clearest to output them in a separate [] from the bitmap range
21348              * stuff.  If the result is to be complemented, we have to show
21349              * everything in one [], as the inversion applies to the whole
21350              * thing.  Use {braces} to separate them from anything in the
21351              * bitmap and anything above the bitmap. */
21352             if (unresolved) {
21353                 if (inverted) {
21354                     if (! do_sep) { /* If didn't output anything in the bitmap
21355                                      */
21356                         sv_catpvs(sv, "^");
21357                     }
21358                     sv_catpvs(sv, "{");
21359                 }
21360                 else if (do_sep) {
21361                     Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
21362                                                       PL_colors[0]);
21363                 }
21364                 sv_catsv(sv, unresolved);
21365                 if (inverted) {
21366                     sv_catpvs(sv, "}");
21367                 }
21368                 do_sep = ! inverted;
21369             }
21370         }
21371
21372         /* And, finally, add the above-the-bitmap stuff */
21373         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
21374             SV* contents;
21375
21376             /* See if truncation size is overridden */
21377             const STRLEN dump_len = (PL_dump_re_max_len > 256)
21378                                     ? PL_dump_re_max_len
21379                                     : 256;
21380
21381             /* This is output in a separate [] */
21382             if (do_sep) {
21383                 Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
21384             }
21385
21386             /* And, for easy of understanding, it is shown in the
21387              * uncomplemented form if possible.  The one exception being if
21388              * there are unresolved items, where the inversion has to be
21389              * delayed until runtime */
21390             if (inverted && ! unresolved) {
21391                 _invlist_invert(nonbitmap_invlist);
21392                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
21393             }
21394
21395             contents = invlist_contents(nonbitmap_invlist,
21396                                         FALSE /* output suitable for catsv */
21397                                        );
21398
21399             /* If the output is shorter than the permissible maximum, just do it. */
21400             if (SvCUR(contents) <= dump_len) {
21401                 sv_catsv(sv, contents);
21402             }
21403             else {
21404                 const char * contents_string = SvPVX(contents);
21405                 STRLEN i = dump_len;
21406
21407                 /* Otherwise, start at the permissible max and work back to the
21408                  * first break possibility */
21409                 while (i > 0 && contents_string[i] != ' ') {
21410                     i--;
21411                 }
21412                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
21413                                        find a legal break */
21414                     i = dump_len;
21415                 }
21416
21417                 sv_catpvn(sv, contents_string, i);
21418                 sv_catpvs(sv, "...");
21419             }
21420
21421             SvREFCNT_dec_NN(contents);
21422             SvREFCNT_dec_NN(nonbitmap_invlist);
21423         }
21424
21425         /* And finally the matching, closing ']' */
21426         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
21427
21428         if (OP(o) == ANYOFHs) {
21429             Perl_sv_catpvf(aTHX_ sv, " (Leading UTF-8 bytes=%s", _byte_dump_string((U8 *) ((struct regnode_anyofhs *) o)->string, FLAGS(o), 1));
21430         }
21431         else if (inRANGE(OP(o), ANYOFH, ANYOFRb)) {
21432             U8 lowest = (OP(o) != ANYOFHr)
21433                          ? FLAGS(o)
21434                          : LOWEST_ANYOF_HRx_BYTE(FLAGS(o));
21435             U8 highest = (OP(o) == ANYOFHr)
21436                          ? HIGHEST_ANYOF_HRx_BYTE(FLAGS(o))
21437                          : (OP(o) == ANYOFH || OP(o) == ANYOFR)
21438                            ? 0xFF
21439                            : lowest;
21440 #ifndef EBCDIC
21441             if (OP(o) != ANYOFR || ! isASCII(ANYOFRbase(o) + ANYOFRdelta(o)))
21442 #endif
21443             {
21444                 Perl_sv_catpvf(aTHX_ sv, " (First UTF-8 byte=%02X", lowest);
21445                 if (lowest != highest) {
21446                     Perl_sv_catpvf(aTHX_ sv, "-%02X", highest);
21447                 }
21448                 Perl_sv_catpvf(aTHX_ sv, ")");
21449             }
21450         }
21451
21452         SvREFCNT_dec(unresolved);
21453     }
21454     else if (k == ANYOFM) {
21455         SV * cp_list = get_ANYOFM_contents(o);
21456
21457         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
21458         if (OP(o) == NANYOFM) {
21459             _invlist_invert(cp_list);
21460         }
21461
21462         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, 0, TRUE);
21463         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
21464
21465         SvREFCNT_dec(cp_list);
21466     }
21467     else if (k == POSIXD || k == NPOSIXD) {
21468         U8 index = FLAGS(o) * 2;
21469         if (index < C_ARRAY_LENGTH(anyofs)) {
21470             if (*anyofs[index] != '[')  {
21471                 sv_catpvs(sv, "[");
21472             }
21473             sv_catpv(sv, anyofs[index]);
21474             if (*anyofs[index] != '[')  {
21475                 sv_catpvs(sv, "]");
21476             }
21477         }
21478         else {
21479             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
21480         }
21481     }
21482     else if (k == BOUND || k == NBOUND) {
21483         /* Must be synced with order of 'bound_type' in regcomp.h */
21484         const char * const bounds[] = {
21485             "",      /* Traditional */
21486             "{gcb}",
21487             "{lb}",
21488             "{sb}",
21489             "{wb}"
21490         };
21491         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
21492         sv_catpv(sv, bounds[FLAGS(o)]);
21493     }
21494     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) {
21495         Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags));
21496         if (o->next_off) {
21497             Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off);
21498         }
21499         Perl_sv_catpvf(aTHX_ sv, "]");
21500     }
21501     else if (OP(o) == SBOL)
21502         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
21503
21504     /* add on the verb argument if there is one */
21505     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
21506         if ( ARG(o) )
21507             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
21508                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
21509         else
21510             sv_catpvs(sv, ":NULL");
21511     }
21512 #else
21513     PERL_UNUSED_CONTEXT;
21514     PERL_UNUSED_ARG(sv);
21515     PERL_UNUSED_ARG(o);
21516     PERL_UNUSED_ARG(prog);
21517     PERL_UNUSED_ARG(reginfo);
21518     PERL_UNUSED_ARG(pRExC_state);
21519 #endif  /* DEBUGGING */
21520 }
21521
21522
21523
21524 SV *
21525 Perl_re_intuit_string(pTHX_ REGEXP * const r)
21526 {                               /* Assume that RE_INTUIT is set */
21527     /* Returns an SV containing a string that must appear in the target for it
21528      * to match, or NULL if nothing is known that must match.
21529      *
21530      * CAUTION: the SV can be freed during execution of the regex engine */
21531
21532     struct regexp *const prog = ReANY(r);
21533     DECLARE_AND_GET_RE_DEBUG_FLAGS;
21534
21535     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
21536     PERL_UNUSED_CONTEXT;
21537
21538     DEBUG_COMPILE_r(
21539         {
21540             if (prog->maxlen > 0) {
21541                 const char * const s = SvPV_nolen_const(RX_UTF8(r)
21542                       ? prog->check_utf8 : prog->check_substr);
21543
21544                 if (!PL_colorset) reginitcolors();
21545                 Perl_re_printf( aTHX_
21546                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
21547                       PL_colors[4],
21548                       RX_UTF8(r) ? "utf8 " : "",
21549                       PL_colors[5], PL_colors[0],
21550                       s,
21551                       PL_colors[1],
21552                       (strlen(s) > PL_dump_re_max_len ? "..." : ""));
21553             }
21554         } );
21555
21556     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
21557     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
21558 }
21559
21560 /*
21561    pregfree()
21562
21563    handles refcounting and freeing the perl core regexp structure. When
21564    it is necessary to actually free the structure the first thing it
21565    does is call the 'free' method of the regexp_engine associated to
21566    the regexp, allowing the handling of the void *pprivate; member
21567    first. (This routine is not overridable by extensions, which is why
21568    the extensions free is called first.)
21569
21570    See regdupe and regdupe_internal if you change anything here.
21571 */
21572 #ifndef PERL_IN_XSUB_RE
21573 void
21574 Perl_pregfree(pTHX_ REGEXP *r)
21575 {
21576     SvREFCNT_dec(r);
21577 }
21578
21579 void
21580 Perl_pregfree2(pTHX_ REGEXP *rx)
21581 {
21582     struct regexp *const r = ReANY(rx);
21583     DECLARE_AND_GET_RE_DEBUG_FLAGS;
21584
21585     PERL_ARGS_ASSERT_PREGFREE2;
21586
21587     if (! r)
21588         return;
21589
21590     if (r->mother_re) {
21591         ReREFCNT_dec(r->mother_re);
21592     } else {
21593         CALLREGFREE_PVT(rx); /* free the private data */
21594         SvREFCNT_dec(RXp_PAREN_NAMES(r));
21595     }
21596     if (r->substrs) {
21597         int i;
21598         for (i = 0; i < 2; i++) {
21599             SvREFCNT_dec(r->substrs->data[i].substr);
21600             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
21601         }
21602         Safefree(r->substrs);
21603     }
21604     RX_MATCH_COPY_FREE(rx);
21605 #ifdef PERL_ANY_COW
21606     SvREFCNT_dec(r->saved_copy);
21607 #endif
21608     Safefree(r->offs);
21609     SvREFCNT_dec(r->qr_anoncv);
21610     if (r->recurse_locinput)
21611         Safefree(r->recurse_locinput);
21612 }
21613
21614
21615 /*  reg_temp_copy()
21616
21617     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
21618     except that dsv will be created if NULL.
21619
21620     This function is used in two main ways. First to implement
21621         $r = qr/....; $s = $$r;
21622
21623     Secondly, it is used as a hacky workaround to the structural issue of
21624     match results
21625     being stored in the regexp structure which is in turn stored in
21626     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
21627     could be PL_curpm in multiple contexts, and could require multiple
21628     result sets being associated with the pattern simultaneously, such
21629     as when doing a recursive match with (??{$qr})
21630
21631     The solution is to make a lightweight copy of the regexp structure
21632     when a qr// is returned from the code executed by (??{$qr}) this
21633     lightweight copy doesn't actually own any of its data except for
21634     the starp/end and the actual regexp structure itself.
21635
21636 */
21637
21638
21639 REGEXP *
21640 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
21641 {
21642     struct regexp *drx;
21643     struct regexp *const srx = ReANY(ssv);
21644     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
21645
21646     PERL_ARGS_ASSERT_REG_TEMP_COPY;
21647
21648     if (!dsv)
21649         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
21650     else {
21651         assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV));
21652
21653         /* our only valid caller, sv_setsv_flags(), should have done
21654          * a SV_CHECK_THINKFIRST_COW_DROP() by now */
21655         assert(!SvOOK(dsv));
21656         assert(!SvIsCOW(dsv));
21657         assert(!SvROK(dsv));
21658
21659         if (SvPVX_const(dsv)) {
21660             if (SvLEN(dsv))
21661                 Safefree(SvPVX(dsv));
21662             SvPVX(dsv) = NULL;
21663         }
21664         SvLEN_set(dsv, 0);
21665         SvCUR_set(dsv, 0);
21666         SvOK_off((SV *)dsv);
21667
21668         if (islv) {
21669             /* For PVLVs, the head (sv_any) points to an XPVLV, while
21670              * the LV's xpvlenu_rx will point to a regexp body, which
21671              * we allocate here */
21672             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
21673             assert(!SvPVX(dsv));
21674             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
21675             temp->sv_any = NULL;
21676             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
21677             SvREFCNT_dec_NN(temp);
21678             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
21679                ing below will not set it. */
21680             SvCUR_set(dsv, SvCUR(ssv));
21681         }
21682     }
21683     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
21684        sv_force_normal(sv) is called.  */
21685     SvFAKE_on(dsv);
21686     drx = ReANY(dsv);
21687
21688     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
21689     SvPV_set(dsv, RX_WRAPPED(ssv));
21690     /* We share the same string buffer as the original regexp, on which we
21691        hold a reference count, incremented when mother_re is set below.
21692        The string pointer is copied here, being part of the regexp struct.
21693      */
21694     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
21695            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
21696     if (!islv)
21697         SvLEN_set(dsv, 0);
21698     if (srx->offs) {
21699         const I32 npar = srx->nparens+1;
21700         Newx(drx->offs, npar, regexp_paren_pair);
21701         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
21702     }
21703     if (srx->substrs) {
21704         int i;
21705         Newx(drx->substrs, 1, struct reg_substr_data);
21706         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
21707
21708         for (i = 0; i < 2; i++) {
21709             SvREFCNT_inc_void(drx->substrs->data[i].substr);
21710             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
21711         }
21712
21713         /* check_substr and check_utf8, if non-NULL, point to either their
21714            anchored or float namesakes, and don't hold a second reference.  */
21715     }
21716     RX_MATCH_COPIED_off(dsv);
21717 #ifdef PERL_ANY_COW
21718     drx->saved_copy = NULL;
21719 #endif
21720     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
21721     SvREFCNT_inc_void(drx->qr_anoncv);
21722     if (srx->recurse_locinput)
21723         Newx(drx->recurse_locinput, srx->nparens + 1, char *);
21724
21725     return dsv;
21726 }
21727 #endif
21728
21729
21730 /* regfree_internal()
21731
21732    Free the private data in a regexp. This is overloadable by
21733    extensions. Perl takes care of the regexp structure in pregfree(),
21734    this covers the *pprivate pointer which technically perl doesn't
21735    know about, however of course we have to handle the
21736    regexp_internal structure when no extension is in use.
21737
21738    Note this is called before freeing anything in the regexp
21739    structure.
21740  */
21741
21742 void
21743 Perl_regfree_internal(pTHX_ REGEXP * const rx)
21744 {
21745     struct regexp *const r = ReANY(rx);
21746     RXi_GET_DECL(r, ri);
21747     DECLARE_AND_GET_RE_DEBUG_FLAGS;
21748
21749     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
21750
21751     if (! ri) {
21752         return;
21753     }
21754
21755     DEBUG_COMPILE_r({
21756         if (!PL_colorset)
21757             reginitcolors();
21758         {
21759             SV *dsv= sv_newmortal();
21760             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
21761                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
21762             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
21763                 PL_colors[4], PL_colors[5], s);
21764         }
21765     });
21766
21767 #ifdef RE_TRACK_PATTERN_OFFSETS
21768     if (ri->u.offsets)
21769         Safefree(ri->u.offsets);             /* 20010421 MJD */
21770 #endif
21771     if (ri->code_blocks)
21772         S_free_codeblocks(aTHX_ ri->code_blocks);
21773
21774     if (ri->data) {
21775         int n = ri->data->count;
21776
21777         while (--n >= 0) {
21778           /* If you add a ->what type here, update the comment in regcomp.h */
21779             switch (ri->data->what[n]) {
21780             case 'a':
21781             case 'r':
21782             case 's':
21783             case 'S':
21784             case 'u':
21785                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
21786                 break;
21787             case 'f':
21788                 Safefree(ri->data->data[n]);
21789                 break;
21790             case 'l':
21791             case 'L':
21792                 break;
21793             case 'T':
21794                 { /* Aho Corasick add-on structure for a trie node.
21795                      Used in stclass optimization only */
21796                     U32 refcount;
21797                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
21798 #ifdef USE_ITHREADS
21799 #endif
21800                     OP_REFCNT_LOCK;
21801                     refcount = --aho->refcount;
21802                     OP_REFCNT_UNLOCK;
21803                     if ( !refcount ) {
21804                         PerlMemShared_free(aho->states);
21805                         PerlMemShared_free(aho->fail);
21806                          /* do this last!!!! */
21807                         PerlMemShared_free(ri->data->data[n]);
21808                         /* we should only ever get called once, so
21809                          * assert as much, and also guard the free
21810                          * which /might/ happen twice. At the least
21811                          * it will make code anlyzers happy and it
21812                          * doesn't cost much. - Yves */
21813                         assert(ri->regstclass);
21814                         if (ri->regstclass) {
21815                             PerlMemShared_free(ri->regstclass);
21816                             ri->regstclass = 0;
21817                         }
21818                     }
21819                 }
21820                 break;
21821             case 't':
21822                 {
21823                     /* trie structure. */
21824                     U32 refcount;
21825                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
21826 #ifdef USE_ITHREADS
21827 #endif
21828                     OP_REFCNT_LOCK;
21829                     refcount = --trie->refcount;
21830                     OP_REFCNT_UNLOCK;
21831                     if ( !refcount ) {
21832                         PerlMemShared_free(trie->charmap);
21833                         PerlMemShared_free(trie->states);
21834                         PerlMemShared_free(trie->trans);
21835                         if (trie->bitmap)
21836                             PerlMemShared_free(trie->bitmap);
21837                         if (trie->jump)
21838                             PerlMemShared_free(trie->jump);
21839                         PerlMemShared_free(trie->wordinfo);
21840                         /* do this last!!!! */
21841                         PerlMemShared_free(ri->data->data[n]);
21842                     }
21843                 }
21844                 break;
21845             default:
21846                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
21847                                                     ri->data->what[n]);
21848             }
21849         }
21850         Safefree(ri->data->what);
21851         Safefree(ri->data);
21852     }
21853
21854     Safefree(ri);
21855 }
21856
21857 #define av_dup_inc(s, t)        MUTABLE_AV(sv_dup_inc((const SV *)s, t))
21858 #define hv_dup_inc(s, t)        MUTABLE_HV(sv_dup_inc((const SV *)s, t))
21859 #define SAVEPVN(p, n)   ((p) ? savepvn(p, n) : NULL)
21860
21861 /*
21862 =for apidoc_section REGEXP Functions
21863 =for apidoc re_dup_guts
21864 Duplicate a regexp.
21865
21866 This routine is expected to clone a given regexp structure. It is only
21867 compiled under USE_ITHREADS.
21868
21869 After all of the core data stored in struct regexp is duplicated
21870 the C<regexp_engine.dupe> method is used to copy any private data
21871 stored in the *pprivate pointer. This allows extensions to handle
21872 any duplication they need to do.
21873
21874 =cut
21875
21876    See pregfree() and regfree_internal() if you change anything here.
21877 */
21878 #if defined(USE_ITHREADS)
21879 #ifndef PERL_IN_XSUB_RE
21880 void
21881 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
21882 {
21883     I32 npar;
21884     const struct regexp *r = ReANY(sstr);
21885     struct regexp *ret = ReANY(dstr);
21886
21887     PERL_ARGS_ASSERT_RE_DUP_GUTS;
21888
21889     npar = r->nparens+1;
21890     Newx(ret->offs, npar, regexp_paren_pair);
21891     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
21892
21893     if (ret->substrs) {
21894         /* Do it this way to avoid reading from *r after the StructCopy().
21895            That way, if any of the sv_dup_inc()s dislodge *r from the L1
21896            cache, it doesn't matter.  */
21897         int i;
21898         const bool anchored = r->check_substr
21899             ? r->check_substr == r->substrs->data[0].substr
21900             : r->check_utf8   == r->substrs->data[0].utf8_substr;
21901         Newx(ret->substrs, 1, struct reg_substr_data);
21902         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
21903
21904         for (i = 0; i < 2; i++) {
21905             ret->substrs->data[i].substr =
21906                         sv_dup_inc(ret->substrs->data[i].substr, param);
21907             ret->substrs->data[i].utf8_substr =
21908                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
21909         }
21910
21911         /* check_substr and check_utf8, if non-NULL, point to either their
21912            anchored or float namesakes, and don't hold a second reference.  */
21913
21914         if (ret->check_substr) {
21915             if (anchored) {
21916                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
21917
21918                 ret->check_substr = ret->substrs->data[0].substr;
21919                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
21920             } else {
21921                 assert(r->check_substr == r->substrs->data[1].substr);
21922                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
21923
21924                 ret->check_substr = ret->substrs->data[1].substr;
21925                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
21926             }
21927         } else if (ret->check_utf8) {
21928             if (anchored) {
21929                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
21930             } else {
21931                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
21932             }
21933         }
21934     }
21935
21936     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
21937     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
21938     if (r->recurse_locinput)
21939         Newx(ret->recurse_locinput, r->nparens + 1, char *);
21940
21941     if (ret->pprivate)
21942         RXi_SET(ret, CALLREGDUPE_PVT(dstr, param));
21943
21944     if (RX_MATCH_COPIED(dstr))
21945         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
21946     else
21947         ret->subbeg = NULL;
21948 #ifdef PERL_ANY_COW
21949     ret->saved_copy = NULL;
21950 #endif
21951
21952     /* Whether mother_re be set or no, we need to copy the string.  We
21953        cannot refrain from copying it when the storage points directly to
21954        our mother regexp, because that's
21955                1: a buffer in a different thread
21956                2: something we no longer hold a reference on
21957                so we need to copy it locally.  */
21958     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
21959     /* set malloced length to a non-zero value so it will be freed
21960      * (otherwise in combination with SVf_FAKE it looks like an alien
21961      * buffer). It doesn't have to be the actual malloced size, since it
21962      * should never be grown */
21963     SvLEN_set(dstr, SvCUR(sstr)+1);
21964     ret->mother_re   = NULL;
21965 }
21966 #endif /* PERL_IN_XSUB_RE */
21967
21968 /*
21969    regdupe_internal()
21970
21971    This is the internal complement to regdupe() which is used to copy
21972    the structure pointed to by the *pprivate pointer in the regexp.
21973    This is the core version of the extension overridable cloning hook.
21974    The regexp structure being duplicated will be copied by perl prior
21975    to this and will be provided as the regexp *r argument, however
21976    with the /old/ structures pprivate pointer value. Thus this routine
21977    may override any copying normally done by perl.
21978
21979    It returns a pointer to the new regexp_internal structure.
21980 */
21981
21982 void *
21983 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
21984 {
21985     struct regexp *const r = ReANY(rx);
21986     regexp_internal *reti;
21987     int len;
21988     RXi_GET_DECL(r, ri);
21989
21990     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
21991
21992     len = ProgLen(ri);
21993
21994     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
21995           char, regexp_internal);
21996     Copy(ri->program, reti->program, len+1, regnode);
21997
21998
21999     if (ri->code_blocks) {
22000         int n;
22001         Newx(reti->code_blocks, 1, struct reg_code_blocks);
22002         Newx(reti->code_blocks->cb, ri->code_blocks->count,
22003                     struct reg_code_block);
22004         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
22005              ri->code_blocks->count, struct reg_code_block);
22006         for (n = 0; n < ri->code_blocks->count; n++)
22007              reti->code_blocks->cb[n].src_regex = (REGEXP*)
22008                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
22009         reti->code_blocks->count = ri->code_blocks->count;
22010         reti->code_blocks->refcnt = 1;
22011     }
22012     else
22013         reti->code_blocks = NULL;
22014
22015     reti->regstclass = NULL;
22016
22017     if (ri->data) {
22018         struct reg_data *d;
22019         const int count = ri->data->count;
22020         int i;
22021
22022         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
22023                 char, struct reg_data);
22024         Newx(d->what, count, U8);
22025
22026         d->count = count;
22027         for (i = 0; i < count; i++) {
22028             d->what[i] = ri->data->what[i];
22029             switch (d->what[i]) {
22030                 /* see also regcomp.h and regfree_internal() */
22031             case 'a': /* actually an AV, but the dup function is identical.
22032                          values seem to be "plain sv's" generally. */
22033             case 'r': /* a compiled regex (but still just another SV) */
22034             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
22035                          this use case should go away, the code could have used
22036                          'a' instead - see S_set_ANYOF_arg() for array contents. */
22037             case 'S': /* actually an SV, but the dup function is identical.  */
22038             case 'u': /* actually an HV, but the dup function is identical.
22039                          values are "plain sv's" */
22040                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
22041                 break;
22042             case 'f':
22043                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
22044                  * patterns which could start with several different things. Pre-TRIE
22045                  * this was more important than it is now, however this still helps
22046                  * in some places, for instance /x?a+/ might produce a SSC equivalent
22047                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
22048                  * in regexec.c
22049                  */
22050                 /* This is cheating. */
22051                 Newx(d->data[i], 1, regnode_ssc);
22052                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
22053                 reti->regstclass = (regnode*)d->data[i];
22054                 break;
22055             case 'T':
22056                 /* AHO-CORASICK fail table */
22057                 /* Trie stclasses are readonly and can thus be shared
22058                  * without duplication. We free the stclass in pregfree
22059                  * when the corresponding reg_ac_data struct is freed.
22060                  */
22061                 reti->regstclass= ri->regstclass;
22062                 /* FALLTHROUGH */
22063             case 't':
22064                 /* TRIE transition table */
22065                 OP_REFCNT_LOCK;
22066                 ((reg_trie_data*)ri->data->data[i])->refcount++;
22067                 OP_REFCNT_UNLOCK;
22068                 /* FALLTHROUGH */
22069             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
22070             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
22071                          is not from another regexp */
22072                 d->data[i] = ri->data->data[i];
22073                 break;
22074             default:
22075                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
22076                                                            ri->data->what[i]);
22077             }
22078         }
22079
22080         reti->data = d;
22081     }
22082     else
22083         reti->data = NULL;
22084
22085     reti->name_list_idx = ri->name_list_idx;
22086
22087 #ifdef RE_TRACK_PATTERN_OFFSETS
22088     if (ri->u.offsets) {
22089         Newx(reti->u.offsets, 2*len+1, U32);
22090         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
22091     }
22092 #else
22093     SetProgLen(reti, len);
22094 #endif
22095
22096     return (void*)reti;
22097 }
22098
22099 #endif    /* USE_ITHREADS */
22100
22101 #ifndef PERL_IN_XSUB_RE
22102
22103 /*
22104  - regnext - dig the "next" pointer out of a node
22105  */
22106 regnode *
22107 Perl_regnext(pTHX_ regnode *p)
22108 {
22109     I32 offset;
22110
22111     if (!p)
22112         return(NULL);
22113
22114     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
22115         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
22116                                                 (int)OP(p), (int)REGNODE_MAX);
22117     }
22118
22119     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
22120     if (offset == 0)
22121         return(NULL);
22122
22123     return(p+offset);
22124 }
22125
22126 #endif
22127
22128 STATIC void
22129 S_re_croak(pTHX_ bool utf8, const char* pat,...)
22130 {
22131     va_list args;
22132     STRLEN len = strlen(pat);
22133     char buf[512];
22134     SV *msv;
22135     const char *message;
22136
22137     PERL_ARGS_ASSERT_RE_CROAK;
22138
22139     if (len > 510)
22140         len = 510;
22141     Copy(pat, buf, len , char);
22142     buf[len] = '\n';
22143     buf[len + 1] = '\0';
22144     va_start(args, pat);
22145     msv = vmess(buf, &args);
22146     va_end(args);
22147     message = SvPV_const(msv, len);
22148     if (len > 512)
22149         len = 512;
22150     Copy(message, buf, len , char);
22151     /* len-1 to avoid \n */
22152     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, len-1, buf));
22153 }
22154
22155 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
22156
22157 #ifndef PERL_IN_XSUB_RE
22158 void
22159 Perl_save_re_context(pTHX)
22160 {
22161     I32 nparens = -1;
22162     I32 i;
22163
22164     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
22165
22166     if (PL_curpm) {
22167         const REGEXP * const rx = PM_GETRE(PL_curpm);
22168         if (rx)
22169             nparens = RX_NPARENS(rx);
22170     }
22171
22172     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
22173      * that PL_curpm will be null, but that utf8.pm and the modules it
22174      * loads will only use $1..$3.
22175      * The t/porting/re_context.t test file checks this assumption.
22176      */
22177     if (nparens == -1)
22178         nparens = 3;
22179
22180     for (i = 1; i <= nparens; i++) {
22181         char digits[TYPE_CHARS(long)];
22182         const STRLEN len = my_snprintf(digits, sizeof(digits),
22183                                        "%lu", (long)i);
22184         GV *const *const gvp
22185             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
22186
22187         if (gvp) {
22188             GV * const gv = *gvp;
22189             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
22190                 save_scalar(gv);
22191         }
22192     }
22193 }
22194 #endif
22195
22196 #ifdef DEBUGGING
22197
22198 STATIC void
22199 S_put_code_point(pTHX_ SV *sv, UV c)
22200 {
22201     PERL_ARGS_ASSERT_PUT_CODE_POINT;
22202
22203     if (c > 255) {
22204         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
22205     }
22206     else if (isPRINT(c)) {
22207         const char string = (char) c;
22208
22209         /* We use {phrase} as metanotation in the class, so also escape literal
22210          * braces */
22211         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
22212             sv_catpvs(sv, "\\");
22213         sv_catpvn(sv, &string, 1);
22214     }
22215     else if (isMNEMONIC_CNTRL(c)) {
22216         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
22217     }
22218     else {
22219         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
22220     }
22221 }
22222
22223 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
22224
22225 STATIC void
22226 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
22227 {
22228     /* Appends to 'sv' a displayable version of the range of code points from
22229      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
22230      * that have them, when they occur at the beginning or end of the range.
22231      * It uses hex to output the remaining code points, unless 'allow_literals'
22232      * is true, in which case the printable ASCII ones are output as-is (though
22233      * some of these will be escaped by put_code_point()).
22234      *
22235      * NOTE:  This is designed only for printing ranges of code points that fit
22236      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
22237      */
22238
22239     const unsigned int min_range_count = 3;
22240
22241     assert(start <= end);
22242
22243     PERL_ARGS_ASSERT_PUT_RANGE;
22244
22245     while (start <= end) {
22246         UV this_end;
22247         const char * format;
22248
22249         if (    end - start < min_range_count
22250             && (end - start <= 2 || (isPRINT_A(start) && isPRINT_A(end))))
22251         {
22252             /* Output a range of 1 or 2 chars individually, or longer ranges
22253              * when printable */
22254             for (; start <= end; start++) {
22255                 put_code_point(sv, start);
22256             }
22257             break;
22258         }
22259
22260         /* If permitted by the input options, and there is a possibility that
22261          * this range contains a printable literal, look to see if there is
22262          * one. */
22263         if (allow_literals && start <= MAX_PRINT_A) {
22264
22265             /* If the character at the beginning of the range isn't an ASCII
22266              * printable, effectively split the range into two parts:
22267              *  1) the portion before the first such printable,
22268              *  2) the rest
22269              * and output them separately. */
22270             if (! isPRINT_A(start)) {
22271                 UV temp_end = start + 1;
22272
22273                 /* There is no point looking beyond the final possible
22274                  * printable, in MAX_PRINT_A */
22275                 UV max = MIN(end, MAX_PRINT_A);
22276
22277                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
22278                     temp_end++;
22279                 }
22280
22281                 /* Here, temp_end points to one beyond the first printable if
22282                  * found, or to one beyond 'max' if not.  If none found, make
22283                  * sure that we use the entire range */
22284                 if (temp_end > MAX_PRINT_A) {
22285                     temp_end = end + 1;
22286                 }
22287
22288                 /* Output the first part of the split range: the part that
22289                  * doesn't have printables, with the parameter set to not look
22290                  * for literals (otherwise we would infinitely recurse) */
22291                 put_range(sv, start, temp_end - 1, FALSE);
22292
22293                 /* The 2nd part of the range (if any) starts here. */
22294                 start = temp_end;
22295
22296                 /* We do a continue, instead of dropping down, because even if
22297                  * the 2nd part is non-empty, it could be so short that we want
22298                  * to output it as individual characters, as tested for at the
22299                  * top of this loop.  */
22300                 continue;
22301             }
22302
22303             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
22304              * output a sub-range of just the digits or letters, then process
22305              * the remaining portion as usual. */
22306             if (isALPHANUMERIC_A(start)) {
22307                 UV mask = (isDIGIT_A(start))
22308                            ? _CC_DIGIT
22309                              : isUPPER_A(start)
22310                                ? _CC_UPPER
22311                                : _CC_LOWER;
22312                 UV temp_end = start + 1;
22313
22314                 /* Find the end of the sub-range that includes just the
22315                  * characters in the same class as the first character in it */
22316                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
22317                     temp_end++;
22318                 }
22319                 temp_end--;
22320
22321                 /* For short ranges, don't duplicate the code above to output
22322                  * them; just call recursively */
22323                 if (temp_end - start < min_range_count) {
22324                     put_range(sv, start, temp_end, FALSE);
22325                 }
22326                 else {  /* Output as a range */
22327                     put_code_point(sv, start);
22328                     sv_catpvs(sv, "-");
22329                     put_code_point(sv, temp_end);
22330                 }
22331                 start = temp_end + 1;
22332                 continue;
22333             }
22334
22335             /* We output any other printables as individual characters */
22336             if (isPUNCT_A(start) || isSPACE_A(start)) {
22337                 while (start <= end && (isPUNCT_A(start)
22338                                         || isSPACE_A(start)))
22339                 {
22340                     put_code_point(sv, start);
22341                     start++;
22342                 }
22343                 continue;
22344             }
22345         } /* End of looking for literals */
22346
22347         /* Here is not to output as a literal.  Some control characters have
22348          * mnemonic names.  Split off any of those at the beginning and end of
22349          * the range to print mnemonically.  It isn't possible for many of
22350          * these to be in a row, so this won't overwhelm with output */
22351         if (   start <= end
22352             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
22353         {
22354             while (isMNEMONIC_CNTRL(start) && start <= end) {
22355                 put_code_point(sv, start);
22356                 start++;
22357             }
22358
22359             /* If this didn't take care of the whole range ... */
22360             if (start <= end) {
22361
22362                 /* Look backwards from the end to find the final non-mnemonic
22363                  * */
22364                 UV temp_end = end;
22365                 while (isMNEMONIC_CNTRL(temp_end)) {
22366                     temp_end--;
22367                 }
22368
22369                 /* And separately output the interior range that doesn't start
22370                  * or end with mnemonics */
22371                 put_range(sv, start, temp_end, FALSE);
22372
22373                 /* Then output the mnemonic trailing controls */
22374                 start = temp_end + 1;
22375                 while (start <= end) {
22376                     put_code_point(sv, start);
22377                     start++;
22378                 }
22379                 break;
22380             }
22381         }
22382
22383         /* As a final resort, output the range or subrange as hex. */
22384
22385         if (start >= NUM_ANYOF_CODE_POINTS) {
22386             this_end = end;
22387         }
22388         else {  /* Have to split range at the bitmap boundary */
22389             this_end = (end < NUM_ANYOF_CODE_POINTS)
22390                         ? end
22391                         : NUM_ANYOF_CODE_POINTS - 1;
22392         }
22393 #if NUM_ANYOF_CODE_POINTS > 256
22394         format = (this_end < 256)
22395                  ? "\\x%02" UVXf "-\\x%02" UVXf
22396                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
22397 #else
22398         format = "\\x%02" UVXf "-\\x%02" UVXf;
22399 #endif
22400         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
22401         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
22402         GCC_DIAG_RESTORE_STMT;
22403         break;
22404     }
22405 }
22406
22407 STATIC void
22408 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
22409 {
22410     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
22411      * 'invlist' */
22412
22413     UV start, end;
22414     bool allow_literals = TRUE;
22415
22416     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
22417
22418     /* Generally, it is more readable if printable characters are output as
22419      * literals, but if a range (nearly) spans all of them, it's best to output
22420      * it as a single range.  This code will use a single range if all but 2
22421      * ASCII printables are in it */
22422     invlist_iterinit(invlist);
22423     while (invlist_iternext(invlist, &start, &end)) {
22424
22425         /* If the range starts beyond the final printable, it doesn't have any
22426          * in it */
22427         if (start > MAX_PRINT_A) {
22428             break;
22429         }
22430
22431         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
22432          * all but two, the range must start and end no later than 2 from
22433          * either end */
22434         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
22435             if (end > MAX_PRINT_A) {
22436                 end = MAX_PRINT_A;
22437             }
22438             if (start < ' ') {
22439                 start = ' ';
22440             }
22441             if (end - start >= MAX_PRINT_A - ' ' - 2) {
22442                 allow_literals = FALSE;
22443             }
22444             break;
22445         }
22446     }
22447     invlist_iterfinish(invlist);
22448
22449     /* Here we have figured things out.  Output each range */
22450     invlist_iterinit(invlist);
22451     while (invlist_iternext(invlist, &start, &end)) {
22452         if (start >= NUM_ANYOF_CODE_POINTS) {
22453             break;
22454         }
22455         put_range(sv, start, end, allow_literals);
22456     }
22457     invlist_iterfinish(invlist);
22458
22459     return;
22460 }
22461
22462 STATIC SV*
22463 S_put_charclass_bitmap_innards_common(pTHX_
22464         SV* invlist,            /* The bitmap */
22465         SV* posixes,            /* Under /l, things like [:word:], \S */
22466         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
22467         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
22468         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
22469         const bool invert       /* Is the result to be inverted? */
22470 )
22471 {
22472     /* Create and return an SV containing a displayable version of the bitmap
22473      * and associated information determined by the input parameters.  If the
22474      * output would have been only the inversion indicator '^', NULL is instead
22475      * returned. */
22476
22477     SV * output;
22478
22479     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
22480
22481     if (invert) {
22482         output = newSVpvs("^");
22483     }
22484     else {
22485         output = newSVpvs("");
22486     }
22487
22488     /* First, the code points in the bitmap that are unconditionally there */
22489     put_charclass_bitmap_innards_invlist(output, invlist);
22490
22491     /* Traditionally, these have been placed after the main code points */
22492     if (posixes) {
22493         sv_catsv(output, posixes);
22494     }
22495
22496     if (only_utf8 && _invlist_len(only_utf8)) {
22497         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
22498         put_charclass_bitmap_innards_invlist(output, only_utf8);
22499     }
22500
22501     if (not_utf8 && _invlist_len(not_utf8)) {
22502         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
22503         put_charclass_bitmap_innards_invlist(output, not_utf8);
22504     }
22505
22506     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
22507         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
22508         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
22509
22510         /* This is the only list in this routine that can legally contain code
22511          * points outside the bitmap range.  The call just above to
22512          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
22513          * output them here.  There's about a half-dozen possible, and none in
22514          * contiguous ranges longer than 2 */
22515         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
22516             UV start, end;
22517             SV* above_bitmap = NULL;
22518
22519             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
22520
22521             invlist_iterinit(above_bitmap);
22522             while (invlist_iternext(above_bitmap, &start, &end)) {
22523                 UV i;
22524
22525                 for (i = start; i <= end; i++) {
22526                     put_code_point(output, i);
22527                 }
22528             }
22529             invlist_iterfinish(above_bitmap);
22530             SvREFCNT_dec_NN(above_bitmap);
22531         }
22532     }
22533
22534     if (invert && SvCUR(output) == 1) {
22535         return NULL;
22536     }
22537
22538     return output;
22539 }
22540
22541 STATIC bool
22542 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
22543                                      char *bitmap,
22544                                      SV *nonbitmap_invlist,
22545                                      SV *only_utf8_locale_invlist,
22546                                      const regnode * const node,
22547                                      const U8 flags,
22548                                      const bool force_as_is_display)
22549 {
22550     /* Appends to 'sv' a displayable version of the innards of the bracketed
22551      * character class defined by the other arguments:
22552      *  'bitmap' points to the bitmap, or NULL if to ignore that.
22553      *  'nonbitmap_invlist' is an inversion list of the code points that are in
22554      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
22555      *      none.  The reasons for this could be that they require some
22556      *      condition such as the target string being or not being in UTF-8
22557      *      (under /d), or because they came from a user-defined property that
22558      *      was not resolved at the time of the regex compilation (under /u)
22559      *  'only_utf8_locale_invlist' is an inversion list of the code points that
22560      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
22561      *  'node' is the regex pattern ANYOF node.  It is needed only when the
22562      *      above two parameters are not null, and is passed so that this
22563      *      routine can tease apart the various reasons for them.
22564      *  'flags' is the flags field of 'node'
22565      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
22566      *      to invert things to see if that leads to a cleaner display.  If
22567      *      FALSE, this routine is free to use its judgment about doing this.
22568      *
22569      * It returns TRUE if there was actually something output.  (It may be that
22570      * the bitmap, etc is empty.)
22571      *
22572      * When called for outputting the bitmap of a non-ANYOF node, just pass the
22573      * bitmap, with the succeeding parameters set to NULL, and the final one to
22574      * FALSE.
22575      */
22576
22577     /* In general, it tries to display the 'cleanest' representation of the
22578      * innards, choosing whether to display them inverted or not, regardless of
22579      * whether the class itself is to be inverted.  However,  there are some
22580      * cases where it can't try inverting, as what actually matches isn't known
22581      * until runtime, and hence the inversion isn't either. */
22582
22583     bool inverting_allowed = ! force_as_is_display;
22584
22585     int i;
22586     STRLEN orig_sv_cur = SvCUR(sv);
22587
22588     SV* invlist;            /* Inversion list we accumulate of code points that
22589                                are unconditionally matched */
22590     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
22591                                UTF-8 */
22592     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
22593                              */
22594     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
22595     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
22596                                        is UTF-8 */
22597
22598     SV* as_is_display;      /* The output string when we take the inputs
22599                                literally */
22600     SV* inverted_display;   /* The output string when we invert the inputs */
22601
22602     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
22603                                                    to match? */
22604     /* We are biased in favor of displaying things without them being inverted,
22605      * as that is generally easier to understand */
22606     const int bias = 5;
22607
22608     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
22609
22610     /* Start off with whatever code points are passed in.  (We clone, so we
22611      * don't change the caller's list) */
22612     if (nonbitmap_invlist) {
22613         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
22614         invlist = invlist_clone(nonbitmap_invlist, NULL);
22615     }
22616     else {  /* Worst case size is every other code point is matched */
22617         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
22618     }
22619
22620     if (flags) {
22621         if (OP(node) == ANYOFD) {
22622
22623             /* This flag indicates that the code points below 0x100 in the
22624              * nonbitmap list are precisely the ones that match only when the
22625              * target is UTF-8 (they should all be non-ASCII). */
22626             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
22627             {
22628                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
22629                 _invlist_subtract(invlist, only_utf8, &invlist);
22630             }
22631
22632             /* And this flag for matching all non-ASCII 0xFF and below */
22633             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
22634             {
22635                 not_utf8 = invlist_clone(PL_UpperLatin1, NULL);
22636             }
22637         }
22638         else if (OP(node) == ANYOFL || OP(node) == ANYOFPOSIXL) {
22639
22640             /* If either of these flags are set, what matches isn't
22641              * determinable except during execution, so don't know enough here
22642              * to invert */
22643             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
22644                 inverting_allowed = FALSE;
22645             }
22646
22647             /* What the posix classes match also varies at runtime, so these
22648              * will be output symbolically. */
22649             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
22650                 int i;
22651
22652                 posixes = newSVpvs("");
22653                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
22654                     if (ANYOF_POSIXL_TEST(node, i)) {
22655                         sv_catpv(posixes, anyofs[i]);
22656                     }
22657                 }
22658             }
22659         }
22660     }
22661
22662     /* Accumulate the bit map into the unconditional match list */
22663     if (bitmap) {
22664         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
22665             if (BITMAP_TEST(bitmap, i)) {
22666                 int start = i++;
22667                 for (;
22668                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
22669                      i++)
22670                 { /* empty */ }
22671                 invlist = _add_range_to_invlist(invlist, start, i-1);
22672             }
22673         }
22674     }
22675
22676     /* Make sure that the conditional match lists don't have anything in them
22677      * that match unconditionally; otherwise the output is quite confusing.
22678      * This could happen if the code that populates these misses some
22679      * duplication. */
22680     if (only_utf8) {
22681         _invlist_subtract(only_utf8, invlist, &only_utf8);
22682     }
22683     if (not_utf8) {
22684         _invlist_subtract(not_utf8, invlist, &not_utf8);
22685     }
22686
22687     if (only_utf8_locale_invlist) {
22688
22689         /* Since this list is passed in, we have to make a copy before
22690          * modifying it */
22691         only_utf8_locale = invlist_clone(only_utf8_locale_invlist, NULL);
22692
22693         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
22694
22695         /* And, it can get really weird for us to try outputting an inverted
22696          * form of this list when it has things above the bitmap, so don't even
22697          * try */
22698         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
22699             inverting_allowed = FALSE;
22700         }
22701     }
22702
22703     /* Calculate what the output would be if we take the input as-is */
22704     as_is_display = put_charclass_bitmap_innards_common(invlist,
22705                                                     posixes,
22706                                                     only_utf8,
22707                                                     not_utf8,
22708                                                     only_utf8_locale,
22709                                                     invert);
22710
22711     /* If have to take the output as-is, just do that */
22712     if (! inverting_allowed) {
22713         if (as_is_display) {
22714             sv_catsv(sv, as_is_display);
22715             SvREFCNT_dec_NN(as_is_display);
22716         }
22717     }
22718     else { /* But otherwise, create the output again on the inverted input, and
22719               use whichever version is shorter */
22720
22721         int inverted_bias, as_is_bias;
22722
22723         /* We will apply our bias to whichever of the results doesn't have
22724          * the '^' */
22725         if (invert) {
22726             invert = FALSE;
22727             as_is_bias = bias;
22728             inverted_bias = 0;
22729         }
22730         else {
22731             invert = TRUE;
22732             as_is_bias = 0;
22733             inverted_bias = bias;
22734         }
22735
22736         /* Now invert each of the lists that contribute to the output,
22737          * excluding from the result things outside the possible range */
22738
22739         /* For the unconditional inversion list, we have to add in all the
22740          * conditional code points, so that when inverted, they will be gone
22741          * from it */
22742         _invlist_union(only_utf8, invlist, &invlist);
22743         _invlist_union(not_utf8, invlist, &invlist);
22744         _invlist_union(only_utf8_locale, invlist, &invlist);
22745         _invlist_invert(invlist);
22746         _invlist_intersection(invlist, PL_InBitmap, &invlist);
22747
22748         if (only_utf8) {
22749             _invlist_invert(only_utf8);
22750             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
22751         }
22752         else if (not_utf8) {
22753
22754             /* If a code point matches iff the target string is not in UTF-8,
22755              * then complementing the result has it not match iff not in UTF-8,
22756              * which is the same thing as matching iff it is UTF-8. */
22757             only_utf8 = not_utf8;
22758             not_utf8 = NULL;
22759         }
22760
22761         if (only_utf8_locale) {
22762             _invlist_invert(only_utf8_locale);
22763             _invlist_intersection(only_utf8_locale,
22764                                   PL_InBitmap,
22765                                   &only_utf8_locale);
22766         }
22767
22768         inverted_display = put_charclass_bitmap_innards_common(
22769                                             invlist,
22770                                             posixes,
22771                                             only_utf8,
22772                                             not_utf8,
22773                                             only_utf8_locale, invert);
22774
22775         /* Use the shortest representation, taking into account our bias
22776          * against showing it inverted */
22777         if (   inverted_display
22778             && (   ! as_is_display
22779                 || (  SvCUR(inverted_display) + inverted_bias
22780                     < SvCUR(as_is_display)    + as_is_bias)))
22781         {
22782             sv_catsv(sv, inverted_display);
22783         }
22784         else if (as_is_display) {
22785             sv_catsv(sv, as_is_display);
22786         }
22787
22788         SvREFCNT_dec(as_is_display);
22789         SvREFCNT_dec(inverted_display);
22790     }
22791
22792     SvREFCNT_dec_NN(invlist);
22793     SvREFCNT_dec(only_utf8);
22794     SvREFCNT_dec(not_utf8);
22795     SvREFCNT_dec(posixes);
22796     SvREFCNT_dec(only_utf8_locale);
22797
22798     return SvCUR(sv) > orig_sv_cur;
22799 }
22800
22801 #define CLEAR_OPTSTART                                                       \
22802     if (optstart) STMT_START {                                               \
22803         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
22804                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
22805         optstart=NULL;                                                       \
22806     } STMT_END
22807
22808 #define DUMPUNTIL(b,e)                                                       \
22809                     CLEAR_OPTSTART;                                          \
22810                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
22811
22812 STATIC const regnode *
22813 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
22814             const regnode *last, const regnode *plast,
22815             SV* sv, I32 indent, U32 depth)
22816 {
22817     U8 op = PSEUDO;     /* Arbitrary non-END op. */
22818     const regnode *next;
22819     const regnode *optstart= NULL;
22820
22821     RXi_GET_DECL(r, ri);
22822     DECLARE_AND_GET_RE_DEBUG_FLAGS;
22823
22824     PERL_ARGS_ASSERT_DUMPUNTIL;
22825
22826 #ifdef DEBUG_DUMPUNTIL
22827     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
22828         last ? last-start : 0, plast ? plast-start : 0);
22829 #endif
22830
22831     if (plast && plast < last)
22832         last= plast;
22833
22834     while (PL_regkind[op] != END && (!last || node < last)) {
22835         assert(node);
22836         /* While that wasn't END last time... */
22837         NODE_ALIGN(node);
22838         op = OP(node);
22839         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
22840             indent--;
22841         next = regnext((regnode *)node);
22842
22843         /* Where, what. */
22844         if (OP(node) == OPTIMIZED) {
22845             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
22846                 optstart = node;
22847             else
22848                 goto after_print;
22849         } else
22850             CLEAR_OPTSTART;
22851
22852         regprop(r, sv, node, NULL, NULL);
22853         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
22854                       (int)(2*indent + 1), "", SvPVX_const(sv));
22855
22856         if (OP(node) != OPTIMIZED) {
22857             if (next == NULL)           /* Next ptr. */
22858                 Perl_re_printf( aTHX_  " (0)");
22859             else if (PL_regkind[(U8)op] == BRANCH
22860                      && PL_regkind[OP(next)] != BRANCH )
22861                 Perl_re_printf( aTHX_  " (FAIL)");
22862             else
22863                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
22864             Perl_re_printf( aTHX_ "\n");
22865         }
22866
22867       after_print:
22868         if (PL_regkind[(U8)op] == BRANCHJ) {
22869             assert(next);
22870             {
22871                 const regnode *nnode = (OP(next) == LONGJMP
22872                                        ? regnext((regnode *)next)
22873                                        : next);
22874                 if (last && nnode > last)
22875                     nnode = last;
22876                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
22877             }
22878         }
22879         else if (PL_regkind[(U8)op] == BRANCH) {
22880             assert(next);
22881             DUMPUNTIL(NEXTOPER(node), next);
22882         }
22883         else if ( PL_regkind[(U8)op]  == TRIE ) {
22884             const regnode *this_trie = node;
22885             const char op = OP(node);
22886             const U32 n = ARG(node);
22887             const reg_ac_data * const ac = op>=AHOCORASICK ?
22888                (reg_ac_data *)ri->data->data[n] :
22889                NULL;
22890             const reg_trie_data * const trie =
22891                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
22892 #ifdef DEBUGGING
22893             AV *const trie_words
22894                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
22895 #endif
22896             const regnode *nextbranch= NULL;
22897             I32 word_idx;
22898             SvPVCLEAR(sv);
22899             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
22900                 SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0);
22901
22902                 Perl_re_indentf( aTHX_  "%s ",
22903                     indent+3,
22904                     elem_ptr
22905                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
22906                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
22907                                 PL_colors[0], PL_colors[1],
22908                                 (SvUTF8(*elem_ptr)
22909                                  ? PERL_PV_ESCAPE_UNI
22910                                  : 0)
22911                                 | PERL_PV_PRETTY_ELLIPSES
22912                                 | PERL_PV_PRETTY_LTGT
22913                             )
22914                     : "???"
22915                 );
22916                 if (trie->jump) {
22917                     U16 dist= trie->jump[word_idx+1];
22918                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
22919                                (UV)((dist ? this_trie + dist : next) - start));
22920                     if (dist) {
22921                         if (!nextbranch)
22922                             nextbranch= this_trie + trie->jump[0];
22923                         DUMPUNTIL(this_trie + dist, nextbranch);
22924                     }
22925                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
22926                         nextbranch= regnext((regnode *)nextbranch);
22927                 } else {
22928                     Perl_re_printf( aTHX_  "\n");
22929                 }
22930             }
22931             if (last && next > last)
22932                 node= last;
22933             else
22934                 node= next;
22935         }
22936         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
22937             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
22938                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
22939         }
22940         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
22941             assert(next);
22942             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
22943         }
22944         else if ( op == PLUS || op == STAR) {
22945             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
22946         }
22947         else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) {
22948             /* Literal string, where present. */
22949             node += NODE_SZ_STR(node) - 1;
22950             node = NEXTOPER(node);
22951         }
22952         else {
22953             node = NEXTOPER(node);
22954             node += regarglen[(U8)op];
22955         }
22956         if (op == CURLYX || op == OPEN || op == SROPEN)
22957             indent++;
22958     }
22959     CLEAR_OPTSTART;
22960 #ifdef DEBUG_DUMPUNTIL
22961     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
22962 #endif
22963     return node;
22964 }
22965
22966 #endif  /* DEBUGGING */
22967
22968 #ifndef PERL_IN_XSUB_RE
22969
22970 #  include "uni_keywords.h"
22971
22972 void
22973 Perl_init_uniprops(pTHX)
22974 {
22975
22976 #  ifdef DEBUGGING
22977     char * dump_len_string;
22978
22979     dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
22980     if (   ! dump_len_string
22981         || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
22982     {
22983         PL_dump_re_max_len = 60;    /* A reasonable default */
22984     }
22985 #  endif
22986
22987     PL_user_def_props = newHV();
22988
22989 #  ifdef USE_ITHREADS
22990
22991     HvSHAREKEYS_off(PL_user_def_props);
22992     PL_user_def_props_aTHX = aTHX;
22993
22994 #  endif
22995
22996     /* Set up the inversion list interpreter-level variables */
22997
22998     PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
22999     PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALNUM]);
23000     PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALPHA]);
23001     PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXBLANK]);
23002     PL_XPosix_ptrs[_CC_CASED] =  _new_invlist_C_array(uni_prop_ptrs[UNI_CASED]);
23003     PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXCNTRL]);
23004     PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXDIGIT]);
23005     PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXGRAPH]);
23006     PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXLOWER]);
23007     PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPRINT]);
23008     PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPUNCT]);
23009     PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXSPACE]);
23010     PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXUPPER]);
23011     PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_VERTSPACE]);
23012     PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXWORD]);
23013     PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXXDIGIT]);
23014
23015     PL_Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
23016     PL_Posix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALNUM]);
23017     PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALPHA]);
23018     PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXBLANK]);
23019     PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
23020     PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXCNTRL]);
23021     PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXDIGIT]);
23022     PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXGRAPH]);
23023     PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXLOWER]);
23024     PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPRINT]);
23025     PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPUNCT]);
23026     PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXSPACE]);
23027     PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXUPPER]);
23028     PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
23029     PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXWORD]);
23030     PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXXDIGIT]);
23031
23032     PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
23033     PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
23034     PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
23035     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
23036     PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
23037
23038     PL_InBitmap = _new_invlist_C_array(InBitmap_invlist);
23039     PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
23040     PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
23041     PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
23042
23043     PL_Assigned_invlist = _new_invlist_C_array(uni_prop_ptrs[UNI_ASSIGNED]);
23044
23045     PL_utf8_perl_idstart = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDSTART]);
23046     PL_utf8_perl_idcont = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDCONT]);
23047
23048     PL_utf8_charname_begin = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_BEGIN]);
23049     PL_utf8_charname_continue = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_CONTINUE]);
23050
23051     PL_in_some_fold = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_ANY_FOLDS]);
23052     PL_HasMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
23053                                             UNI__PERL_FOLDS_TO_MULTI_CHAR]);
23054     PL_InMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
23055                                             UNI__PERL_IS_IN_MULTI_CHAR_FOLD]);
23056     PL_utf8_toupper = _new_invlist_C_array(Uppercase_Mapping_invlist);
23057     PL_utf8_tolower = _new_invlist_C_array(Lowercase_Mapping_invlist);
23058     PL_utf8_totitle = _new_invlist_C_array(Titlecase_Mapping_invlist);
23059     PL_utf8_tofold = _new_invlist_C_array(Case_Folding_invlist);
23060     PL_utf8_tosimplefold = _new_invlist_C_array(Simple_Case_Folding_invlist);
23061     PL_utf8_foldclosures = _new_invlist_C_array(_Perl_IVCF_invlist);
23062     PL_utf8_mark = _new_invlist_C_array(uni_prop_ptrs[UNI_M]);
23063     PL_CCC_non0_non230 = _new_invlist_C_array(_Perl_CCC_non0_non230_invlist);
23064     PL_Private_Use = _new_invlist_C_array(uni_prop_ptrs[UNI_CO]);
23065
23066 #  ifdef UNI_XIDC
23067     /* The below are used only by deprecated functions.  They could be removed */
23068     PL_utf8_xidcont  = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDC]);
23069     PL_utf8_idcont   = _new_invlist_C_array(uni_prop_ptrs[UNI_IDC]);
23070     PL_utf8_xidstart = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDS]);
23071 #  endif
23072 }
23073
23074 /* These four functions are compiled only in regcomp.c, where they have access
23075  * to the data they return.  They are a way for re_comp.c to get access to that
23076  * data without having to compile the whole data structures. */
23077
23078 I16
23079 Perl_do_uniprop_match(const char * const key, const U16 key_len)
23080 {
23081     PERL_ARGS_ASSERT_DO_UNIPROP_MATCH;
23082
23083     return match_uniprop((U8 *) key, key_len);
23084 }
23085
23086 SV *
23087 Perl_get_prop_definition(pTHX_ const int table_index)
23088 {
23089     PERL_ARGS_ASSERT_GET_PROP_DEFINITION;
23090
23091     /* Create and return the inversion list */
23092     return _new_invlist_C_array(uni_prop_ptrs[table_index]);
23093 }
23094
23095 const char * const *
23096 Perl_get_prop_values(const int table_index)
23097 {
23098     PERL_ARGS_ASSERT_GET_PROP_VALUES;
23099
23100     return UNI_prop_value_ptrs[table_index];
23101 }
23102
23103 const char *
23104 Perl_get_deprecated_property_msg(const Size_t warning_offset)
23105 {
23106     PERL_ARGS_ASSERT_GET_DEPRECATED_PROPERTY_MSG;
23107
23108     return deprecated_property_msgs[warning_offset];
23109 }
23110
23111 #  if 0
23112
23113 This code was mainly added for backcompat to give a warning for non-portable
23114 code points in user-defined properties.  But experiments showed that the
23115 warning in earlier perls were only omitted on overflow, which should be an
23116 error, so there really isnt a backcompat issue, and actually adding the
23117 warning when none was present before might cause breakage, for little gain.  So
23118 khw left this code in, but not enabled.  Tests were never added.
23119
23120 embed.fnc entry:
23121 Ei      |const char *|get_extended_utf8_msg|const UV cp
23122
23123 PERL_STATIC_INLINE const char *
23124 S_get_extended_utf8_msg(pTHX_ const UV cp)
23125 {
23126     U8 dummy[UTF8_MAXBYTES + 1];
23127     HV *msgs;
23128     SV **msg;
23129
23130     uvchr_to_utf8_flags_msgs(dummy, cp, UNICODE_WARN_PERL_EXTENDED,
23131                              &msgs);
23132
23133     msg = hv_fetchs(msgs, "text", 0);
23134     assert(msg);
23135
23136     (void) sv_2mortal((SV *) msgs);
23137
23138     return SvPVX(*msg);
23139 }
23140
23141 #  endif
23142 #endif /* end of ! PERL_IN_XSUB_RE */
23143
23144 STATIC REGEXP *
23145 S_compile_wildcard(pTHX_ const char * subpattern, const STRLEN len,
23146                          const bool ignore_case)
23147 {
23148     /* Pretends that the input subpattern is qr/subpattern/aam, compiling it
23149      * possibly with /i if the 'ignore_case' parameter is true.  Use /aa
23150      * because nothing outside of ASCII will match.  Use /m because the input
23151      * string may be a bunch of lines strung together.
23152      *
23153      * Also sets up the debugging info */
23154
23155     U32 flags = PMf_MULTILINE|PMf_WILDCARD;
23156     U32 rx_flags;
23157     SV * subpattern_sv = sv_2mortal(newSVpvn(subpattern, len));
23158     REGEXP * subpattern_re;
23159     DECLARE_AND_GET_RE_DEBUG_FLAGS;
23160
23161     PERL_ARGS_ASSERT_COMPILE_WILDCARD;
23162
23163     if (ignore_case) {
23164         flags |= PMf_FOLD;
23165     }
23166     set_regex_charset(&flags, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
23167
23168     /* Like in op.c, we copy the compile time pm flags to the rx ones */
23169     rx_flags = flags & RXf_PMf_COMPILETIME;
23170
23171 #ifndef PERL_IN_XSUB_RE
23172     /* Use the core engine if this file is regcomp.c.  That means no
23173      * 'use re "Debug ..." is in effect, so the core engine is sufficient */
23174     subpattern_re = Perl_re_op_compile(aTHX_ &subpattern_sv, 1, NULL,
23175                                              &PL_core_reg_engine,
23176                                              NULL, NULL,
23177                                              rx_flags, flags);
23178 #else
23179     if (isDEBUG_WILDCARD) {
23180         /* Use the special debugging engine if this file is re_comp.c and wants
23181          * to output the wildcard matching.  This uses whatever
23182          * 'use re "Debug ..." is in effect */
23183         subpattern_re = Perl_re_op_compile(aTHX_ &subpattern_sv, 1, NULL,
23184                                                  &my_reg_engine,
23185                                                  NULL, NULL,
23186                                                  rx_flags, flags);
23187     }
23188     else {
23189         /* Use the special wildcard engine if this file is re_comp.c and
23190          * doesn't want to output the wildcard matching.  This uses whatever
23191          * 'use re "Debug ..." is in effect for compilation, but this engine
23192          * structure has been set up so that it uses the core engine for
23193          * execution, so no execution debugging as a result of re.pm will be
23194          * displayed. */
23195         subpattern_re = Perl_re_op_compile(aTHX_ &subpattern_sv, 1, NULL,
23196                                                  &wild_reg_engine,
23197                                                  NULL, NULL,
23198                                                  rx_flags, flags);
23199         /* XXX The above has the effect that any user-supplied regex engine
23200          * won't be called for matching wildcards.  That might be good, or bad.
23201          * It could be changed in several ways.  The reason it is done the
23202          * current way is to avoid having to save and restore
23203          * ^{^RE_DEBUG_FLAGS} around the execution.  save_scalar() perhaps
23204          * could be used.  Another suggestion is to keep the authoritative
23205          * value of the debug flags in a thread-local variable and add set/get
23206          * magic to ${^RE_DEBUG_FLAGS} to keep the C level variable up to date.
23207          * Still another is to pass a flag, say in the engine's intflags that
23208          * would be checked each time before doing the debug output */
23209     }
23210 #endif
23211
23212     assert(subpattern_re);  /* Should have died if didn't compile successfully */
23213     return subpattern_re;
23214 }
23215
23216 STATIC I32
23217 S_execute_wildcard(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
23218          char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
23219 {
23220     I32 result;
23221     DECLARE_AND_GET_RE_DEBUG_FLAGS;
23222
23223     PERL_ARGS_ASSERT_EXECUTE_WILDCARD;
23224
23225     ENTER;
23226
23227     /* The compilation has set things up so that if the program doesn't want to
23228      * see the wildcard matching procedure, it will get the core execution
23229      * engine, which is subject only to -Dr.  So we have to turn that off
23230      * around this procedure */
23231     if (! isDEBUG_WILDCARD) {
23232         /* Note! Casts away 'volatile' */
23233         SAVEI32(PL_debug);
23234         PL_debug &= ~ DEBUG_r_FLAG;
23235     }
23236
23237     result = CALLREGEXEC(prog, stringarg, strend, strbeg, minend, screamer,
23238                          NULL, nosave);
23239     LEAVE;
23240
23241     return result;
23242 }
23243
23244 SV *
23245 S_handle_user_defined_property(pTHX_
23246
23247     /* Parses the contents of a user-defined property definition; returning the
23248      * expanded definition if possible.  If so, the return is an inversion
23249      * list.
23250      *
23251      * If there are subroutines that are part of the expansion and which aren't
23252      * known at the time of the call to this function, this returns what
23253      * parse_uniprop_string() returned for the first one encountered.
23254      *
23255      * If an error was found, NULL is returned, and 'msg' gets a suitable
23256      * message appended to it.  (Appending allows the back trace of how we got
23257      * to the faulty definition to be displayed through nested calls of
23258      * user-defined subs.)
23259      *
23260      * The caller IS responsible for freeing any returned SV.
23261      *
23262      * The syntax of the contents is pretty much described in perlunicode.pod,
23263      * but we also allow comments on each line */
23264
23265     const char * name,          /* Name of property */
23266     const STRLEN name_len,      /* The name's length in bytes */
23267     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
23268     const bool to_fold,         /* ? Is this under /i */
23269     const bool runtime,         /* ? Are we in compile- or run-time */
23270     const bool deferrable,      /* Is it ok for this property's full definition
23271                                    to be deferred until later? */
23272     SV* contents,               /* The property's definition */
23273     bool *user_defined_ptr,     /* This will be set TRUE as we wouldn't be
23274                                    getting called unless this is thought to be
23275                                    a user-defined property */
23276     SV * msg,                   /* Any error or warning msg(s) are appended to
23277                                    this */
23278     const STRLEN level)         /* Recursion level of this call */
23279 {
23280     STRLEN len;
23281     const char * string         = SvPV_const(contents, len);
23282     const char * const e        = string + len;
23283     const bool is_contents_utf8 = cBOOL(SvUTF8(contents));
23284     const STRLEN msgs_length_on_entry = SvCUR(msg);
23285
23286     const char * s0 = string;   /* Points to first byte in the current line
23287                                    being parsed in 'string' */
23288     const char overflow_msg[] = "Code point too large in \"";
23289     SV* running_definition = NULL;
23290
23291     PERL_ARGS_ASSERT_HANDLE_USER_DEFINED_PROPERTY;
23292
23293     *user_defined_ptr = TRUE;
23294
23295     /* Look at each line */
23296     while (s0 < e) {
23297         const char * s;     /* Current byte */
23298         char op = '+';      /* Default operation is 'union' */
23299         IV   min = 0;       /* range begin code point */
23300         IV   max = -1;      /* and range end */
23301         SV* this_definition;
23302
23303         /* Skip comment lines */
23304         if (*s0 == '#') {
23305             s0 = strchr(s0, '\n');
23306             if (s0 == NULL) {
23307                 break;
23308             }
23309             s0++;
23310             continue;
23311         }
23312
23313         /* For backcompat, allow an empty first line */
23314         if (*s0 == '\n') {
23315             s0++;
23316             continue;
23317         }
23318
23319         /* First character in the line may optionally be the operation */
23320         if (   *s0 == '+'
23321             || *s0 == '!'
23322             || *s0 == '-'
23323             || *s0 == '&')
23324         {
23325             op = *s0++;
23326         }
23327
23328         /* If the line is one or two hex digits separated by blank space, its
23329          * a range; otherwise it is either another user-defined property or an
23330          * error */
23331
23332         s = s0;
23333
23334         if (! isXDIGIT(*s)) {
23335             goto check_if_property;
23336         }
23337
23338         do { /* Each new hex digit will add 4 bits. */
23339             if (min > ( (IV) MAX_LEGAL_CP >> 4)) {
23340                 s = strchr(s, '\n');
23341                 if (s == NULL) {
23342                     s = e;
23343                 }
23344                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23345                 sv_catpv(msg, overflow_msg);
23346                 Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
23347                                      UTF8fARG(is_contents_utf8, s - s0, s0));
23348                 sv_catpvs(msg, "\"");
23349                 goto return_failure;
23350             }
23351
23352             /* Accumulate this digit into the value */
23353             min = (min << 4) + READ_XDIGIT(s);
23354         } while (isXDIGIT(*s));
23355
23356         while (isBLANK(*s)) { s++; }
23357
23358         /* We allow comments at the end of the line */
23359         if (*s == '#') {
23360             s = strchr(s, '\n');
23361             if (s == NULL) {
23362                 s = e;
23363             }
23364             s++;
23365         }
23366         else if (s < e && *s != '\n') {
23367             if (! isXDIGIT(*s)) {
23368                 goto check_if_property;
23369             }
23370
23371             /* Look for the high point of the range */
23372             max = 0;
23373             do {
23374                 if (max > ( (IV) MAX_LEGAL_CP >> 4)) {
23375                     s = strchr(s, '\n');
23376                     if (s == NULL) {
23377                         s = e;
23378                     }
23379                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23380                     sv_catpv(msg, overflow_msg);
23381                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
23382                                       UTF8fARG(is_contents_utf8, s - s0, s0));
23383                     sv_catpvs(msg, "\"");
23384                     goto return_failure;
23385                 }
23386
23387                 max = (max << 4) + READ_XDIGIT(s);
23388             } while (isXDIGIT(*s));
23389
23390             while (isBLANK(*s)) { s++; }
23391
23392             if (*s == '#') {
23393                 s = strchr(s, '\n');
23394                 if (s == NULL) {
23395                     s = e;
23396                 }
23397             }
23398             else if (s < e && *s != '\n') {
23399                 goto check_if_property;
23400             }
23401         }
23402
23403         if (max == -1) {    /* The line only had one entry */
23404             max = min;
23405         }
23406         else if (max < min) {
23407             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23408             sv_catpvs(msg, "Illegal range in \"");
23409             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
23410                                 UTF8fARG(is_contents_utf8, s - s0, s0));
23411             sv_catpvs(msg, "\"");
23412             goto return_failure;
23413         }
23414
23415 #  if 0   /* See explanation at definition above of get_extended_utf8_msg() */
23416
23417         if (   UNICODE_IS_PERL_EXTENDED(min)
23418             || UNICODE_IS_PERL_EXTENDED(max))
23419         {
23420             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23421
23422             /* If both code points are non-portable, warn only on the lower
23423              * one. */
23424             sv_catpv(msg, get_extended_utf8_msg(
23425                                             (UNICODE_IS_PERL_EXTENDED(min))
23426                                             ? min : max));
23427             sv_catpvs(msg, " in \"");
23428             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
23429                                  UTF8fARG(is_contents_utf8, s - s0, s0));
23430             sv_catpvs(msg, "\"");
23431         }
23432
23433 #  endif
23434
23435         /* Here, this line contains a legal range */
23436         this_definition = sv_2mortal(_new_invlist(2));
23437         this_definition = _add_range_to_invlist(this_definition, min, max);
23438         goto calculate;
23439
23440       check_if_property:
23441
23442         /* Here it isn't a legal range line.  See if it is a legal property
23443          * line.  First find the end of the meat of the line */
23444         s = strpbrk(s, "#\n");
23445         if (s == NULL) {
23446             s = e;
23447         }
23448
23449         /* Ignore trailing blanks in keeping with the requirements of
23450          * parse_uniprop_string() */
23451         s--;
23452         while (s > s0 && isBLANK_A(*s)) {
23453             s--;
23454         }
23455         s++;
23456
23457         this_definition = parse_uniprop_string(s0, s - s0,
23458                                                is_utf8, to_fold, runtime,
23459                                                deferrable,
23460                                                NULL,
23461                                                user_defined_ptr, msg,
23462                                                (name_len == 0)
23463                                                 ? level /* Don't increase level
23464                                                            if input is empty */
23465                                                 : level + 1
23466                                               );
23467         if (this_definition == NULL) {
23468             goto return_failure;    /* 'msg' should have had the reason
23469                                        appended to it by the above call */
23470         }
23471
23472         if (! is_invlist(this_definition)) {    /* Unknown at this time */
23473             return newSVsv(this_definition);
23474         }
23475
23476         if (*s != '\n') {
23477             s = strchr(s, '\n');
23478             if (s == NULL) {
23479                 s = e;
23480             }
23481         }
23482
23483       calculate:
23484
23485         switch (op) {
23486             case '+':
23487                 _invlist_union(running_definition, this_definition,
23488                                                         &running_definition);
23489                 break;
23490             case '-':
23491                 _invlist_subtract(running_definition, this_definition,
23492                                                         &running_definition);
23493                 break;
23494             case '&':
23495                 _invlist_intersection(running_definition, this_definition,
23496                                                         &running_definition);
23497                 break;
23498             case '!':
23499                 _invlist_union_complement_2nd(running_definition,
23500                                         this_definition, &running_definition);
23501                 break;
23502             default:
23503                 Perl_croak(aTHX_ "panic: %s: %d: Unexpected operation %d",
23504                                  __FILE__, __LINE__, op);
23505                 break;
23506         }
23507
23508         /* Position past the '\n' */
23509         s0 = s + 1;
23510     }   /* End of loop through the lines of 'contents' */
23511
23512     /* Here, we processed all the lines in 'contents' without error.  If we
23513      * didn't add any warnings, simply return success */
23514     if (msgs_length_on_entry == SvCUR(msg)) {
23515
23516         /* If the expansion was empty, the answer isn't nothing: its an empty
23517          * inversion list */
23518         if (running_definition == NULL) {
23519             running_definition = _new_invlist(1);
23520         }
23521
23522         return running_definition;
23523     }
23524
23525     /* Otherwise, add some explanatory text, but we will return success */
23526     goto return_msg;
23527
23528   return_failure:
23529     running_definition = NULL;
23530
23531   return_msg:
23532
23533     if (name_len > 0) {
23534         sv_catpvs(msg, " in expansion of ");
23535         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
23536     }
23537
23538     return running_definition;
23539 }
23540
23541 /* As explained below, certain operations need to take place in the first
23542  * thread created.  These macros switch contexts */
23543 #  ifdef USE_ITHREADS
23544 #    define DECLARATION_FOR_GLOBAL_CONTEXT                                  \
23545                                         PerlInterpreter * save_aTHX = aTHX;
23546 #    define SWITCH_TO_GLOBAL_CONTEXT                                        \
23547                            PERL_SET_CONTEXT((aTHX = PL_user_def_props_aTHX))
23548 #    define RESTORE_CONTEXT  PERL_SET_CONTEXT((aTHX = save_aTHX));
23549 #    define CUR_CONTEXT      aTHX
23550 #    define ORIGINAL_CONTEXT save_aTHX
23551 #  else
23552 #    define DECLARATION_FOR_GLOBAL_CONTEXT    dNOOP
23553 #    define SWITCH_TO_GLOBAL_CONTEXT          NOOP
23554 #    define RESTORE_CONTEXT                   NOOP
23555 #    define CUR_CONTEXT                       NULL
23556 #    define ORIGINAL_CONTEXT                  NULL
23557 #  endif
23558
23559 STATIC void
23560 S_delete_recursion_entry(pTHX_ void *key)
23561 {
23562     /* Deletes the entry used to detect recursion when expanding user-defined
23563      * properties.  This is a function so it can be set up to be called even if
23564      * the program unexpectedly quits */
23565
23566     SV ** current_entry;
23567     const STRLEN key_len = strlen((const char *) key);
23568     DECLARATION_FOR_GLOBAL_CONTEXT;
23569
23570     SWITCH_TO_GLOBAL_CONTEXT;
23571
23572     /* If the entry is one of these types, it is a permanent entry, and not the
23573      * one used to detect recursions.  This function should delete only the
23574      * recursion entry */
23575     current_entry = hv_fetch(PL_user_def_props, (const char *) key, key_len, 0);
23576     if (     current_entry
23577         && ! is_invlist(*current_entry)
23578         && ! SvPOK(*current_entry))
23579     {
23580         (void) hv_delete(PL_user_def_props, (const char *) key, key_len,
23581                                                                     G_DISCARD);
23582     }
23583
23584     RESTORE_CONTEXT;
23585 }
23586
23587 STATIC SV *
23588 S_get_fq_name(pTHX_
23589               const char * const name,    /* The first non-blank in the \p{}, \P{} */
23590               const Size_t name_len,      /* Its length in bytes, not including any trailing space */
23591               const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
23592               const bool has_colon_colon
23593              )
23594 {
23595     /* Returns a mortal SV containing the fully qualified version of the input
23596      * name */
23597
23598     SV * fq_name;
23599
23600     fq_name = newSVpvs_flags("", SVs_TEMP);
23601
23602     /* Use the current package if it wasn't included in our input */
23603     if (! has_colon_colon) {
23604         const HV * pkg = (IN_PERL_COMPILETIME)
23605                          ? PL_curstash
23606                          : CopSTASH(PL_curcop);
23607         const char* pkgname = HvNAME(pkg);
23608
23609         Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
23610                       UTF8fARG(is_utf8, strlen(pkgname), pkgname));
23611         sv_catpvs(fq_name, "::");
23612     }
23613
23614     Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
23615                          UTF8fARG(is_utf8, name_len, name));
23616     return fq_name;
23617 }
23618
23619 STATIC SV *
23620 S_parse_uniprop_string(pTHX_
23621
23622     /* Parse the interior of a \p{}, \P{}.  Returns its definition if knowable
23623      * now.  If so, the return is an inversion list.
23624      *
23625      * If the property is user-defined, it is a subroutine, which in turn
23626      * may call other subroutines.  This function will call the whole nest of
23627      * them to get the definition they return; if some aren't known at the time
23628      * of the call to this function, the fully qualified name of the highest
23629      * level sub is returned.  It is an error to call this function at runtime
23630      * without every sub defined.
23631      *
23632      * If an error was found, NULL is returned, and 'msg' gets a suitable
23633      * message appended to it.  (Appending allows the back trace of how we got
23634      * to the faulty definition to be displayed through nested calls of
23635      * user-defined subs.)
23636      *
23637      * The caller should NOT try to free any returned inversion list.
23638      *
23639      * Other parameters will be set on return as described below */
23640
23641     const char * const name,    /* The first non-blank in the \p{}, \P{} */
23642     Size_t name_len,            /* Its length in bytes, not including any
23643                                    trailing space */
23644     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
23645     const bool to_fold,         /* ? Is this under /i */
23646     const bool runtime,         /* TRUE if this is being called at run time */
23647     const bool deferrable,      /* TRUE if it's ok for the definition to not be
23648                                    known at this call */
23649     AV ** strings,              /* To return string property values, like named
23650                                    sequences */
23651     bool *user_defined_ptr,     /* Upon return from this function it will be
23652                                    set to TRUE if any component is a
23653                                    user-defined property */
23654     SV * msg,                   /* Any error or warning msg(s) are appended to
23655                                    this */
23656     const STRLEN level)         /* Recursion level of this call */
23657 {
23658     char* lookup_name;          /* normalized name for lookup in our tables */
23659     unsigned lookup_len;        /* Its length */
23660     enum { Not_Strict = 0,      /* Some properties have stricter name */
23661            Strict,              /* normalization rules, which we decide */
23662            As_Is                /* upon based on parsing */
23663          } stricter = Not_Strict;
23664
23665     /* nv= or numeric_value=, or possibly one of the cjk numeric properties
23666      * (though it requires extra effort to download them from Unicode and
23667      * compile perl to know about them) */
23668     bool is_nv_type = FALSE;
23669
23670     unsigned int i, j = 0;
23671     int equals_pos = -1;    /* Where the '=' is found, or negative if none */
23672     int slash_pos  = -1;    /* Where the '/' is found, or negative if none */
23673     int table_index = 0;    /* The entry number for this property in the table
23674                                of all Unicode property names */
23675     bool starts_with_Is = FALSE;  /* ? Does the name start with 'Is' */
23676     Size_t lookup_offset = 0;   /* Used to ignore the first few characters of
23677                                    the normalized name in certain situations */
23678     Size_t non_pkg_begin = 0;   /* Offset of first byte in 'name' that isn't
23679                                    part of a package name */
23680     Size_t lun_non_pkg_begin = 0;   /* Similarly for 'lookup_name' */
23681     bool could_be_user_defined = TRUE;  /* ? Could this be a user-defined
23682                                              property rather than a Unicode
23683                                              one. */
23684     SV * prop_definition = NULL;  /* The returned definition of 'name' or NULL
23685                                      if an error.  If it is an inversion list,
23686                                      it is the definition.  Otherwise it is a
23687                                      string containing the fully qualified sub
23688                                      name of 'name' */
23689     SV * fq_name = NULL;        /* For user-defined properties, the fully
23690                                    qualified name */
23691     bool invert_return = FALSE; /* ? Do we need to complement the result before
23692                                      returning it */
23693     bool stripped_utf8_pkg = FALSE; /* Set TRUE if the input includes an
23694                                        explicit utf8:: package that we strip
23695                                        off  */
23696     /* The expansion of properties that could be either user-defined or
23697      * official unicode ones is deferred until runtime, including a marker for
23698      * those that might be in the latter category.  This boolean indicates if
23699      * we've seen that marker.  If not, what we're parsing can't be such an
23700      * official Unicode property whose expansion was deferred */
23701     bool could_be_deferred_official = FALSE;
23702
23703     PERL_ARGS_ASSERT_PARSE_UNIPROP_STRING;
23704
23705     /* The input will be normalized into 'lookup_name' */
23706     Newx(lookup_name, name_len, char);
23707     SAVEFREEPV(lookup_name);
23708
23709     /* Parse the input. */
23710     for (i = 0; i < name_len; i++) {
23711         char cur = name[i];
23712
23713         /* Most of the characters in the input will be of this ilk, being parts
23714          * of a name */
23715         if (isIDCONT_A(cur)) {
23716
23717             /* Case differences are ignored.  Our lookup routine assumes
23718              * everything is lowercase, so normalize to that */
23719             if (isUPPER_A(cur)) {
23720                 lookup_name[j++] = toLOWER_A(cur);
23721                 continue;
23722             }
23723
23724             if (cur == '_') { /* Don't include these in the normalized name */
23725                 continue;
23726             }
23727
23728             lookup_name[j++] = cur;
23729
23730             /* The first character in a user-defined name must be of this type.
23731              * */
23732             if (i - non_pkg_begin == 0 && ! isIDFIRST_A(cur)) {
23733                 could_be_user_defined = FALSE;
23734             }
23735
23736             continue;
23737         }
23738
23739         /* Here, the character is not something typically in a name,  But these
23740          * two types of characters (and the '_' above) can be freely ignored in
23741          * most situations.  Later it may turn out we shouldn't have ignored
23742          * them, and we have to reparse, but we don't have enough information
23743          * yet to make that decision */
23744         if (cur == '-' || isSPACE_A(cur)) {
23745             could_be_user_defined = FALSE;
23746             continue;
23747         }
23748
23749         /* An equals sign or single colon mark the end of the first part of
23750          * the property name */
23751         if (    cur == '='
23752             || (cur == ':' && (i >= name_len - 1 || name[i+1] != ':')))
23753         {
23754             lookup_name[j++] = '='; /* Treat the colon as an '=' */
23755             equals_pos = j; /* Note where it occurred in the input */
23756             could_be_user_defined = FALSE;
23757             break;
23758         }
23759
23760         /* If this looks like it is a marker we inserted at compile time,
23761          * set a flag and otherwise ignore it.  If it isn't in the final
23762          * position, keep it as it would have been user input. */
23763         if (     UNLIKELY(cur == DEFERRED_COULD_BE_OFFICIAL_MARKERc)
23764             && ! deferrable
23765             &&   could_be_user_defined
23766             &&   i == name_len - 1)
23767         {
23768             name_len--;
23769             could_be_deferred_official = TRUE;
23770             continue;
23771         }
23772
23773         /* Otherwise, this character is part of the name. */
23774         lookup_name[j++] = cur;
23775
23776         /* Here it isn't a single colon, so if it is a colon, it must be a
23777          * double colon */
23778         if (cur == ':') {
23779
23780             /* A double colon should be a package qualifier.  We note its
23781              * position and continue.  Note that one could have
23782              *      pkg1::pkg2::...::foo
23783              * so that the position at the end of the loop will be just after
23784              * the final qualifier */
23785
23786             i++;
23787             non_pkg_begin = i + 1;
23788             lookup_name[j++] = ':';
23789             lun_non_pkg_begin = j;
23790         }
23791         else { /* Only word chars (and '::') can be in a user-defined name */
23792             could_be_user_defined = FALSE;
23793         }
23794     } /* End of parsing through the lhs of the property name (or all of it if
23795          no rhs) */
23796
23797 #  define STRLENs(s)  (sizeof("" s "") - 1)
23798
23799     /* If there is a single package name 'utf8::', it is ambiguous.  It could
23800      * be for a user-defined property, or it could be a Unicode property, as
23801      * all of them are considered to be for that package.  For the purposes of
23802      * parsing the rest of the property, strip it off */
23803     if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
23804         lookup_name +=  STRLENs("utf8::");
23805         j -=  STRLENs("utf8::");
23806         equals_pos -=  STRLENs("utf8::");
23807         stripped_utf8_pkg = TRUE;
23808     }
23809
23810     /* Here, we are either done with the whole property name, if it was simple;
23811      * or are positioned just after the '=' if it is compound. */
23812
23813     if (equals_pos >= 0) {
23814         assert(stricter == Not_Strict); /* We shouldn't have set this yet */
23815
23816         /* Space immediately after the '=' is ignored */
23817         i++;
23818         for (; i < name_len; i++) {
23819             if (! isSPACE_A(name[i])) {
23820                 break;
23821             }
23822         }
23823
23824         /* Most punctuation after the equals indicates a subpattern, like
23825          * \p{foo=/bar/} */
23826         if (   isPUNCT_A(name[i])
23827             &&  name[i] != '-'
23828             &&  name[i] != '+'
23829             &&  name[i] != '_'
23830             &&  name[i] != '{'
23831                 /* A backslash means the real delimitter is the next character,
23832                  * but it must be punctuation */
23833             && (name[i] != '\\' || (i < name_len && isPUNCT_A(name[i+1]))))
23834         {
23835             bool special_property = memEQs(lookup_name, j - 1, "name")
23836                                  || memEQs(lookup_name, j - 1, "na");
23837             if (! special_property) {
23838                 /* Find the property.  The table includes the equals sign, so
23839                  * we use 'j' as-is */
23840                 table_index = do_uniprop_match(lookup_name, j);
23841             }
23842             if (special_property || table_index) {
23843                 REGEXP * subpattern_re;
23844                 char open = name[i++];
23845                 char close;
23846                 const char * pos_in_brackets;
23847                 const char * const * prop_values;
23848                 bool escaped = 0;
23849
23850                 /* Backslash => delimitter is the character following.  We
23851                  * already checked that it is punctuation */
23852                 if (open == '\\') {
23853                     open = name[i++];
23854                     escaped = 1;
23855                 }
23856
23857                 /* This data structure is constructed so that the matching
23858                  * closing bracket is 3 past its matching opening.  The second
23859                  * set of closing is so that if the opening is something like
23860                  * ']', the closing will be that as well.  Something similar is
23861                  * done in toke.c */
23862                 pos_in_brackets = memCHRs("([<)]>)]>", open);
23863                 close = (pos_in_brackets) ? pos_in_brackets[3] : open;
23864
23865                 if (    i >= name_len
23866                     ||  name[name_len-1] != close
23867                     || (escaped && name[name_len-2] != '\\')
23868                         /* Also make sure that there are enough characters.
23869                          * e.g., '\\\' would show up incorrectly as legal even
23870                          * though it is too short */
23871                     || (SSize_t) (name_len - i - 1 - escaped) < 0)
23872                 {
23873                     sv_catpvs(msg, "Unicode property wildcard not terminated");
23874                     goto append_name_to_msg;
23875                 }
23876
23877                 Perl_ck_warner_d(aTHX_
23878                     packWARN(WARN_EXPERIMENTAL__UNIPROP_WILDCARDS),
23879                     "The Unicode property wildcards feature is experimental");
23880
23881                 if (special_property) {
23882                     const char * error_msg;
23883                     const char * revised_name = name + i;
23884                     Size_t revised_name_len = name_len - (i + 1 + escaped);
23885
23886                     /* Currently, the only 'special_property' is name, which we
23887                      * lookup in _charnames.pm */
23888
23889                     if (! load_charnames(newSVpvs("placeholder"),
23890                                          revised_name, revised_name_len,
23891                                          &error_msg))
23892                     {
23893                         sv_catpv(msg, error_msg);
23894                         goto append_name_to_msg;
23895                     }
23896
23897                     /* Farm this out to a function just to make the current
23898                      * function less unwieldy */
23899                     if (handle_names_wildcard(revised_name, revised_name_len,
23900                                               &prop_definition,
23901                                               strings))
23902                     {
23903                         return prop_definition;
23904                     }
23905
23906                     goto failed;
23907                 }
23908
23909                 prop_values = get_prop_values(table_index);
23910
23911                 /* Now create and compile the wildcard subpattern.  Use /i
23912                  * because the property values are supposed to match with case
23913                  * ignored. */
23914                 subpattern_re = compile_wildcard(name + i,
23915                                                  name_len - i - 1 - escaped,
23916                                                  TRUE /* /i */
23917                                                 );
23918
23919                 /* For each legal property value, see if the supplied pattern
23920                  * matches it. */
23921                 while (*prop_values) {
23922                     const char * const entry = *prop_values;
23923                     const Size_t len = strlen(entry);
23924                     SV* entry_sv = newSVpvn_flags(entry, len, SVs_TEMP);
23925
23926                     if (execute_wildcard(subpattern_re,
23927                                  (char *) entry,
23928                                  (char *) entry + len,
23929                                  (char *) entry, 0,
23930                                  entry_sv,
23931                                  0))
23932                     { /* Here, matched.  Add to the returned list */
23933                         Size_t total_len = j + len;
23934                         SV * sub_invlist = NULL;
23935                         char * this_string;
23936
23937                         /* We know this is a legal \p{property=value}.  Call
23938                          * the function to return the list of code points that
23939                          * match it */
23940                         Newxz(this_string, total_len + 1, char);
23941                         Copy(lookup_name, this_string, j, char);
23942                         my_strlcat(this_string, entry, total_len + 1);
23943                         SAVEFREEPV(this_string);
23944                         sub_invlist = parse_uniprop_string(this_string,
23945                                                            total_len,
23946                                                            is_utf8,
23947                                                            to_fold,
23948                                                            runtime,
23949                                                            deferrable,
23950                                                            NULL,
23951                                                            user_defined_ptr,
23952                                                            msg,
23953                                                            level + 1);
23954                         _invlist_union(prop_definition, sub_invlist,
23955                                        &prop_definition);
23956                     }
23957
23958                     prop_values++;  /* Next iteration, look at next propvalue */
23959                 } /* End of looking through property values; (the data
23960                      structure is terminated by a NULL ptr) */
23961
23962                 SvREFCNT_dec_NN(subpattern_re);
23963
23964                 if (prop_definition) {
23965                     return prop_definition;
23966                 }
23967
23968                 sv_catpvs(msg, "No Unicode property value wildcard matches:");
23969                 goto append_name_to_msg;
23970             }
23971
23972             /* Here's how khw thinks we should proceed to handle the properties
23973              * not yet done:    Bidi Mirroring Glyph        can map to ""
23974                                 Bidi Paired Bracket         can map to ""
23975                                 Case Folding  (both full and simple)
23976                                             Shouldn't /i be good enough for Full
23977                                 Decomposition Mapping
23978                                 Equivalent Unified Ideograph    can map to ""
23979                                 Lowercase Mapping  (both full and simple)
23980                                 NFKC Case Fold                  can map to ""
23981                                 Titlecase Mapping  (both full and simple)
23982                                 Uppercase Mapping  (both full and simple)
23983              * Handle these the same way Name is done, using say, _wild.pm, but
23984              * having both loose and full, like in charclass_invlists.h.
23985              * Perhaps move block and script to that as they are somewhat large
23986              * in charclass_invlists.h.
23987              * For properties where the default is the code point itself, such
23988              * as any of the case changing mappings, the string would otherwise
23989              * consist of all Unicode code points in UTF-8 strung together.
23990              * This would be impractical.  So instead, examine their compiled
23991              * pattern, looking at the ssc.  If none, reject the pattern as an
23992              * error.  Otherwise run the pattern against every code point in
23993              * the ssc.  The ssc is kind of like tr18's 3.9 Possible Match Sets
23994              * And it might be good to create an API to return the ssc.
23995              * Or handle them like the algorithmic names are done
23996              */
23997         } /* End of is a wildcard subppattern */
23998
23999         /* \p{name=...} is handled specially.  Instead of using the normal
24000          * mechanism involving charclass_invlists.h, it uses _charnames.pm
24001          * which has the necessary (huge) data accessible to it, and which
24002          * doesn't get loaded unless necessary.  The legal syntax for names is
24003          * somewhat different than other properties due both to the vagaries of
24004          * a few outlier official names, and the fact that only a few ASCII
24005          * characters are permitted in them */
24006         if (   memEQs(lookup_name, j - 1, "name")
24007             || memEQs(lookup_name, j - 1, "na"))
24008         {
24009             dSP;
24010             HV * table;
24011             SV * character;
24012             const char * error_msg;
24013             CV* lookup_loose;
24014             SV * character_name;
24015             STRLEN character_len;
24016             UV cp;
24017
24018             stricter = As_Is;
24019
24020             /* Since the RHS (after skipping initial space) is passed unchanged
24021              * to charnames, and there are different criteria for what are
24022              * legal characters in the name, just parse it here.  A character
24023              * name must begin with an ASCII alphabetic */
24024             if (! isALPHA(name[i])) {
24025                 goto failed;
24026             }
24027             lookup_name[j++] = name[i];
24028
24029             for (++i; i < name_len; i++) {
24030                 /* Official names can only be in the ASCII range, and only
24031                  * certain characters */
24032                 if (! isASCII(name[i]) || ! isCHARNAME_CONT(name[i])) {
24033                     goto failed;
24034                 }
24035                 lookup_name[j++] = name[i];
24036             }
24037
24038             /* Finished parsing, save the name into an SV */
24039             character_name = newSVpvn(lookup_name + equals_pos, j - equals_pos);
24040
24041             /* Make sure _charnames is loaded.  (The parameters give context
24042              * for any errors generated */
24043             table = load_charnames(character_name, name, name_len, &error_msg);
24044             if (table == NULL) {
24045                 sv_catpv(msg, error_msg);
24046                 goto append_name_to_msg;
24047             }
24048
24049             lookup_loose = get_cvs("_charnames::_loose_regcomp_lookup", 0);
24050             if (! lookup_loose) {
24051                 Perl_croak(aTHX_
24052                        "panic: Can't find '_charnames::_loose_regcomp_lookup");
24053             }
24054
24055             PUSHSTACKi(PERLSI_REGCOMP);
24056             ENTER ;
24057             SAVETMPS;
24058             save_re_context();
24059
24060             PUSHMARK(SP) ;
24061             XPUSHs(character_name);
24062             PUTBACK;
24063             call_sv(MUTABLE_SV(lookup_loose), G_SCALAR);
24064
24065             SPAGAIN ;
24066
24067             character = POPs;
24068             SvREFCNT_inc_simple_void_NN(character);
24069
24070             PUTBACK ;
24071             FREETMPS ;
24072             LEAVE ;
24073             POPSTACK;
24074
24075             if (! SvOK(character)) {
24076                 goto failed;
24077             }
24078
24079             cp = valid_utf8_to_uvchr((U8 *) SvPVX(character), &character_len);
24080             if (character_len == SvCUR(character)) {
24081                 prop_definition = add_cp_to_invlist(NULL, cp);
24082             }
24083             else {
24084                 AV * this_string;
24085
24086                 /* First of the remaining characters in the string. */
24087                 char * remaining = SvPVX(character) + character_len;
24088
24089                 if (strings == NULL) {
24090                     goto failed;    /* XXX Perhaps a specific msg instead, like
24091                                        'not available here' */
24092                 }
24093
24094                 if (*strings == NULL) {
24095                     *strings = newAV();
24096                 }
24097
24098                 this_string = newAV();
24099                 av_push(this_string, newSVuv(cp));
24100
24101                 do {
24102                     cp = valid_utf8_to_uvchr((U8 *) remaining, &character_len);
24103                     av_push(this_string, newSVuv(cp));
24104                     remaining += character_len;
24105                 } while (remaining < SvEND(character));
24106
24107                 av_push(*strings, (SV *) this_string);
24108             }
24109
24110             return prop_definition;
24111         }
24112
24113         /* Certain properties whose values are numeric need special handling.
24114          * They may optionally be prefixed by 'is'.  Ignore that prefix for the
24115          * purposes of checking if this is one of those properties */
24116         if (memBEGINPs(lookup_name, j, "is")) {
24117             lookup_offset = 2;
24118         }
24119
24120         /* Then check if it is one of these specially-handled properties.  The
24121          * possibilities are hard-coded because easier this way, and the list
24122          * is unlikely to change.
24123          *
24124          * All numeric value type properties are of this ilk, and are also
24125          * special in a different way later on.  So find those first.  There
24126          * are several numeric value type properties in the Unihan DB (which is
24127          * unlikely to be compiled with perl, but we handle it here in case it
24128          * does get compiled).  They all end with 'numeric'.  The interiors
24129          * aren't checked for the precise property.  This would stop working if
24130          * a cjk property were to be created that ended with 'numeric' and
24131          * wasn't a numeric type */
24132         is_nv_type = memEQs(lookup_name + lookup_offset,
24133                        j - 1 - lookup_offset, "numericvalue")
24134                   || memEQs(lookup_name + lookup_offset,
24135                       j - 1 - lookup_offset, "nv")
24136                   || (   memENDPs(lookup_name + lookup_offset,
24137                             j - 1 - lookup_offset, "numeric")
24138                       && (   memBEGINPs(lookup_name + lookup_offset,
24139                                       j - 1 - lookup_offset, "cjk")
24140                           || memBEGINPs(lookup_name + lookup_offset,
24141                                       j - 1 - lookup_offset, "k")));
24142         if (   is_nv_type
24143             || memEQs(lookup_name + lookup_offset,
24144                       j - 1 - lookup_offset, "canonicalcombiningclass")
24145             || memEQs(lookup_name + lookup_offset,
24146                       j - 1 - lookup_offset, "ccc")
24147             || memEQs(lookup_name + lookup_offset,
24148                       j - 1 - lookup_offset, "age")
24149             || memEQs(lookup_name + lookup_offset,
24150                       j - 1 - lookup_offset, "in")
24151             || memEQs(lookup_name + lookup_offset,
24152                       j - 1 - lookup_offset, "presentin"))
24153         {
24154             unsigned int k;
24155
24156             /* Since the stuff after the '=' is a number, we can't throw away
24157              * '-' willy-nilly, as those could be a minus sign.  Other stricter
24158              * rules also apply.  However, these properties all can have the
24159              * rhs not be a number, in which case they contain at least one
24160              * alphabetic.  In those cases, the stricter rules don't apply.
24161              * But the numeric type properties can have the alphas [Ee] to
24162              * signify an exponent, and it is still a number with stricter
24163              * rules.  So look for an alpha that signifies not-strict */
24164             stricter = Strict;
24165             for (k = i; k < name_len; k++) {
24166                 if (   isALPHA_A(name[k])
24167                     && (! is_nv_type || ! isALPHA_FOLD_EQ(name[k], 'E')))
24168                 {
24169                     stricter = Not_Strict;
24170                     break;
24171                 }
24172             }
24173         }
24174
24175         if (stricter) {
24176
24177             /* A number may have a leading '+' or '-'.  The latter is retained
24178              * */
24179             if (name[i] == '+') {
24180                 i++;
24181             }
24182             else if (name[i] == '-') {
24183                 lookup_name[j++] = '-';
24184                 i++;
24185             }
24186
24187             /* Skip leading zeros including single underscores separating the
24188              * zeros, or between the final leading zero and the first other
24189              * digit */
24190             for (; i < name_len - 1; i++) {
24191                 if (    name[i] != '0'
24192                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
24193                 {
24194                     break;
24195                 }
24196             }
24197         }
24198     }
24199     else {  /* No '=' */
24200
24201        /* Only a few properties without an '=' should be parsed with stricter
24202         * rules.  The list is unlikely to change. */
24203         if (   memBEGINPs(lookup_name, j, "perl")
24204             && memNEs(lookup_name + 4, j - 4, "space")
24205             && memNEs(lookup_name + 4, j - 4, "word"))
24206         {
24207             stricter = Strict;
24208
24209             /* We set the inputs back to 0 and the code below will reparse,
24210              * using strict */
24211             i = j = 0;
24212         }
24213     }
24214
24215     /* Here, we have either finished the property, or are positioned to parse
24216      * the remainder, and we know if stricter rules apply.  Finish out, if not
24217      * already done */
24218     for (; i < name_len; i++) {
24219         char cur = name[i];
24220
24221         /* In all instances, case differences are ignored, and we normalize to
24222          * lowercase */
24223         if (isUPPER_A(cur)) {
24224             lookup_name[j++] = toLOWER(cur);
24225             continue;
24226         }
24227
24228         /* An underscore is skipped, but not under strict rules unless it
24229          * separates two digits */
24230         if (cur == '_') {
24231             if (    stricter
24232                 && (     i == 0 || (int) i == equals_pos || i == name_len- 1
24233                     || ! isDIGIT_A(name[i-1]) || ! isDIGIT_A(name[i+1])))
24234             {
24235                 lookup_name[j++] = '_';
24236             }
24237             continue;
24238         }
24239
24240         /* Hyphens are skipped except under strict */
24241         if (cur == '-' && ! stricter) {
24242             continue;
24243         }
24244
24245         /* XXX Bug in documentation.  It says white space skipped adjacent to
24246          * non-word char.  Maybe we should, but shouldn't skip it next to a dot
24247          * in a number */
24248         if (isSPACE_A(cur) && ! stricter) {
24249             continue;
24250         }
24251
24252         lookup_name[j++] = cur;
24253
24254         /* Unless this is a non-trailing slash, we are done with it */
24255         if (i >= name_len - 1 || cur != '/') {
24256             continue;
24257         }
24258
24259         slash_pos = j;
24260
24261         /* A slash in the 'numeric value' property indicates that what follows
24262          * is a denominator.  It can have a leading '+' and '0's that should be
24263          * skipped.  But we have never allowed a negative denominator, so treat
24264          * a minus like every other character.  (No need to rule out a second
24265          * '/', as that won't match anything anyway */
24266         if (is_nv_type) {
24267             i++;
24268             if (i < name_len && name[i] == '+') {
24269                 i++;
24270             }
24271
24272             /* Skip leading zeros including underscores separating digits */
24273             for (; i < name_len - 1; i++) {
24274                 if (   name[i] != '0'
24275                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
24276                 {
24277                     break;
24278                 }
24279             }
24280
24281             /* Store the first real character in the denominator */
24282             if (i < name_len) {
24283                 lookup_name[j++] = name[i];
24284             }
24285         }
24286     }
24287
24288     /* Here are completely done parsing the input 'name', and 'lookup_name'
24289      * contains a copy, normalized.
24290      *
24291      * This special case is grandfathered in: 'L_' and 'GC=L_' are accepted and
24292      * different from without the underscores.  */
24293     if (  (   UNLIKELY(memEQs(lookup_name, j, "l"))
24294            || UNLIKELY(memEQs(lookup_name, j, "gc=l")))
24295         && UNLIKELY(name[name_len-1] == '_'))
24296     {
24297         lookup_name[j++] = '&';
24298     }
24299
24300     /* If the original input began with 'In' or 'Is', it could be a subroutine
24301      * call to a user-defined property instead of a Unicode property name. */
24302     if (    name_len - non_pkg_begin > 2
24303         &&  name[non_pkg_begin+0] == 'I'
24304         && (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
24305     {
24306         /* Names that start with In have different characterstics than those
24307          * that start with Is */
24308         if (name[non_pkg_begin+1] == 's') {
24309             starts_with_Is = TRUE;
24310         }
24311     }
24312     else {
24313         could_be_user_defined = FALSE;
24314     }
24315
24316     if (could_be_user_defined) {
24317         CV* user_sub;
24318
24319         /* If the user defined property returns the empty string, it could
24320          * easily be because the pattern is being compiled before the data it
24321          * actually needs to compile is available.  This could be argued to be
24322          * a bug in the perl code, but this is a change of behavior for Perl,
24323          * so we handle it.  This means that intentionally returning nothing
24324          * will not be resolved until runtime */
24325         bool empty_return = FALSE;
24326
24327         /* Here, the name could be for a user defined property, which are
24328          * implemented as subs. */
24329         user_sub = get_cvn_flags(name, name_len, 0);
24330         if (! user_sub) {
24331
24332             /* Here, the property name could be a user-defined one, but there
24333              * is no subroutine to handle it (as of now).   Defer handling it
24334              * until runtime.  Otherwise, a block defined by Unicode in a later
24335              * release would get the synonym InFoo added for it, and existing
24336              * code that used that name would suddenly break if it referred to
24337              * the property before the sub was declared.  See [perl #134146] */
24338             if (deferrable) {
24339                 goto definition_deferred;
24340             }
24341
24342             /* Here, we are at runtime, and didn't find the user property.  It
24343              * could be an official property, but only if no package was
24344              * specified, or just the utf8:: package. */
24345             if (could_be_deferred_official) {
24346                 lookup_name += lun_non_pkg_begin;
24347                 j -= lun_non_pkg_begin;
24348             }
24349             else if (! stripped_utf8_pkg) {
24350                 goto unknown_user_defined;
24351             }
24352
24353             /* Drop down to look up in the official properties */
24354         }
24355         else {
24356             const char insecure[] = "Insecure user-defined property";
24357
24358             /* Here, there is a sub by the correct name.  Normally we call it
24359              * to get the property definition */
24360             dSP;
24361             SV * user_sub_sv = MUTABLE_SV(user_sub);
24362             SV * error;     /* Any error returned by calling 'user_sub' */
24363             SV * key;       /* The key into the hash of user defined sub names
24364                              */
24365             SV * placeholder;
24366             SV ** saved_user_prop_ptr;      /* Hash entry for this property */
24367
24368             /* How many times to retry when another thread is in the middle of
24369              * expanding the same definition we want */
24370             PERL_INT_FAST8_T retry_countdown = 10;
24371
24372             DECLARATION_FOR_GLOBAL_CONTEXT;
24373
24374             /* If we get here, we know this property is user-defined */
24375             *user_defined_ptr = TRUE;
24376
24377             /* We refuse to call a potentially tainted subroutine; returning an
24378              * error instead */
24379             if (TAINT_get) {
24380                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24381                 sv_catpvn(msg, insecure, sizeof(insecure) - 1);
24382                 goto append_name_to_msg;
24383             }
24384
24385             /* In principal, we only call each subroutine property definition
24386              * once during the life of the program.  This guarantees that the
24387              * property definition never changes.  The results of the single
24388              * sub call are stored in a hash, which is used instead for future
24389              * references to this property.  The property definition is thus
24390              * immutable.  But, to allow the user to have a /i-dependent
24391              * definition, we call the sub once for non-/i, and once for /i,
24392              * should the need arise, passing the /i status as a parameter.
24393              *
24394              * We start by constructing the hash key name, consisting of the
24395              * fully qualified subroutine name, preceded by the /i status, so
24396              * that there is a key for /i and a different key for non-/i */
24397             key = newSVpvn(((to_fold) ? "1" : "0"), 1);
24398             fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
24399                                           non_pkg_begin != 0);
24400             sv_catsv(key, fq_name);
24401             sv_2mortal(key);
24402
24403             /* We only call the sub once throughout the life of the program
24404              * (with the /i, non-/i exception noted above).  That means the
24405              * hash must be global and accessible to all threads.  It is
24406              * created at program start-up, before any threads are created, so
24407              * is accessible to all children.  But this creates some
24408              * complications.
24409              *
24410              * 1) The keys can't be shared, or else problems arise; sharing is
24411              *    turned off at hash creation time
24412              * 2) All SVs in it are there for the remainder of the life of the
24413              *    program, and must be created in the same interpreter context
24414              *    as the hash, or else they will be freed from the wrong pool
24415              *    at global destruction time.  This is handled by switching to
24416              *    the hash's context to create each SV going into it, and then
24417              *    immediately switching back
24418              * 3) All accesses to the hash must be controlled by a mutex, to
24419              *    prevent two threads from getting an unstable state should
24420              *    they simultaneously be accessing it.  The code below is
24421              *    crafted so that the mutex is locked whenever there is an
24422              *    access and unlocked only when the next stable state is
24423              *    achieved.
24424              *
24425              * The hash stores either the definition of the property if it was
24426              * valid, or, if invalid, the error message that was raised.  We
24427              * use the type of SV to distinguish.
24428              *
24429              * There's also the need to guard against the definition expansion
24430              * from infinitely recursing.  This is handled by storing the aTHX
24431              * of the expanding thread during the expansion.  Again the SV type
24432              * is used to distinguish this from the other two cases.  If we
24433              * come to here and the hash entry for this property is our aTHX,
24434              * it means we have recursed, and the code assumes that we would
24435              * infinitely recurse, so instead stops and raises an error.
24436              * (Any recursion has always been treated as infinite recursion in
24437              * this feature.)
24438              *
24439              * If instead, the entry is for a different aTHX, it means that
24440              * that thread has gotten here first, and hasn't finished expanding
24441              * the definition yet.  We just have to wait until it is done.  We
24442              * sleep and retry a few times, returning an error if the other
24443              * thread doesn't complete. */
24444
24445           re_fetch:
24446             USER_PROP_MUTEX_LOCK;
24447
24448             /* If we have an entry for this key, the subroutine has already
24449              * been called once with this /i status. */
24450             saved_user_prop_ptr = hv_fetch(PL_user_def_props,
24451                                                    SvPVX(key), SvCUR(key), 0);
24452             if (saved_user_prop_ptr) {
24453
24454                 /* If the saved result is an inversion list, it is the valid
24455                  * definition of this property */
24456                 if (is_invlist(*saved_user_prop_ptr)) {
24457                     prop_definition = *saved_user_prop_ptr;
24458
24459                     /* The SV in the hash won't be removed until global
24460                      * destruction, so it is stable and we can unlock */
24461                     USER_PROP_MUTEX_UNLOCK;
24462
24463                     /* The caller shouldn't try to free this SV */
24464                     return prop_definition;
24465                 }
24466
24467                 /* Otherwise, if it is a string, it is the error message
24468                  * that was returned when we first tried to evaluate this
24469                  * property.  Fail, and append the message */
24470                 if (SvPOK(*saved_user_prop_ptr)) {
24471                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24472                     sv_catsv(msg, *saved_user_prop_ptr);
24473
24474                     /* The SV in the hash won't be removed until global
24475                      * destruction, so it is stable and we can unlock */
24476                     USER_PROP_MUTEX_UNLOCK;
24477
24478                     return NULL;
24479                 }
24480
24481                 assert(SvIOK(*saved_user_prop_ptr));
24482
24483                 /* Here, we have an unstable entry in the hash.  Either another
24484                  * thread is in the middle of expanding the property's
24485                  * definition, or we are ourselves recursing.  We use the aTHX
24486                  * in it to distinguish */
24487                 if (SvIV(*saved_user_prop_ptr) != PTR2IV(CUR_CONTEXT)) {
24488
24489                     /* Here, it's another thread doing the expanding.  We've
24490                      * looked as much as we are going to at the contents of the
24491                      * hash entry.  It's safe to unlock. */
24492                     USER_PROP_MUTEX_UNLOCK;
24493
24494                     /* Retry a few times */
24495                     if (retry_countdown-- > 0) {
24496                         PerlProc_sleep(1);
24497                         goto re_fetch;
24498                     }
24499
24500                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24501                     sv_catpvs(msg, "Timeout waiting for another thread to "
24502                                    "define");
24503                     goto append_name_to_msg;
24504                 }
24505
24506                 /* Here, we are recursing; don't dig any deeper */
24507                 USER_PROP_MUTEX_UNLOCK;
24508
24509                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24510                 sv_catpvs(msg,
24511                           "Infinite recursion in user-defined property");
24512                 goto append_name_to_msg;
24513             }
24514
24515             /* Here, this thread has exclusive control, and there is no entry
24516              * for this property in the hash.  So we have the go ahead to
24517              * expand the definition ourselves. */
24518
24519             PUSHSTACKi(PERLSI_REGCOMP);
24520             ENTER;
24521
24522             /* Create a temporary placeholder in the hash to detect recursion
24523              * */
24524             SWITCH_TO_GLOBAL_CONTEXT;
24525             placeholder= newSVuv(PTR2IV(ORIGINAL_CONTEXT));
24526             (void) hv_store_ent(PL_user_def_props, key, placeholder, 0);
24527             RESTORE_CONTEXT;
24528
24529             /* Now that we have a placeholder, we can let other threads
24530              * continue */
24531             USER_PROP_MUTEX_UNLOCK;
24532
24533             /* Make sure the placeholder always gets destroyed */
24534             SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(key));
24535
24536             PUSHMARK(SP);
24537             SAVETMPS;
24538
24539             /* Call the user's function, with the /i status as a parameter.
24540              * Note that we have gone to a lot of trouble to keep this call
24541              * from being within the locked mutex region. */
24542             XPUSHs(boolSV(to_fold));
24543             PUTBACK;
24544
24545             /* The following block was taken from swash_init().  Presumably
24546              * they apply to here as well, though we no longer use a swash --
24547              * khw */
24548             SAVEHINTS();
24549             save_re_context();
24550             /* We might get here via a subroutine signature which uses a utf8
24551              * parameter name, at which point PL_subname will have been set
24552              * but not yet used. */
24553             save_item(PL_subname);
24554
24555             /* G_SCALAR guarantees a single return value */
24556             (void) call_sv(user_sub_sv, G_EVAL|G_SCALAR);
24557
24558             SPAGAIN;
24559
24560             error = ERRSV;
24561             if (TAINT_get || SvTRUE(error)) {
24562                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24563                 if (SvTRUE(error)) {
24564                     sv_catpvs(msg, "Error \"");
24565                     sv_catsv(msg, error);
24566                     sv_catpvs(msg, "\"");
24567                 }
24568                 if (TAINT_get) {
24569                     if (SvTRUE(error)) sv_catpvs(msg, "; ");
24570                     sv_catpvn(msg, insecure, sizeof(insecure) - 1);
24571                 }
24572
24573                 if (name_len > 0) {
24574                     sv_catpvs(msg, " in expansion of ");
24575                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8,
24576                                                                   name_len,
24577                                                                   name));
24578                 }
24579
24580                 (void) POPs;
24581                 prop_definition = NULL;
24582             }
24583             else {
24584                 SV * contents = POPs;
24585
24586                 /* The contents is supposed to be the expansion of the property
24587                  * definition.  If the definition is deferrable, and we got an
24588                  * empty string back, set a flag to later defer it (after clean
24589                  * up below). */
24590                 if (      deferrable
24591                     && (! SvPOK(contents) || SvCUR(contents) == 0))
24592                 {
24593                         empty_return = TRUE;
24594                 }
24595                 else { /* Otherwise, call a function to check for valid syntax,
24596                           and handle it */
24597
24598                     prop_definition = handle_user_defined_property(
24599                                                     name, name_len,
24600                                                     is_utf8, to_fold, runtime,
24601                                                     deferrable,
24602                                                     contents, user_defined_ptr,
24603                                                     msg,
24604                                                     level);
24605                 }
24606             }
24607
24608             /* Here, we have the results of the expansion.  Delete the
24609              * placeholder, and if the definition is now known, replace it with
24610              * that definition.  We need exclusive access to the hash, and we
24611              * can't let anyone else in, between when we delete the placeholder
24612              * and add the permanent entry */
24613             USER_PROP_MUTEX_LOCK;
24614
24615             S_delete_recursion_entry(aTHX_ SvPVX(key));
24616
24617             if (    ! empty_return
24618                 && (! prop_definition || is_invlist(prop_definition)))
24619             {
24620                 /* If we got success we use the inversion list defining the
24621                  * property; otherwise use the error message */
24622                 SWITCH_TO_GLOBAL_CONTEXT;
24623                 (void) hv_store_ent(PL_user_def_props,
24624                                     key,
24625                                     ((prop_definition)
24626                                      ? newSVsv(prop_definition)
24627                                      : newSVsv(msg)),
24628                                     0);
24629                 RESTORE_CONTEXT;
24630             }
24631
24632             /* All done, and the hash now has a permanent entry for this
24633              * property.  Give up exclusive control */
24634             USER_PROP_MUTEX_UNLOCK;
24635
24636             FREETMPS;
24637             LEAVE;
24638             POPSTACK;
24639
24640             if (empty_return) {
24641                 goto definition_deferred;
24642             }
24643
24644             if (prop_definition) {
24645
24646                 /* If the definition is for something not known at this time,
24647                  * we toss it, and go return the main property name, as that's
24648                  * the one the user will be aware of */
24649                 if (! is_invlist(prop_definition)) {
24650                     SvREFCNT_dec_NN(prop_definition);
24651                     goto definition_deferred;
24652                 }
24653
24654                 sv_2mortal(prop_definition);
24655             }
24656
24657             /* And return */
24658             return prop_definition;
24659
24660         }   /* End of calling the subroutine for the user-defined property */
24661     }       /* End of it could be a user-defined property */
24662
24663     /* Here it wasn't a user-defined property that is known at this time.  See
24664      * if it is a Unicode property */
24665
24666     lookup_len = j;     /* This is a more mnemonic name than 'j' */
24667
24668     /* Get the index into our pointer table of the inversion list corresponding
24669      * to the property */
24670     table_index = do_uniprop_match(lookup_name, lookup_len);
24671
24672     /* If it didn't find the property ... */
24673     if (table_index == 0) {
24674
24675         /* Try again stripping off any initial 'Is'.  This is because we
24676          * promise that an initial Is is optional.  The same isn't true of
24677          * names that start with 'In'.  Those can match only blocks, and the
24678          * lookup table already has those accounted for.  The lookup table also
24679          * has already accounted for Perl extensions (without and = sign)
24680          * starting with 'i's'. */
24681         if (starts_with_Is && equals_pos >= 0) {
24682             lookup_name += 2;
24683             lookup_len -= 2;
24684             equals_pos -= 2;
24685             slash_pos -= 2;
24686
24687             table_index = do_uniprop_match(lookup_name, lookup_len);
24688         }
24689
24690         if (table_index == 0) {
24691             char * canonical;
24692
24693             /* Here, we didn't find it.  If not a numeric type property, and
24694              * can't be a user-defined one, it isn't a legal property */
24695             if (! is_nv_type) {
24696                 if (! could_be_user_defined) {
24697                     goto failed;
24698                 }
24699
24700                 /* Here, the property name is legal as a user-defined one.   At
24701                  * compile time, it might just be that the subroutine for that
24702                  * property hasn't been encountered yet, but at runtime, it's
24703                  * an error to try to use an undefined one */
24704                 if (! deferrable) {
24705                     goto unknown_user_defined;;
24706                 }
24707
24708                 goto definition_deferred;
24709             } /* End of isn't a numeric type property */
24710
24711             /* The numeric type properties need more work to decide.  What we
24712              * do is make sure we have the number in canonical form and look
24713              * that up. */
24714
24715             if (slash_pos < 0) {    /* No slash */
24716
24717                 /* When it isn't a rational, take the input, convert it to a
24718                  * NV, then create a canonical string representation of that
24719                  * NV. */
24720
24721                 NV value;
24722                 SSize_t value_len = lookup_len - equals_pos;
24723
24724                 /* Get the value */
24725                 if (   value_len <= 0
24726                     || my_atof3(lookup_name + equals_pos, &value,
24727                                 value_len)
24728                           != lookup_name + lookup_len)
24729                 {
24730                     goto failed;
24731                 }
24732
24733                 /* If the value is an integer, the canonical value is integral
24734                  * */
24735                 if (Perl_ceil(value) == value) {
24736                     canonical = Perl_form(aTHX_ "%.*s%.0" NVff,
24737                                             equals_pos, lookup_name, value);
24738                 }
24739                 else {  /* Otherwise, it is %e with a known precision */
24740                     char * exp_ptr;
24741
24742                     canonical = Perl_form(aTHX_ "%.*s%.*" NVef,
24743                                                 equals_pos, lookup_name,
24744                                                 PL_E_FORMAT_PRECISION, value);
24745
24746                     /* The exponent generated is expecting two digits, whereas
24747                      * %e on some systems will generate three.  Remove leading
24748                      * zeros in excess of 2 from the exponent.  We start
24749                      * looking for them after the '=' */
24750                     exp_ptr = strchr(canonical + equals_pos, 'e');
24751                     if (exp_ptr) {
24752                         char * cur_ptr = exp_ptr + 2; /* past the 'e[+-]' */
24753                         SSize_t excess_exponent_len = strlen(cur_ptr) - 2;
24754
24755                         assert(*(cur_ptr - 1) == '-' || *(cur_ptr - 1) == '+');
24756
24757                         if (excess_exponent_len > 0) {
24758                             SSize_t leading_zeros = strspn(cur_ptr, "0");
24759                             SSize_t excess_leading_zeros
24760                                     = MIN(leading_zeros, excess_exponent_len);
24761                             if (excess_leading_zeros > 0) {
24762                                 Move(cur_ptr + excess_leading_zeros,
24763                                      cur_ptr,
24764                                      strlen(cur_ptr) - excess_leading_zeros
24765                                        + 1,  /* Copy the NUL as well */
24766                                      char);
24767                             }
24768                         }
24769                     }
24770                 }
24771             }
24772             else {  /* Has a slash.  Create a rational in canonical form  */
24773                 UV numerator, denominator, gcd, trial;
24774                 const char * end_ptr;
24775                 const char * sign = "";
24776
24777                 /* We can't just find the numerator, denominator, and do the
24778                  * division, then use the method above, because that is
24779                  * inexact.  And the input could be a rational that is within
24780                  * epsilon (given our precision) of a valid rational, and would
24781                  * then incorrectly compare valid.
24782                  *
24783                  * We're only interested in the part after the '=' */
24784                 const char * this_lookup_name = lookup_name + equals_pos;
24785                 lookup_len -= equals_pos;
24786                 slash_pos -= equals_pos;
24787
24788                 /* Handle any leading minus */
24789                 if (this_lookup_name[0] == '-') {
24790                     sign = "-";
24791                     this_lookup_name++;
24792                     lookup_len--;
24793                     slash_pos--;
24794                 }
24795
24796                 /* Convert the numerator to numeric */
24797                 end_ptr = this_lookup_name + slash_pos;
24798                 if (! grok_atoUV(this_lookup_name, &numerator, &end_ptr)) {
24799                     goto failed;
24800                 }
24801
24802                 /* It better have included all characters before the slash */
24803                 if (*end_ptr != '/') {
24804                     goto failed;
24805                 }
24806
24807                 /* Set to look at just the denominator */
24808                 this_lookup_name += slash_pos;
24809                 lookup_len -= slash_pos;
24810                 end_ptr = this_lookup_name + lookup_len;
24811
24812                 /* Convert the denominator to numeric */
24813                 if (! grok_atoUV(this_lookup_name, &denominator, &end_ptr)) {
24814                     goto failed;
24815                 }
24816
24817                 /* It better be the rest of the characters, and don't divide by
24818                  * 0 */
24819                 if (   end_ptr != this_lookup_name + lookup_len
24820                     || denominator == 0)
24821                 {
24822                     goto failed;
24823                 }
24824
24825                 /* Get the greatest common denominator using
24826                    http://en.wikipedia.org/wiki/Euclidean_algorithm */
24827                 gcd = numerator;
24828                 trial = denominator;
24829                 while (trial != 0) {
24830                     UV temp = trial;
24831                     trial = gcd % trial;
24832                     gcd = temp;
24833                 }
24834
24835                 /* If already in lowest possible terms, we have already tried
24836                  * looking this up */
24837                 if (gcd == 1) {
24838                     goto failed;
24839                 }
24840
24841                 /* Reduce the rational, which should put it in canonical form
24842                  * */
24843                 numerator /= gcd;
24844                 denominator /= gcd;
24845
24846                 canonical = Perl_form(aTHX_ "%.*s%s%" UVuf "/%" UVuf,
24847                         equals_pos, lookup_name, sign, numerator, denominator);
24848             }
24849
24850             /* Here, we have the number in canonical form.  Try that */
24851             table_index = do_uniprop_match(canonical, strlen(canonical));
24852             if (table_index == 0) {
24853                 goto failed;
24854             }
24855         }   /* End of still didn't find the property in our table */
24856     }       /* End of       didn't find the property in our table */
24857
24858     /* Here, we have a non-zero return, which is an index into a table of ptrs.
24859      * A negative return signifies that the real index is the absolute value,
24860      * but the result needs to be inverted */
24861     if (table_index < 0) {
24862         invert_return = TRUE;
24863         table_index = -table_index;
24864     }
24865
24866     /* Out-of band indices indicate a deprecated property.  The proper index is
24867      * modulo it with the table size.  And dividing by the table size yields
24868      * an offset into a table constructed by regen/mk_invlists.pl to contain
24869      * the corresponding warning message */
24870     if (table_index > MAX_UNI_KEYWORD_INDEX) {
24871         Size_t warning_offset = table_index / MAX_UNI_KEYWORD_INDEX;
24872         table_index %= MAX_UNI_KEYWORD_INDEX;
24873         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
24874                 "Use of '%.*s' in \\p{} or \\P{} is deprecated because: %s",
24875                 (int) name_len, name,
24876                 get_deprecated_property_msg(warning_offset));
24877     }
24878
24879     /* In a few properties, a different property is used under /i.  These are
24880      * unlikely to change, so are hard-coded here. */
24881     if (to_fold) {
24882         if (   table_index == UNI_XPOSIXUPPER
24883             || table_index == UNI_XPOSIXLOWER
24884             || table_index == UNI_TITLE)
24885         {
24886             table_index = UNI_CASED;
24887         }
24888         else if (   table_index == UNI_UPPERCASELETTER
24889                  || table_index == UNI_LOWERCASELETTER
24890 #  ifdef UNI_TITLECASELETTER   /* Missing from early Unicodes */
24891                  || table_index == UNI_TITLECASELETTER
24892 #  endif
24893         ) {
24894             table_index = UNI_CASEDLETTER;
24895         }
24896         else if (  table_index == UNI_POSIXUPPER
24897                 || table_index == UNI_POSIXLOWER)
24898         {
24899             table_index = UNI_POSIXALPHA;
24900         }
24901     }
24902
24903     /* Create and return the inversion list */
24904     prop_definition = get_prop_definition(table_index);
24905     sv_2mortal(prop_definition);
24906
24907     /* See if there is a private use override to add to this definition */
24908     {
24909         COPHH * hinthash = (IN_PERL_COMPILETIME)
24910                            ? CopHINTHASH_get(&PL_compiling)
24911                            : CopHINTHASH_get(PL_curcop);
24912         SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0);
24913
24914         if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) {
24915
24916             /* See if there is an element in the hints hash for this table */
24917             SV * pu_lookup = Perl_newSVpvf(aTHX_ "%d=", table_index);
24918             const char * pos = strstr(SvPVX(pu_overrides), SvPVX(pu_lookup));
24919
24920             if (pos) {
24921                 bool dummy;
24922                 SV * pu_definition;
24923                 SV * pu_invlist;
24924                 SV * expanded_prop_definition =
24925                             sv_2mortal(invlist_clone(prop_definition, NULL));
24926
24927                 /* If so, it's definition is the string from here to the next
24928                  * \a character.  And its format is the same as a user-defined
24929                  * property */
24930                 pos += SvCUR(pu_lookup);
24931                 pu_definition = newSVpvn(pos, strchr(pos, '\a') - pos);
24932                 pu_invlist = handle_user_defined_property(lookup_name,
24933                                                           lookup_len,
24934                                                           0, /* Not UTF-8 */
24935                                                           0, /* Not folded */
24936                                                           runtime,
24937                                                           deferrable,
24938                                                           pu_definition,
24939                                                           &dummy,
24940                                                           msg,
24941                                                           level);
24942                 if (TAINT_get) {
24943                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24944                     sv_catpvs(msg, "Insecure private-use override");
24945                     goto append_name_to_msg;
24946                 }
24947
24948                 /* For now, as a safety measure, make sure that it doesn't
24949                  * override non-private use code points */
24950                 _invlist_intersection(pu_invlist, PL_Private_Use, &pu_invlist);
24951
24952                 /* Add it to the list to be returned */
24953                 _invlist_union(prop_definition, pu_invlist,
24954                                &expanded_prop_definition);
24955                 prop_definition = expanded_prop_definition;
24956                 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__PRIVATE_USE), "The private_use feature is experimental");
24957             }
24958         }
24959     }
24960
24961     if (invert_return) {
24962         _invlist_invert(prop_definition);
24963     }
24964     return prop_definition;
24965
24966   unknown_user_defined:
24967     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24968     sv_catpvs(msg, "Unknown user-defined property name");
24969     goto append_name_to_msg;
24970
24971   failed:
24972     if (non_pkg_begin != 0) {
24973         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24974         sv_catpvs(msg, "Illegal user-defined property name");
24975     }
24976     else {
24977         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
24978         sv_catpvs(msg, "Can't find Unicode property definition");
24979     }
24980     /* FALLTHROUGH */
24981
24982   append_name_to_msg:
24983     {
24984         const char * prefix = (runtime && level == 0) ?  " \\p{" : " \"";
24985         const char * suffix = (runtime && level == 0) ?  "}" : "\"";
24986
24987         sv_catpv(msg, prefix);
24988         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
24989         sv_catpv(msg, suffix);
24990     }
24991
24992     return NULL;
24993
24994   definition_deferred:
24995
24996     {
24997         bool is_qualified = non_pkg_begin != 0;  /* If has "::" */
24998
24999         /* Here it could yet to be defined, so defer evaluation of this until
25000          * its needed at runtime.  We need the fully qualified property name to
25001          * avoid ambiguity */
25002         if (! fq_name) {
25003             fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
25004                                                                 is_qualified);
25005         }
25006
25007         /* If it didn't come with a package, or the package is utf8::, this
25008          * actually could be an official Unicode property whose inclusion we
25009          * are deferring until runtime to make sure that it isn't overridden by
25010          * a user-defined property of the same name (which we haven't
25011          * encountered yet).  Add a marker to indicate this possibility, for
25012          * use at such time when we first need the definition during pattern
25013          * matching execution */
25014         if (! is_qualified || memBEGINPs(name, non_pkg_begin, "utf8::")) {
25015             sv_catpvs(fq_name, DEFERRED_COULD_BE_OFFICIAL_MARKERs);
25016         }
25017
25018         /* We also need a trailing newline */
25019         sv_catpvs(fq_name, "\n");
25020
25021         *user_defined_ptr = TRUE;
25022         return fq_name;
25023     }
25024 }
25025
25026 STATIC bool
25027 S_handle_names_wildcard(pTHX_ const char * wname, /* wildcard name to match */
25028                               const STRLEN wname_len, /* Its length */
25029                               SV ** prop_definition,
25030                               AV ** strings)
25031 {
25032     /* Deal with Name property wildcard subpatterns; returns TRUE if there were
25033      * any matches, adding them to prop_definition */
25034
25035     dSP;
25036
25037     CV * get_names_info;        /* entry to charnames.pm to get info we need */
25038     SV * names_string;          /* Contains all character names, except algo */
25039     SV * algorithmic_names;     /* Contains info about algorithmically
25040                                    generated character names */
25041     REGEXP * subpattern_re;     /* The user's pattern to match with */
25042     struct regexp * prog;       /* The compiled pattern */
25043     char * all_names_start;     /* lib/unicore/Name.pl string of every
25044                                    (non-algorithmic) character name */
25045     char * cur_pos;             /* We match, effectively using /gc; this is
25046                                    where we are now */
25047     bool found_matches = FALSE; /* Did any name match so far? */
25048     SV * empty;                 /* For matching zero length names */
25049     SV * must_sv;               /* Contains the substring, if any, that must be
25050                                    in a name for the subpattern to match */
25051     const char * must;          /* The PV of 'must' */
25052     STRLEN must_len;            /* And its length */
25053     SV * syllable_name = NULL;  /* For Hangul syllables */
25054     const char hangul_prefix[] = "HANGUL SYLLABLE ";
25055     const STRLEN hangul_prefix_len = sizeof(hangul_prefix) - 1;
25056
25057     /* By inspection, there are a maximum of 7 bytes in the suffix of a hangul
25058      * syllable name, and these are immutable and guaranteed by the Unicode
25059      * standard to never be extended */
25060     const STRLEN syl_max_len = hangul_prefix_len + 7;
25061
25062     IV i;
25063
25064     PERL_ARGS_ASSERT_HANDLE_NAMES_WILDCARD;
25065
25066     /* Make sure _charnames is loaded.  (The parameters give context
25067      * for any errors generated */
25068     get_names_info = get_cv("_charnames::_get_names_info", 0);
25069     if (! get_names_info) {
25070         Perl_croak(aTHX_ "panic: Can't find '_charnames::_get_names_info");
25071     }
25072
25073     /* Get the charnames data */
25074     PUSHSTACKi(PERLSI_REGCOMP);
25075     ENTER ;
25076     SAVETMPS;
25077     save_re_context();
25078
25079     PUSHMARK(SP) ;
25080     PUTBACK;
25081
25082     /* Special _charnames entry point that returns the info this routine
25083      * requires */
25084     call_sv(MUTABLE_SV(get_names_info), G_ARRAY);
25085
25086     SPAGAIN ;
25087
25088     /* Data structure for names which end in their very own code points */
25089     algorithmic_names = POPs;
25090     SvREFCNT_inc_simple_void_NN(algorithmic_names);
25091
25092     /* The lib/unicore/Name.pl string */
25093     names_string = POPs;
25094     SvREFCNT_inc_simple_void_NN(names_string);
25095
25096     PUTBACK ;
25097     FREETMPS ;
25098     LEAVE ;
25099     POPSTACK;
25100
25101     if (   ! SvROK(names_string)
25102         || ! SvROK(algorithmic_names))
25103     {   /* Perhaps should panic instead XXX */
25104         SvREFCNT_dec(names_string);
25105         SvREFCNT_dec(algorithmic_names);
25106         return FALSE;
25107     }
25108
25109     names_string = sv_2mortal(SvRV(names_string));
25110     all_names_start = SvPVX(names_string);
25111     cur_pos = all_names_start;
25112
25113     algorithmic_names= sv_2mortal(SvRV(algorithmic_names));
25114
25115     /* Compile the subpattern consisting of the name being looked for */
25116     subpattern_re = compile_wildcard(wname, wname_len, FALSE /* /-i */ );
25117
25118     must_sv = re_intuit_string(subpattern_re);
25119     if (must_sv) {
25120         /* regexec.c can free the re_intuit_string() return. GH #17734 */
25121         must_sv = sv_2mortal(newSVsv(must_sv));
25122         must = SvPV(must_sv, must_len);
25123     }
25124     else {
25125         must = "";
25126         must_len = 0;
25127     }
25128
25129     /* (Note: 'must' could contain a NUL.  And yet we use strspn() below on it.
25130      * This works because the NUL causes the function to return early, thus
25131      * showing that there are characters in it other than the acceptable ones,
25132      * which is our desired result.) */
25133
25134     prog = ReANY(subpattern_re);
25135
25136     /* If only nothing is matched, skip to where empty names are looked for */
25137     if (prog->maxlen == 0) {
25138         goto check_empty;
25139     }
25140
25141     /* And match against the string of all names /gc.  Don't even try if it
25142      * must match a character not found in any name. */
25143     if (strspn(must, "\n -0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ()") == must_len)
25144     {
25145         while (execute_wildcard(subpattern_re,
25146                                 cur_pos,
25147                                 SvEND(names_string),
25148                                 all_names_start, 0,
25149                                 names_string,
25150                                 0))
25151         { /* Here, matched. */
25152
25153             /* Note the string entries look like
25154              *      00001\nSTART OF HEADING\n\n
25155              * so we could match anywhere in that string.  We have to rule out
25156              * matching a code point line */
25157             char * this_name_start = all_names_start
25158                                                 + RX_OFFS(subpattern_re)->start;
25159             char * this_name_end   = all_names_start
25160                                                 + RX_OFFS(subpattern_re)->end;
25161             char * cp_start;
25162             char * cp_end;
25163             UV cp = 0;      /* Silences some compilers */
25164             AV * this_string = NULL;
25165             bool is_multi = FALSE;
25166
25167             /* If matched nothing, advance to next possible match */
25168             if (this_name_start == this_name_end) {
25169                 cur_pos = (char *) memchr(this_name_end + 1, '\n',
25170                                           SvEND(names_string) - this_name_end);
25171                 if (cur_pos == NULL) {
25172                     break;
25173                 }
25174             }
25175             else {
25176                 /* Position the next match to start beyond the current returned
25177                  * entry */
25178                 cur_pos = (char *) memchr(this_name_end, '\n',
25179                                           SvEND(names_string) - this_name_end);
25180             }
25181
25182             /* Back up to the \n just before the beginning of the character. */
25183             cp_end = (char *) my_memrchr(all_names_start,
25184                                          '\n',
25185                                          this_name_start - all_names_start);
25186
25187             /* If we didn't find a \n, it means it matched somewhere in the
25188              * initial '00000' in the string, so isn't a real match */
25189             if (cp_end == NULL) {
25190                 continue;
25191             }
25192
25193             this_name_start = cp_end + 1;   /* The name starts just after */
25194             cp_end--;                       /* the \n, and the code point */
25195                                             /* ends just before it */
25196
25197             /* All code points are 5 digits long */
25198             cp_start = cp_end - 4;
25199
25200             /* This shouldn't happen, as we found a \n, and the first \n is
25201              * further along than what we subtracted */
25202             assert(cp_start >= all_names_start);
25203
25204             if (cp_start == all_names_start) {
25205                 *prop_definition = add_cp_to_invlist(*prop_definition, 0);
25206                 continue;
25207             }
25208
25209             /* If the character is a blank, we either have a named sequence, or
25210              * something is wrong */
25211             if (*(cp_start - 1) == ' ') {
25212                 cp_start = (char *) my_memrchr(all_names_start,
25213                                                '\n',
25214                                                cp_start - all_names_start);
25215                 cp_start++;
25216             }
25217
25218             assert(cp_start != NULL && cp_start >= all_names_start + 2);
25219
25220             /* Except for the first line in the string, the sequence before the
25221              * code point is \n\n.  If that isn't the case here, we didn't
25222              * match the name of a character.  (We could have matched a named
25223              * sequence, not currently handled */
25224             if (*(cp_start - 1) != '\n' || *(cp_start - 2) != '\n') {
25225                 continue;
25226             }
25227
25228             /* We matched!  Add this to the list */
25229             found_matches = TRUE;
25230
25231             /* Loop through all the code points in the sequence */
25232             while (cp_start < cp_end) {
25233
25234                 /* Calculate this code point from its 5 digits */
25235                 cp = (XDIGIT_VALUE(cp_start[0]) << 16)
25236                    + (XDIGIT_VALUE(cp_start[1]) << 12)
25237                    + (XDIGIT_VALUE(cp_start[2]) << 8)
25238                    + (XDIGIT_VALUE(cp_start[3]) << 4)
25239                    +  XDIGIT_VALUE(cp_start[4]);
25240
25241                 cp_start += 6;  /* Go past any blank */
25242
25243                 if (cp_start < cp_end || is_multi) {
25244                     if (this_string == NULL) {
25245                         this_string = newAV();
25246                     }
25247
25248                     is_multi = TRUE;
25249                     av_push(this_string, newSVuv(cp));
25250                 }
25251             }
25252
25253             if (is_multi) { /* Was more than one code point */
25254                 if (*strings == NULL) {
25255                     *strings = newAV();
25256                 }
25257
25258                 av_push(*strings, (SV *) this_string);
25259             }
25260             else {  /* Only a single code point */
25261                 *prop_definition = add_cp_to_invlist(*prop_definition, cp);
25262             }
25263         } /* End of loop through the non-algorithmic names string */
25264     }
25265
25266     /* There are also character names not in 'names_string'.  These are
25267      * algorithmically generatable.  Try this pattern on each possible one.
25268      * (khw originally planned to leave this out given the large number of
25269      * matches attempted; but the speed turned out to be quite acceptable
25270      *
25271      * There are plenty of opportunities to optimize to skip many of the tests.
25272      * beyond the rudimentary ones already here */
25273
25274     /* First see if the subpattern matches any of the algorithmic generatable
25275      * Hangul syllable names.
25276      *
25277      * We know none of these syllable names will match if the input pattern
25278      * requires more bytes than any syllable has, or if the input pattern only
25279      * matches an empty name, or if the pattern has something it must match and
25280      * one of the characters in that isn't in any Hangul syllable. */
25281     if (    prog->minlen <= (SSize_t) syl_max_len
25282         &&  prog->maxlen > 0
25283         && (strspn(must, "\n ABCDEGHIJKLMNOPRSTUWY") == must_len))
25284     {
25285         /* These constants, names, values, and algorithm are adapted from the
25286          * Unicode standard, version 5.1, section 3.12, and should never
25287          * change. */
25288         const char * JamoL[] = {
25289             "G", "GG", "N", "D", "DD", "R", "M", "B", "BB",
25290             "S", "SS", "", "J", "JJ", "C", "K", "T", "P", "H"
25291         };
25292         const int LCount = C_ARRAY_LENGTH(JamoL);
25293
25294         const char * JamoV[] = {
25295             "A", "AE", "YA", "YAE", "EO", "E", "YEO", "YE", "O", "WA",
25296             "WAE", "OE", "YO", "U", "WEO", "WE", "WI", "YU", "EU", "YI",
25297             "I"
25298         };
25299         const int VCount = C_ARRAY_LENGTH(JamoV);
25300
25301         const char * JamoT[] = {
25302             "", "G", "GG", "GS", "N", "NJ", "NH", "D", "L",
25303             "LG", "LM", "LB", "LS", "LT", "LP", "LH", "M", "B",
25304             "BS", "S", "SS", "NG", "J", "C", "K", "T", "P", "H"
25305         };
25306         const int TCount = C_ARRAY_LENGTH(JamoT);
25307
25308         int L, V, T;
25309
25310         /* This is the initial Hangul syllable code point; each time through the
25311          * inner loop, it maps to the next higher code point.  For more info,
25312          * see the Hangul syllable section of the Unicode standard. */
25313         int cp = 0xAC00;
25314
25315         syllable_name = sv_2mortal(newSV(syl_max_len));
25316         sv_setpvn(syllable_name, hangul_prefix, hangul_prefix_len);
25317
25318         for (L = 0; L < LCount; L++) {
25319             for (V = 0; V < VCount; V++) {
25320                 for (T = 0; T < TCount; T++) {
25321
25322                     /* Truncate back to the prefix, which is unvarying */
25323                     SvCUR_set(syllable_name, hangul_prefix_len);
25324
25325                     sv_catpv(syllable_name, JamoL[L]);
25326                     sv_catpv(syllable_name, JamoV[V]);
25327                     sv_catpv(syllable_name, JamoT[T]);
25328
25329                     if (execute_wildcard(subpattern_re,
25330                                 SvPVX(syllable_name),
25331                                 SvEND(syllable_name),
25332                                 SvPVX(syllable_name), 0,
25333                                 syllable_name,
25334                                 0))
25335                     {
25336                         *prop_definition = add_cp_to_invlist(*prop_definition,
25337                                                              cp);
25338                         found_matches = TRUE;
25339                     }
25340
25341                     cp++;
25342                 }
25343             }
25344         }
25345     }
25346
25347     /* The rest of the algorithmically generatable names are of the form
25348      * "PREFIX-code_point".  The prefixes and the code point limits of each
25349      * were returned to us in the array 'algorithmic_names' from data in
25350      * lib/unicore/Name.pm.  'code_point' in the name is expressed in hex. */
25351     for (i = 0; i <= av_top_index((AV *) algorithmic_names); i++) {
25352         IV j;
25353
25354         /* Each element of the array is a hash, giving the details for the
25355          * series of names it covers.  There is the base name of the characters
25356          * in the series, and the low and high code points in the series.  And,
25357          * for optimization purposes a string containing all the legal
25358          * characters that could possibly be in a name in this series. */
25359         HV * this_series = (HV *) SvRV(* av_fetch((AV *) algorithmic_names, i, 0));
25360         SV * prefix = * hv_fetchs(this_series, "name", 0);
25361         IV low = SvIV(* hv_fetchs(this_series, "low", 0));
25362         IV high = SvIV(* hv_fetchs(this_series, "high", 0));
25363         char * legal = SvPVX(* hv_fetchs(this_series, "legal", 0));
25364
25365         /* Pre-allocate an SV with enough space */
25366         SV * algo_name = sv_2mortal(Perl_newSVpvf(aTHX_ "%s-0000",
25367                                                         SvPVX(prefix)));
25368         if (high >= 0x10000) {
25369             sv_catpvs(algo_name, "0");
25370         }
25371
25372         /* This series can be skipped entirely if the pattern requires
25373          * something longer than any name in the series, or can only match an
25374          * empty name, or contains a character not found in any name in the
25375          * series */
25376         if (    prog->minlen <= (SSize_t) SvCUR(algo_name)
25377             &&  prog->maxlen > 0
25378             && (strspn(must, legal) == must_len))
25379         {
25380             for (j = low; j <= high; j++) { /* For each code point in the series */
25381
25382                 /* Get its name, and see if it matches the subpattern */
25383                 Perl_sv_setpvf(aTHX_ algo_name, "%s-%X", SvPVX(prefix),
25384                                      (unsigned) j);
25385
25386                 if (execute_wildcard(subpattern_re,
25387                                     SvPVX(algo_name),
25388                                     SvEND(algo_name),
25389                                     SvPVX(algo_name), 0,
25390                                     algo_name,
25391                                     0))
25392                 {
25393                     *prop_definition = add_cp_to_invlist(*prop_definition, j);
25394                     found_matches = TRUE;
25395                 }
25396             }
25397         }
25398     }
25399
25400   check_empty:
25401     /* Finally, see if the subpattern matches an empty string */
25402     empty = newSVpvs("");
25403     if (execute_wildcard(subpattern_re,
25404                          SvPVX(empty),
25405                          SvEND(empty),
25406                          SvPVX(empty), 0,
25407                          empty,
25408                          0))
25409     {
25410         /* Many code points have empty names.  Currently these are the \p{GC=C}
25411          * ones, minus CC and CF */
25412
25413         SV * empty_names_ref = get_prop_definition(UNI_C);
25414         SV * empty_names = invlist_clone(empty_names_ref, NULL);
25415
25416         SV * subtract = get_prop_definition(UNI_CC);
25417
25418         _invlist_subtract(empty_names, subtract, &empty_names);
25419         SvREFCNT_dec_NN(empty_names_ref);
25420         SvREFCNT_dec_NN(subtract);
25421
25422         subtract = get_prop_definition(UNI_CF);
25423         _invlist_subtract(empty_names, subtract, &empty_names);
25424         SvREFCNT_dec_NN(subtract);
25425
25426         _invlist_union(*prop_definition, empty_names, prop_definition);
25427         found_matches = TRUE;
25428         SvREFCNT_dec_NN(empty_names);
25429     }
25430     SvREFCNT_dec_NN(empty);
25431
25432 #if 0
25433     /* If we ever were to accept aliases for, say private use names, we would
25434      * need to do something fancier to find empty names.  The code below works
25435      * (at the time it was written), and is slower than the above */
25436     const char empties_pat[] = "^.";
25437     if (strNE(name, empties_pat)) {
25438         SV * empty = newSVpvs("");
25439         if (execute_wildcard(subpattern_re,
25440                     SvPVX(empty),
25441                     SvEND(empty),
25442                     SvPVX(empty), 0,
25443                     empty,
25444                     0))
25445         {
25446             SV * empties = NULL;
25447
25448             (void) handle_names_wildcard(empties_pat, strlen(empties_pat), &empties);
25449
25450             _invlist_union_complement_2nd(*prop_definition, empties, prop_definition);
25451             SvREFCNT_dec_NN(empties);
25452
25453             found_matches = TRUE;
25454         }
25455         SvREFCNT_dec_NN(empty);
25456     }
25457 #endif
25458
25459     SvREFCNT_dec_NN(subpattern_re);
25460     return found_matches;
25461 }
25462
25463 /*
25464  * ex: set ts=8 sts=4 sw=4 et:
25465  */