This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pod/perlpod: Add advice about Z<> uses
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #define REG_COMP_C
78 #ifdef PERL_IN_XSUB_RE
79 #  include "re_comp.h"
80 EXTERN_C const struct regexp_engine my_reg_engine;
81 #else
82 #  include "regcomp.h"
83 #endif
84
85 #include "dquote_inline.h"
86 #include "invlist_inline.h"
87 #include "unicode_constants.h"
88
89 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
90  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
91 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
92  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
93 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
94 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
95
96 #ifndef STATIC
97 #define STATIC  static
98 #endif
99
100 /* this is a chain of data about sub patterns we are processing that
101    need to be handled separately/specially in study_chunk. Its so
102    we can simulate recursion without losing state.  */
103 struct scan_frame;
104 typedef struct scan_frame {
105     regnode *last_regnode;      /* last node to process in this frame */
106     regnode *next_regnode;      /* next node to process when last is reached */
107     U32 prev_recursed_depth;
108     I32 stopparen;              /* what stopparen do we use */
109
110     struct scan_frame *this_prev_frame; /* this previous frame */
111     struct scan_frame *prev_frame;      /* previous frame */
112     struct scan_frame *next_frame;      /* next frame */
113 } scan_frame;
114
115 /* Certain characters are output as a sequence with the first being a
116  * backslash. */
117 #define isBACKSLASHED_PUNCT(c)  strchr("-[]\\^", c)
118
119
120 struct RExC_state_t {
121     U32         flags;                  /* RXf_* are we folding, multilining? */
122     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
123     char        *precomp;               /* uncompiled string. */
124     char        *precomp_end;           /* pointer to end of uncompiled string. */
125     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
126     regexp      *rx;                    /* perl core regexp structure */
127     regexp_internal     *rxi;           /* internal data for regexp object
128                                            pprivate field */
129     char        *start;                 /* Start of input for compile */
130     char        *end;                   /* End of input for compile */
131     char        *parse;                 /* Input-scan pointer. */
132     char        *copy_start;            /* start of copy of input within
133                                            constructed parse string */
134     char        *save_copy_start;       /* Provides one level of saving
135                                            and restoring 'copy_start' */
136     char        *copy_start_in_input;   /* Position in input string
137                                            corresponding to copy_start */
138     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
139     regnode     *emit_start;            /* Start of emitted-code area */
140     regnode_offset emit;                /* Code-emit pointer */
141     I32         naughty;                /* How bad is this pattern? */
142     I32         sawback;                /* Did we see \1, ...? */
143     U32         seen;
144     SSize_t     size;                   /* Number of regnode equivalents in
145                                            pattern */
146
147     /* position beyond 'precomp' of the warning message furthest away from
148      * 'precomp'.  During the parse, no warnings are raised for any problems
149      * earlier in the parse than this position.  This works if warnings are
150      * raised the first time a given spot is parsed, and if only one
151      * independent warning is raised for any given spot */
152     Size_t      latest_warn_offset;
153
154     I32         npar;                   /* Capture buffer count so far in the
155                                            parse, (OPEN) plus one. ("par" 0 is
156                                            the whole pattern)*/
157     I32         total_par;              /* During initial parse, is either 0,
158                                            or -1; the latter indicating a
159                                            reparse is needed.  After that pass,
160                                            it is what 'npar' became after the
161                                            pass.  Hence, it being > 0 indicates
162                                            we are in a reparse situation */
163     I32         nestroot;               /* root parens we are in - used by
164                                            accept */
165     I32         seen_zerolen;
166     regnode_offset *open_parens;        /* offsets to open parens */
167     regnode_offset *close_parens;       /* offsets to close parens */
168     I32      parens_buf_size;           /* #slots malloced open/close_parens */
169     regnode     *end_op;                /* END node in program */
170     I32         utf8;           /* whether the pattern is utf8 or not */
171     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
172                                 /* XXX use this for future optimisation of case
173                                  * where pattern must be upgraded to utf8. */
174     I32         uni_semantics;  /* If a d charset modifier should use unicode
175                                    rules, even if the pattern is not in
176                                    utf8 */
177     HV          *paren_names;           /* Paren names */
178
179     regnode     **recurse;              /* Recurse regops */
180     I32         recurse_count;          /* Number of recurse regops we have generated */
181     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
182                                            through */
183     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
184     I32         in_lookbehind;
185     I32         contains_locale;
186     I32         override_recoding;
187 #ifdef EBCDIC
188     I32         recode_x_to_native;
189 #endif
190     I32         in_multi_char_class;
191     struct reg_code_blocks *code_blocks;/* positions of literal (?{})
192                                             within pattern */
193     int         code_index;             /* next code_blocks[] slot */
194     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
195     scan_frame *frame_head;
196     scan_frame *frame_last;
197     U32         frame_count;
198     AV         *warn_text;
199     HV         *unlexed_names;
200 #ifdef ADD_TO_REGEXEC
201     char        *starttry;              /* -Dr: where regtry was called. */
202 #define RExC_starttry   (pRExC_state->starttry)
203 #endif
204     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
205 #ifdef DEBUGGING
206     const char  *lastparse;
207     I32         lastnum;
208     AV          *paren_name_list;       /* idx -> name */
209     U32         study_chunk_recursed_count;
210     SV          *mysv1;
211     SV          *mysv2;
212
213 #define RExC_lastparse  (pRExC_state->lastparse)
214 #define RExC_lastnum    (pRExC_state->lastnum)
215 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
216 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
217 #define RExC_mysv       (pRExC_state->mysv1)
218 #define RExC_mysv1      (pRExC_state->mysv1)
219 #define RExC_mysv2      (pRExC_state->mysv2)
220
221 #endif
222     bool        seen_d_op;
223     bool        strict;
224     bool        study_started;
225     bool        in_script_run;
226     bool        use_BRANCHJ;
227 };
228
229 #define RExC_flags      (pRExC_state->flags)
230 #define RExC_pm_flags   (pRExC_state->pm_flags)
231 #define RExC_precomp    (pRExC_state->precomp)
232 #define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
233 #define RExC_copy_start_in_constructed  (pRExC_state->copy_start)
234 #define RExC_save_copy_start_in_constructed  (pRExC_state->save_copy_start)
235 #define RExC_precomp_end (pRExC_state->precomp_end)
236 #define RExC_rx_sv      (pRExC_state->rx_sv)
237 #define RExC_rx         (pRExC_state->rx)
238 #define RExC_rxi        (pRExC_state->rxi)
239 #define RExC_start      (pRExC_state->start)
240 #define RExC_end        (pRExC_state->end)
241 #define RExC_parse      (pRExC_state->parse)
242 #define RExC_latest_warn_offset (pRExC_state->latest_warn_offset )
243 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
244 #define RExC_seen_d_op (pRExC_state->seen_d_op) /* Seen something that differs
245                                                    under /d from /u ? */
246
247
248 #ifdef RE_TRACK_PATTERN_OFFSETS
249 #  define RExC_offsets  (RExC_rxi->u.offsets) /* I am not like the
250                                                          others */
251 #endif
252 #define RExC_emit       (pRExC_state->emit)
253 #define RExC_emit_start (pRExC_state->emit_start)
254 #define RExC_sawback    (pRExC_state->sawback)
255 #define RExC_seen       (pRExC_state->seen)
256 #define RExC_size       (pRExC_state->size)
257 #define RExC_maxlen        (pRExC_state->maxlen)
258 #define RExC_npar       (pRExC_state->npar)
259 #define RExC_total_parens       (pRExC_state->total_par)
260 #define RExC_parens_buf_size    (pRExC_state->parens_buf_size)
261 #define RExC_nestroot   (pRExC_state->nestroot)
262 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
263 #define RExC_utf8       (pRExC_state->utf8)
264 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
265 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
266 #define RExC_open_parens        (pRExC_state->open_parens)
267 #define RExC_close_parens       (pRExC_state->close_parens)
268 #define RExC_end_op     (pRExC_state->end_op)
269 #define RExC_paren_names        (pRExC_state->paren_names)
270 #define RExC_recurse    (pRExC_state->recurse)
271 #define RExC_recurse_count      (pRExC_state->recurse_count)
272 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
273 #define RExC_study_chunk_recursed_bytes  \
274                                    (pRExC_state->study_chunk_recursed_bytes)
275 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
276 #define RExC_contains_locale    (pRExC_state->contains_locale)
277 #ifdef EBCDIC
278 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
279 #endif
280 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
281 #define RExC_frame_head (pRExC_state->frame_head)
282 #define RExC_frame_last (pRExC_state->frame_last)
283 #define RExC_frame_count (pRExC_state->frame_count)
284 #define RExC_strict (pRExC_state->strict)
285 #define RExC_study_started      (pRExC_state->study_started)
286 #define RExC_warn_text (pRExC_state->warn_text)
287 #define RExC_in_script_run      (pRExC_state->in_script_run)
288 #define RExC_use_BRANCHJ        (pRExC_state->use_BRANCHJ)
289 #define RExC_unlexed_names (pRExC_state->unlexed_names)
290
291 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
292  * a flag to disable back-off on the fixed/floating substrings - if it's
293  * a high complexity pattern we assume the benefit of avoiding a full match
294  * is worth the cost of checking for the substrings even if they rarely help.
295  */
296 #define RExC_naughty    (pRExC_state->naughty)
297 #define TOO_NAUGHTY (10)
298 #define MARK_NAUGHTY(add) \
299     if (RExC_naughty < TOO_NAUGHTY) \
300         RExC_naughty += (add)
301 #define MARK_NAUGHTY_EXP(exp, add) \
302     if (RExC_naughty < TOO_NAUGHTY) \
303         RExC_naughty += RExC_naughty / (exp) + (add)
304
305 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
306 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
307         ((*s) == '{' && regcurly(s)))
308
309 /*
310  * Flags to be passed up and down.
311  */
312 #define WORST           0       /* Worst case. */
313 #define HASWIDTH        0x01    /* Known to not match null strings, could match
314                                    non-null ones. */
315
316 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
317  * character.  (There needs to be a case: in the switch statement in regexec.c
318  * for any node marked SIMPLE.)  Note that this is not the same thing as
319  * REGNODE_SIMPLE */
320 #define SIMPLE          0x02
321 #define SPSTART         0x04    /* Starts with * or + */
322 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
323 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
324 #define RESTART_PARSE   0x20    /* Need to redo the parse */
325 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PARSE, need to
326                                    calcuate sizes as UTF-8 */
327
328 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
329
330 /* whether trie related optimizations are enabled */
331 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
332 #define TRIE_STUDY_OPT
333 #define FULL_TRIE_STUDY
334 #define TRIE_STCLASS
335 #endif
336
337
338
339 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
340 #define PBITVAL(paren) (1 << ((paren) & 7))
341 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
342 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
343 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
344
345 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
346                                      if (!UTF) {                           \
347                                          *flagp = RESTART_PARSE|NEED_UTF8; \
348                                          return 0;                         \
349                                      }                                     \
350                              } STMT_END
351
352 /* Change from /d into /u rules, and restart the parse.  RExC_uni_semantics is
353  * a flag that indicates we need to override /d with /u as a result of
354  * something in the pattern.  It should only be used in regards to calling
355  * set_regex_charset() or get_regex_charse() */
356 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
357     STMT_START {                                                            \
358             if (DEPENDS_SEMANTICS) {                                        \
359                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
360                 RExC_uni_semantics = 1;                                     \
361                 if (RExC_seen_d_op && LIKELY(! IN_PARENS_PASS)) {           \
362                     /* No need to restart the parse if we haven't seen      \
363                      * anything that differs between /u and /d, and no need \
364                      * to restart immediately if we're going to reparse     \
365                      * anyway to count parens */                            \
366                     *flagp |= RESTART_PARSE;                                \
367                     return restart_retval;                                  \
368                 }                                                           \
369             }                                                               \
370     } STMT_END
371
372 #define REQUIRE_BRANCHJ(flagp, restart_retval)                              \
373     STMT_START {                                                            \
374                 RExC_use_BRANCHJ = 1;                                       \
375                 if (LIKELY(! IN_PARENS_PASS)) {                             \
376                     /* No need to restart the parse immediately if we're    \
377                      * going to reparse anyway to count parens */           \
378                     *flagp |= RESTART_PARSE;                                \
379                     return restart_retval;                                  \
380                 }                                                           \
381     } STMT_END
382
383 /* Until we have completed the parse, we leave RExC_total_parens at 0 or
384  * less.  After that, it must always be positive, because the whole re is
385  * considered to be surrounded by virtual parens.  Setting it to negative
386  * indicates there is some construct that needs to know the actual number of
387  * parens to be properly handled.  And that means an extra pass will be
388  * required after we've counted them all */
389 #define ALL_PARENS_COUNTED (RExC_total_parens > 0)
390 #define REQUIRE_PARENS_PASS                                                 \
391     STMT_START {  /* No-op if have completed a pass */                      \
392                     if (! ALL_PARENS_COUNTED) RExC_total_parens = -1;       \
393     } STMT_END
394 #define IN_PARENS_PASS (RExC_total_parens < 0)
395
396
397 /* This is used to return failure (zero) early from the calling function if
398  * various flags in 'flags' are set.  Two flags always cause a return:
399  * 'RESTART_PARSE' and 'NEED_UTF8'.   'extra' can be used to specify any
400  * additional flags that should cause a return; 0 if none.  If the return will
401  * be done, '*flagp' is first set to be all of the flags that caused the
402  * return. */
403 #define RETURN_FAIL_ON_RESTART_OR_FLAGS(flags,flagp,extra)                  \
404     STMT_START {                                                            \
405             if ((flags) & (RESTART_PARSE|NEED_UTF8|(extra))) {              \
406                 *(flagp) = (flags) & (RESTART_PARSE|NEED_UTF8|(extra));     \
407                 return 0;                                                   \
408             }                                                               \
409     } STMT_END
410
411 #define MUST_RESTART(flags) ((flags) & (RESTART_PARSE))
412
413 #define RETURN_FAIL_ON_RESTART(flags,flagp)                                 \
414                         RETURN_FAIL_ON_RESTART_OR_FLAGS( flags, flagp, 0)
415 #define RETURN_FAIL_ON_RESTART_FLAGP(flagp)                                 \
416                                     if (MUST_RESTART(*(flagp))) return 0
417
418 /* This converts the named class defined in regcomp.h to its equivalent class
419  * number defined in handy.h. */
420 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
421 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
422
423 #define _invlist_union_complement_2nd(a, b, output) \
424                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
425 #define _invlist_intersection_complement_2nd(a, b, output) \
426                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
427
428 /* About scan_data_t.
429
430   During optimisation we recurse through the regexp program performing
431   various inplace (keyhole style) optimisations. In addition study_chunk
432   and scan_commit populate this data structure with information about
433   what strings MUST appear in the pattern. We look for the longest
434   string that must appear at a fixed location, and we look for the
435   longest string that may appear at a floating location. So for instance
436   in the pattern:
437
438     /FOO[xX]A.*B[xX]BAR/
439
440   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
441   strings (because they follow a .* construct). study_chunk will identify
442   both FOO and BAR as being the longest fixed and floating strings respectively.
443
444   The strings can be composites, for instance
445
446      /(f)(o)(o)/
447
448   will result in a composite fixed substring 'foo'.
449
450   For each string some basic information is maintained:
451
452   - min_offset
453     This is the position the string must appear at, or not before.
454     It also implicitly (when combined with minlenp) tells us how many
455     characters must match before the string we are searching for.
456     Likewise when combined with minlenp and the length of the string it
457     tells us how many characters must appear after the string we have
458     found.
459
460   - max_offset
461     Only used for floating strings. This is the rightmost point that
462     the string can appear at. If set to SSize_t_MAX it indicates that the
463     string can occur infinitely far to the right.
464     For fixed strings, it is equal to min_offset.
465
466   - minlenp
467     A pointer to the minimum number of characters of the pattern that the
468     string was found inside. This is important as in the case of positive
469     lookahead or positive lookbehind we can have multiple patterns
470     involved. Consider
471
472     /(?=FOO).*F/
473
474     The minimum length of the pattern overall is 3, the minimum length
475     of the lookahead part is 3, but the minimum length of the part that
476     will actually match is 1. So 'FOO's minimum length is 3, but the
477     minimum length for the F is 1. This is important as the minimum length
478     is used to determine offsets in front of and behind the string being
479     looked for.  Since strings can be composites this is the length of the
480     pattern at the time it was committed with a scan_commit. Note that
481     the length is calculated by study_chunk, so that the minimum lengths
482     are not known until the full pattern has been compiled, thus the
483     pointer to the value.
484
485   - lookbehind
486
487     In the case of lookbehind the string being searched for can be
488     offset past the start point of the final matching string.
489     If this value was just blithely removed from the min_offset it would
490     invalidate some of the calculations for how many chars must match
491     before or after (as they are derived from min_offset and minlen and
492     the length of the string being searched for).
493     When the final pattern is compiled and the data is moved from the
494     scan_data_t structure into the regexp structure the information
495     about lookbehind is factored in, with the information that would
496     have been lost precalculated in the end_shift field for the
497     associated string.
498
499   The fields pos_min and pos_delta are used to store the minimum offset
500   and the delta to the maximum offset at the current point in the pattern.
501
502 */
503
504 struct scan_data_substrs {
505     SV      *str;       /* longest substring found in pattern */
506     SSize_t min_offset; /* earliest point in string it can appear */
507     SSize_t max_offset; /* latest point in string it can appear */
508     SSize_t *minlenp;   /* pointer to the minlen relevant to the string */
509     SSize_t lookbehind; /* is the pos of the string modified by LB */
510     I32 flags;          /* per substring SF_* and SCF_* flags */
511 };
512
513 typedef struct scan_data_t {
514     /*I32 len_min;      unused */
515     /*I32 len_delta;    unused */
516     SSize_t pos_min;
517     SSize_t pos_delta;
518     SV *last_found;
519     SSize_t last_end;       /* min value, <0 unless valid. */
520     SSize_t last_start_min;
521     SSize_t last_start_max;
522     U8      cur_is_floating; /* whether the last_* values should be set as
523                               * the next fixed (0) or floating (1)
524                               * substring */
525
526     /* [0] is longest fixed substring so far, [1] is longest float so far */
527     struct scan_data_substrs  substrs[2];
528
529     I32 flags;             /* common SF_* and SCF_* flags */
530     I32 whilem_c;
531     SSize_t *last_closep;
532     regnode_ssc *start_class;
533 } scan_data_t;
534
535 /*
536  * Forward declarations for pregcomp()'s friends.
537  */
538
539 static const scan_data_t zero_scan_data = {
540     0, 0, NULL, 0, 0, 0, 0,
541     {
542         { NULL, 0, 0, 0, 0, 0 },
543         { NULL, 0, 0, 0, 0, 0 },
544     },
545     0, 0, NULL, NULL
546 };
547
548 /* study flags */
549
550 #define SF_BEFORE_SEOL          0x0001
551 #define SF_BEFORE_MEOL          0x0002
552 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
553
554 #define SF_IS_INF               0x0040
555 #define SF_HAS_PAR              0x0080
556 #define SF_IN_PAR               0x0100
557 #define SF_HAS_EVAL             0x0200
558
559
560 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
561  * longest substring in the pattern. When it is not set the optimiser keeps
562  * track of position, but does not keep track of the actual strings seen,
563  *
564  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
565  * /foo/i will not.
566  *
567  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
568  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
569  * turned off because of the alternation (BRANCH). */
570 #define SCF_DO_SUBSTR           0x0400
571
572 #define SCF_DO_STCLASS_AND      0x0800
573 #define SCF_DO_STCLASS_OR       0x1000
574 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
575 #define SCF_WHILEM_VISITED_POS  0x2000
576
577 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
578 #define SCF_SEEN_ACCEPT         0x8000
579 #define SCF_TRIE_DOING_RESTUDY 0x10000
580 #define SCF_IN_DEFINE          0x20000
581
582
583
584
585 #define UTF cBOOL(RExC_utf8)
586
587 /* The enums for all these are ordered so things work out correctly */
588 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
589 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
590                                                      == REGEX_DEPENDS_CHARSET)
591 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
592 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
593                                                      >= REGEX_UNICODE_CHARSET)
594 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
595                                             == REGEX_ASCII_RESTRICTED_CHARSET)
596 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
597                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
598 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
599                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
600
601 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
602
603 /* For programs that want to be strictly Unicode compatible by dying if any
604  * attempt is made to match a non-Unicode code point against a Unicode
605  * property.  */
606 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
607
608 #define OOB_NAMEDCLASS          -1
609
610 /* There is no code point that is out-of-bounds, so this is problematic.  But
611  * its only current use is to initialize a variable that is always set before
612  * looked at. */
613 #define OOB_UNICODE             0xDEADBEEF
614
615 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
616
617
618 /* length of regex to show in messages that don't mark a position within */
619 #define RegexLengthToShowInErrorMessages 127
620
621 /*
622  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
623  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
624  * op/pragma/warn/regcomp.
625  */
626 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
627 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
628
629 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
630                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
631
632 /* The code in this file in places uses one level of recursion with parsing
633  * rebased to an alternate string constructed by us in memory.  This can take
634  * the form of something that is completely different from the input, or
635  * something that uses the input as part of the alternate.  In the first case,
636  * there should be no possibility of an error, as we are in complete control of
637  * the alternate string.  But in the second case we don't completely control
638  * the input portion, so there may be errors in that.  Here's an example:
639  *      /[abc\x{DF}def]/ui
640  * is handled specially because \x{df} folds to a sequence of more than one
641  * character: 'ss'.  What is done is to create and parse an alternate string,
642  * which looks like this:
643  *      /(?:\x{DF}|[abc\x{DF}def])/ui
644  * where it uses the input unchanged in the middle of something it constructs,
645  * which is a branch for the DF outside the character class, and clustering
646  * parens around the whole thing. (It knows enough to skip the DF inside the
647  * class while in this substitute parse.) 'abc' and 'def' may have errors that
648  * need to be reported.  The general situation looks like this:
649  *
650  *                                       |<------- identical ------>|
651  *              sI                       tI               xI       eI
652  * Input:       ---------------------------------------------------------------
653  * Constructed:         ---------------------------------------------------
654  *                      sC               tC               xC       eC     EC
655  *                                       |<------- identical ------>|
656  *
657  * sI..eI   is the portion of the input pattern we are concerned with here.
658  * sC..EC   is the constructed substitute parse string.
659  *  sC..tC  is constructed by us
660  *  tC..eC  is an exact duplicate of the portion of the input pattern tI..eI.
661  *          In the diagram, these are vertically aligned.
662  *  eC..EC  is also constructed by us.
663  * xC       is the position in the substitute parse string where we found a
664  *          problem.
665  * xI       is the position in the original pattern corresponding to xC.
666  *
667  * We want to display a message showing the real input string.  Thus we need to
668  * translate from xC to xI.  We know that xC >= tC, since the portion of the
669  * string sC..tC has been constructed by us, and so shouldn't have errors.  We
670  * get:
671  *      xI = tI + (xC - tC)
672  *
673  * When the substitute parse is constructed, the code needs to set:
674  *      RExC_start (sC)
675  *      RExC_end (eC)
676  *      RExC_copy_start_in_input  (tI)
677  *      RExC_copy_start_in_constructed (tC)
678  * and restore them when done.
679  *
680  * During normal processing of the input pattern, both
681  * 'RExC_copy_start_in_input' and 'RExC_copy_start_in_constructed' are set to
682  * sI, so that xC equals xI.
683  */
684
685 #define sI              RExC_precomp
686 #define eI              RExC_precomp_end
687 #define sC              RExC_start
688 #define eC              RExC_end
689 #define tI              RExC_copy_start_in_input
690 #define tC              RExC_copy_start_in_constructed
691 #define xI(xC)          (tI + (xC - tC))
692 #define xI_offset(xC)   (xI(xC) - sI)
693
694 #define REPORT_LOCATION_ARGS(xC)                                            \
695     UTF8fARG(UTF,                                                           \
696              (xI(xC) > eI) /* Don't run off end */                          \
697               ? eI - sI   /* Length before the <--HERE */                   \
698               : ((xI_offset(xC) >= 0)                                       \
699                  ? xI_offset(xC)                                            \
700                  : (Perl_croak(aTHX_ "panic: %s: %d: negative offset: %"    \
701                                     IVdf " trying to output message for "   \
702                                     " pattern %.*s",                        \
703                                     __FILE__, __LINE__, (IV) xI_offset(xC), \
704                                     ((int) (eC - sC)), sC), 0)),            \
705              sI),         /* The input pattern printed up to the <--HERE */ \
706     UTF8fARG(UTF,                                                           \
707              (xI(xC) > eI) ? 0 : eI - xI(xC), /* Length after <--HERE */    \
708              (xI(xC) > eI) ? eI : xI(xC))     /* pattern after <--HERE */
709
710 /* Used to point after bad bytes for an error message, but avoid skipping
711  * past a nul byte. */
712 #define SKIP_IF_CHAR(s, e) (!*(s) ? 0 : UTF ? UTF8_SAFE_SKIP(s, e) : 1)
713
714 /* Set up to clean up after our imminent demise */
715 #define PREPARE_TO_DIE                                                      \
716     STMT_START {                                                            \
717         if (RExC_rx_sv)                                                     \
718             SAVEFREESV(RExC_rx_sv);                                         \
719         if (RExC_open_parens)                                               \
720             SAVEFREEPV(RExC_open_parens);                                   \
721         if (RExC_close_parens)                                              \
722             SAVEFREEPV(RExC_close_parens);                                  \
723     } STMT_END
724
725 /*
726  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
727  * arg. Show regex, up to a maximum length. If it's too long, chop and add
728  * "...".
729  */
730 #define _FAIL(code) STMT_START {                                        \
731     const char *ellipses = "";                                          \
732     IV len = RExC_precomp_end - RExC_precomp;                           \
733                                                                         \
734     PREPARE_TO_DIE;                                                     \
735     if (len > RegexLengthToShowInErrorMessages) {                       \
736         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
737         len = RegexLengthToShowInErrorMessages - 10;                    \
738         ellipses = "...";                                               \
739     }                                                                   \
740     code;                                                               \
741 } STMT_END
742
743 #define FAIL(msg) _FAIL(                            \
744     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
745             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
746
747 #define FAIL2(msg,arg) _FAIL(                       \
748     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
749             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
750
751 /*
752  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
753  */
754 #define Simple_vFAIL(m) STMT_START {                                    \
755     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
756             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
757 } STMT_END
758
759 /*
760  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
761  */
762 #define vFAIL(m) STMT_START {                           \
763     PREPARE_TO_DIE;                                     \
764     Simple_vFAIL(m);                                    \
765 } STMT_END
766
767 /*
768  * Like Simple_vFAIL(), but accepts two arguments.
769  */
770 #define Simple_vFAIL2(m,a1) STMT_START {                        \
771     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
772                       REPORT_LOCATION_ARGS(RExC_parse));        \
773 } STMT_END
774
775 /*
776  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
777  */
778 #define vFAIL2(m,a1) STMT_START {                       \
779     PREPARE_TO_DIE;                                     \
780     Simple_vFAIL2(m, a1);                               \
781 } STMT_END
782
783
784 /*
785  * Like Simple_vFAIL(), but accepts three arguments.
786  */
787 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
788     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
789             REPORT_LOCATION_ARGS(RExC_parse));                  \
790 } STMT_END
791
792 /*
793  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
794  */
795 #define vFAIL3(m,a1,a2) STMT_START {                    \
796     PREPARE_TO_DIE;                                     \
797     Simple_vFAIL3(m, a1, a2);                           \
798 } STMT_END
799
800 /*
801  * Like Simple_vFAIL(), but accepts four arguments.
802  */
803 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
804     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
805             REPORT_LOCATION_ARGS(RExC_parse));                  \
806 } STMT_END
807
808 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
809     PREPARE_TO_DIE;                                     \
810     Simple_vFAIL4(m, a1, a2, a3);                       \
811 } STMT_END
812
813 /* A specialized version of vFAIL2 that works with UTF8f */
814 #define vFAIL2utf8f(m, a1) STMT_START {             \
815     PREPARE_TO_DIE;                                 \
816     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
817             REPORT_LOCATION_ARGS(RExC_parse));      \
818 } STMT_END
819
820 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
821     PREPARE_TO_DIE;                                     \
822     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
823             REPORT_LOCATION_ARGS(RExC_parse));          \
824 } STMT_END
825
826 /* Setting this to NULL is a signal to not output warnings */
827 #define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE                               \
828     STMT_START {                                                            \
829       RExC_save_copy_start_in_constructed  = RExC_copy_start_in_constructed;\
830       RExC_copy_start_in_constructed = NULL;                                \
831     } STMT_END
832 #define RESTORE_WARNINGS                                                    \
833     RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
834
835 /* Since a warning can be generated multiple times as the input is reparsed, we
836  * output it the first time we come to that point in the parse, but suppress it
837  * otherwise.  'RExC_copy_start_in_constructed' being NULL is a flag to not
838  * generate any warnings */
839 #define TO_OUTPUT_WARNINGS(loc)                                         \
840   (   RExC_copy_start_in_constructed                                    \
841    && ((xI(loc)) - RExC_precomp) > (Ptrdiff_t) RExC_latest_warn_offset)
842
843 /* After we've emitted a warning, we save the position in the input so we don't
844  * output it again */
845 #define UPDATE_WARNINGS_LOC(loc)                                        \
846     STMT_START {                                                        \
847         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
848             RExC_latest_warn_offset = (xI(loc)) - RExC_precomp;         \
849         }                                                               \
850     } STMT_END
851
852 /* 'warns' is the output of the packWARNx macro used in 'code' */
853 #define _WARN_HELPER(loc, warns, code)                                  \
854     STMT_START {                                                        \
855         if (! RExC_copy_start_in_constructed) {                         \
856             Perl_croak( aTHX_ "panic! %s: %d: Tried to warn when none"  \
857                               " expected at '%s'",                      \
858                               __FILE__, __LINE__, loc);                 \
859         }                                                               \
860         if (TO_OUTPUT_WARNINGS(loc)) {                                  \
861             if (ckDEAD(warns))                                          \
862                 PREPARE_TO_DIE;                                         \
863             code;                                                       \
864             UPDATE_WARNINGS_LOC(loc);                                   \
865         }                                                               \
866     } STMT_END
867
868 /* m is not necessarily a "literal string", in this macro */
869 #define reg_warn_non_literal_string(loc, m)                             \
870     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
871                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
872                                        "%s" REPORT_LOCATION,            \
873                                   m, REPORT_LOCATION_ARGS(loc)))
874
875 #define ckWARNreg(loc,m)                                                \
876     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
877                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
878                                           m REPORT_LOCATION,            \
879                                           REPORT_LOCATION_ARGS(loc)))
880
881 #define vWARN(loc, m)                                                   \
882     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
883                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
884                                        m REPORT_LOCATION,               \
885                                        REPORT_LOCATION_ARGS(loc)))      \
886
887 #define vWARN_dep(loc, m)                                               \
888     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
889                       Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),      \
890                                        m REPORT_LOCATION,               \
891                                        REPORT_LOCATION_ARGS(loc)))
892
893 #define ckWARNdep(loc,m)                                                \
894     _WARN_HELPER(loc, packWARN(WARN_DEPRECATED),                        \
895                       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \
896                                             m REPORT_LOCATION,          \
897                                             REPORT_LOCATION_ARGS(loc)))
898
899 #define ckWARNregdep(loc,m)                                                 \
900     _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP),              \
901                       Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,     \
902                                                       WARN_REGEXP),         \
903                                              m REPORT_LOCATION,             \
904                                              REPORT_LOCATION_ARGS(loc)))
905
906 #define ckWARN2reg_d(loc,m, a1)                                             \
907     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
908                       Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),         \
909                                             m REPORT_LOCATION,              \
910                                             a1, REPORT_LOCATION_ARGS(loc)))
911
912 #define ckWARN2reg(loc, m, a1)                                              \
913     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
914                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
915                                           m REPORT_LOCATION,                \
916                                           a1, REPORT_LOCATION_ARGS(loc)))
917
918 #define vWARN3(loc, m, a1, a2)                                              \
919     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
920                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),              \
921                                        m REPORT_LOCATION,                   \
922                                        a1, a2, REPORT_LOCATION_ARGS(loc)))
923
924 #define ckWARN3reg(loc, m, a1, a2)                                          \
925     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                                \
926                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),           \
927                                           m REPORT_LOCATION,                \
928                                           a1, a2,                           \
929                                           REPORT_LOCATION_ARGS(loc)))
930
931 #define vWARN4(loc, m, a1, a2, a3)                                      \
932     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
933                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
934                                        m REPORT_LOCATION,               \
935                                        a1, a2, a3,                      \
936                                        REPORT_LOCATION_ARGS(loc)))
937
938 #define ckWARN4reg(loc, m, a1, a2, a3)                                  \
939     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
940                       Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),       \
941                                           m REPORT_LOCATION,            \
942                                           a1, a2, a3,                   \
943                                           REPORT_LOCATION_ARGS(loc)))
944
945 #define vWARN5(loc, m, a1, a2, a3, a4)                                  \
946     _WARN_HELPER(loc, packWARN(WARN_REGEXP),                            \
947                       Perl_warner(aTHX_ packWARN(WARN_REGEXP),          \
948                                        m REPORT_LOCATION,               \
949                                        a1, a2, a3, a4,                  \
950                                        REPORT_LOCATION_ARGS(loc)))
951
952 #define ckWARNexperimental(loc, class, m)                               \
953     _WARN_HELPER(loc, packWARN(class),                                  \
954                       Perl_ck_warner_d(aTHX_ packWARN(class),           \
955                                             m REPORT_LOCATION,          \
956                                             REPORT_LOCATION_ARGS(loc)))
957
958 /* Convert between a pointer to a node and its offset from the beginning of the
959  * program */
960 #define REGNODE_p(offset)    (RExC_emit_start + (offset))
961 #define REGNODE_OFFSET(node) ((node) - RExC_emit_start)
962
963 /* Macros for recording node offsets.   20001227 mjd@plover.com
964  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
965  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
966  * Element 0 holds the number n.
967  * Position is 1 indexed.
968  */
969 #ifndef RE_TRACK_PATTERN_OFFSETS
970 #define Set_Node_Offset_To_R(offset,byte)
971 #define Set_Node_Offset(node,byte)
972 #define Set_Cur_Node_Offset
973 #define Set_Node_Length_To_R(node,len)
974 #define Set_Node_Length(node,len)
975 #define Set_Node_Cur_Length(node,start)
976 #define Node_Offset(n)
977 #define Node_Length(n)
978 #define Set_Node_Offset_Length(node,offset,len)
979 #define ProgLen(ri) ri->u.proglen
980 #define SetProgLen(ri,x) ri->u.proglen = x
981 #define Track_Code(code)
982 #else
983 #define ProgLen(ri) ri->u.offsets[0]
984 #define SetProgLen(ri,x) ri->u.offsets[0] = x
985 #define Set_Node_Offset_To_R(offset,byte) STMT_START {                  \
986         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
987                     __LINE__, (int)(offset), (int)(byte)));             \
988         if((offset) < 0) {                                              \
989             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
990                                          (int)(offset));                \
991         } else {                                                        \
992             RExC_offsets[2*(offset)-1] = (byte);                        \
993         }                                                               \
994 } STMT_END
995
996 #define Set_Node_Offset(node,byte)                                      \
997     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (byte)-RExC_start)
998 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
999
1000 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
1001         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
1002                 __LINE__, (int)(node), (int)(len)));                    \
1003         if((node) < 0) {                                                \
1004             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
1005                                          (int)(node));                  \
1006         } else {                                                        \
1007             RExC_offsets[2*(node)] = (len);                             \
1008         }                                                               \
1009 } STMT_END
1010
1011 #define Set_Node_Length(node,len) \
1012     Set_Node_Length_To_R(REGNODE_OFFSET(node), len)
1013 #define Set_Node_Cur_Length(node, start)                \
1014     Set_Node_Length(node, RExC_parse - start)
1015
1016 /* Get offsets and lengths */
1017 #define Node_Offset(n) (RExC_offsets[2*(REGNODE_OFFSET(n))-1])
1018 #define Node_Length(n) (RExC_offsets[2*(REGNODE_OFFSET(n))])
1019
1020 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
1021     Set_Node_Offset_To_R(REGNODE_OFFSET(node), (offset));       \
1022     Set_Node_Length_To_R(REGNODE_OFFSET(node), (len));  \
1023 } STMT_END
1024
1025 #define Track_Code(code) STMT_START { code } STMT_END
1026 #endif
1027
1028 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
1029 #define EXPERIMENTAL_INPLACESCAN
1030 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
1031
1032 #ifdef DEBUGGING
1033 int
1034 Perl_re_printf(pTHX_ const char *fmt, ...)
1035 {
1036     va_list ap;
1037     int result;
1038     PerlIO *f= Perl_debug_log;
1039     PERL_ARGS_ASSERT_RE_PRINTF;
1040     va_start(ap, fmt);
1041     result = PerlIO_vprintf(f, fmt, ap);
1042     va_end(ap);
1043     return result;
1044 }
1045
1046 int
1047 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
1048 {
1049     va_list ap;
1050     int result;
1051     PerlIO *f= Perl_debug_log;
1052     PERL_ARGS_ASSERT_RE_INDENTF;
1053     va_start(ap, depth);
1054     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
1055     result = PerlIO_vprintf(f, fmt, ap);
1056     va_end(ap);
1057     return result;
1058 }
1059 #endif /* DEBUGGING */
1060
1061 #define DEBUG_RExC_seen()                                                   \
1062         DEBUG_OPTIMISE_MORE_r({                                             \
1063             Perl_re_printf( aTHX_ "RExC_seen: ");                           \
1064                                                                             \
1065             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
1066                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                \
1067                                                                             \
1068             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
1069                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");              \
1070                                                                             \
1071             if (RExC_seen & REG_GPOS_SEEN)                                  \
1072                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                    \
1073                                                                             \
1074             if (RExC_seen & REG_RECURSE_SEEN)                               \
1075                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                 \
1076                                                                             \
1077             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
1078                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");      \
1079                                                                             \
1080             if (RExC_seen & REG_VERBARG_SEEN)                               \
1081                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                 \
1082                                                                             \
1083             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
1084                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                \
1085                                                                             \
1086             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
1087                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");          \
1088                                                                             \
1089             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
1090                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");          \
1091                                                                             \
1092             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
1093                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");    \
1094                                                                             \
1095             Perl_re_printf( aTHX_ "\n");                                    \
1096         });
1097
1098 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
1099   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
1100
1101
1102 #ifdef DEBUGGING
1103 static void
1104 S_debug_show_study_flags(pTHX_ U32 flags, const char *open_str,
1105                                     const char *close_str)
1106 {
1107     if (!flags)
1108         return;
1109
1110     Perl_re_printf( aTHX_  "%s", open_str);
1111     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_SEOL);
1112     DEBUG_SHOW_STUDY_FLAG(flags, SF_BEFORE_MEOL);
1113     DEBUG_SHOW_STUDY_FLAG(flags, SF_IS_INF);
1114     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_PAR);
1115     DEBUG_SHOW_STUDY_FLAG(flags, SF_IN_PAR);
1116     DEBUG_SHOW_STUDY_FLAG(flags, SF_HAS_EVAL);
1117     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_SUBSTR);
1118     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_AND);
1119     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS_OR);
1120     DEBUG_SHOW_STUDY_FLAG(flags, SCF_DO_STCLASS);
1121     DEBUG_SHOW_STUDY_FLAG(flags, SCF_WHILEM_VISITED_POS);
1122     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_RESTUDY);
1123     DEBUG_SHOW_STUDY_FLAG(flags, SCF_SEEN_ACCEPT);
1124     DEBUG_SHOW_STUDY_FLAG(flags, SCF_TRIE_DOING_RESTUDY);
1125     DEBUG_SHOW_STUDY_FLAG(flags, SCF_IN_DEFINE);
1126     Perl_re_printf( aTHX_  "%s", close_str);
1127 }
1128
1129
1130 static void
1131 S_debug_studydata(pTHX_ const char *where, scan_data_t *data,
1132                     U32 depth, int is_inf)
1133 {
1134     GET_RE_DEBUG_FLAGS_DECL;
1135
1136     DEBUG_OPTIMISE_MORE_r({
1137         if (!data)
1138             return;
1139         Perl_re_indentf(aTHX_  "%s: Pos:%" IVdf "/%" IVdf " Flags: 0x%" UVXf,
1140             depth,
1141             where,
1142             (IV)data->pos_min,
1143             (IV)data->pos_delta,
1144             (UV)data->flags
1145         );
1146
1147         S_debug_show_study_flags(aTHX_ data->flags," [","]");
1148
1149         Perl_re_printf( aTHX_
1150             " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",
1151             (IV)data->whilem_c,
1152             (IV)(data->last_closep ? *((data)->last_closep) : -1),
1153             is_inf ? "INF " : ""
1154         );
1155
1156         if (data->last_found) {
1157             int i;
1158             Perl_re_printf(aTHX_
1159                 "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf,
1160                     SvPVX_const(data->last_found),
1161                     (IV)data->last_end,
1162                     (IV)data->last_start_min,
1163                     (IV)data->last_start_max
1164             );
1165
1166             for (i = 0; i < 2; i++) {
1167                 Perl_re_printf(aTHX_
1168                     " %s%s: '%s' @ %" IVdf "/%" IVdf,
1169                     data->cur_is_floating == i ? "*" : "",
1170                     i ? "Float" : "Fixed",
1171                     SvPVX_const(data->substrs[i].str),
1172                     (IV)data->substrs[i].min_offset,
1173                     (IV)data->substrs[i].max_offset
1174                 );
1175                 S_debug_show_study_flags(aTHX_ data->substrs[i].flags," [","]");
1176             }
1177         }
1178
1179         Perl_re_printf( aTHX_ "\n");
1180     });
1181 }
1182
1183
1184 static void
1185 S_debug_peep(pTHX_ const char *str, const RExC_state_t *pRExC_state,
1186                 regnode *scan, U32 depth, U32 flags)
1187 {
1188     GET_RE_DEBUG_FLAGS_DECL;
1189
1190     DEBUG_OPTIMISE_r({
1191         regnode *Next;
1192
1193         if (!scan)
1194             return;
1195         Next = regnext(scan);
1196         regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
1197         Perl_re_indentf( aTHX_   "%s>%3d: %s (%d)",
1198             depth,
1199             str,
1200             REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),
1201             Next ? (REG_NODE_NUM(Next)) : 0 );
1202         S_debug_show_study_flags(aTHX_ flags," [ ","]");
1203         Perl_re_printf( aTHX_  "\n");
1204    });
1205 }
1206
1207
1208 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) \
1209                     S_debug_studydata(aTHX_ where, data, depth, is_inf)
1210
1211 #  define DEBUG_PEEP(str, scan, depth, flags)   \
1212                     S_debug_peep(aTHX_ str, pRExC_state, scan, depth, flags)
1213
1214 #else
1215 #  define DEBUG_STUDYDATA(where, data, depth, is_inf) NOOP
1216 #  define DEBUG_PEEP(str, scan, depth, flags)         NOOP
1217 #endif
1218
1219
1220 /* =========================================================
1221  * BEGIN edit_distance stuff.
1222  *
1223  * This calculates how many single character changes of any type are needed to
1224  * transform a string into another one.  It is taken from version 3.1 of
1225  *
1226  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1227  */
1228
1229 /* Our unsorted dictionary linked list.   */
1230 /* Note we use UVs, not chars. */
1231
1232 struct dictionary{
1233   UV key;
1234   UV value;
1235   struct dictionary* next;
1236 };
1237 typedef struct dictionary item;
1238
1239
1240 PERL_STATIC_INLINE item*
1241 push(UV key, item* curr)
1242 {
1243     item* head;
1244     Newx(head, 1, item);
1245     head->key = key;
1246     head->value = 0;
1247     head->next = curr;
1248     return head;
1249 }
1250
1251
1252 PERL_STATIC_INLINE item*
1253 find(item* head, UV key)
1254 {
1255     item* iterator = head;
1256     while (iterator){
1257         if (iterator->key == key){
1258             return iterator;
1259         }
1260         iterator = iterator->next;
1261     }
1262
1263     return NULL;
1264 }
1265
1266 PERL_STATIC_INLINE item*
1267 uniquePush(item* head, UV key)
1268 {
1269     item* iterator = head;
1270
1271     while (iterator){
1272         if (iterator->key == key) {
1273             return head;
1274         }
1275         iterator = iterator->next;
1276     }
1277
1278     return push(key, head);
1279 }
1280
1281 PERL_STATIC_INLINE void
1282 dict_free(item* head)
1283 {
1284     item* iterator = head;
1285
1286     while (iterator) {
1287         item* temp = iterator;
1288         iterator = iterator->next;
1289         Safefree(temp);
1290     }
1291
1292     head = NULL;
1293 }
1294
1295 /* End of Dictionary Stuff */
1296
1297 /* All calculations/work are done here */
1298 STATIC int
1299 S_edit_distance(const UV* src,
1300                 const UV* tgt,
1301                 const STRLEN x,             /* length of src[] */
1302                 const STRLEN y,             /* length of tgt[] */
1303                 const SSize_t maxDistance
1304 )
1305 {
1306     item *head = NULL;
1307     UV swapCount, swapScore, targetCharCount, i, j;
1308     UV *scores;
1309     UV score_ceil = x + y;
1310
1311     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1312
1313     /* intialize matrix start values */
1314     Newx(scores, ( (x + 2) * (y + 2)), UV);
1315     scores[0] = score_ceil;
1316     scores[1 * (y + 2) + 0] = score_ceil;
1317     scores[0 * (y + 2) + 1] = score_ceil;
1318     scores[1 * (y + 2) + 1] = 0;
1319     head = uniquePush(uniquePush(head, src[0]), tgt[0]);
1320
1321     /* work loops    */
1322     /* i = src index */
1323     /* j = tgt index */
1324     for (i=1;i<=x;i++) {
1325         if (i < x)
1326             head = uniquePush(head, src[i]);
1327         scores[(i+1) * (y + 2) + 1] = i;
1328         scores[(i+1) * (y + 2) + 0] = score_ceil;
1329         swapCount = 0;
1330
1331         for (j=1;j<=y;j++) {
1332             if (i == 1) {
1333                 if(j < y)
1334                 head = uniquePush(head, tgt[j]);
1335                 scores[1 * (y + 2) + (j + 1)] = j;
1336                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1337             }
1338
1339             targetCharCount = find(head, tgt[j-1])->value;
1340             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1341
1342             if (src[i-1] != tgt[j-1]){
1343                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(swapScore,(MIN(scores[i * (y + 2) + j], MIN(scores[(i+1) * (y + 2) + j], scores[i * (y + 2) + (j + 1)])) + 1));
1344             }
1345             else {
1346                 swapCount = j;
1347                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1348             }
1349         }
1350
1351         find(head, src[i-1])->value = i;
1352     }
1353
1354     {
1355         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1356         dict_free(head);
1357         Safefree(scores);
1358         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1359     }
1360 }
1361
1362 /* END of edit_distance() stuff
1363  * ========================================================= */
1364
1365 /* is c a control character for which we have a mnemonic? */
1366 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1367
1368 STATIC const char *
1369 S_cntrl_to_mnemonic(const U8 c)
1370 {
1371     /* Returns the mnemonic string that represents character 'c', if one
1372      * exists; NULL otherwise.  The only ones that exist for the purposes of
1373      * this routine are a few control characters */
1374
1375     switch (c) {
1376         case '\a':       return "\\a";
1377         case '\b':       return "\\b";
1378         case ESC_NATIVE: return "\\e";
1379         case '\f':       return "\\f";
1380         case '\n':       return "\\n";
1381         case '\r':       return "\\r";
1382         case '\t':       return "\\t";
1383     }
1384
1385     return NULL;
1386 }
1387
1388 /* Mark that we cannot extend a found fixed substring at this point.
1389    Update the longest found anchored substring or the longest found
1390    floating substrings if needed. */
1391
1392 STATIC void
1393 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1394                     SSize_t *minlenp, int is_inf)
1395 {
1396     const STRLEN l = CHR_SVLEN(data->last_found);
1397     SV * const longest_sv = data->substrs[data->cur_is_floating].str;
1398     const STRLEN old_l = CHR_SVLEN(longest_sv);
1399     GET_RE_DEBUG_FLAGS_DECL;
1400
1401     PERL_ARGS_ASSERT_SCAN_COMMIT;
1402
1403     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1404         const U8 i = data->cur_is_floating;
1405         SvSetMagicSV(longest_sv, data->last_found);
1406         data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min;
1407
1408         if (!i) /* fixed */
1409             data->substrs[0].max_offset = data->substrs[0].min_offset;
1410         else { /* float */
1411             data->substrs[1].max_offset = (l
1412                           ? data->last_start_max
1413                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1414                                          ? SSize_t_MAX
1415                                          : data->pos_min + data->pos_delta));
1416             if (is_inf
1417                  || (STRLEN)data->substrs[1].max_offset > (STRLEN)SSize_t_MAX)
1418                 data->substrs[1].max_offset = SSize_t_MAX;
1419         }
1420
1421         if (data->flags & SF_BEFORE_EOL)
1422             data->substrs[i].flags |= (data->flags & SF_BEFORE_EOL);
1423         else
1424             data->substrs[i].flags &= ~SF_BEFORE_EOL;
1425         data->substrs[i].minlenp = minlenp;
1426         data->substrs[i].lookbehind = 0;
1427     }
1428
1429     SvCUR_set(data->last_found, 0);
1430     {
1431         SV * const sv = data->last_found;
1432         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1433             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1434             if (mg)
1435                 mg->mg_len = 0;
1436         }
1437     }
1438     data->last_end = -1;
1439     data->flags &= ~SF_BEFORE_EOL;
1440     DEBUG_STUDYDATA("commit", data, 0, is_inf);
1441 }
1442
1443 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1444  * list that describes which code points it matches */
1445
1446 STATIC void
1447 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1448 {
1449     /* Set the SSC 'ssc' to match an empty string or any code point */
1450
1451     PERL_ARGS_ASSERT_SSC_ANYTHING;
1452
1453     assert(is_ANYOF_SYNTHETIC(ssc));
1454
1455     /* mortalize so won't leak */
1456     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1457     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1458 }
1459
1460 STATIC int
1461 S_ssc_is_anything(const regnode_ssc *ssc)
1462 {
1463     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1464      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1465      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1466      * in any way, so there's no point in using it */
1467
1468     UV start, end;
1469     bool ret;
1470
1471     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1472
1473     assert(is_ANYOF_SYNTHETIC(ssc));
1474
1475     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1476         return FALSE;
1477     }
1478
1479     /* See if the list consists solely of the range 0 - Infinity */
1480     invlist_iterinit(ssc->invlist);
1481     ret = invlist_iternext(ssc->invlist, &start, &end)
1482           && start == 0
1483           && end == UV_MAX;
1484
1485     invlist_iterfinish(ssc->invlist);
1486
1487     if (ret) {
1488         return TRUE;
1489     }
1490
1491     /* If e.g., both \w and \W are set, matches everything */
1492     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1493         int i;
1494         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1495             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1496                 return TRUE;
1497             }
1498         }
1499     }
1500
1501     return FALSE;
1502 }
1503
1504 STATIC void
1505 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1506 {
1507     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1508      * string, any code point, or any posix class under locale */
1509
1510     PERL_ARGS_ASSERT_SSC_INIT;
1511
1512     Zero(ssc, 1, regnode_ssc);
1513     set_ANYOF_SYNTHETIC(ssc);
1514     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1515     ssc_anything(ssc);
1516
1517     /* If any portion of the regex is to operate under locale rules that aren't
1518      * fully known at compile time, initialization includes it.  The reason
1519      * this isn't done for all regexes is that the optimizer was written under
1520      * the assumption that locale was all-or-nothing.  Given the complexity and
1521      * lack of documentation in the optimizer, and that there are inadequate
1522      * test cases for locale, many parts of it may not work properly, it is
1523      * safest to avoid locale unless necessary. */
1524     if (RExC_contains_locale) {
1525         ANYOF_POSIXL_SETALL(ssc);
1526     }
1527     else {
1528         ANYOF_POSIXL_ZERO(ssc);
1529     }
1530 }
1531
1532 STATIC int
1533 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1534                         const regnode_ssc *ssc)
1535 {
1536     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1537      * to the list of code points matched, and locale posix classes; hence does
1538      * not check its flags) */
1539
1540     UV start, end;
1541     bool ret;
1542
1543     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1544
1545     assert(is_ANYOF_SYNTHETIC(ssc));
1546
1547     invlist_iterinit(ssc->invlist);
1548     ret = invlist_iternext(ssc->invlist, &start, &end)
1549           && start == 0
1550           && end == UV_MAX;
1551
1552     invlist_iterfinish(ssc->invlist);
1553
1554     if (! ret) {
1555         return FALSE;
1556     }
1557
1558     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1559         return FALSE;
1560     }
1561
1562     return TRUE;
1563 }
1564
1565 #define INVLIST_INDEX 0
1566 #define ONLY_LOCALE_MATCHES_INDEX 1
1567 #define DEFERRED_USER_DEFINED_INDEX 2
1568
1569 STATIC SV*
1570 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1571                                const regnode_charclass* const node)
1572 {
1573     /* Returns a mortal inversion list defining which code points are matched
1574      * by 'node', which is of type ANYOF.  Handles complementing the result if
1575      * appropriate.  If some code points aren't knowable at this time, the
1576      * returned list must, and will, contain every code point that is a
1577      * possibility. */
1578
1579     dVAR;
1580     SV* invlist = NULL;
1581     SV* only_utf8_locale_invlist = NULL;
1582     unsigned int i;
1583     const U32 n = ARG(node);
1584     bool new_node_has_latin1 = FALSE;
1585     const U8 flags = OP(node) == ANYOFH ? 0 : ANYOF_FLAGS(node);
1586
1587     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1588
1589     /* Look at the data structure created by S_set_ANYOF_arg() */
1590     if (n != ANYOF_ONLY_HAS_BITMAP) {
1591         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1592         AV * const av = MUTABLE_AV(SvRV(rv));
1593         SV **const ary = AvARRAY(av);
1594         assert(RExC_rxi->data->what[n] == 's');
1595
1596         if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
1597
1598             /* Here there are things that won't be known until runtime -- we
1599              * have to assume it could be anything */
1600             invlist = sv_2mortal(_new_invlist(1));
1601             return _add_range_to_invlist(invlist, 0, UV_MAX);
1602         }
1603         else if (ary[INVLIST_INDEX]) {
1604
1605             /* Use the node's inversion list */
1606             invlist = sv_2mortal(invlist_clone(ary[INVLIST_INDEX], NULL));
1607         }
1608
1609         /* Get the code points valid only under UTF-8 locales */
1610         if (   (flags & ANYOFL_FOLD)
1611             &&  av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX)
1612         {
1613             only_utf8_locale_invlist = ary[ONLY_LOCALE_MATCHES_INDEX];
1614         }
1615     }
1616
1617     if (! invlist) {
1618         invlist = sv_2mortal(_new_invlist(0));
1619     }
1620
1621     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1622      * code points, and an inversion list for the others, but if there are code
1623      * points that should match only conditionally on the target string being
1624      * UTF-8, those are placed in the inversion list, and not the bitmap.
1625      * Since there are circumstances under which they could match, they are
1626      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1627      * to exclude them here, so that when we invert below, the end result
1628      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1629      * have to do this here before we add the unconditionally matched code
1630      * points */
1631     if (flags & ANYOF_INVERT) {
1632         _invlist_intersection_complement_2nd(invlist,
1633                                              PL_UpperLatin1,
1634                                              &invlist);
1635     }
1636
1637     /* Add in the points from the bit map */
1638     if (OP(node) != ANYOFH) {
1639         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1640             if (ANYOF_BITMAP_TEST(node, i)) {
1641                 unsigned int start = i++;
1642
1643                 for (;    i < NUM_ANYOF_CODE_POINTS
1644                        && ANYOF_BITMAP_TEST(node, i); ++i)
1645                 {
1646                     /* empty */
1647                 }
1648                 invlist = _add_range_to_invlist(invlist, start, i-1);
1649                 new_node_has_latin1 = TRUE;
1650             }
1651         }
1652     }
1653
1654     /* If this can match all upper Latin1 code points, have to add them
1655      * as well.  But don't add them if inverting, as when that gets done below,
1656      * it would exclude all these characters, including the ones it shouldn't
1657      * that were added just above */
1658     if (! (flags & ANYOF_INVERT) && OP(node) == ANYOFD
1659         && (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1660     {
1661         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1662     }
1663
1664     /* Similarly for these */
1665     if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1666         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1667     }
1668
1669     if (flags & ANYOF_INVERT) {
1670         _invlist_invert(invlist);
1671     }
1672     else if (flags & ANYOFL_FOLD) {
1673         if (new_node_has_latin1) {
1674
1675             /* Under /li, any 0-255 could fold to any other 0-255, depending on
1676              * the locale.  We can skip this if there are no 0-255 at all. */
1677             _invlist_union(invlist, PL_Latin1, &invlist);
1678
1679             invlist = add_cp_to_invlist(invlist, LATIN_SMALL_LETTER_DOTLESS_I);
1680             invlist = add_cp_to_invlist(invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
1681         }
1682         else {
1683             if (_invlist_contains_cp(invlist, LATIN_SMALL_LETTER_DOTLESS_I)) {
1684                 invlist = add_cp_to_invlist(invlist, 'I');
1685             }
1686             if (_invlist_contains_cp(invlist,
1687                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE))
1688             {
1689                 invlist = add_cp_to_invlist(invlist, 'i');
1690             }
1691         }
1692     }
1693
1694     /* Similarly add the UTF-8 locale possible matches.  These have to be
1695      * deferred until after the non-UTF-8 locale ones are taken care of just
1696      * above, or it leads to wrong results under ANYOF_INVERT */
1697     if (only_utf8_locale_invlist) {
1698         _invlist_union_maybe_complement_2nd(invlist,
1699                                             only_utf8_locale_invlist,
1700                                             flags & ANYOF_INVERT,
1701                                             &invlist);
1702     }
1703
1704     return invlist;
1705 }
1706
1707 /* These two functions currently do the exact same thing */
1708 #define ssc_init_zero           ssc_init
1709
1710 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1711 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1712
1713 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1714  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1715  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1716
1717 STATIC void
1718 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1719                 const regnode_charclass *and_with)
1720 {
1721     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1722      * another SSC or a regular ANYOF class.  Can create false positives. */
1723
1724     SV* anded_cp_list;
1725     U8  and_with_flags = (OP(and_with) == ANYOFH) ? 0 : ANYOF_FLAGS(and_with);
1726     U8  anded_flags;
1727
1728     PERL_ARGS_ASSERT_SSC_AND;
1729
1730     assert(is_ANYOF_SYNTHETIC(ssc));
1731
1732     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1733      * the code point inversion list and just the relevant flags */
1734     if (is_ANYOF_SYNTHETIC(and_with)) {
1735         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1736         anded_flags = and_with_flags;
1737
1738         /* XXX This is a kludge around what appears to be deficiencies in the
1739          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1740          * there are paths through the optimizer where it doesn't get weeded
1741          * out when it should.  And if we don't make some extra provision for
1742          * it like the code just below, it doesn't get added when it should.
1743          * This solution is to add it only when AND'ing, which is here, and
1744          * only when what is being AND'ed is the pristine, original node
1745          * matching anything.  Thus it is like adding it to ssc_anything() but
1746          * only when the result is to be AND'ed.  Probably the same solution
1747          * could be adopted for the same problem we have with /l matching,
1748          * which is solved differently in S_ssc_init(), and that would lead to
1749          * fewer false positives than that solution has.  But if this solution
1750          * creates bugs, the consequences are only that a warning isn't raised
1751          * that should be; while the consequences for having /l bugs is
1752          * incorrect matches */
1753         if (ssc_is_anything((regnode_ssc *)and_with)) {
1754             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1755         }
1756     }
1757     else {
1758         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1759         if (OP(and_with) == ANYOFD) {
1760             anded_flags = and_with_flags & ANYOF_COMMON_FLAGS;
1761         }
1762         else {
1763             anded_flags = and_with_flags
1764             &( ANYOF_COMMON_FLAGS
1765               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1766               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1767             if (ANYOFL_UTF8_LOCALE_REQD(and_with_flags)) {
1768                 anded_flags &=
1769                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1770             }
1771         }
1772     }
1773
1774     ANYOF_FLAGS(ssc) &= anded_flags;
1775
1776     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1777      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1778      * 'and_with' may be inverted.  When not inverted, we have the situation of
1779      * computing:
1780      *  (C1 | P1) & (C2 | P2)
1781      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1782      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1783      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1784      *                    <=  ((C1 & C2) | P1 | P2)
1785      * Alternatively, the last few steps could be:
1786      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1787      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1788      *                    <=  (C1 | C2 | (P1 & P2))
1789      * We favor the second approach if either P1 or P2 is non-empty.  This is
1790      * because these components are a barrier to doing optimizations, as what
1791      * they match cannot be known until the moment of matching as they are
1792      * dependent on the current locale, 'AND"ing them likely will reduce or
1793      * eliminate them.
1794      * But we can do better if we know that C1,P1 are in their initial state (a
1795      * frequent occurrence), each matching everything:
1796      *  (<everything>) & (C2 | P2) =  C2 | P2
1797      * Similarly, if C2,P2 are in their initial state (again a frequent
1798      * occurrence), the result is a no-op
1799      *  (C1 | P1) & (<everything>) =  C1 | P1
1800      *
1801      * Inverted, we have
1802      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1803      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1804      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1805      * */
1806
1807     if ((and_with_flags & ANYOF_INVERT)
1808         && ! is_ANYOF_SYNTHETIC(and_with))
1809     {
1810         unsigned int i;
1811
1812         ssc_intersection(ssc,
1813                          anded_cp_list,
1814                          FALSE /* Has already been inverted */
1815                          );
1816
1817         /* If either P1 or P2 is empty, the intersection will be also; can skip
1818          * the loop */
1819         if (! (and_with_flags & ANYOF_MATCHES_POSIXL)) {
1820             ANYOF_POSIXL_ZERO(ssc);
1821         }
1822         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1823
1824             /* Note that the Posix class component P from 'and_with' actually
1825              * looks like:
1826              *      P = Pa | Pb | ... | Pn
1827              * where each component is one posix class, such as in [\w\s].
1828              * Thus
1829              *      ~P = ~(Pa | Pb | ... | Pn)
1830              *         = ~Pa & ~Pb & ... & ~Pn
1831              *        <= ~Pa | ~Pb | ... | ~Pn
1832              * The last is something we can easily calculate, but unfortunately
1833              * is likely to have many false positives.  We could do better
1834              * in some (but certainly not all) instances if two classes in
1835              * P have known relationships.  For example
1836              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1837              * So
1838              *      :lower: & :print: = :lower:
1839              * And similarly for classes that must be disjoint.  For example,
1840              * since \s and \w can have no elements in common based on rules in
1841              * the POSIX standard,
1842              *      \w & ^\S = nothing
1843              * Unfortunately, some vendor locales do not meet the Posix
1844              * standard, in particular almost everything by Microsoft.
1845              * The loop below just changes e.g., \w into \W and vice versa */
1846
1847             regnode_charclass_posixl temp;
1848             int add = 1;    /* To calculate the index of the complement */
1849
1850             Zero(&temp, 1, regnode_charclass_posixl);
1851             ANYOF_POSIXL_ZERO(&temp);
1852             for (i = 0; i < ANYOF_MAX; i++) {
1853                 assert(i % 2 != 0
1854                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1855                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1856
1857                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1858                     ANYOF_POSIXL_SET(&temp, i + add);
1859                 }
1860                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1861             }
1862             ANYOF_POSIXL_AND(&temp, ssc);
1863
1864         } /* else ssc already has no posixes */
1865     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1866          in its initial state */
1867     else if (! is_ANYOF_SYNTHETIC(and_with)
1868              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1869     {
1870         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1871          * copy it over 'ssc' */
1872         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1873             if (is_ANYOF_SYNTHETIC(and_with)) {
1874                 StructCopy(and_with, ssc, regnode_ssc);
1875             }
1876             else {
1877                 ssc->invlist = anded_cp_list;
1878                 ANYOF_POSIXL_ZERO(ssc);
1879                 if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1880                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1881                 }
1882             }
1883         }
1884         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1885                  || (and_with_flags & ANYOF_MATCHES_POSIXL))
1886         {
1887             /* One or the other of P1, P2 is non-empty. */
1888             if (and_with_flags & ANYOF_MATCHES_POSIXL) {
1889                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1890             }
1891             ssc_union(ssc, anded_cp_list, FALSE);
1892         }
1893         else { /* P1 = P2 = empty */
1894             ssc_intersection(ssc, anded_cp_list, FALSE);
1895         }
1896     }
1897 }
1898
1899 STATIC void
1900 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1901                const regnode_charclass *or_with)
1902 {
1903     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1904      * another SSC or a regular ANYOF class.  Can create false positives if
1905      * 'or_with' is to be inverted. */
1906
1907     SV* ored_cp_list;
1908     U8 ored_flags;
1909     U8  or_with_flags = (OP(or_with) == ANYOFH) ? 0 : ANYOF_FLAGS(or_with);
1910
1911     PERL_ARGS_ASSERT_SSC_OR;
1912
1913     assert(is_ANYOF_SYNTHETIC(ssc));
1914
1915     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1916      * the code point inversion list and just the relevant flags */
1917     if (is_ANYOF_SYNTHETIC(or_with)) {
1918         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1919         ored_flags = or_with_flags;
1920     }
1921     else {
1922         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1923         ored_flags = or_with_flags & ANYOF_COMMON_FLAGS;
1924         if (OP(or_with) != ANYOFD) {
1925             ored_flags
1926             |= or_with_flags
1927              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1928                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1929             if (ANYOFL_UTF8_LOCALE_REQD(or_with_flags)) {
1930                 ored_flags |=
1931                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1932             }
1933         }
1934     }
1935
1936     ANYOF_FLAGS(ssc) |= ored_flags;
1937
1938     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1939      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1940      * 'or_with' may be inverted.  When not inverted, we have the simple
1941      * situation of computing:
1942      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1943      * If P1|P2 yields a situation with both a class and its complement are
1944      * set, like having both \w and \W, this matches all code points, and we
1945      * can delete these from the P component of the ssc going forward.  XXX We
1946      * might be able to delete all the P components, but I (khw) am not certain
1947      * about this, and it is better to be safe.
1948      *
1949      * Inverted, we have
1950      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1951      *                         <=  (C1 | P1) | ~C2
1952      *                         <=  (C1 | ~C2) | P1
1953      * (which results in actually simpler code than the non-inverted case)
1954      * */
1955
1956     if ((or_with_flags & ANYOF_INVERT)
1957         && ! is_ANYOF_SYNTHETIC(or_with))
1958     {
1959         /* We ignore P2, leaving P1 going forward */
1960     }   /* else  Not inverted */
1961     else if (or_with_flags & ANYOF_MATCHES_POSIXL) {
1962         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1963         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1964             unsigned int i;
1965             for (i = 0; i < ANYOF_MAX; i += 2) {
1966                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1967                 {
1968                     ssc_match_all_cp(ssc);
1969                     ANYOF_POSIXL_CLEAR(ssc, i);
1970                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1971                 }
1972             }
1973         }
1974     }
1975
1976     ssc_union(ssc,
1977               ored_cp_list,
1978               FALSE /* Already has been inverted */
1979               );
1980 }
1981
1982 PERL_STATIC_INLINE void
1983 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1984 {
1985     PERL_ARGS_ASSERT_SSC_UNION;
1986
1987     assert(is_ANYOF_SYNTHETIC(ssc));
1988
1989     _invlist_union_maybe_complement_2nd(ssc->invlist,
1990                                         invlist,
1991                                         invert2nd,
1992                                         &ssc->invlist);
1993 }
1994
1995 PERL_STATIC_INLINE void
1996 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1997                          SV* const invlist,
1998                          const bool invert2nd)
1999 {
2000     PERL_ARGS_ASSERT_SSC_INTERSECTION;
2001
2002     assert(is_ANYOF_SYNTHETIC(ssc));
2003
2004     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
2005                                                invlist,
2006                                                invert2nd,
2007                                                &ssc->invlist);
2008 }
2009
2010 PERL_STATIC_INLINE void
2011 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
2012 {
2013     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
2014
2015     assert(is_ANYOF_SYNTHETIC(ssc));
2016
2017     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
2018 }
2019
2020 PERL_STATIC_INLINE void
2021 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
2022 {
2023     /* AND just the single code point 'cp' into the SSC 'ssc' */
2024
2025     SV* cp_list = _new_invlist(2);
2026
2027     PERL_ARGS_ASSERT_SSC_CP_AND;
2028
2029     assert(is_ANYOF_SYNTHETIC(ssc));
2030
2031     cp_list = add_cp_to_invlist(cp_list, cp);
2032     ssc_intersection(ssc, cp_list,
2033                      FALSE /* Not inverted */
2034                      );
2035     SvREFCNT_dec_NN(cp_list);
2036 }
2037
2038 PERL_STATIC_INLINE void
2039 S_ssc_clear_locale(regnode_ssc *ssc)
2040 {
2041     /* Set the SSC 'ssc' to not match any locale things */
2042     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
2043
2044     assert(is_ANYOF_SYNTHETIC(ssc));
2045
2046     ANYOF_POSIXL_ZERO(ssc);
2047     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
2048 }
2049
2050 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
2051
2052 STATIC bool
2053 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
2054 {
2055     /* The synthetic start class is used to hopefully quickly winnow down
2056      * places where a pattern could start a match in the target string.  If it
2057      * doesn't really narrow things down that much, there isn't much point to
2058      * having the overhead of using it.  This function uses some very crude
2059      * heuristics to decide if to use the ssc or not.
2060      *
2061      * It returns TRUE if 'ssc' rules out more than half what it considers to
2062      * be the "likely" possible matches, but of course it doesn't know what the
2063      * actual things being matched are going to be; these are only guesses
2064      *
2065      * For /l matches, it assumes that the only likely matches are going to be
2066      *      in the 0-255 range, uniformly distributed, so half of that is 127
2067      * For /a and /d matches, it assumes that the likely matches will be just
2068      *      the ASCII range, so half of that is 63
2069      * For /u and there isn't anything matching above the Latin1 range, it
2070      *      assumes that that is the only range likely to be matched, and uses
2071      *      half that as the cut-off: 127.  If anything matches above Latin1,
2072      *      it assumes that all of Unicode could match (uniformly), except for
2073      *      non-Unicode code points and things in the General Category "Other"
2074      *      (unassigned, private use, surrogates, controls and formats).  This
2075      *      is a much large number. */
2076
2077     U32 count = 0;      /* Running total of number of code points matched by
2078                            'ssc' */
2079     UV start, end;      /* Start and end points of current range in inversion
2080                            XXX outdated.  UTF-8 locales are common, what about invert? list */
2081     const U32 max_code_points = (LOC)
2082                                 ?  256
2083                                 : ((  ! UNI_SEMANTICS
2084                                     ||  invlist_highest(ssc->invlist) < 256)
2085                                   ? 128
2086                                   : NON_OTHER_COUNT);
2087     const U32 max_match = max_code_points / 2;
2088
2089     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
2090
2091     invlist_iterinit(ssc->invlist);
2092     while (invlist_iternext(ssc->invlist, &start, &end)) {
2093         if (start >= max_code_points) {
2094             break;
2095         }
2096         end = MIN(end, max_code_points - 1);
2097         count += end - start + 1;
2098         if (count >= max_match) {
2099             invlist_iterfinish(ssc->invlist);
2100             return FALSE;
2101         }
2102     }
2103
2104     return TRUE;
2105 }
2106
2107
2108 STATIC void
2109 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
2110 {
2111     /* The inversion list in the SSC is marked mortal; now we need a more
2112      * permanent copy, which is stored the same way that is done in a regular
2113      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
2114      * map */
2115
2116     SV* invlist = invlist_clone(ssc->invlist, NULL);
2117
2118     PERL_ARGS_ASSERT_SSC_FINALIZE;
2119
2120     assert(is_ANYOF_SYNTHETIC(ssc));
2121
2122     /* The code in this file assumes that all but these flags aren't relevant
2123      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
2124      * by the time we reach here */
2125     assert(! (ANYOF_FLAGS(ssc)
2126         & ~( ANYOF_COMMON_FLAGS
2127             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
2128             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
2129
2130     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
2131
2132     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist, NULL, NULL);
2133
2134     /* Make sure is clone-safe */
2135     ssc->invlist = NULL;
2136
2137     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
2138         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
2139         OP(ssc) = ANYOFPOSIXL;
2140     }
2141     else if (RExC_contains_locale) {
2142         OP(ssc) = ANYOFL;
2143     }
2144
2145     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
2146 }
2147
2148 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
2149 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
2150 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
2151 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
2152                                ? (TRIE_LIST_CUR( idx ) - 1)           \
2153                                : 0 )
2154
2155
2156 #ifdef DEBUGGING
2157 /*
2158    dump_trie(trie,widecharmap,revcharmap)
2159    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
2160    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
2161
2162    These routines dump out a trie in a somewhat readable format.
2163    The _interim_ variants are used for debugging the interim
2164    tables that are used to generate the final compressed
2165    representation which is what dump_trie expects.
2166
2167    Part of the reason for their existence is to provide a form
2168    of documentation as to how the different representations function.
2169
2170 */
2171
2172 /*
2173   Dumps the final compressed table form of the trie to Perl_debug_log.
2174   Used for debugging make_trie().
2175 */
2176
2177 STATIC void
2178 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
2179             AV *revcharmap, U32 depth)
2180 {
2181     U32 state;
2182     SV *sv=sv_newmortal();
2183     int colwidth= widecharmap ? 6 : 4;
2184     U16 word;
2185     GET_RE_DEBUG_FLAGS_DECL;
2186
2187     PERL_ARGS_ASSERT_DUMP_TRIE;
2188
2189     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
2190         depth+1, "Match","Base","Ofs" );
2191
2192     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
2193         SV ** const tmp = av_fetch( revcharmap, state, 0);
2194         if ( tmp ) {
2195             Perl_re_printf( aTHX_  "%*s",
2196                 colwidth,
2197                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2198                             PL_colors[0], PL_colors[1],
2199                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2200                             PERL_PV_ESCAPE_FIRSTCHAR
2201                 )
2202             );
2203         }
2204     }
2205     Perl_re_printf( aTHX_  "\n");
2206     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2207
2208     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2209         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2210     Perl_re_printf( aTHX_  "\n");
2211
2212     for( state = 1 ; state < trie->statecount ; state++ ) {
2213         const U32 base = trie->states[ state ].trans.base;
2214
2215         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2216
2217         if ( trie->states[ state ].wordnum ) {
2218             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2219         } else {
2220             Perl_re_printf( aTHX_  "%6s", "" );
2221         }
2222
2223         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2224
2225         if ( base ) {
2226             U32 ofs = 0;
2227
2228             while( ( base + ofs  < trie->uniquecharcount ) ||
2229                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2230                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2231                                                                     != state))
2232                     ofs++;
2233
2234             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2235
2236             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2237                 if ( ( base + ofs >= trie->uniquecharcount )
2238                         && ( base + ofs - trie->uniquecharcount
2239                                                         < trie->lasttrans )
2240                         && trie->trans[ base + ofs
2241                                     - trie->uniquecharcount ].check == state )
2242                 {
2243                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2244                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2245                    );
2246                 } else {
2247                     Perl_re_printf( aTHX_  "%*s", colwidth,"   ." );
2248                 }
2249             }
2250
2251             Perl_re_printf( aTHX_  "]");
2252
2253         }
2254         Perl_re_printf( aTHX_  "\n" );
2255     }
2256     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2257                                 depth);
2258     for (word=1; word <= trie->wordcount; word++) {
2259         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2260             (int)word, (int)(trie->wordinfo[word].prev),
2261             (int)(trie->wordinfo[word].len));
2262     }
2263     Perl_re_printf( aTHX_  "\n" );
2264 }
2265 /*
2266   Dumps a fully constructed but uncompressed trie in list form.
2267   List tries normally only are used for construction when the number of
2268   possible chars (trie->uniquecharcount) is very high.
2269   Used for debugging make_trie().
2270 */
2271 STATIC void
2272 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2273                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2274                          U32 depth)
2275 {
2276     U32 state;
2277     SV *sv=sv_newmortal();
2278     int colwidth= widecharmap ? 6 : 4;
2279     GET_RE_DEBUG_FLAGS_DECL;
2280
2281     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2282
2283     /* print out the table precompression.  */
2284     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2285             depth+1 );
2286     Perl_re_indentf( aTHX_  "%s",
2287             depth+1, "------:-----+-----------------\n" );
2288
2289     for( state=1 ; state < next_alloc ; state ++ ) {
2290         U16 charid;
2291
2292         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2293             depth+1, (UV)state  );
2294         if ( ! trie->states[ state ].wordnum ) {
2295             Perl_re_printf( aTHX_  "%5s| ","");
2296         } else {
2297             Perl_re_printf( aTHX_  "W%4x| ",
2298                 trie->states[ state ].wordnum
2299             );
2300         }
2301         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2302             SV ** const tmp = av_fetch( revcharmap,
2303                                         TRIE_LIST_ITEM(state, charid).forid, 0);
2304             if ( tmp ) {
2305                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2306                     colwidth,
2307                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2308                               colwidth,
2309                               PL_colors[0], PL_colors[1],
2310                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2311                               | PERL_PV_ESCAPE_FIRSTCHAR
2312                     ) ,
2313                     TRIE_LIST_ITEM(state, charid).forid,
2314                     (UV)TRIE_LIST_ITEM(state, charid).newstate
2315                 );
2316                 if (!(charid % 10))
2317                     Perl_re_printf( aTHX_  "\n%*s| ",
2318                         (int)((depth * 2) + 14), "");
2319             }
2320         }
2321         Perl_re_printf( aTHX_  "\n");
2322     }
2323 }
2324
2325 /*
2326   Dumps a fully constructed but uncompressed trie in table form.
2327   This is the normal DFA style state transition table, with a few
2328   twists to facilitate compression later.
2329   Used for debugging make_trie().
2330 */
2331 STATIC void
2332 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2333                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2334                           U32 depth)
2335 {
2336     U32 state;
2337     U16 charid;
2338     SV *sv=sv_newmortal();
2339     int colwidth= widecharmap ? 6 : 4;
2340     GET_RE_DEBUG_FLAGS_DECL;
2341
2342     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2343
2344     /*
2345        print out the table precompression so that we can do a visual check
2346        that they are identical.
2347      */
2348
2349     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2350
2351     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2352         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2353         if ( tmp ) {
2354             Perl_re_printf( aTHX_  "%*s",
2355                 colwidth,
2356                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2357                             PL_colors[0], PL_colors[1],
2358                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2359                             PERL_PV_ESCAPE_FIRSTCHAR
2360                 )
2361             );
2362         }
2363     }
2364
2365     Perl_re_printf( aTHX_ "\n");
2366     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2367
2368     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2369         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2370     }
2371
2372     Perl_re_printf( aTHX_  "\n" );
2373
2374     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2375
2376         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2377             depth+1,
2378             (UV)TRIE_NODENUM( state ) );
2379
2380         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2381             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2382             if (v)
2383                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2384             else
2385                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2386         }
2387         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2388             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2389                                             (UV)trie->trans[ state ].check );
2390         } else {
2391             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2392                                             (UV)trie->trans[ state ].check,
2393             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2394         }
2395     }
2396 }
2397
2398 #endif
2399
2400
2401 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2402   startbranch: the first branch in the whole branch sequence
2403   first      : start branch of sequence of branch-exact nodes.
2404                May be the same as startbranch
2405   last       : Thing following the last branch.
2406                May be the same as tail.
2407   tail       : item following the branch sequence
2408   count      : words in the sequence
2409   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2410   depth      : indent depth
2411
2412 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2413
2414 A trie is an N'ary tree where the branches are determined by digital
2415 decomposition of the key. IE, at the root node you look up the 1st character and
2416 follow that branch repeat until you find the end of the branches. Nodes can be
2417 marked as "accepting" meaning they represent a complete word. Eg:
2418
2419   /he|she|his|hers/
2420
2421 would convert into the following structure. Numbers represent states, letters
2422 following numbers represent valid transitions on the letter from that state, if
2423 the number is in square brackets it represents an accepting state, otherwise it
2424 will be in parenthesis.
2425
2426       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2427       |    |
2428       |   (2)
2429       |    |
2430      (1)   +-i->(6)-+-s->[7]
2431       |
2432       +-s->(3)-+-h->(4)-+-e->[5]
2433
2434       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2435
2436 This shows that when matching against the string 'hers' we will begin at state 1
2437 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2438 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2439 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2440 single traverse. We store a mapping from accepting to state to which word was
2441 matched, and then when we have multiple possibilities we try to complete the
2442 rest of the regex in the order in which they occurred in the alternation.
2443
2444 The only prior NFA like behaviour that would be changed by the TRIE support is
2445 the silent ignoring of duplicate alternations which are of the form:
2446
2447  / (DUPE|DUPE) X? (?{ ... }) Y /x
2448
2449 Thus EVAL blocks following a trie may be called a different number of times with
2450 and without the optimisation. With the optimisations dupes will be silently
2451 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2452 the following demonstrates:
2453
2454  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2455
2456 which prints out 'word' three times, but
2457
2458  'words'=~/(word|word|word)(?{ print $1 })S/
2459
2460 which doesnt print it out at all. This is due to other optimisations kicking in.
2461
2462 Example of what happens on a structural level:
2463
2464 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2465
2466    1: CURLYM[1] {1,32767}(18)
2467    5:   BRANCH(8)
2468    6:     EXACT <ac>(16)
2469    8:   BRANCH(11)
2470    9:     EXACT <ad>(16)
2471   11:   BRANCH(14)
2472   12:     EXACT <ab>(16)
2473   16:   SUCCEED(0)
2474   17:   NOTHING(18)
2475   18: END(0)
2476
2477 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2478 and should turn into:
2479
2480    1: CURLYM[1] {1,32767}(18)
2481    5:   TRIE(16)
2482         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2483           <ac>
2484           <ad>
2485           <ab>
2486   16:   SUCCEED(0)
2487   17:   NOTHING(18)
2488   18: END(0)
2489
2490 Cases where tail != last would be like /(?foo|bar)baz/:
2491
2492    1: BRANCH(4)
2493    2:   EXACT <foo>(8)
2494    4: BRANCH(7)
2495    5:   EXACT <bar>(8)
2496    7: TAIL(8)
2497    8: EXACT <baz>(10)
2498   10: END(0)
2499
2500 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2501 and would end up looking like:
2502
2503     1: TRIE(8)
2504       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2505         <foo>
2506         <bar>
2507    7: TAIL(8)
2508    8: EXACT <baz>(10)
2509   10: END(0)
2510
2511     d = uvchr_to_utf8_flags(d, uv, 0);
2512
2513 is the recommended Unicode-aware way of saying
2514
2515     *(d++) = uv;
2516 */
2517
2518 #define TRIE_STORE_REVCHAR(val)                                            \
2519     STMT_START {                                                           \
2520         if (UTF) {                                                         \
2521             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2522             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2523             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2524             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2525             SvPOK_on(zlopp);                                               \
2526             SvUTF8_on(zlopp);                                              \
2527             av_push(revcharmap, zlopp);                                    \
2528         } else {                                                           \
2529             char ooooff = (char)val;                                           \
2530             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2531         }                                                                  \
2532         } STMT_END
2533
2534 /* This gets the next character from the input, folding it if not already
2535  * folded. */
2536 #define TRIE_READ_CHAR STMT_START {                                           \
2537     wordlen++;                                                                \
2538     if ( UTF ) {                                                              \
2539         /* if it is UTF then it is either already folded, or does not need    \
2540          * folding */                                                         \
2541         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2542     }                                                                         \
2543     else if (folder == PL_fold_latin1) {                                      \
2544         /* This folder implies Unicode rules, which in the range expressible  \
2545          *  by not UTF is the lower case, with the two exceptions, one of     \
2546          *  which should have been taken care of before calling this */       \
2547         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2548         uvc = toLOWER_L1(*uc);                                                \
2549         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2550         len = 1;                                                              \
2551     } else {                                                                  \
2552         /* raw data, will be folded later if needed */                        \
2553         uvc = (U32)*uc;                                                       \
2554         len = 1;                                                              \
2555     }                                                                         \
2556 } STMT_END
2557
2558
2559
2560 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2561     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2562         U32 ging = TRIE_LIST_LEN( state ) * 2;                  \
2563         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2564         TRIE_LIST_LEN( state ) = ging;                          \
2565     }                                                           \
2566     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2567     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2568     TRIE_LIST_CUR( state )++;                                   \
2569 } STMT_END
2570
2571 #define TRIE_LIST_NEW(state) STMT_START {                       \
2572     Newx( trie->states[ state ].trans.list,                     \
2573         4, reg_trie_trans_le );                                 \
2574      TRIE_LIST_CUR( state ) = 1;                                \
2575      TRIE_LIST_LEN( state ) = 4;                                \
2576 } STMT_END
2577
2578 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2579     U16 dupe= trie->states[ state ].wordnum;                    \
2580     regnode * const noper_next = regnext( noper );              \
2581                                                                 \
2582     DEBUG_r({                                                   \
2583         /* store the word for dumping */                        \
2584         SV* tmp;                                                \
2585         if (OP(noper) != NOTHING)                               \
2586             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2587         else                                                    \
2588             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2589         av_push( trie_words, tmp );                             \
2590     });                                                         \
2591                                                                 \
2592     curword++;                                                  \
2593     trie->wordinfo[curword].prev   = 0;                         \
2594     trie->wordinfo[curword].len    = wordlen;                   \
2595     trie->wordinfo[curword].accept = state;                     \
2596                                                                 \
2597     if ( noper_next < tail ) {                                  \
2598         if (!trie->jump)                                        \
2599             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2600                                                  sizeof(U16) ); \
2601         trie->jump[curword] = (U16)(noper_next - convert);      \
2602         if (!jumper)                                            \
2603             jumper = noper_next;                                \
2604         if (!nextbranch)                                        \
2605             nextbranch= regnext(cur);                           \
2606     }                                                           \
2607                                                                 \
2608     if ( dupe ) {                                               \
2609         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2610         /* chain, so that when the bits of chain are later    */\
2611         /* linked together, the dups appear in the chain      */\
2612         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2613         trie->wordinfo[dupe].prev = curword;                    \
2614     } else {                                                    \
2615         /* we haven't inserted this word yet.                */ \
2616         trie->states[ state ].wordnum = curword;                \
2617     }                                                           \
2618 } STMT_END
2619
2620
2621 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2622      ( ( base + charid >=  ucharcount                                   \
2623          && base + charid < ubound                                      \
2624          && state == trie->trans[ base - ucharcount + charid ].check    \
2625          && trie->trans[ base - ucharcount + charid ].next )            \
2626            ? trie->trans[ base - ucharcount + charid ].next             \
2627            : ( state==1 ? special : 0 )                                 \
2628       )
2629
2630 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2631 STMT_START {                                                \
2632     TRIE_BITMAP_SET(trie, uvc);                             \
2633     /* store the folded codepoint */                        \
2634     if ( folder )                                           \
2635         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2636                                                             \
2637     if ( !UTF ) {                                           \
2638         /* store first byte of utf8 representation of */    \
2639         /* variant codepoints */                            \
2640         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2641             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2642         }                                                   \
2643     }                                                       \
2644 } STMT_END
2645 #define MADE_TRIE       1
2646 #define MADE_JUMP_TRIE  2
2647 #define MADE_EXACT_TRIE 4
2648
2649 STATIC I32
2650 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2651                   regnode *first, regnode *last, regnode *tail,
2652                   U32 word_count, U32 flags, U32 depth)
2653 {
2654     /* first pass, loop through and scan words */
2655     reg_trie_data *trie;
2656     HV *widecharmap = NULL;
2657     AV *revcharmap = newAV();
2658     regnode *cur;
2659     STRLEN len = 0;
2660     UV uvc = 0;
2661     U16 curword = 0;
2662     U32 next_alloc = 0;
2663     regnode *jumper = NULL;
2664     regnode *nextbranch = NULL;
2665     regnode *convert = NULL;
2666     U32 *prev_states; /* temp array mapping each state to previous one */
2667     /* we just use folder as a flag in utf8 */
2668     const U8 * folder = NULL;
2669
2670     /* in the below add_data call we are storing either 'tu' or 'tuaa'
2671      * which stands for one trie structure, one hash, optionally followed
2672      * by two arrays */
2673 #ifdef DEBUGGING
2674     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuaa"));
2675     AV *trie_words = NULL;
2676     /* along with revcharmap, this only used during construction but both are
2677      * useful during debugging so we store them in the struct when debugging.
2678      */
2679 #else
2680     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2681     STRLEN trie_charcount=0;
2682 #endif
2683     SV *re_trie_maxbuff;
2684     GET_RE_DEBUG_FLAGS_DECL;
2685
2686     PERL_ARGS_ASSERT_MAKE_TRIE;
2687 #ifndef DEBUGGING
2688     PERL_UNUSED_ARG(depth);
2689 #endif
2690
2691     switch (flags) {
2692         case EXACT: case EXACT_ONLY8: case EXACTL: break;
2693         case EXACTFAA:
2694         case EXACTFUP:
2695         case EXACTFU:
2696         case EXACTFLU8: folder = PL_fold_latin1; break;
2697         case EXACTF:  folder = PL_fold; break;
2698         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2699     }
2700
2701     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2702     trie->refcount = 1;
2703     trie->startstate = 1;
2704     trie->wordcount = word_count;
2705     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2706     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2707     if (flags == EXACT || flags == EXACT_ONLY8 || flags == EXACTL)
2708         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2709     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2710                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2711
2712     DEBUG_r({
2713         trie_words = newAV();
2714     });
2715
2716     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, GV_ADD);
2717     assert(re_trie_maxbuff);
2718     if (!SvIOK(re_trie_maxbuff)) {
2719         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2720     }
2721     DEBUG_TRIE_COMPILE_r({
2722         Perl_re_indentf( aTHX_
2723           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2724           depth+1,
2725           REG_NODE_NUM(startbranch), REG_NODE_NUM(first),
2726           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2727     });
2728
2729    /* Find the node we are going to overwrite */
2730     if ( first == startbranch && OP( last ) != BRANCH ) {
2731         /* whole branch chain */
2732         convert = first;
2733     } else {
2734         /* branch sub-chain */
2735         convert = NEXTOPER( first );
2736     }
2737
2738     /*  -- First loop and Setup --
2739
2740        We first traverse the branches and scan each word to determine if it
2741        contains widechars, and how many unique chars there are, this is
2742        important as we have to build a table with at least as many columns as we
2743        have unique chars.
2744
2745        We use an array of integers to represent the character codes 0..255
2746        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2747        the native representation of the character value as the key and IV's for
2748        the coded index.
2749
2750        *TODO* If we keep track of how many times each character is used we can
2751        remap the columns so that the table compression later on is more
2752        efficient in terms of memory by ensuring the most common value is in the
2753        middle and the least common are on the outside.  IMO this would be better
2754        than a most to least common mapping as theres a decent chance the most
2755        common letter will share a node with the least common, meaning the node
2756        will not be compressible. With a middle is most common approach the worst
2757        case is when we have the least common nodes twice.
2758
2759      */
2760
2761     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2762         regnode *noper = NEXTOPER( cur );
2763         const U8 *uc;
2764         const U8 *e;
2765         int foldlen = 0;
2766         U32 wordlen      = 0;         /* required init */
2767         STRLEN minchars = 0;
2768         STRLEN maxchars = 0;
2769         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2770                                                bitmap?*/
2771
2772         if (OP(noper) == NOTHING) {
2773             /* skip past a NOTHING at the start of an alternation
2774              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2775              */
2776             regnode *noper_next= regnext(noper);
2777             if (noper_next < tail)
2778                 noper= noper_next;
2779         }
2780
2781         if (    noper < tail
2782             && (    OP(noper) == flags
2783                 || (flags == EXACT && OP(noper) == EXACT_ONLY8)
2784                 || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
2785                                          || OP(noper) == EXACTFUP))))
2786         {
2787             uc= (U8*)STRING(noper);
2788             e= uc + STR_LEN(noper);
2789         } else {
2790             trie->minlen= 0;
2791             continue;
2792         }
2793
2794
2795         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2796             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2797                                           regardless of encoding */
2798             if (OP( noper ) == EXACTFUP) {
2799                 /* false positives are ok, so just set this */
2800                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2801             }
2802         }
2803
2804         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2805                                            branch */
2806             TRIE_CHARCOUNT(trie)++;
2807             TRIE_READ_CHAR;
2808
2809             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2810              * is in effect.  Under /i, this character can match itself, or
2811              * anything that folds to it.  If not under /i, it can match just
2812              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2813              * all fold to k, and all are single characters.   But some folds
2814              * expand to more than one character, so for example LATIN SMALL
2815              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2816              * the string beginning at 'uc' is 'ffi', it could be matched by
2817              * three characters, or just by the one ligature character. (It
2818              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2819              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2820              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2821              * match.)  The trie needs to know the minimum and maximum number
2822              * of characters that could match so that it can use size alone to
2823              * quickly reject many match attempts.  The max is simple: it is
2824              * the number of folded characters in this branch (since a fold is
2825              * never shorter than what folds to it. */
2826
2827             maxchars++;
2828
2829             /* And the min is equal to the max if not under /i (indicated by
2830              * 'folder' being NULL), or there are no multi-character folds.  If
2831              * there is a multi-character fold, the min is incremented just
2832              * once, for the character that folds to the sequence.  Each
2833              * character in the sequence needs to be added to the list below of
2834              * characters in the trie, but we count only the first towards the
2835              * min number of characters needed.  This is done through the
2836              * variable 'foldlen', which is returned by the macros that look
2837              * for these sequences as the number of bytes the sequence
2838              * occupies.  Each time through the loop, we decrement 'foldlen' by
2839              * how many bytes the current char occupies.  Only when it reaches
2840              * 0 do we increment 'minchars' or look for another multi-character
2841              * sequence. */
2842             if (folder == NULL) {
2843                 minchars++;
2844             }
2845             else if (foldlen > 0) {
2846                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2847             }
2848             else {
2849                 minchars++;
2850
2851                 /* See if *uc is the beginning of a multi-character fold.  If
2852                  * so, we decrement the length remaining to look at, to account
2853                  * for the current character this iteration.  (We can use 'uc'
2854                  * instead of the fold returned by TRIE_READ_CHAR because for
2855                  * non-UTF, the latin1_safe macro is smart enough to account
2856                  * for all the unfolded characters, and because for UTF, the
2857                  * string will already have been folded earlier in the
2858                  * compilation process */
2859                 if (UTF) {
2860                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2861                         foldlen -= UTF8SKIP(uc);
2862                     }
2863                 }
2864                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2865                     foldlen--;
2866                 }
2867             }
2868
2869             /* The current character (and any potential folds) should be added
2870              * to the possible matching characters for this position in this
2871              * branch */
2872             if ( uvc < 256 ) {
2873                 if ( folder ) {
2874                     U8 folded= folder[ (U8) uvc ];
2875                     if ( !trie->charmap[ folded ] ) {
2876                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2877                         TRIE_STORE_REVCHAR( folded );
2878                     }
2879                 }
2880                 if ( !trie->charmap[ uvc ] ) {
2881                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2882                     TRIE_STORE_REVCHAR( uvc );
2883                 }
2884                 if ( set_bit ) {
2885                     /* store the codepoint in the bitmap, and its folded
2886                      * equivalent. */
2887                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2888                     set_bit = 0; /* We've done our bit :-) */
2889                 }
2890             } else {
2891
2892                 /* XXX We could come up with the list of code points that fold
2893                  * to this using PL_utf8_foldclosures, except not for
2894                  * multi-char folds, as there may be multiple combinations
2895                  * there that could work, which needs to wait until runtime to
2896                  * resolve (The comment about LIGATURE FFI above is such an
2897                  * example */
2898
2899                 SV** svpp;
2900                 if ( !widecharmap )
2901                     widecharmap = newHV();
2902
2903                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2904
2905                 if ( !svpp )
2906                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2907
2908                 if ( !SvTRUE( *svpp ) ) {
2909                     sv_setiv( *svpp, ++trie->uniquecharcount );
2910                     TRIE_STORE_REVCHAR(uvc);
2911                 }
2912             }
2913         } /* end loop through characters in this branch of the trie */
2914
2915         /* We take the min and max for this branch and combine to find the min
2916          * and max for all branches processed so far */
2917         if( cur == first ) {
2918             trie->minlen = minchars;
2919             trie->maxlen = maxchars;
2920         } else if (minchars < trie->minlen) {
2921             trie->minlen = minchars;
2922         } else if (maxchars > trie->maxlen) {
2923             trie->maxlen = maxchars;
2924         }
2925     } /* end first pass */
2926     DEBUG_TRIE_COMPILE_r(
2927         Perl_re_indentf( aTHX_
2928                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2929                 depth+1,
2930                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2931                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2932                 (int)trie->minlen, (int)trie->maxlen )
2933     );
2934
2935     /*
2936         We now know what we are dealing with in terms of unique chars and
2937         string sizes so we can calculate how much memory a naive
2938         representation using a flat table  will take. If it's over a reasonable
2939         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2940         conservative but potentially much slower representation using an array
2941         of lists.
2942
2943         At the end we convert both representations into the same compressed
2944         form that will be used in regexec.c for matching with. The latter
2945         is a form that cannot be used to construct with but has memory
2946         properties similar to the list form and access properties similar
2947         to the table form making it both suitable for fast searches and
2948         small enough that its feasable to store for the duration of a program.
2949
2950         See the comment in the code where the compressed table is produced
2951         inplace from the flat tabe representation for an explanation of how
2952         the compression works.
2953
2954     */
2955
2956
2957     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2958     prev_states[1] = 0;
2959
2960     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2961                                                     > SvIV(re_trie_maxbuff) )
2962     {
2963         /*
2964             Second Pass -- Array Of Lists Representation
2965
2966             Each state will be represented by a list of charid:state records
2967             (reg_trie_trans_le) the first such element holds the CUR and LEN
2968             points of the allocated array. (See defines above).
2969
2970             We build the initial structure using the lists, and then convert
2971             it into the compressed table form which allows faster lookups
2972             (but cant be modified once converted).
2973         */
2974
2975         STRLEN transcount = 1;
2976
2977         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2978             depth+1));
2979
2980         trie->states = (reg_trie_state *)
2981             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2982                                   sizeof(reg_trie_state) );
2983         TRIE_LIST_NEW(1);
2984         next_alloc = 2;
2985
2986         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2987
2988             regnode *noper   = NEXTOPER( cur );
2989             U32 state        = 1;         /* required init */
2990             U16 charid       = 0;         /* sanity init */
2991             U32 wordlen      = 0;         /* required init */
2992
2993             if (OP(noper) == NOTHING) {
2994                 regnode *noper_next= regnext(noper);
2995                 if (noper_next < tail)
2996                     noper= noper_next;
2997             }
2998
2999             if (    noper < tail
3000                 && (    OP(noper) == flags
3001                     || (flags == EXACT && OP(noper) == EXACT_ONLY8)
3002                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
3003                                              || OP(noper) == EXACTFUP))))
3004             {
3005                 const U8 *uc= (U8*)STRING(noper);
3006                 const U8 *e= uc + STR_LEN(noper);
3007
3008                 for ( ; uc < e ; uc += len ) {
3009
3010                     TRIE_READ_CHAR;
3011
3012                     if ( uvc < 256 ) {
3013                         charid = trie->charmap[ uvc ];
3014                     } else {
3015                         SV** const svpp = hv_fetch( widecharmap,
3016                                                     (char*)&uvc,
3017                                                     sizeof( UV ),
3018                                                     0);
3019                         if ( !svpp ) {
3020                             charid = 0;
3021                         } else {
3022                             charid=(U16)SvIV( *svpp );
3023                         }
3024                     }
3025                     /* charid is now 0 if we dont know the char read, or
3026                      * nonzero if we do */
3027                     if ( charid ) {
3028
3029                         U16 check;
3030                         U32 newstate = 0;
3031
3032                         charid--;
3033                         if ( !trie->states[ state ].trans.list ) {
3034                             TRIE_LIST_NEW( state );
3035                         }
3036                         for ( check = 1;
3037                               check <= TRIE_LIST_USED( state );
3038                               check++ )
3039                         {
3040                             if ( TRIE_LIST_ITEM( state, check ).forid
3041                                                                     == charid )
3042                             {
3043                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
3044                                 break;
3045                             }
3046                         }
3047                         if ( ! newstate ) {
3048                             newstate = next_alloc++;
3049                             prev_states[newstate] = state;
3050                             TRIE_LIST_PUSH( state, charid, newstate );
3051                             transcount++;
3052                         }
3053                         state = newstate;
3054                     } else {
3055                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3056                     }
3057                 }
3058             }
3059             TRIE_HANDLE_WORD(state);
3060
3061         } /* end second pass */
3062
3063         /* next alloc is the NEXT state to be allocated */
3064         trie->statecount = next_alloc;
3065         trie->states = (reg_trie_state *)
3066             PerlMemShared_realloc( trie->states,
3067                                    next_alloc
3068                                    * sizeof(reg_trie_state) );
3069
3070         /* and now dump it out before we compress it */
3071         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
3072                                                          revcharmap, next_alloc,
3073                                                          depth+1)
3074         );
3075
3076         trie->trans = (reg_trie_trans *)
3077             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
3078         {
3079             U32 state;
3080             U32 tp = 0;
3081             U32 zp = 0;
3082
3083
3084             for( state=1 ; state < next_alloc ; state ++ ) {
3085                 U32 base=0;
3086
3087                 /*
3088                 DEBUG_TRIE_COMPILE_MORE_r(
3089                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
3090                 );
3091                 */
3092
3093                 if (trie->states[state].trans.list) {
3094                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
3095                     U16 maxid=minid;
3096                     U16 idx;
3097
3098                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3099                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
3100                         if ( forid < minid ) {
3101                             minid=forid;
3102                         } else if ( forid > maxid ) {
3103                             maxid=forid;
3104                         }
3105                     }
3106                     if ( transcount < tp + maxid - minid + 1) {
3107                         transcount *= 2;
3108                         trie->trans = (reg_trie_trans *)
3109                             PerlMemShared_realloc( trie->trans,
3110                                                      transcount
3111                                                      * sizeof(reg_trie_trans) );
3112                         Zero( trie->trans + (transcount / 2),
3113                               transcount / 2,
3114                               reg_trie_trans );
3115                     }
3116                     base = trie->uniquecharcount + tp - minid;
3117                     if ( maxid == minid ) {
3118                         U32 set = 0;
3119                         for ( ; zp < tp ; zp++ ) {
3120                             if ( ! trie->trans[ zp ].next ) {
3121                                 base = trie->uniquecharcount + zp - minid;
3122                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
3123                                                                    1).newstate;
3124                                 trie->trans[ zp ].check = state;
3125                                 set = 1;
3126                                 break;
3127                             }
3128                         }
3129                         if ( !set ) {
3130                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
3131                                                                    1).newstate;
3132                             trie->trans[ tp ].check = state;
3133                             tp++;
3134                             zp = tp;
3135                         }
3136                     } else {
3137                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
3138                             const U32 tid = base
3139                                            - trie->uniquecharcount
3140                                            + TRIE_LIST_ITEM( state, idx ).forid;
3141                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
3142                                                                 idx ).newstate;
3143                             trie->trans[ tid ].check = state;
3144                         }
3145                         tp += ( maxid - minid + 1 );
3146                     }
3147                     Safefree(trie->states[ state ].trans.list);
3148                 }
3149                 /*
3150                 DEBUG_TRIE_COMPILE_MORE_r(
3151                     Perl_re_printf( aTHX_  " base: %d\n",base);
3152                 );
3153                 */
3154                 trie->states[ state ].trans.base=base;
3155             }
3156             trie->lasttrans = tp + 1;
3157         }
3158     } else {
3159         /*
3160            Second Pass -- Flat Table Representation.
3161
3162            we dont use the 0 slot of either trans[] or states[] so we add 1 to
3163            each.  We know that we will need Charcount+1 trans at most to store
3164            the data (one row per char at worst case) So we preallocate both
3165            structures assuming worst case.
3166
3167            We then construct the trie using only the .next slots of the entry
3168            structs.
3169
3170            We use the .check field of the first entry of the node temporarily
3171            to make compression both faster and easier by keeping track of how
3172            many non zero fields are in the node.
3173
3174            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
3175            transition.
3176
3177            There are two terms at use here: state as a TRIE_NODEIDX() which is
3178            a number representing the first entry of the node, and state as a
3179            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
3180            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
3181            if there are 2 entrys per node. eg:
3182
3183              A B       A B
3184           1. 2 4    1. 3 7
3185           2. 0 3    3. 0 5
3186           3. 0 0    5. 0 0
3187           4. 0 0    7. 0 0
3188
3189            The table is internally in the right hand, idx form. However as we
3190            also have to deal with the states array which is indexed by nodenum
3191            we have to use TRIE_NODENUM() to convert.
3192
3193         */
3194         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
3195             depth+1));
3196
3197         trie->trans = (reg_trie_trans *)
3198             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
3199                                   * trie->uniquecharcount + 1,
3200                                   sizeof(reg_trie_trans) );
3201         trie->states = (reg_trie_state *)
3202             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
3203                                   sizeof(reg_trie_state) );
3204         next_alloc = trie->uniquecharcount + 1;
3205
3206
3207         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3208
3209             regnode *noper   = NEXTOPER( cur );
3210
3211             U32 state        = 1;         /* required init */
3212
3213             U16 charid       = 0;         /* sanity init */
3214             U32 accept_state = 0;         /* sanity init */
3215
3216             U32 wordlen      = 0;         /* required init */
3217
3218             if (OP(noper) == NOTHING) {
3219                 regnode *noper_next= regnext(noper);
3220                 if (noper_next < tail)
3221                     noper= noper_next;
3222             }
3223
3224             if (    noper < tail
3225                 && (    OP(noper) == flags
3226                     || (flags == EXACT && OP(noper) == EXACT_ONLY8)
3227                     || (flags == EXACTFU && (   OP(noper) == EXACTFU_ONLY8
3228                                              || OP(noper) == EXACTFUP))))
3229             {
3230                 const U8 *uc= (U8*)STRING(noper);
3231                 const U8 *e= uc + STR_LEN(noper);
3232
3233                 for ( ; uc < e ; uc += len ) {
3234
3235                     TRIE_READ_CHAR;
3236
3237                     if ( uvc < 256 ) {
3238                         charid = trie->charmap[ uvc ];
3239                     } else {
3240                         SV* const * const svpp = hv_fetch( widecharmap,
3241                                                            (char*)&uvc,
3242                                                            sizeof( UV ),
3243                                                            0);
3244                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3245                     }
3246                     if ( charid ) {
3247                         charid--;
3248                         if ( !trie->trans[ state + charid ].next ) {
3249                             trie->trans[ state + charid ].next = next_alloc;
3250                             trie->trans[ state ].check++;
3251                             prev_states[TRIE_NODENUM(next_alloc)]
3252                                     = TRIE_NODENUM(state);
3253                             next_alloc += trie->uniquecharcount;
3254                         }
3255                         state = trie->trans[ state + charid ].next;
3256                     } else {
3257                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3258                     }
3259                     /* charid is now 0 if we dont know the char read, or
3260                      * nonzero if we do */
3261                 }
3262             }
3263             accept_state = TRIE_NODENUM( state );
3264             TRIE_HANDLE_WORD(accept_state);
3265
3266         } /* end second pass */
3267
3268         /* and now dump it out before we compress it */
3269         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3270                                                           revcharmap,
3271                                                           next_alloc, depth+1));
3272
3273         {
3274         /*
3275            * Inplace compress the table.*
3276
3277            For sparse data sets the table constructed by the trie algorithm will
3278            be mostly 0/FAIL transitions or to put it another way mostly empty.
3279            (Note that leaf nodes will not contain any transitions.)
3280
3281            This algorithm compresses the tables by eliminating most such
3282            transitions, at the cost of a modest bit of extra work during lookup:
3283
3284            - Each states[] entry contains a .base field which indicates the
3285            index in the state[] array wheres its transition data is stored.
3286
3287            - If .base is 0 there are no valid transitions from that node.
3288
3289            - If .base is nonzero then charid is added to it to find an entry in
3290            the trans array.
3291
3292            -If trans[states[state].base+charid].check!=state then the
3293            transition is taken to be a 0/Fail transition. Thus if there are fail
3294            transitions at the front of the node then the .base offset will point
3295            somewhere inside the previous nodes data (or maybe even into a node
3296            even earlier), but the .check field determines if the transition is
3297            valid.
3298
3299            XXX - wrong maybe?
3300            The following process inplace converts the table to the compressed
3301            table: We first do not compress the root node 1,and mark all its
3302            .check pointers as 1 and set its .base pointer as 1 as well. This
3303            allows us to do a DFA construction from the compressed table later,
3304            and ensures that any .base pointers we calculate later are greater
3305            than 0.
3306
3307            - We set 'pos' to indicate the first entry of the second node.
3308
3309            - We then iterate over the columns of the node, finding the first and
3310            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3311            and set the .check pointers accordingly, and advance pos
3312            appropriately and repreat for the next node. Note that when we copy
3313            the next pointers we have to convert them from the original
3314            NODEIDX form to NODENUM form as the former is not valid post
3315            compression.
3316
3317            - If a node has no transitions used we mark its base as 0 and do not
3318            advance the pos pointer.
3319
3320            - If a node only has one transition we use a second pointer into the
3321            structure to fill in allocated fail transitions from other states.
3322            This pointer is independent of the main pointer and scans forward
3323            looking for null transitions that are allocated to a state. When it
3324            finds one it writes the single transition into the "hole".  If the
3325            pointer doesnt find one the single transition is appended as normal.
3326
3327            - Once compressed we can Renew/realloc the structures to release the
3328            excess space.
3329
3330            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3331            specifically Fig 3.47 and the associated pseudocode.
3332
3333            demq
3334         */
3335         const U32 laststate = TRIE_NODENUM( next_alloc );
3336         U32 state, charid;
3337         U32 pos = 0, zp=0;
3338         trie->statecount = laststate;
3339
3340         for ( state = 1 ; state < laststate ; state++ ) {
3341             U8 flag = 0;
3342             const U32 stateidx = TRIE_NODEIDX( state );
3343             const U32 o_used = trie->trans[ stateidx ].check;
3344             U32 used = trie->trans[ stateidx ].check;
3345             trie->trans[ stateidx ].check = 0;
3346
3347             for ( charid = 0;
3348                   used && charid < trie->uniquecharcount;
3349                   charid++ )
3350             {
3351                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3352                     if ( trie->trans[ stateidx + charid ].next ) {
3353                         if (o_used == 1) {
3354                             for ( ; zp < pos ; zp++ ) {
3355                                 if ( ! trie->trans[ zp ].next ) {
3356                                     break;
3357                                 }
3358                             }
3359                             trie->states[ state ].trans.base
3360                                                     = zp
3361                                                       + trie->uniquecharcount
3362                                                       - charid ;
3363                             trie->trans[ zp ].next
3364                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3365                                                              + charid ].next );
3366                             trie->trans[ zp ].check = state;
3367                             if ( ++zp > pos ) pos = zp;
3368                             break;
3369                         }
3370                         used--;
3371                     }
3372                     if ( !flag ) {
3373                         flag = 1;
3374                         trie->states[ state ].trans.base
3375                                        = pos + trie->uniquecharcount - charid ;
3376                     }
3377                     trie->trans[ pos ].next
3378                         = SAFE_TRIE_NODENUM(
3379                                        trie->trans[ stateidx + charid ].next );
3380                     trie->trans[ pos ].check = state;
3381                     pos++;
3382                 }
3383             }
3384         }
3385         trie->lasttrans = pos + 1;
3386         trie->states = (reg_trie_state *)
3387             PerlMemShared_realloc( trie->states, laststate
3388                                    * sizeof(reg_trie_state) );
3389         DEBUG_TRIE_COMPILE_MORE_r(
3390             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3391                 depth+1,
3392                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3393                        + 1 ),
3394                 (IV)next_alloc,
3395                 (IV)pos,
3396                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3397             );
3398
3399         } /* end table compress */
3400     }
3401     DEBUG_TRIE_COMPILE_MORE_r(
3402             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3403                 depth+1,
3404                 (UV)trie->statecount,
3405                 (UV)trie->lasttrans)
3406     );
3407     /* resize the trans array to remove unused space */
3408     trie->trans = (reg_trie_trans *)
3409         PerlMemShared_realloc( trie->trans, trie->lasttrans
3410                                * sizeof(reg_trie_trans) );
3411
3412     {   /* Modify the program and insert the new TRIE node */
3413         U8 nodetype =(U8)(flags & 0xFF);
3414         char *str=NULL;
3415
3416 #ifdef DEBUGGING
3417         regnode *optimize = NULL;
3418 #ifdef RE_TRACK_PATTERN_OFFSETS
3419
3420         U32 mjd_offset = 0;
3421         U32 mjd_nodelen = 0;
3422 #endif /* RE_TRACK_PATTERN_OFFSETS */
3423 #endif /* DEBUGGING */
3424         /*
3425            This means we convert either the first branch or the first Exact,
3426            depending on whether the thing following (in 'last') is a branch
3427            or not and whther first is the startbranch (ie is it a sub part of
3428            the alternation or is it the whole thing.)
3429            Assuming its a sub part we convert the EXACT otherwise we convert
3430            the whole branch sequence, including the first.
3431          */
3432         /* Find the node we are going to overwrite */
3433         if ( first != startbranch || OP( last ) == BRANCH ) {
3434             /* branch sub-chain */
3435             NEXT_OFF( first ) = (U16)(last - first);
3436 #ifdef RE_TRACK_PATTERN_OFFSETS
3437             DEBUG_r({
3438                 mjd_offset= Node_Offset((convert));
3439                 mjd_nodelen= Node_Length((convert));
3440             });
3441 #endif
3442             /* whole branch chain */
3443         }
3444 #ifdef RE_TRACK_PATTERN_OFFSETS
3445         else {
3446             DEBUG_r({
3447                 const  regnode *nop = NEXTOPER( convert );
3448                 mjd_offset= Node_Offset((nop));
3449                 mjd_nodelen= Node_Length((nop));
3450             });
3451         }
3452         DEBUG_OPTIMISE_r(
3453             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3454                 depth+1,
3455                 (UV)mjd_offset, (UV)mjd_nodelen)
3456         );
3457 #endif
3458         /* But first we check to see if there is a common prefix we can
3459            split out as an EXACT and put in front of the TRIE node.  */
3460         trie->startstate= 1;
3461         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3462             /* we want to find the first state that has more than
3463              * one transition, if that state is not the first state
3464              * then we have a common prefix which we can remove.
3465              */
3466             U32 state;
3467             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3468                 U32 ofs = 0;
3469                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3470                                        transition, -1 means none */
3471                 U32 count = 0;
3472                 const U32 base = trie->states[ state ].trans.base;
3473
3474                 /* does this state terminate an alternation? */
3475                 if ( trie->states[state].wordnum )
3476                         count = 1;
3477
3478                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3479                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3480                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3481                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3482                     {
3483                         if ( ++count > 1 ) {
3484                             /* we have more than one transition */
3485                             SV **tmp;
3486                             U8 *ch;
3487                             /* if this is the first state there is no common prefix
3488                              * to extract, so we can exit */
3489                             if ( state == 1 ) break;
3490                             tmp = av_fetch( revcharmap, ofs, 0);
3491                             ch = (U8*)SvPV_nolen_const( *tmp );
3492
3493                             /* if we are on count 2 then we need to initialize the
3494                              * bitmap, and store the previous char if there was one
3495                              * in it*/
3496                             if ( count == 2 ) {
3497                                 /* clear the bitmap */
3498                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3499                                 DEBUG_OPTIMISE_r(
3500                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3501                                         depth+1,
3502                                         (UV)state));
3503                                 if (first_ofs >= 0) {
3504                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3505                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3506
3507                                     TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3508                                     DEBUG_OPTIMISE_r(
3509                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3510                                     );
3511                                 }
3512                             }
3513                             /* store the current firstchar in the bitmap */
3514                             TRIE_BITMAP_SET_FOLDED(trie,*ch, folder);
3515                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3516                         }
3517                         first_ofs = ofs;
3518                     }
3519                 }
3520                 if ( count == 1 ) {
3521                     /* This state has only one transition, its transition is part
3522                      * of a common prefix - we need to concatenate the char it
3523                      * represents to what we have so far. */
3524                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3525                     STRLEN len;
3526                     char *ch = SvPV( *tmp, len );
3527                     DEBUG_OPTIMISE_r({
3528                         SV *sv=sv_newmortal();
3529                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3530                             depth+1,
3531                             (UV)state, (UV)first_ofs,
3532                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3533                                 PL_colors[0], PL_colors[1],
3534                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3535                                 PERL_PV_ESCAPE_FIRSTCHAR
3536                             )
3537                         );
3538                     });
3539                     if ( state==1 ) {
3540                         OP( convert ) = nodetype;
3541                         str=STRING(convert);
3542                         STR_LEN(convert)=0;
3543                     }
3544                     STR_LEN(convert) += len;
3545                     while (len--)
3546                         *str++ = *ch++;
3547                 } else {
3548 #ifdef DEBUGGING
3549                     if (state>1)
3550                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3551 #endif
3552                     break;
3553                 }
3554             }
3555             trie->prefixlen = (state-1);
3556             if (str) {
3557                 regnode *n = convert+NODE_SZ_STR(convert);
3558                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3559                 trie->startstate = state;
3560                 trie->minlen -= (state - 1);
3561                 trie->maxlen -= (state - 1);
3562 #ifdef DEBUGGING
3563                /* At least the UNICOS C compiler choked on this
3564                 * being argument to DEBUG_r(), so let's just have
3565                 * it right here. */
3566                if (
3567 #ifdef PERL_EXT_RE_BUILD
3568                    1
3569 #else
3570                    DEBUG_r_TEST
3571 #endif
3572                    ) {
3573                    regnode *fix = convert;
3574                    U32 word = trie->wordcount;
3575 #ifdef RE_TRACK_PATTERN_OFFSETS
3576                    mjd_nodelen++;
3577 #endif
3578                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3579                    while( ++fix < n ) {
3580                        Set_Node_Offset_Length(fix, 0, 0);
3581                    }
3582                    while (word--) {
3583                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3584                        if (tmp) {
3585                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3586                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3587                            else
3588                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3589                        }
3590                    }
3591                }
3592 #endif
3593                 if (trie->maxlen) {
3594                     convert = n;
3595                 } else {
3596                     NEXT_OFF(convert) = (U16)(tail - convert);
3597                     DEBUG_r(optimize= n);
3598                 }
3599             }
3600         }
3601         if (!jumper)
3602             jumper = last;
3603         if ( trie->maxlen ) {
3604             NEXT_OFF( convert ) = (U16)(tail - convert);
3605             ARG_SET( convert, data_slot );
3606             /* Store the offset to the first unabsorbed branch in
3607                jump[0], which is otherwise unused by the jump logic.
3608                We use this when dumping a trie and during optimisation. */
3609             if (trie->jump)
3610                 trie->jump[0] = (U16)(nextbranch - convert);
3611
3612             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3613              *   and there is a bitmap
3614              *   and the first "jump target" node we found leaves enough room
3615              * then convert the TRIE node into a TRIEC node, with the bitmap
3616              * embedded inline in the opcode - this is hypothetically faster.
3617              */
3618             if ( !trie->states[trie->startstate].wordnum
3619                  && trie->bitmap
3620                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3621             {
3622                 OP( convert ) = TRIEC;
3623                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3624                 PerlMemShared_free(trie->bitmap);
3625                 trie->bitmap= NULL;
3626             } else
3627                 OP( convert ) = TRIE;
3628
3629             /* store the type in the flags */
3630             convert->flags = nodetype;
3631             DEBUG_r({
3632             optimize = convert
3633                       + NODE_STEP_REGNODE
3634                       + regarglen[ OP( convert ) ];
3635             });
3636             /* XXX We really should free up the resource in trie now,
3637                    as we won't use them - (which resources?) dmq */
3638         }
3639         /* needed for dumping*/
3640         DEBUG_r(if (optimize) {
3641             regnode *opt = convert;
3642
3643             while ( ++opt < optimize) {
3644                 Set_Node_Offset_Length(opt, 0, 0);
3645             }
3646             /*
3647                 Try to clean up some of the debris left after the
3648                 optimisation.
3649              */
3650             while( optimize < jumper ) {
3651                 Track_Code( mjd_nodelen += Node_Length((optimize)); );
3652                 OP( optimize ) = OPTIMIZED;
3653                 Set_Node_Offset_Length(optimize, 0, 0);
3654                 optimize++;
3655             }
3656             Set_Node_Offset_Length(convert, mjd_offset, mjd_nodelen);
3657         });
3658     } /* end node insert */
3659
3660     /*  Finish populating the prev field of the wordinfo array.  Walk back
3661      *  from each accept state until we find another accept state, and if
3662      *  so, point the first word's .prev field at the second word. If the
3663      *  second already has a .prev field set, stop now. This will be the
3664      *  case either if we've already processed that word's accept state,
3665      *  or that state had multiple words, and the overspill words were
3666      *  already linked up earlier.
3667      */
3668     {
3669         U16 word;
3670         U32 state;
3671         U16 prev;
3672
3673         for (word=1; word <= trie->wordcount; word++) {
3674             prev = 0;
3675             if (trie->wordinfo[word].prev)
3676                 continue;
3677             state = trie->wordinfo[word].accept;
3678             while (state) {
3679                 state = prev_states[state];
3680                 if (!state)
3681                     break;
3682                 prev = trie->states[state].wordnum;
3683                 if (prev)
3684                     break;
3685             }
3686             trie->wordinfo[word].prev = prev;
3687         }
3688         Safefree(prev_states);
3689     }
3690
3691
3692     /* and now dump out the compressed format */
3693     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3694
3695     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3696 #ifdef DEBUGGING
3697     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3698     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3699 #else
3700     SvREFCNT_dec_NN(revcharmap);
3701 #endif
3702     return trie->jump
3703            ? MADE_JUMP_TRIE
3704            : trie->startstate>1
3705              ? MADE_EXACT_TRIE
3706              : MADE_TRIE;
3707 }
3708
3709 STATIC regnode *
3710 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3711 {
3712 /* The Trie is constructed and compressed now so we can build a fail array if
3713  * it's needed
3714
3715    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3716    3.32 in the
3717    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3718    Ullman 1985/88
3719    ISBN 0-201-10088-6
3720
3721    We find the fail state for each state in the trie, this state is the longest
3722    proper suffix of the current state's 'word' that is also a proper prefix of
3723    another word in our trie. State 1 represents the word '' and is thus the
3724    default fail state. This allows the DFA not to have to restart after its
3725    tried and failed a word at a given point, it simply continues as though it
3726    had been matching the other word in the first place.
3727    Consider
3728       'abcdgu'=~/abcdefg|cdgu/
3729    When we get to 'd' we are still matching the first word, we would encounter
3730    'g' which would fail, which would bring us to the state representing 'd' in
3731    the second word where we would try 'g' and succeed, proceeding to match
3732    'cdgu'.
3733  */
3734  /* add a fail transition */
3735     const U32 trie_offset = ARG(source);
3736     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3737     U32 *q;
3738     const U32 ucharcount = trie->uniquecharcount;
3739     const U32 numstates = trie->statecount;
3740     const U32 ubound = trie->lasttrans + ucharcount;
3741     U32 q_read = 0;
3742     U32 q_write = 0;
3743     U32 charid;
3744     U32 base = trie->states[ 1 ].trans.base;
3745     U32 *fail;
3746     reg_ac_data *aho;
3747     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3748     regnode *stclass;
3749     GET_RE_DEBUG_FLAGS_DECL;
3750
3751     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3752     PERL_UNUSED_CONTEXT;
3753 #ifndef DEBUGGING
3754     PERL_UNUSED_ARG(depth);
3755 #endif
3756
3757     if ( OP(source) == TRIE ) {
3758         struct regnode_1 *op = (struct regnode_1 *)
3759             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3760         StructCopy(source, op, struct regnode_1);
3761         stclass = (regnode *)op;
3762     } else {
3763         struct regnode_charclass *op = (struct regnode_charclass *)
3764             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3765         StructCopy(source, op, struct regnode_charclass);
3766         stclass = (regnode *)op;
3767     }
3768     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3769
3770     ARG_SET( stclass, data_slot );
3771     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3772     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3773     aho->trie=trie_offset;
3774     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3775     Copy( trie->states, aho->states, numstates, reg_trie_state );
3776     Newx( q, numstates, U32);
3777     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3778     aho->refcount = 1;
3779     fail = aho->fail;
3780     /* initialize fail[0..1] to be 1 so that we always have
3781        a valid final fail state */
3782     fail[ 0 ] = fail[ 1 ] = 1;
3783
3784     for ( charid = 0; charid < ucharcount ; charid++ ) {
3785         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3786         if ( newstate ) {
3787             q[ q_write ] = newstate;
3788             /* set to point at the root */
3789             fail[ q[ q_write++ ] ]=1;
3790         }
3791     }
3792     while ( q_read < q_write) {
3793         const U32 cur = q[ q_read++ % numstates ];
3794         base = trie->states[ cur ].trans.base;
3795
3796         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3797             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3798             if (ch_state) {
3799                 U32 fail_state = cur;
3800                 U32 fail_base;
3801                 do {
3802                     fail_state = fail[ fail_state ];
3803                     fail_base = aho->states[ fail_state ].trans.base;
3804                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3805
3806                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3807                 fail[ ch_state ] = fail_state;
3808                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3809                 {
3810                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3811                 }
3812                 q[ q_write++ % numstates] = ch_state;
3813             }
3814         }
3815     }
3816     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3817        when we fail in state 1, this allows us to use the
3818        charclass scan to find a valid start char. This is based on the principle
3819        that theres a good chance the string being searched contains lots of stuff
3820        that cant be a start char.
3821      */
3822     fail[ 0 ] = fail[ 1 ] = 0;
3823     DEBUG_TRIE_COMPILE_r({
3824         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3825                       depth, (UV)numstates
3826         );
3827         for( q_read=1; q_read<numstates; q_read++ ) {
3828             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3829         }
3830         Perl_re_printf( aTHX_  "\n");
3831     });
3832     Safefree(q);
3833     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3834     return stclass;
3835 }
3836
3837
3838 /* The below joins as many adjacent EXACTish nodes as possible into a single
3839  * one.  The regop may be changed if the node(s) contain certain sequences that
3840  * require special handling.  The joining is only done if:
3841  * 1) there is room in the current conglomerated node to entirely contain the
3842  *    next one.
3843  * 2) they are compatible node types
3844  *
3845  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3846  * these get optimized out
3847  *
3848  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3849  * as possible, even if that means splitting an existing node so that its first
3850  * part is moved to the preceeding node.  This would maximise the efficiency of
3851  * memEQ during matching.
3852  *
3853  * If a node is to match under /i (folded), the number of characters it matches
3854  * can be different than its character length if it contains a multi-character
3855  * fold.  *min_subtract is set to the total delta number of characters of the
3856  * input nodes.
3857  *
3858  * And *unfolded_multi_char is set to indicate whether or not the node contains
3859  * an unfolded multi-char fold.  This happens when it won't be known until
3860  * runtime whether the fold is valid or not; namely
3861  *  1) for EXACTF nodes that contain LATIN SMALL LETTER SHARP S, as only if the
3862  *      target string being matched against turns out to be UTF-8 is that fold
3863  *      valid; or
3864  *  2) for EXACTFL nodes whose folding rules depend on the locale in force at
3865  *      runtime.
3866  * (Multi-char folds whose components are all above the Latin1 range are not
3867  * run-time locale dependent, and have already been folded by the time this
3868  * function is called.)
3869  *
3870  * This is as good a place as any to discuss the design of handling these
3871  * multi-character fold sequences.  It's been wrong in Perl for a very long
3872  * time.  There are three code points in Unicode whose multi-character folds
3873  * were long ago discovered to mess things up.  The previous designs for
3874  * dealing with these involved assigning a special node for them.  This
3875  * approach doesn't always work, as evidenced by this example:
3876  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3877  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3878  * would match just the \xDF, it won't be able to handle the case where a
3879  * successful match would have to cross the node's boundary.  The new approach
3880  * that hopefully generally solves the problem generates an EXACTFUP node
3881  * that is "sss" in this case.
3882  *
3883  * It turns out that there are problems with all multi-character folds, and not
3884  * just these three.  Now the code is general, for all such cases.  The
3885  * approach taken is:
3886  * 1)   This routine examines each EXACTFish node that could contain multi-
3887  *      character folded sequences.  Since a single character can fold into
3888  *      such a sequence, the minimum match length for this node is less than
3889  *      the number of characters in the node.  This routine returns in
3890  *      *min_subtract how many characters to subtract from the the actual
3891  *      length of the string to get a real minimum match length; it is 0 if
3892  *      there are no multi-char foldeds.  This delta is used by the caller to
3893  *      adjust the min length of the match, and the delta between min and max,
3894  *      so that the optimizer doesn't reject these possibilities based on size
3895  *      constraints.
3896  *
3897  * 2)   For the sequence involving the LATIN SMALL LETTER SHARP S (U+00DF)
3898  *      under /u, we fold it to 'ss' in regatom(), and in this routine, after
3899  *      joining, we scan for occurrences of the sequence 'ss' in non-UTF-8
3900  *      EXACTFU nodes.  The node type of such nodes is then changed to
3901  *      EXACTFUP, indicating it is problematic, and needs careful handling.
3902  *      (The procedures in step 1) above are sufficient to handle this case in
3903  *      UTF-8 encoded nodes.)  The reason this is problematic is that this is
3904  *      the only case where there is a possible fold length change in non-UTF-8
3905  *      patterns.  By reserving a special node type for problematic cases, the
3906  *      far more common regular EXACTFU nodes can be processed faster.
3907  *      regexec.c takes advantage of this.
3908  *
3909  *      EXACTFUP has been created as a grab-bag for (hopefully uncommon)
3910  *      problematic cases.   These all only occur when the pattern is not
3911  *      UTF-8.  In addition to the 'ss' sequence where there is a possible fold
3912  *      length change, it handles the situation where the string cannot be
3913  *      entirely folded.  The strings in an EXACTFish node are folded as much
3914  *      as possible during compilation in regcomp.c.  This saves effort in
3915  *      regex matching.  By using an EXACTFUP node when it is not possible to
3916  *      fully fold at compile time, regexec.c can know that everything in an
3917  *      EXACTFU node is folded, so folding can be skipped at runtime.  The only
3918  *      case where folding in EXACTFU nodes can't be done at compile time is
3919  *      the presumably uncommon MICRO SIGN, when the pattern isn't UTF-8.  This
3920  *      is because its fold requires UTF-8 to represent.  Thus EXACTFUP nodes
3921  *      handle two very different cases.  Alternatively, there could have been
3922  *      a node type where there are length changes, one for unfolded, and one
3923  *      for both.  If yet another special case needed to be created, the number
3924  *      of required node types would have to go to 7.  khw figures that even
3925  *      though there are plenty of node types to spare, that the maintenance
3926  *      cost wasn't worth the small speedup of doing it that way, especially
3927  *      since he thinks the MICRO SIGN is rarely encountered in practice.
3928  *
3929  *      There are other cases where folding isn't done at compile time, but
3930  *      none of them are under /u, and hence not for EXACTFU nodes.  The folds
3931  *      in EXACTFL nodes aren't known until runtime, and vary as the locale
3932  *      changes.  Some folds in EXACTF depend on if the runtime target string
3933  *      is UTF-8 or not.  (regatom() will create an EXACTFU node even under /di
3934  *      when no fold in it depends on the UTF-8ness of the target string.)
3935  *
3936  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3937  *      validity of the fold won't be known until runtime, and so must remain
3938  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFAA
3939  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3940  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3941  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3942  *      The reason this is a problem is that the optimizer part of regexec.c
3943  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3944  *      that a character in the pattern corresponds to at most a single
3945  *      character in the target string.  (And I do mean character, and not byte
3946  *      here, unlike other parts of the documentation that have never been
3947  *      updated to account for multibyte Unicode.)  Sharp s in EXACTF and
3948  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFAA
3949  *      nodes it can match "\x{17F}\x{17F}".  These, along with other ones in
3950  *      EXACTFL nodes, violate the assumption, and they are the only instances
3951  *      where it is violated.  I'm reluctant to try to change the assumption,
3952  *      as the code involved is impenetrable to me (khw), so instead the code
3953  *      here punts.  This routine examines EXACTFL nodes, and (when the pattern
3954  *      isn't UTF-8) EXACTF and EXACTFAA for such unfolded folds, and returns a
3955  *      boolean indicating whether or not the node contains such a fold.  When
3956  *      it is true, the caller sets a flag that later causes the optimizer in
3957  *      this file to not set values for the floating and fixed string lengths,
3958  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3959  *      assumption.  Thus, there is no optimization based on string lengths for
3960  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3961  *      EXACTF and EXACTFAA nodes that contain the sharp s.  (The reason the
3962  *      assumption is wrong only in these cases is that all other non-UTF-8
3963  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3964  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3965  *      EXACTF nodes because we don't know at compile time if it actually
3966  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3967  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3968  *      always matches; and EXACTFAA where it never does.  In an EXACTFAA node
3969  *      in a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3970  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3971  *      string would require the pattern to be forced into UTF-8, the overhead
3972  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3973  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3974  *      locale.)
3975  *
3976  *      Similarly, the code that generates tries doesn't currently handle
3977  *      not-already-folded multi-char folds, and it looks like a pain to change
3978  *      that.  Therefore, trie generation of EXACTFAA nodes with the sharp s
3979  *      doesn't work.  Instead, such an EXACTFAA is turned into a new regnode,
3980  *      EXACTFAA_NO_TRIE, which the trie code knows not to handle.  Most people
3981  *      using /iaa matching will be doing so almost entirely with ASCII
3982  *      strings, so this should rarely be encountered in practice */
3983
3984 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3985     if (PL_regkind[OP(scan)] == EXACT) \
3986         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags), NULL, depth+1)
3987
3988 STATIC U32
3989 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3990                    UV *min_subtract, bool *unfolded_multi_char,
3991                    U32 flags, regnode *val, U32 depth)
3992 {
3993     /* Merge several consecutive EXACTish nodes into one. */
3994
3995     regnode *n = regnext(scan);
3996     U32 stringok = 1;
3997     regnode *next = scan + NODE_SZ_STR(scan);
3998     U32 merged = 0;
3999     U32 stopnow = 0;
4000 #ifdef DEBUGGING
4001     regnode *stop = scan;
4002     GET_RE_DEBUG_FLAGS_DECL;
4003 #else
4004     PERL_UNUSED_ARG(depth);
4005 #endif
4006
4007     PERL_ARGS_ASSERT_JOIN_EXACT;
4008 #ifndef EXPERIMENTAL_INPLACESCAN
4009     PERL_UNUSED_ARG(flags);
4010     PERL_UNUSED_ARG(val);
4011 #endif
4012     DEBUG_PEEP("join", scan, depth, 0);
4013
4014     assert(PL_regkind[OP(scan)] == EXACT);
4015
4016     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
4017      * EXACT ones that are mergeable to the current one. */
4018     while (    n
4019            && (    PL_regkind[OP(n)] == NOTHING
4020                || (stringok && PL_regkind[OP(n)] == EXACT))
4021            && NEXT_OFF(n)
4022            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
4023     {
4024
4025         if (OP(n) == TAIL || n > next)
4026             stringok = 0;
4027         if (PL_regkind[OP(n)] == NOTHING) {
4028             DEBUG_PEEP("skip:", n, depth, 0);
4029             NEXT_OFF(scan) += NEXT_OFF(n);
4030             next = n + NODE_STEP_REGNODE;
4031 #ifdef DEBUGGING
4032             if (stringok)
4033                 stop = n;
4034 #endif
4035             n = regnext(n);
4036         }
4037         else if (stringok) {
4038             const unsigned int oldl = STR_LEN(scan);
4039             regnode * const nnext = regnext(n);
4040
4041             /* XXX I (khw) kind of doubt that this works on platforms (should
4042              * Perl ever run on one) where U8_MAX is above 255 because of lots
4043              * of other assumptions */
4044             /* Don't join if the sum can't fit into a single node */
4045             if (oldl + STR_LEN(n) > U8_MAX)
4046                 break;
4047
4048             /* Joining something that requires UTF-8 with something that
4049              * doesn't, means the result requires UTF-8. */
4050             if (OP(scan) == EXACT && (OP(n) == EXACT_ONLY8)) {
4051                 OP(scan) = EXACT_ONLY8;
4052             }
4053             else if (OP(scan) == EXACT_ONLY8 && (OP(n) == EXACT)) {
4054                 ;   /* join is compatible, no need to change OP */
4055             }
4056             else if ((OP(scan) == EXACTFU) && (OP(n) == EXACTFU_ONLY8)) {
4057                 OP(scan) = EXACTFU_ONLY8;
4058             }
4059             else if ((OP(scan) == EXACTFU_ONLY8) && (OP(n) == EXACTFU)) {
4060                 ;   /* join is compatible, no need to change OP */
4061             }
4062             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU) {
4063                 ;   /* join is compatible, no need to change OP */
4064             }
4065             else if (OP(scan) == EXACTFU && OP(n) == EXACTFU_S_EDGE) {
4066
4067                  /* Under /di, temporary EXACTFU_S_EDGE nodes are generated,
4068                   * which can join with EXACTFU ones.  We check for this case
4069                   * here.  These need to be resolved to either EXACTFU or
4070                   * EXACTF at joining time.  They have nothing in them that
4071                   * would forbid them from being the more desirable EXACTFU
4072                   * nodes except that they begin and/or end with a single [Ss].
4073                   * The reason this is problematic is because they could be
4074                   * joined in this loop with an adjacent node that ends and/or
4075                   * begins with [Ss] which would then form the sequence 'ss',
4076                   * which matches differently under /di than /ui, in which case
4077                   * EXACTFU can't be used.  If the 'ss' sequence doesn't get
4078                   * formed, the nodes get absorbed into any adjacent EXACTFU
4079                   * node.  And if the only adjacent node is EXACTF, they get
4080                   * absorbed into that, under the theory that a longer node is
4081                   * better than two shorter ones, even if one is EXACTFU.  Note
4082                   * that EXACTFU_ONLY8 is generated only for UTF-8 patterns,
4083                   * and the EXACTFU_S_EDGE ones only for non-UTF-8.  */
4084
4085                 if (STRING(n)[STR_LEN(n)-1] == 's') {
4086
4087                     /* Here the joined node would end with 's'.  If the node
4088                      * following the combination is an EXACTF one, it's better to
4089                      * join this trailing edge 's' node with that one, leaving the
4090                      * current one in 'scan' be the more desirable EXACTFU */
4091                     if (OP(nnext) == EXACTF) {
4092                         break;
4093                     }
4094
4095                     OP(scan) = EXACTFU_S_EDGE;
4096
4097                 }   /* Otherwise, the beginning 's' of the 2nd node just
4098                        becomes an interior 's' in 'scan' */
4099             }
4100             else if (OP(scan) == EXACTF && OP(n) == EXACTF) {
4101                 ;   /* join is compatible, no need to change OP */
4102             }
4103             else if (OP(scan) == EXACTF && OP(n) == EXACTFU_S_EDGE) {
4104
4105                 /* EXACTF nodes are compatible for joining with EXACTFU_S_EDGE
4106                  * nodes.  But the latter nodes can be also joined with EXACTFU
4107                  * ones, and that is a better outcome, so if the node following
4108                  * 'n' is EXACTFU, quit now so that those two can be joined
4109                  * later */
4110                 if (OP(nnext) == EXACTFU) {
4111                     break;
4112                 }
4113
4114                 /* The join is compatible, and the combined node will be
4115                  * EXACTF.  (These don't care if they begin or end with 's' */
4116             }
4117             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU_S_EDGE) {
4118                 if (   STRING(scan)[STR_LEN(scan)-1] == 's'
4119                     && STRING(n)[0] == 's')
4120                 {
4121                     /* When combined, we have the sequence 'ss', which means we
4122                      * have to remain /di */
4123                     OP(scan) = EXACTF;
4124                 }
4125             }
4126             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTFU) {
4127                 if (STRING(n)[0] == 's') {
4128                     ;   /* Here the join is compatible and the combined node
4129                            starts with 's', no need to change OP */
4130                 }
4131                 else {  /* Now the trailing 's' is in the interior */
4132                     OP(scan) = EXACTFU;
4133                 }
4134             }
4135             else if (OP(scan) == EXACTFU_S_EDGE && OP(n) == EXACTF) {
4136
4137                 /* The join is compatible, and the combined node will be
4138                  * EXACTF.  (These don't care if they begin or end with 's' */
4139                 OP(scan) = EXACTF;
4140             }
4141             else if (OP(scan) != OP(n)) {
4142
4143                 /* The only other compatible joinings are the same node type */
4144                 break;
4145             }
4146
4147             DEBUG_PEEP("merg", n, depth, 0);
4148             merged++;
4149
4150             NEXT_OFF(scan) += NEXT_OFF(n);
4151             STR_LEN(scan) += STR_LEN(n);
4152             next = n + NODE_SZ_STR(n);
4153             /* Now we can overwrite *n : */
4154             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
4155 #ifdef DEBUGGING
4156             stop = next - 1;
4157 #endif
4158             n = nnext;
4159             if (stopnow) break;
4160         }
4161
4162 #ifdef EXPERIMENTAL_INPLACESCAN
4163         if (flags && !NEXT_OFF(n)) {
4164             DEBUG_PEEP("atch", val, depth, 0);
4165             if (reg_off_by_arg[OP(n)]) {
4166                 ARG_SET(n, val - n);
4167             }
4168             else {
4169                 NEXT_OFF(n) = val - n;
4170             }
4171             stopnow = 1;
4172         }
4173 #endif
4174     }
4175
4176     /* This temporary node can now be turned into EXACTFU, and must, as
4177      * regexec.c doesn't handle it */
4178     if (OP(scan) == EXACTFU_S_EDGE) {
4179         OP(scan) = EXACTFU;
4180     }
4181
4182     *min_subtract = 0;
4183     *unfolded_multi_char = FALSE;
4184
4185     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
4186      * can now analyze for sequences of problematic code points.  (Prior to
4187      * this final joining, sequences could have been split over boundaries, and
4188      * hence missed).  The sequences only happen in folding, hence for any
4189      * non-EXACT EXACTish node */
4190     if (OP(scan) != EXACT && OP(scan) != EXACT_ONLY8 && OP(scan) != EXACTL) {
4191         U8* s0 = (U8*) STRING(scan);
4192         U8* s = s0;
4193         U8* s_end = s0 + STR_LEN(scan);
4194
4195         int total_count_delta = 0;  /* Total delta number of characters that
4196                                        multi-char folds expand to */
4197
4198         /* One pass is made over the node's string looking for all the
4199          * possibilities.  To avoid some tests in the loop, there are two main
4200          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
4201          * non-UTF-8 */
4202         if (UTF) {
4203             U8* folded = NULL;
4204
4205             if (OP(scan) == EXACTFL) {
4206                 U8 *d;
4207
4208                 /* An EXACTFL node would already have been changed to another
4209                  * node type unless there is at least one character in it that
4210                  * is problematic; likely a character whose fold definition
4211                  * won't be known until runtime, and so has yet to be folded.
4212                  * For all but the UTF-8 locale, folds are 1-1 in length, but
4213                  * to handle the UTF-8 case, we need to create a temporary
4214                  * folded copy using UTF-8 locale rules in order to analyze it.
4215                  * This is because our macros that look to see if a sequence is
4216                  * a multi-char fold assume everything is folded (otherwise the
4217                  * tests in those macros would be too complicated and slow).
4218                  * Note that here, the non-problematic folds will have already
4219                  * been done, so we can just copy such characters.  We actually
4220                  * don't completely fold the EXACTFL string.  We skip the
4221                  * unfolded multi-char folds, as that would just create work
4222                  * below to figure out the size they already are */
4223
4224                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
4225                 d = folded;
4226                 while (s < s_end) {
4227                     STRLEN s_len = UTF8SKIP(s);
4228                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
4229                         Copy(s, d, s_len, U8);
4230                         d += s_len;
4231                     }
4232                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
4233                         *unfolded_multi_char = TRUE;
4234                         Copy(s, d, s_len, U8);
4235                         d += s_len;
4236                     }
4237                     else if (isASCII(*s)) {
4238                         *(d++) = toFOLD(*s);
4239                     }
4240                     else {
4241                         STRLEN len;
4242                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
4243                         d += len;
4244                     }
4245                     s += s_len;
4246                 }
4247
4248                 /* Point the remainder of the routine to look at our temporary
4249                  * folded copy */
4250                 s = folded;
4251                 s_end = d;
4252             } /* End of creating folded copy of EXACTFL string */
4253
4254             /* Examine the string for a multi-character fold sequence.  UTF-8
4255              * patterns have all characters pre-folded by the time this code is
4256              * executed */
4257             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
4258                                      length sequence we are looking for is 2 */
4259             {
4260                 int count = 0;  /* How many characters in a multi-char fold */
4261                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
4262                 if (! len) {    /* Not a multi-char fold: get next char */
4263                     s += UTF8SKIP(s);
4264                     continue;
4265                 }
4266
4267                 { /* Here is a generic multi-char fold. */
4268                     U8* multi_end  = s + len;
4269
4270                     /* Count how many characters are in it.  In the case of
4271                      * /aa, no folds which contain ASCII code points are
4272                      * allowed, so check for those, and skip if found. */
4273                     if (OP(scan) != EXACTFAA && OP(scan) != EXACTFAA_NO_TRIE) {
4274                         count = utf8_length(s, multi_end);
4275                         s = multi_end;
4276                     }
4277                     else {
4278                         while (s < multi_end) {
4279                             if (isASCII(*s)) {
4280                                 s++;
4281                                 goto next_iteration;
4282                             }
4283                             else {
4284                                 s += UTF8SKIP(s);
4285                             }
4286                             count++;
4287                         }
4288                     }
4289                 }
4290
4291                 /* The delta is how long the sequence is minus 1 (1 is how long
4292                  * the character that folds to the sequence is) */
4293                 total_count_delta += count - 1;
4294               next_iteration: ;
4295             }
4296
4297             /* We created a temporary folded copy of the string in EXACTFL
4298              * nodes.  Therefore we need to be sure it doesn't go below zero,
4299              * as the real string could be shorter */
4300             if (OP(scan) == EXACTFL) {
4301                 int total_chars = utf8_length((U8*) STRING(scan),
4302                                            (U8*) STRING(scan) + STR_LEN(scan));
4303                 if (total_count_delta > total_chars) {
4304                     total_count_delta = total_chars;
4305                 }
4306             }
4307
4308             *min_subtract += total_count_delta;
4309             Safefree(folded);
4310         }
4311         else if (OP(scan) == EXACTFAA) {
4312
4313             /* Non-UTF-8 pattern, EXACTFAA node.  There can't be a multi-char
4314              * fold to the ASCII range (and there are no existing ones in the
4315              * upper latin1 range).  But, as outlined in the comments preceding
4316              * this function, we need to flag any occurrences of the sharp s.
4317              * This character forbids trie formation (because of added
4318              * complexity) */
4319 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4320    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4321                                       || UNICODE_DOT_DOT_VERSION > 0)
4322             while (s < s_end) {
4323                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4324                     OP(scan) = EXACTFAA_NO_TRIE;
4325                     *unfolded_multi_char = TRUE;
4326                     break;
4327                 }
4328                 s++;
4329             }
4330         }
4331         else {
4332
4333             /* Non-UTF-8 pattern, not EXACTFAA node.  Look for the multi-char
4334              * folds that are all Latin1.  As explained in the comments
4335              * preceding this function, we look also for the sharp s in EXACTF
4336              * and EXACTFL nodes; it can be in the final position.  Otherwise
4337              * we can stop looking 1 byte earlier because have to find at least
4338              * two characters for a multi-fold */
4339             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4340                               ? s_end
4341                               : s_end -1;
4342
4343             while (s < upper) {
4344                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4345                 if (! len) {    /* Not a multi-char fold. */
4346                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4347                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4348                     {
4349                         *unfolded_multi_char = TRUE;
4350                     }
4351                     s++;
4352                     continue;
4353                 }
4354
4355                 if (len == 2
4356                     && isALPHA_FOLD_EQ(*s, 's')
4357                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4358                 {
4359
4360                     /* EXACTF nodes need to know that the minimum length
4361                      * changed so that a sharp s in the string can match this
4362                      * ss in the pattern, but they remain EXACTF nodes, as they
4363                      * won't match this unless the target string is is UTF-8,
4364                      * which we don't know until runtime.  EXACTFL nodes can't
4365                      * transform into EXACTFU nodes */
4366                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4367                         OP(scan) = EXACTFUP;
4368                     }
4369                 }
4370
4371                 *min_subtract += len - 1;
4372                 s += len;
4373             }
4374 #endif
4375         }
4376
4377         if (     STR_LEN(scan) == 1
4378             &&   isALPHA_A(* STRING(scan))
4379             &&  (         OP(scan) == EXACTFAA
4380                  || (     OP(scan) == EXACTFU
4381                      && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(scan)))))
4382         {
4383             U8 mask = ~ ('A' ^ 'a'); /* These differ in just one bit */
4384
4385             /* Replace a length 1 ASCII fold pair node with an ANYOFM node,
4386              * with the mask set to the complement of the bit that differs
4387              * between upper and lower case, and the lowest code point of the
4388              * pair (which the '&' forces) */
4389             OP(scan) = ANYOFM;
4390             ARG_SET(scan, *STRING(scan) & mask);
4391             FLAGS(scan) = mask;
4392         }
4393     }
4394
4395 #ifdef DEBUGGING
4396     /* Allow dumping but overwriting the collection of skipped
4397      * ops and/or strings with fake optimized ops */
4398     n = scan + NODE_SZ_STR(scan);
4399     while (n <= stop) {
4400         OP(n) = OPTIMIZED;
4401         FLAGS(n) = 0;
4402         NEXT_OFF(n) = 0;
4403         n++;
4404     }
4405 #endif
4406     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl", scan, depth, 0);});
4407     return stopnow;
4408 }
4409
4410 /* REx optimizer.  Converts nodes into quicker variants "in place".
4411    Finds fixed substrings.  */
4412
4413 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4414    to the position after last scanned or to NULL. */
4415
4416 #define INIT_AND_WITHP \
4417     assert(!and_withp); \
4418     Newx(and_withp, 1, regnode_ssc); \
4419     SAVEFREEPV(and_withp)
4420
4421
4422 static void
4423 S_unwind_scan_frames(pTHX_ const void *p)
4424 {
4425     scan_frame *f= (scan_frame *)p;
4426     do {
4427         scan_frame *n= f->next_frame;
4428         Safefree(f);
4429         f= n;
4430     } while (f);
4431 }
4432
4433 /* the return from this sub is the minimum length that could possibly match */
4434 STATIC SSize_t
4435 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4436                         SSize_t *minlenp, SSize_t *deltap,
4437                         regnode *last,
4438                         scan_data_t *data,
4439                         I32 stopparen,
4440                         U32 recursed_depth,
4441                         regnode_ssc *and_withp,
4442                         U32 flags, U32 depth)
4443                         /* scanp: Start here (read-write). */
4444                         /* deltap: Write maxlen-minlen here. */
4445                         /* last: Stop before this one. */
4446                         /* data: string data about the pattern */
4447                         /* stopparen: treat close N as END */
4448                         /* recursed: which subroutines have we recursed into */
4449                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4450 {
4451     dVAR;
4452     /* There must be at least this number of characters to match */
4453     SSize_t min = 0;
4454     I32 pars = 0, code;
4455     regnode *scan = *scanp, *next;
4456     SSize_t delta = 0;
4457     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4458     int is_inf_internal = 0;            /* The studied chunk is infinite */
4459     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4460     scan_data_t data_fake;
4461     SV *re_trie_maxbuff = NULL;
4462     regnode *first_non_open = scan;
4463     SSize_t stopmin = SSize_t_MAX;
4464     scan_frame *frame = NULL;
4465     GET_RE_DEBUG_FLAGS_DECL;
4466
4467     PERL_ARGS_ASSERT_STUDY_CHUNK;
4468     RExC_study_started= 1;
4469
4470     Zero(&data_fake, 1, scan_data_t);
4471
4472     if ( depth == 0 ) {
4473         while (first_non_open && OP(first_non_open) == OPEN)
4474             first_non_open=regnext(first_non_open);
4475     }
4476
4477
4478   fake_study_recurse:
4479     DEBUG_r(
4480         RExC_study_chunk_recursed_count++;
4481     );
4482     DEBUG_OPTIMISE_MORE_r(
4483     {
4484         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4485             depth, (long)stopparen,
4486             (unsigned long)RExC_study_chunk_recursed_count,
4487             (unsigned long)depth, (unsigned long)recursed_depth,
4488             scan,
4489             last);
4490         if (recursed_depth) {
4491             U32 i;
4492             U32 j;
4493             for ( j = 0 ; j < recursed_depth ; j++ ) {
4494                 for ( i = 0 ; i < (U32)RExC_total_parens ; i++ ) {
4495                     if (
4496                         PAREN_TEST(RExC_study_chunk_recursed +
4497                                    ( j * RExC_study_chunk_recursed_bytes), i )
4498                         && (
4499                             !j ||
4500                             !PAREN_TEST(RExC_study_chunk_recursed +
4501                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4502                         )
4503                     ) {
4504                         Perl_re_printf( aTHX_ " %d",(int)i);
4505                         break;
4506                     }
4507                 }
4508                 if ( j + 1 < recursed_depth ) {
4509                     Perl_re_printf( aTHX_  ",");
4510                 }
4511             }
4512         }
4513         Perl_re_printf( aTHX_ "\n");
4514     }
4515     );
4516     while ( scan && OP(scan) != END && scan < last ){
4517         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4518                                    node length to get a real minimum (because
4519                                    the folded version may be shorter) */
4520         bool unfolded_multi_char = FALSE;
4521         /* Peephole optimizer: */
4522         DEBUG_STUDYDATA("Peep", data, depth, is_inf);
4523         DEBUG_PEEP("Peep", scan, depth, flags);
4524
4525
4526         /* The reason we do this here is that we need to deal with things like
4527          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4528          * parsing code, as each (?:..) is handled by a different invocation of
4529          * reg() -- Yves
4530          */
4531         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4532
4533         /* Follow the next-chain of the current node and optimize
4534            away all the NOTHINGs from it.  */
4535         if (OP(scan) != CURLYX) {
4536             const int max = (reg_off_by_arg[OP(scan)]
4537                        ? I32_MAX
4538                        /* I32 may be smaller than U16 on CRAYs! */
4539                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4540             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4541             int noff;
4542             regnode *n = scan;
4543
4544             /* Skip NOTHING and LONGJMP. */
4545             while ((n = regnext(n))
4546                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4547                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4548                    && off + noff < max)
4549                 off += noff;
4550             if (reg_off_by_arg[OP(scan)])
4551                 ARG(scan) = off;
4552             else
4553                 NEXT_OFF(scan) = off;
4554         }
4555
4556         /* The principal pseudo-switch.  Cannot be a switch, since we
4557            look into several different things.  */
4558         if ( OP(scan) == DEFINEP ) {
4559             SSize_t minlen = 0;
4560             SSize_t deltanext = 0;
4561             SSize_t fake_last_close = 0;
4562             I32 f = SCF_IN_DEFINE;
4563
4564             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4565             scan = regnext(scan);
4566             assert( OP(scan) == IFTHEN );
4567             DEBUG_PEEP("expect IFTHEN", scan, depth, flags);
4568
4569             data_fake.last_closep= &fake_last_close;
4570             minlen = *minlenp;
4571             next = regnext(scan);
4572             scan = NEXTOPER(NEXTOPER(scan));
4573             DEBUG_PEEP("scan", scan, depth, flags);
4574             DEBUG_PEEP("next", next, depth, flags);
4575
4576             /* we suppose the run is continuous, last=next...
4577              * NOTE we dont use the return here! */
4578             /* DEFINEP study_chunk() recursion */
4579             (void)study_chunk(pRExC_state, &scan, &minlen,
4580                               &deltanext, next, &data_fake, stopparen,
4581                               recursed_depth, NULL, f, depth+1);
4582
4583             scan = next;
4584         } else
4585         if (
4586             OP(scan) == BRANCH  ||
4587             OP(scan) == BRANCHJ ||
4588             OP(scan) == IFTHEN
4589         ) {
4590             next = regnext(scan);
4591             code = OP(scan);
4592
4593             /* The op(next)==code check below is to see if we
4594              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4595              * IFTHEN is special as it might not appear in pairs.
4596              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4597              * we dont handle it cleanly. */
4598             if (OP(next) == code || code == IFTHEN) {
4599                 /* NOTE - There is similar code to this block below for
4600                  * handling TRIE nodes on a re-study.  If you change stuff here
4601                  * check there too. */
4602                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4603                 regnode_ssc accum;
4604                 regnode * const startbranch=scan;
4605
4606                 if (flags & SCF_DO_SUBSTR) {
4607                     /* Cannot merge strings after this. */
4608                     scan_commit(pRExC_state, data, minlenp, is_inf);
4609                 }
4610
4611                 if (flags & SCF_DO_STCLASS)
4612                     ssc_init_zero(pRExC_state, &accum);
4613
4614                 while (OP(scan) == code) {
4615                     SSize_t deltanext, minnext, fake;
4616                     I32 f = 0;
4617                     regnode_ssc this_class;
4618
4619                     DEBUG_PEEP("Branch", scan, depth, flags);
4620
4621                     num++;
4622                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4623                     if (data) {
4624                         data_fake.whilem_c = data->whilem_c;
4625                         data_fake.last_closep = data->last_closep;
4626                     }
4627                     else
4628                         data_fake.last_closep = &fake;
4629
4630                     data_fake.pos_delta = delta;
4631                     next = regnext(scan);
4632
4633                     scan = NEXTOPER(scan); /* everything */
4634                     if (code != BRANCH)    /* everything but BRANCH */
4635                         scan = NEXTOPER(scan);
4636
4637                     if (flags & SCF_DO_STCLASS) {
4638                         ssc_init(pRExC_state, &this_class);
4639                         data_fake.start_class = &this_class;
4640                         f = SCF_DO_STCLASS_AND;
4641                     }
4642                     if (flags & SCF_WHILEM_VISITED_POS)
4643                         f |= SCF_WHILEM_VISITED_POS;
4644
4645                     /* we suppose the run is continuous, last=next...*/
4646                     /* recurse study_chunk() for each BRANCH in an alternation */
4647                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4648                                       &deltanext, next, &data_fake, stopparen,
4649                                       recursed_depth, NULL, f, depth+1);
4650
4651                     if (min1 > minnext)
4652                         min1 = minnext;
4653                     if (deltanext == SSize_t_MAX) {
4654                         is_inf = is_inf_internal = 1;
4655                         max1 = SSize_t_MAX;
4656                     } else if (max1 < minnext + deltanext)
4657                         max1 = minnext + deltanext;
4658                     scan = next;
4659                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4660                         pars++;
4661                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4662                         if ( stopmin > minnext)
4663                             stopmin = min + min1;
4664                         flags &= ~SCF_DO_SUBSTR;
4665                         if (data)
4666                             data->flags |= SCF_SEEN_ACCEPT;
4667                     }
4668                     if (data) {
4669                         if (data_fake.flags & SF_HAS_EVAL)
4670                             data->flags |= SF_HAS_EVAL;
4671                         data->whilem_c = data_fake.whilem_c;
4672                     }
4673                     if (flags & SCF_DO_STCLASS)
4674                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4675                 }
4676                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4677                     min1 = 0;
4678                 if (flags & SCF_DO_SUBSTR) {
4679                     data->pos_min += min1;
4680                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4681                         data->pos_delta = SSize_t_MAX;
4682                     else
4683                         data->pos_delta += max1 - min1;
4684                     if (max1 != min1 || is_inf)
4685                         data->cur_is_floating = 1;
4686                 }
4687                 min += min1;
4688                 if (delta == SSize_t_MAX
4689                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4690                     delta = SSize_t_MAX;
4691                 else
4692                     delta += max1 - min1;
4693                 if (flags & SCF_DO_STCLASS_OR) {
4694                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4695                     if (min1) {
4696                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4697                         flags &= ~SCF_DO_STCLASS;
4698                     }
4699                 }
4700                 else if (flags & SCF_DO_STCLASS_AND) {
4701                     if (min1) {
4702                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4703                         flags &= ~SCF_DO_STCLASS;
4704                     }
4705                     else {
4706                         /* Switch to OR mode: cache the old value of
4707                          * data->start_class */
4708                         INIT_AND_WITHP;
4709                         StructCopy(data->start_class, and_withp, regnode_ssc);
4710                         flags &= ~SCF_DO_STCLASS_AND;
4711                         StructCopy(&accum, data->start_class, regnode_ssc);
4712                         flags |= SCF_DO_STCLASS_OR;
4713                     }
4714                 }
4715
4716                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4717                         OP( startbranch ) == BRANCH )
4718                 {
4719                 /* demq.
4720
4721                    Assuming this was/is a branch we are dealing with: 'scan'
4722                    now points at the item that follows the branch sequence,
4723                    whatever it is. We now start at the beginning of the
4724                    sequence and look for subsequences of
4725
4726                    BRANCH->EXACT=>x1
4727                    BRANCH->EXACT=>x2
4728                    tail
4729
4730                    which would be constructed from a pattern like
4731                    /A|LIST|OF|WORDS/
4732
4733                    If we can find such a subsequence we need to turn the first
4734                    element into a trie and then add the subsequent branch exact
4735                    strings to the trie.
4736
4737                    We have two cases
4738
4739                      1. patterns where the whole set of branches can be
4740                         converted.
4741
4742                      2. patterns where only a subset can be converted.
4743
4744                    In case 1 we can replace the whole set with a single regop
4745                    for the trie. In case 2 we need to keep the start and end
4746                    branches so
4747
4748                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4749                      becomes BRANCH TRIE; BRANCH X;
4750
4751                   There is an additional case, that being where there is a
4752                   common prefix, which gets split out into an EXACT like node
4753                   preceding the TRIE node.
4754
4755                   If x(1..n)==tail then we can do a simple trie, if not we make
4756                   a "jump" trie, such that when we match the appropriate word
4757                   we "jump" to the appropriate tail node. Essentially we turn
4758                   a nested if into a case structure of sorts.
4759
4760                 */
4761
4762                     int made=0;
4763                     if (!re_trie_maxbuff) {
4764                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4765                         if (!SvIOK(re_trie_maxbuff))
4766                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4767                     }
4768                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4769                         regnode *cur;
4770                         regnode *first = (regnode *)NULL;
4771                         regnode *last = (regnode *)NULL;
4772                         regnode *tail = scan;
4773                         U8 trietype = 0;
4774                         U32 count=0;
4775
4776                         /* var tail is used because there may be a TAIL
4777                            regop in the way. Ie, the exacts will point to the
4778                            thing following the TAIL, but the last branch will
4779                            point at the TAIL. So we advance tail. If we
4780                            have nested (?:) we may have to move through several
4781                            tails.
4782                          */
4783
4784                         while ( OP( tail ) == TAIL ) {
4785                             /* this is the TAIL generated by (?:) */
4786                             tail = regnext( tail );
4787                         }
4788
4789
4790                         DEBUG_TRIE_COMPILE_r({
4791                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4792                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4793                               depth+1,
4794                               "Looking for TRIE'able sequences. Tail node is ",
4795                               (UV) REGNODE_OFFSET(tail),
4796                               SvPV_nolen_const( RExC_mysv )
4797                             );
4798                         });
4799
4800                         /*
4801
4802                             Step through the branches
4803                                 cur represents each branch,
4804                                 noper is the first thing to be matched as part
4805                                       of that branch
4806                                 noper_next is the regnext() of that node.
4807
4808                             We normally handle a case like this
4809                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4810                             support building with NOJUMPTRIE, which restricts
4811                             the trie logic to structures like /FOO|BAR/.
4812
4813                             If noper is a trieable nodetype then the branch is
4814                             a possible optimization target. If we are building
4815                             under NOJUMPTRIE then we require that noper_next is
4816                             the same as scan (our current position in the regex
4817                             program).
4818
4819                             Once we have two or more consecutive such branches
4820                             we can create a trie of the EXACT's contents and
4821                             stitch it in place into the program.
4822
4823                             If the sequence represents all of the branches in
4824                             the alternation we replace the entire thing with a
4825                             single TRIE node.
4826
4827                             Otherwise when it is a subsequence we need to
4828                             stitch it in place and replace only the relevant
4829                             branches. This means the first branch has to remain
4830                             as it is used by the alternation logic, and its
4831                             next pointer, and needs to be repointed at the item
4832                             on the branch chain following the last branch we
4833                             have optimized away.
4834
4835                             This could be either a BRANCH, in which case the
4836                             subsequence is internal, or it could be the item
4837                             following the branch sequence in which case the
4838                             subsequence is at the end (which does not
4839                             necessarily mean the first node is the start of the
4840                             alternation).
4841
4842                             TRIE_TYPE(X) is a define which maps the optype to a
4843                             trietype.
4844
4845                                 optype          |  trietype
4846                                 ----------------+-----------
4847                                 NOTHING         | NOTHING
4848                                 EXACT           | EXACT
4849                                 EXACT_ONLY8     | EXACT
4850                                 EXACTFU         | EXACTFU
4851                                 EXACTFU_ONLY8   | EXACTFU
4852                                 EXACTFUP        | EXACTFU
4853                                 EXACTFAA        | EXACTFAA
4854                                 EXACTL          | EXACTL
4855                                 EXACTFLU8       | EXACTFLU8
4856
4857
4858                         */
4859 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4860                        ? NOTHING                                            \
4861                        : ( EXACT == (X) || EXACT_ONLY8 == (X) )             \
4862                          ? EXACT                                            \
4863                          : (     EXACTFU == (X)                             \
4864                               || EXACTFU_ONLY8 == (X)                       \
4865                               || EXACTFUP == (X) )                          \
4866                            ? EXACTFU                                        \
4867                            : ( EXACTFAA == (X) )                            \
4868                              ? EXACTFAA                                     \
4869                              : ( EXACTL == (X) )                            \
4870                                ? EXACTL                                     \
4871                                : ( EXACTFLU8 == (X) )                       \
4872                                  ? EXACTFLU8                                \
4873                                  : 0 )
4874
4875                         /* dont use tail as the end marker for this traverse */
4876                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4877                             regnode * const noper = NEXTOPER( cur );
4878                             U8 noper_type = OP( noper );
4879                             U8 noper_trietype = TRIE_TYPE( noper_type );
4880 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4881                             regnode * const noper_next = regnext( noper );
4882                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4883                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4884 #endif
4885
4886                             DEBUG_TRIE_COMPILE_r({
4887                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4888                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4889                                    depth+1,
4890                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4891
4892                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4893                                 Perl_re_printf( aTHX_  " -> %d:%s",
4894                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4895
4896                                 if ( noper_next ) {
4897                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4898                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4899                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4900                                 }
4901                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4902                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4903                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4904                                 );
4905                             });
4906
4907                             /* Is noper a trieable nodetype that can be merged
4908                              * with the current trie (if there is one)? */
4909                             if ( noper_trietype
4910                                   &&
4911                                   (
4912                                         ( noper_trietype == NOTHING )
4913                                         || ( trietype == NOTHING )
4914                                         || ( trietype == noper_trietype )
4915                                   )
4916 #ifdef NOJUMPTRIE
4917                                   && noper_next >= tail
4918 #endif
4919                                   && count < U16_MAX)
4920                             {
4921                                 /* Handle mergable triable node Either we are
4922                                  * the first node in a new trieable sequence,
4923                                  * in which case we do some bookkeeping,
4924                                  * otherwise we update the end pointer. */
4925                                 if ( !first ) {
4926                                     first = cur;
4927                                     if ( noper_trietype == NOTHING ) {
4928 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4929                                         regnode * const noper_next = regnext( noper );
4930                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4931                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4932 #endif
4933
4934                                         if ( noper_next_trietype ) {
4935                                             trietype = noper_next_trietype;
4936                                         } else if (noper_next_type)  {
4937                                             /* a NOTHING regop is 1 regop wide.
4938                                              * We need at least two for a trie
4939                                              * so we can't merge this in */
4940                                             first = NULL;
4941                                         }
4942                                     } else {
4943                                         trietype = noper_trietype;
4944                                     }
4945                                 } else {
4946                                     if ( trietype == NOTHING )
4947                                         trietype = noper_trietype;
4948                                     last = cur;
4949                                 }
4950                                 if (first)
4951                                     count++;
4952                             } /* end handle mergable triable node */
4953                             else {
4954                                 /* handle unmergable node -
4955                                  * noper may either be a triable node which can
4956                                  * not be tried together with the current trie,
4957                                  * or a non triable node */
4958                                 if ( last ) {
4959                                     /* If last is set and trietype is not
4960                                      * NOTHING then we have found at least two
4961                                      * triable branch sequences in a row of a
4962                                      * similar trietype so we can turn them
4963                                      * into a trie. If/when we allow NOTHING to
4964                                      * start a trie sequence this condition
4965                                      * will be required, and it isn't expensive
4966                                      * so we leave it in for now. */
4967                                     if ( trietype && trietype != NOTHING )
4968                                         make_trie( pRExC_state,
4969                                                 startbranch, first, cur, tail,
4970                                                 count, trietype, depth+1 );
4971                                     last = NULL; /* note: we clear/update
4972                                                     first, trietype etc below,
4973                                                     so we dont do it here */
4974                                 }
4975                                 if ( noper_trietype
4976 #ifdef NOJUMPTRIE
4977                                      && noper_next >= tail
4978 #endif
4979                                 ){
4980                                     /* noper is triable, so we can start a new
4981                                      * trie sequence */
4982                                     count = 1;
4983                                     first = cur;
4984                                     trietype = noper_trietype;
4985                                 } else if (first) {
4986                                     /* if we already saw a first but the
4987                                      * current node is not triable then we have
4988                                      * to reset the first information. */
4989                                     count = 0;
4990                                     first = NULL;
4991                                     trietype = 0;
4992                                 }
4993                             } /* end handle unmergable node */
4994                         } /* loop over branches */
4995                         DEBUG_TRIE_COMPILE_r({
4996                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4997                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4998                               depth+1, SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
4999                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
5000                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
5001                                PL_reg_name[trietype]
5002                             );
5003
5004                         });
5005                         if ( last && trietype ) {
5006                             if ( trietype != NOTHING ) {
5007                                 /* the last branch of the sequence was part of
5008                                  * a trie, so we have to construct it here
5009                                  * outside of the loop */
5010                                 made= make_trie( pRExC_state, startbranch,
5011                                                  first, scan, tail, count,
5012                                                  trietype, depth+1 );
5013 #ifdef TRIE_STUDY_OPT
5014                                 if ( ((made == MADE_EXACT_TRIE &&
5015                                      startbranch == first)
5016                                      || ( first_non_open == first )) &&
5017                                      depth==0 ) {
5018                                     flags |= SCF_TRIE_RESTUDY;
5019                                     if ( startbranch == first
5020                                          && scan >= tail )
5021                                     {
5022                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
5023                                     }
5024                                 }
5025 #endif
5026                             } else {
5027                                 /* at this point we know whatever we have is a
5028                                  * NOTHING sequence/branch AND if 'startbranch'
5029                                  * is 'first' then we can turn the whole thing
5030                                  * into a NOTHING
5031                                  */
5032                                 if ( startbranch == first ) {
5033                                     regnode *opt;
5034                                     /* the entire thing is a NOTHING sequence,
5035                                      * something like this: (?:|) So we can
5036                                      * turn it into a plain NOTHING op. */
5037                                     DEBUG_TRIE_COMPILE_r({
5038                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
5039                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
5040                                           depth+1,
5041                                           SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur));
5042
5043                                     });
5044                                     OP(startbranch)= NOTHING;
5045                                     NEXT_OFF(startbranch)= tail - startbranch;
5046                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
5047                                         OP(opt)= OPTIMIZED;
5048                                 }
5049                             }
5050                         } /* end if ( last) */
5051                     } /* TRIE_MAXBUF is non zero */
5052
5053                 } /* do trie */
5054
5055             }
5056             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
5057                 scan = NEXTOPER(NEXTOPER(scan));
5058             } else                      /* single branch is optimized. */
5059                 scan = NEXTOPER(scan);
5060             continue;
5061         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
5062             I32 paren = 0;
5063             regnode *start = NULL;
5064             regnode *end = NULL;
5065             U32 my_recursed_depth= recursed_depth;
5066
5067             if (OP(scan) != SUSPEND) { /* GOSUB */
5068                 /* Do setup, note this code has side effects beyond
5069                  * the rest of this block. Specifically setting
5070                  * RExC_recurse[] must happen at least once during
5071                  * study_chunk(). */
5072                 paren = ARG(scan);
5073                 RExC_recurse[ARG2L(scan)] = scan;
5074                 start = REGNODE_p(RExC_open_parens[paren]);
5075                 end   = REGNODE_p(RExC_close_parens[paren]);
5076
5077                 /* NOTE we MUST always execute the above code, even
5078                  * if we do nothing with a GOSUB */
5079                 if (
5080                     ( flags & SCF_IN_DEFINE )
5081                     ||
5082                     (
5083                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
5084                         &&
5085                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
5086                     )
5087                 ) {
5088                     /* no need to do anything here if we are in a define. */
5089                     /* or we are after some kind of infinite construct
5090                      * so we can skip recursing into this item.
5091                      * Since it is infinite we will not change the maxlen
5092                      * or delta, and if we miss something that might raise
5093                      * the minlen it will merely pessimise a little.
5094                      *
5095                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
5096                      * might result in a minlen of 1 and not of 4,
5097                      * but this doesn't make us mismatch, just try a bit
5098                      * harder than we should.
5099                      * */
5100                     scan= regnext(scan);
5101                     continue;
5102                 }
5103
5104                 if (
5105                     !recursed_depth
5106                     ||
5107                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
5108                 ) {
5109                     /* it is quite possible that there are more efficient ways
5110                      * to do this. We maintain a bitmap per level of recursion
5111                      * of which patterns we have entered so we can detect if a
5112                      * pattern creates a possible infinite loop. When we
5113                      * recurse down a level we copy the previous levels bitmap
5114                      * down. When we are at recursion level 0 we zero the top
5115                      * level bitmap. It would be nice to implement a different
5116                      * more efficient way of doing this. In particular the top
5117                      * level bitmap may be unnecessary.
5118                      */
5119                     if (!recursed_depth) {
5120                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
5121                     } else {
5122                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
5123                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
5124                              RExC_study_chunk_recursed_bytes, U8);
5125                     }
5126                     /* we havent recursed into this paren yet, so recurse into it */
5127                     DEBUG_STUDYDATA("gosub-set", data, depth, is_inf);
5128                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
5129                     my_recursed_depth= recursed_depth + 1;
5130                 } else {
5131                     DEBUG_STUDYDATA("gosub-inf", data, depth, is_inf);
5132                     /* some form of infinite recursion, assume infinite length
5133                      * */
5134                     if (flags & SCF_DO_SUBSTR) {
5135                         scan_commit(pRExC_state, data, minlenp, is_inf);
5136                         data->cur_is_floating = 1;
5137                     }
5138                     is_inf = is_inf_internal = 1;
5139                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5140                         ssc_anything(data->start_class);
5141                     flags &= ~SCF_DO_STCLASS;
5142
5143                     start= NULL; /* reset start so we dont recurse later on. */
5144                 }
5145             } else {
5146                 paren = stopparen;
5147                 start = scan + 2;
5148                 end = regnext(scan);
5149             }
5150             if (start) {
5151                 scan_frame *newframe;
5152                 assert(end);
5153                 if (!RExC_frame_last) {
5154                     Newxz(newframe, 1, scan_frame);
5155                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
5156                     RExC_frame_head= newframe;
5157                     RExC_frame_count++;
5158                 } else if (!RExC_frame_last->next_frame) {
5159                     Newxz(newframe, 1, scan_frame);
5160                     RExC_frame_last->next_frame= newframe;
5161                     newframe->prev_frame= RExC_frame_last;
5162                     RExC_frame_count++;
5163                 } else {
5164                     newframe= RExC_frame_last->next_frame;
5165                 }
5166                 RExC_frame_last= newframe;
5167
5168                 newframe->next_regnode = regnext(scan);
5169                 newframe->last_regnode = last;
5170                 newframe->stopparen = stopparen;
5171                 newframe->prev_recursed_depth = recursed_depth;
5172                 newframe->this_prev_frame= frame;
5173
5174                 DEBUG_STUDYDATA("frame-new", data, depth, is_inf);
5175                 DEBUG_PEEP("fnew", scan, depth, flags);
5176
5177                 frame = newframe;
5178                 scan =  start;
5179                 stopparen = paren;
5180                 last = end;
5181                 depth = depth + 1;
5182                 recursed_depth= my_recursed_depth;
5183
5184                 continue;
5185             }
5186         }
5187         else if (   OP(scan) == EXACT
5188                  || OP(scan) == EXACT_ONLY8
5189                  || OP(scan) == EXACTL)
5190         {
5191             SSize_t l = STR_LEN(scan);
5192             UV uc;
5193             assert(l);
5194             if (UTF) {
5195                 const U8 * const s = (U8*)STRING(scan);
5196                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
5197                 l = utf8_length(s, s + l);
5198             } else {
5199                 uc = *((U8*)STRING(scan));
5200             }
5201             min += l;
5202             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
5203                 /* The code below prefers earlier match for fixed
5204                    offset, later match for variable offset.  */
5205                 if (data->last_end == -1) { /* Update the start info. */
5206                     data->last_start_min = data->pos_min;
5207                     data->last_start_max = is_inf
5208                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
5209                 }
5210                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
5211                 if (UTF)
5212                     SvUTF8_on(data->last_found);
5213                 {
5214                     SV * const sv = data->last_found;
5215                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5216                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5217                     if (mg && mg->mg_len >= 0)
5218                         mg->mg_len += utf8_length((U8*)STRING(scan),
5219                                               (U8*)STRING(scan)+STR_LEN(scan));
5220                 }
5221                 data->last_end = data->pos_min + l;
5222                 data->pos_min += l; /* As in the first entry. */
5223                 data->flags &= ~SF_BEFORE_EOL;
5224             }
5225
5226             /* ANDing the code point leaves at most it, and not in locale, and
5227              * can't match null string */
5228             if (flags & SCF_DO_STCLASS_AND) {
5229                 ssc_cp_and(data->start_class, uc);
5230                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5231                 ssc_clear_locale(data->start_class);
5232             }
5233             else if (flags & SCF_DO_STCLASS_OR) {
5234                 ssc_add_cp(data->start_class, uc);
5235                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5236
5237                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5238                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5239             }
5240             flags &= ~SCF_DO_STCLASS;
5241         }
5242         else if (PL_regkind[OP(scan)] == EXACT) {
5243             /* But OP != EXACT!, so is EXACTFish */
5244             SSize_t l = STR_LEN(scan);
5245             const U8 * s = (U8*)STRING(scan);
5246
5247             /* Search for fixed substrings supports EXACT only. */
5248             if (flags & SCF_DO_SUBSTR) {
5249                 assert(data);
5250                 scan_commit(pRExC_state, data, minlenp, is_inf);
5251             }
5252             if (UTF) {
5253                 l = utf8_length(s, s + l);
5254             }
5255             if (unfolded_multi_char) {
5256                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
5257             }
5258             min += l - min_subtract;
5259             assert (min >= 0);
5260             delta += min_subtract;
5261             if (flags & SCF_DO_SUBSTR) {
5262                 data->pos_min += l - min_subtract;
5263                 if (data->pos_min < 0) {
5264                     data->pos_min = 0;
5265                 }
5266                 data->pos_delta += min_subtract;
5267                 if (min_subtract) {
5268                     data->cur_is_floating = 1; /* float */
5269                 }
5270             }
5271
5272             if (flags & SCF_DO_STCLASS) {
5273                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
5274
5275                 assert(EXACTF_invlist);
5276                 if (flags & SCF_DO_STCLASS_AND) {
5277                     if (OP(scan) != EXACTFL)
5278                         ssc_clear_locale(data->start_class);
5279                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5280                     ANYOF_POSIXL_ZERO(data->start_class);
5281                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
5282                 }
5283                 else {  /* SCF_DO_STCLASS_OR */
5284                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
5285                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5286
5287                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5288                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5289                 }
5290                 flags &= ~SCF_DO_STCLASS;
5291                 SvREFCNT_dec(EXACTF_invlist);
5292             }
5293         }
5294         else if (REGNODE_VARIES(OP(scan))) {
5295             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
5296             I32 fl = 0, f = flags;
5297             regnode * const oscan = scan;
5298             regnode_ssc this_class;
5299             regnode_ssc *oclass = NULL;
5300             I32 next_is_eval = 0;
5301
5302             switch (PL_regkind[OP(scan)]) {
5303             case WHILEM:                /* End of (?:...)* . */
5304                 scan = NEXTOPER(scan);
5305                 goto finish;
5306             case PLUS:
5307                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
5308                     next = NEXTOPER(scan);
5309                     if (   OP(next) == EXACT
5310                         || OP(next) == EXACT_ONLY8
5311                         || OP(next) == EXACTL
5312                         || (flags & SCF_DO_STCLASS))
5313                     {
5314                         mincount = 1;
5315                         maxcount = REG_INFTY;
5316                         next = regnext(scan);
5317                         scan = NEXTOPER(scan);
5318                         goto do_curly;
5319                     }
5320                 }
5321                 if (flags & SCF_DO_SUBSTR)
5322                     data->pos_min++;
5323                 min++;
5324                 /* FALLTHROUGH */
5325             case STAR:
5326                 next = NEXTOPER(scan);
5327
5328                 /* This temporary node can now be turned into EXACTFU, and
5329                  * must, as regexec.c doesn't handle it */
5330                 if (OP(next) == EXACTFU_S_EDGE) {
5331                     OP(next) = EXACTFU;
5332                 }
5333
5334                 if (     STR_LEN(next) == 1
5335                     &&   isALPHA_A(* STRING(next))
5336                     && (         OP(next) == EXACTFAA
5337                         || (     OP(next) == EXACTFU
5338                             && ! HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(* STRING(next)))))
5339                 {
5340                     /* These differ in just one bit */
5341                     U8 mask = ~ ('A' ^ 'a');
5342
5343                     assert(isALPHA_A(* STRING(next)));
5344
5345                     /* Then replace it by an ANYOFM node, with
5346                     * the mask set to the complement of the
5347                     * bit that differs between upper and lower
5348                     * case, and the lowest code point of the
5349                     * pair (which the '&' forces) */
5350                     OP(next) = ANYOFM;
5351                     ARG_SET(next, *STRING(next) & mask);
5352                     FLAGS(next) = mask;
5353                 }
5354
5355                 if (flags & SCF_DO_STCLASS) {
5356                     mincount = 0;
5357                     maxcount = REG_INFTY;
5358                     next = regnext(scan);
5359                     scan = NEXTOPER(scan);
5360                     goto do_curly;
5361                 }
5362                 if (flags & SCF_DO_SUBSTR) {
5363                     scan_commit(pRExC_state, data, minlenp, is_inf);
5364                     /* Cannot extend fixed substrings */
5365                     data->cur_is_floating = 1; /* float */
5366                 }
5367                 is_inf = is_inf_internal = 1;
5368                 scan = regnext(scan);
5369                 goto optimize_curly_tail;
5370             case CURLY:
5371                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
5372                     && (scan->flags == stopparen))
5373                 {
5374                     mincount = 1;
5375                     maxcount = 1;
5376                 } else {
5377                     mincount = ARG1(scan);
5378                     maxcount = ARG2(scan);
5379                 }
5380                 next = regnext(scan);
5381                 if (OP(scan) == CURLYX) {
5382                     I32 lp = (data ? *(data->last_closep) : 0);
5383                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5384                 }
5385                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5386                 next_is_eval = (OP(scan) == EVAL);
5387               do_curly:
5388                 if (flags & SCF_DO_SUBSTR) {
5389                     if (mincount == 0)
5390                         scan_commit(pRExC_state, data, minlenp, is_inf);
5391                     /* Cannot extend fixed substrings */
5392                     pos_before = data->pos_min;
5393                 }
5394                 if (data) {
5395                     fl = data->flags;
5396                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5397                     if (is_inf)
5398                         data->flags |= SF_IS_INF;
5399                 }
5400                 if (flags & SCF_DO_STCLASS) {
5401                     ssc_init(pRExC_state, &this_class);
5402                     oclass = data->start_class;
5403                     data->start_class = &this_class;
5404                     f |= SCF_DO_STCLASS_AND;
5405                     f &= ~SCF_DO_STCLASS_OR;
5406                 }
5407                 /* Exclude from super-linear cache processing any {n,m}
5408                    regops for which the combination of input pos and regex
5409                    pos is not enough information to determine if a match
5410                    will be possible.
5411
5412                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5413                    regex pos at the \s*, the prospects for a match depend not
5414                    only on the input position but also on how many (bar\s*)
5415                    repeats into the {4,8} we are. */
5416                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5417                     f &= ~SCF_WHILEM_VISITED_POS;
5418
5419                 /* This will finish on WHILEM, setting scan, or on NULL: */
5420                 /* recurse study_chunk() on loop bodies */
5421                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5422                                   last, data, stopparen, recursed_depth, NULL,
5423                                   (mincount == 0
5424                                    ? (f & ~SCF_DO_SUBSTR)
5425                                    : f)
5426                                   ,depth+1);
5427
5428                 if (flags & SCF_DO_STCLASS)
5429                     data->start_class = oclass;
5430                 if (mincount == 0 || minnext == 0) {
5431                     if (flags & SCF_DO_STCLASS_OR) {
5432                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5433                     }
5434                     else if (flags & SCF_DO_STCLASS_AND) {
5435                         /* Switch to OR mode: cache the old value of
5436                          * data->start_class */
5437                         INIT_AND_WITHP;
5438                         StructCopy(data->start_class, and_withp, regnode_ssc);
5439                         flags &= ~SCF_DO_STCLASS_AND;
5440                         StructCopy(&this_class, data->start_class, regnode_ssc);
5441                         flags |= SCF_DO_STCLASS_OR;
5442                         ANYOF_FLAGS(data->start_class)
5443                                                 |= SSC_MATCHES_EMPTY_STRING;
5444                     }
5445                 } else {                /* Non-zero len */
5446                     if (flags & SCF_DO_STCLASS_OR) {
5447                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5448                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5449                     }
5450                     else if (flags & SCF_DO_STCLASS_AND)
5451                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5452                     flags &= ~SCF_DO_STCLASS;
5453                 }
5454                 if (!scan)              /* It was not CURLYX, but CURLY. */
5455                     scan = next;
5456                 if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR)
5457                     /* ? quantifier ok, except for (?{ ... }) */
5458                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5459                     && (minnext == 0) && (deltanext == 0)
5460                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5461                     && maxcount <= REG_INFTY/3) /* Complement check for big
5462                                                    count */
5463                 {
5464                     _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP),
5465                         Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5466                             "Quantifier unexpected on zero-length expression "
5467                             "in regex m/%" UTF8f "/",
5468                              UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5469                                   RExC_precomp)));
5470                 }
5471
5472                 min += minnext * mincount;
5473                 is_inf_internal |= deltanext == SSize_t_MAX
5474                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5475                 is_inf |= is_inf_internal;
5476                 if (is_inf) {
5477                     delta = SSize_t_MAX;
5478                 } else {
5479                     delta += (minnext + deltanext) * maxcount
5480                              - minnext * mincount;
5481                 }
5482                 /* Try powerful optimization CURLYX => CURLYN. */
5483                 if (  OP(oscan) == CURLYX && data
5484                       && data->flags & SF_IN_PAR
5485                       && !(data->flags & SF_HAS_EVAL)
5486                       && !deltanext && minnext == 1 ) {
5487                     /* Try to optimize to CURLYN.  */
5488                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5489                     regnode * const nxt1 = nxt;
5490 #ifdef DEBUGGING
5491                     regnode *nxt2;
5492 #endif
5493
5494                     /* Skip open. */
5495                     nxt = regnext(nxt);
5496                     if (!REGNODE_SIMPLE(OP(nxt))
5497                         && !(PL_regkind[OP(nxt)] == EXACT
5498                              && STR_LEN(nxt) == 1))
5499                         goto nogo;
5500 #ifdef DEBUGGING
5501                     nxt2 = nxt;
5502 #endif
5503                     nxt = regnext(nxt);
5504                     if (OP(nxt) != CLOSE)
5505                         goto nogo;
5506                     if (RExC_open_parens) {
5507
5508                         /*open->CURLYM*/
5509                         RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5510
5511                         /*close->while*/
5512                         RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2;
5513                     }
5514                     /* Now we know that nxt2 is the only contents: */
5515                     oscan->flags = (U8)ARG(nxt);
5516                     OP(oscan) = CURLYN;
5517                     OP(nxt1) = NOTHING; /* was OPEN. */
5518
5519 #ifdef DEBUGGING
5520                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5521                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5522                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5523                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5524                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5525                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5526 #endif
5527                 }
5528               nogo:
5529
5530                 /* Try optimization CURLYX => CURLYM. */
5531                 if (  OP(oscan) == CURLYX && data
5532                       && !(data->flags & SF_HAS_PAR)
5533                       && !(data->flags & SF_HAS_EVAL)
5534                       && !deltanext     /* atom is fixed width */
5535                       && minnext != 0   /* CURLYM can't handle zero width */
5536
5537                          /* Nor characters whose fold at run-time may be
5538                           * multi-character */
5539                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5540                 ) {
5541                     /* XXXX How to optimize if data == 0? */
5542                     /* Optimize to a simpler form.  */
5543                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5544                     regnode *nxt2;
5545
5546                     OP(oscan) = CURLYM;
5547                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5548                             && (OP(nxt2) != WHILEM))
5549                         nxt = nxt2;
5550                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5551                     /* Need to optimize away parenths. */
5552                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5553                         /* Set the parenth number.  */
5554                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5555
5556                         oscan->flags = (U8)ARG(nxt);
5557                         if (RExC_open_parens) {
5558                              /*open->CURLYM*/
5559                             RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan);
5560
5561                             /*close->NOTHING*/
5562                             RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2)
5563                                                          + 1;
5564                         }
5565                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5566                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5567
5568 #ifdef DEBUGGING
5569                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5570                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5571                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5572                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5573 #endif
5574 #if 0
5575                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5576                             regnode *nnxt = regnext(nxt1);
5577                             if (nnxt == nxt) {
5578                                 if (reg_off_by_arg[OP(nxt1)])
5579                                     ARG_SET(nxt1, nxt2 - nxt1);
5580                                 else if (nxt2 - nxt1 < U16_MAX)
5581                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5582                                 else
5583                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5584                             }
5585                             nxt1 = nnxt;
5586                         }
5587 #endif
5588                         /* Optimize again: */
5589                         /* recurse study_chunk() on optimised CURLYX => CURLYM */
5590                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5591                                     NULL, stopparen, recursed_depth, NULL, 0,
5592                                     depth+1);
5593                     }
5594                     else
5595                         oscan->flags = 0;
5596                 }
5597                 else if ((OP(oscan) == CURLYX)
5598                          && (flags & SCF_WHILEM_VISITED_POS)
5599                          /* See the comment on a similar expression above.
5600                             However, this time it's not a subexpression
5601                             we care about, but the expression itself. */
5602                          && (maxcount == REG_INFTY)
5603                          && data) {
5604                     /* This stays as CURLYX, we can put the count/of pair. */
5605                     /* Find WHILEM (as in regexec.c) */
5606                     regnode *nxt = oscan + NEXT_OFF(oscan);
5607
5608                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5609                         nxt += ARG(nxt);
5610                     nxt = PREVOPER(nxt);
5611                     if (nxt->flags & 0xf) {
5612                         /* we've already set whilem count on this node */
5613                     } else if (++data->whilem_c < 16) {
5614                         assert(data->whilem_c <= RExC_whilem_seen);
5615                         nxt->flags = (U8)(data->whilem_c
5616                             | (RExC_whilem_seen << 4)); /* On WHILEM */
5617                     }
5618                 }
5619                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5620                     pars++;
5621                 if (flags & SCF_DO_SUBSTR) {
5622                     SV *last_str = NULL;
5623                     STRLEN last_chrs = 0;
5624                     int counted = mincount != 0;
5625
5626                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5627                                                                   string. */
5628                         SSize_t b = pos_before >= data->last_start_min
5629                             ? pos_before : data->last_start_min;
5630                         STRLEN l;
5631                         const char * const s = SvPV_const(data->last_found, l);
5632                         SSize_t old = b - data->last_start_min;
5633                         assert(old >= 0);
5634
5635                         if (UTF)
5636                             old = utf8_hop_forward((U8*)s, old,
5637                                                (U8 *) SvEND(data->last_found))
5638                                 - (U8*)s;
5639                         l -= old;
5640                         /* Get the added string: */
5641                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5642                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5643                                             (U8*)(s + old + l)) : l;
5644                         if (deltanext == 0 && pos_before == b) {
5645                             /* What was added is a constant string */
5646                             if (mincount > 1) {
5647
5648                                 SvGROW(last_str, (mincount * l) + 1);
5649                                 repeatcpy(SvPVX(last_str) + l,
5650                                           SvPVX_const(last_str), l,
5651                                           mincount - 1);
5652                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5653                                 /* Add additional parts. */
5654                                 SvCUR_set(data->last_found,
5655                                           SvCUR(data->last_found) - l);
5656                                 sv_catsv(data->last_found, last_str);
5657                                 {
5658                                     SV * sv = data->last_found;
5659                                     MAGIC *mg =
5660                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5661                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5662                                     if (mg && mg->mg_len >= 0)
5663                                         mg->mg_len += last_chrs * (mincount-1);
5664                                 }
5665                                 last_chrs *= mincount;
5666                                 data->last_end += l * (mincount - 1);
5667                             }
5668                         } else {
5669                             /* start offset must point into the last copy */
5670                             data->last_start_min += minnext * (mincount - 1);
5671                             data->last_start_max =
5672                               is_inf
5673                                ? SSize_t_MAX
5674                                : data->last_start_max +
5675                                  (maxcount - 1) * (minnext + data->pos_delta);
5676                         }
5677                     }
5678                     /* It is counted once already... */
5679                     data->pos_min += minnext * (mincount - counted);
5680 #if 0
5681 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5682                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5683                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5684     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5685     (UV)mincount);
5686 if (deltanext != SSize_t_MAX)
5687 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5688     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5689           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5690 #endif
5691                     if (deltanext == SSize_t_MAX
5692                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5693                         data->pos_delta = SSize_t_MAX;
5694                     else
5695                         data->pos_delta += - counted * deltanext +
5696                         (minnext + deltanext) * maxcount - minnext * mincount;
5697                     if (mincount != maxcount) {
5698                          /* Cannot extend fixed substrings found inside
5699                             the group.  */
5700                         scan_commit(pRExC_state, data, minlenp, is_inf);
5701                         if (mincount && last_str) {
5702                             SV * const sv = data->last_found;
5703                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5704                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5705
5706                             if (mg)
5707                                 mg->mg_len = -1;
5708                             sv_setsv(sv, last_str);
5709                             data->last_end = data->pos_min;
5710                             data->last_start_min = data->pos_min - last_chrs;
5711                             data->last_start_max = is_inf
5712                                 ? SSize_t_MAX
5713                                 : data->pos_min + data->pos_delta - last_chrs;
5714                         }
5715                         data->cur_is_floating = 1; /* float */
5716                     }
5717                     SvREFCNT_dec(last_str);
5718                 }
5719                 if (data && (fl & SF_HAS_EVAL))
5720                     data->flags |= SF_HAS_EVAL;
5721               optimize_curly_tail:
5722                 if (OP(oscan) != CURLYX) {
5723                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5724                            && NEXT_OFF(next))
5725                         NEXT_OFF(oscan) += NEXT_OFF(next);
5726                 }
5727                 continue;
5728
5729             default:
5730 #ifdef DEBUGGING
5731                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5732                                                                     OP(scan));
5733 #endif
5734             case REF:
5735             case CLUMP:
5736                 if (flags & SCF_DO_SUBSTR) {
5737                     /* Cannot expect anything... */
5738                     scan_commit(pRExC_state, data, minlenp, is_inf);
5739                     data->cur_is_floating = 1; /* float */
5740                 }
5741                 is_inf = is_inf_internal = 1;
5742                 if (flags & SCF_DO_STCLASS_OR) {
5743                     if (OP(scan) == CLUMP) {
5744                         /* Actually is any start char, but very few code points
5745                          * aren't start characters */
5746                         ssc_match_all_cp(data->start_class);
5747                     }
5748                     else {
5749                         ssc_anything(data->start_class);
5750                     }
5751                 }
5752                 flags &= ~SCF_DO_STCLASS;
5753                 break;
5754             }
5755         }
5756         else if (OP(scan) == LNBREAK) {
5757             if (flags & SCF_DO_STCLASS) {
5758                 if (flags & SCF_DO_STCLASS_AND) {
5759                     ssc_intersection(data->start_class,
5760                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5761                     ssc_clear_locale(data->start_class);
5762                     ANYOF_FLAGS(data->start_class)
5763                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5764                 }
5765                 else if (flags & SCF_DO_STCLASS_OR) {
5766                     ssc_union(data->start_class,
5767                               PL_XPosix_ptrs[_CC_VERTSPACE],
5768                               FALSE);
5769                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5770
5771                     /* See commit msg for
5772                      * 749e076fceedeb708a624933726e7989f2302f6a */
5773                     ANYOF_FLAGS(data->start_class)
5774                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5775                 }
5776                 flags &= ~SCF_DO_STCLASS;
5777             }
5778             min++;
5779             if (delta != SSize_t_MAX)
5780                 delta++;    /* Because of the 2 char string cr-lf */
5781             if (flags & SCF_DO_SUBSTR) {
5782                 /* Cannot expect anything... */
5783                 scan_commit(pRExC_state, data, minlenp, is_inf);
5784                 data->pos_min += 1;
5785                 if (data->pos_delta != SSize_t_MAX) {
5786                     data->pos_delta += 1;
5787                 }
5788                 data->cur_is_floating = 1; /* float */
5789             }
5790         }
5791         else if (REGNODE_SIMPLE(OP(scan))) {
5792
5793             if (flags & SCF_DO_SUBSTR) {
5794                 scan_commit(pRExC_state, data, minlenp, is_inf);
5795                 data->pos_min++;
5796             }
5797             min++;
5798             if (flags & SCF_DO_STCLASS) {
5799                 bool invert = 0;
5800                 SV* my_invlist = NULL;
5801                 U8 namedclass;
5802
5803                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5804                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5805
5806                 /* Some of the logic below assumes that switching
5807                    locale on will only add false positives. */
5808                 switch (OP(scan)) {
5809
5810                 default:
5811 #ifdef DEBUGGING
5812                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5813                                                                      OP(scan));
5814 #endif
5815                 case SANY:
5816                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5817                         ssc_match_all_cp(data->start_class);
5818                     break;
5819
5820                 case REG_ANY:
5821                     {
5822                         SV* REG_ANY_invlist = _new_invlist(2);
5823                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5824                                                             '\n');
5825                         if (flags & SCF_DO_STCLASS_OR) {
5826                             ssc_union(data->start_class,
5827                                       REG_ANY_invlist,
5828                                       TRUE /* TRUE => invert, hence all but \n
5829                                             */
5830                                       );
5831                         }
5832                         else if (flags & SCF_DO_STCLASS_AND) {
5833                             ssc_intersection(data->start_class,
5834                                              REG_ANY_invlist,
5835                                              TRUE  /* TRUE => invert */
5836                                              );
5837                             ssc_clear_locale(data->start_class);
5838                         }
5839                         SvREFCNT_dec_NN(REG_ANY_invlist);
5840                     }
5841                     break;
5842
5843                 case ANYOFD:
5844                 case ANYOFL:
5845                 case ANYOFPOSIXL:
5846                 case ANYOFH:
5847                 case ANYOF:
5848                     if (flags & SCF_DO_STCLASS_AND)
5849                         ssc_and(pRExC_state, data->start_class,
5850                                 (regnode_charclass *) scan);
5851                     else
5852                         ssc_or(pRExC_state, data->start_class,
5853                                                           (regnode_charclass *) scan);
5854                     break;
5855
5856                 case NANYOFM:
5857                 case ANYOFM:
5858                   {
5859                     SV* cp_list = get_ANYOFM_contents(scan);
5860
5861                     if (flags & SCF_DO_STCLASS_OR) {
5862                         ssc_union(data->start_class, cp_list, invert);
5863                     }
5864                     else if (flags & SCF_DO_STCLASS_AND) {
5865                         ssc_intersection(data->start_class, cp_list, invert);
5866                     }
5867
5868                     SvREFCNT_dec_NN(cp_list);
5869                     break;
5870                   }
5871
5872                 case NPOSIXL:
5873                     invert = 1;
5874                     /* FALLTHROUGH */
5875
5876                 case POSIXL:
5877                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5878                     if (flags & SCF_DO_STCLASS_AND) {
5879                         bool was_there = cBOOL(
5880                                           ANYOF_POSIXL_TEST(data->start_class,
5881                                                                  namedclass));
5882                         ANYOF_POSIXL_ZERO(data->start_class);
5883                         if (was_there) {    /* Do an AND */
5884                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5885                         }
5886                         /* No individual code points can now match */
5887                         data->start_class->invlist
5888                                                 = sv_2mortal(_new_invlist(0));
5889                     }
5890                     else {
5891                         int complement = namedclass + ((invert) ? -1 : 1);
5892
5893                         assert(flags & SCF_DO_STCLASS_OR);
5894
5895                         /* If the complement of this class was already there,
5896                          * the result is that they match all code points,
5897                          * (\d + \D == everything).  Remove the classes from
5898                          * future consideration.  Locale is not relevant in
5899                          * this case */
5900                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5901                             ssc_match_all_cp(data->start_class);
5902                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5903                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5904                         }
5905                         else {  /* The usual case; just add this class to the
5906                                    existing set */
5907                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5908                         }
5909                     }
5910                     break;
5911
5912                 case NPOSIXA:   /* For these, we always know the exact set of
5913                                    what's matched */
5914                     invert = 1;
5915                     /* FALLTHROUGH */
5916                 case POSIXA:
5917                     my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL);
5918                     goto join_posix_and_ascii;
5919
5920                 case NPOSIXD:
5921                 case NPOSIXU:
5922                     invert = 1;
5923                     /* FALLTHROUGH */
5924                 case POSIXD:
5925                 case POSIXU:
5926                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL);
5927
5928                     /* NPOSIXD matches all upper Latin1 code points unless the
5929                      * target string being matched is UTF-8, which is
5930                      * unknowable until match time.  Since we are going to
5931                      * invert, we want to get rid of all of them so that the
5932                      * inversion will match all */
5933                     if (OP(scan) == NPOSIXD) {
5934                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5935                                           &my_invlist);
5936                     }
5937
5938                   join_posix_and_ascii:
5939
5940                     if (flags & SCF_DO_STCLASS_AND) {
5941                         ssc_intersection(data->start_class, my_invlist, invert);
5942                         ssc_clear_locale(data->start_class);
5943                     }
5944                     else {
5945                         assert(flags & SCF_DO_STCLASS_OR);
5946                         ssc_union(data->start_class, my_invlist, invert);
5947                     }
5948                     SvREFCNT_dec(my_invlist);
5949                 }
5950                 if (flags & SCF_DO_STCLASS_OR)
5951                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5952                 flags &= ~SCF_DO_STCLASS;
5953             }
5954         }
5955         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5956             data->flags |= (OP(scan) == MEOL
5957                             ? SF_BEFORE_MEOL
5958                             : SF_BEFORE_SEOL);
5959             scan_commit(pRExC_state, data, minlenp, is_inf);
5960
5961         }
5962         else if (  PL_regkind[OP(scan)] == BRANCHJ
5963                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5964                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5965                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5966         {
5967             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5968                 || OP(scan) == UNLESSM )
5969             {
5970                 /* Negative Lookahead/lookbehind
5971                    In this case we can't do fixed string optimisation.
5972                 */
5973
5974                 SSize_t deltanext, minnext, fake = 0;
5975                 regnode *nscan;
5976                 regnode_ssc intrnl;
5977                 int f = 0;
5978
5979                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5980                 if (data) {
5981                     data_fake.whilem_c = data->whilem_c;
5982                     data_fake.last_closep = data->last_closep;
5983                 }
5984                 else
5985                     data_fake.last_closep = &fake;
5986                 data_fake.pos_delta = delta;
5987                 if ( flags & SCF_DO_STCLASS && !scan->flags
5988                      && OP(scan) == IFMATCH ) { /* Lookahead */
5989                     ssc_init(pRExC_state, &intrnl);
5990                     data_fake.start_class = &intrnl;
5991                     f |= SCF_DO_STCLASS_AND;
5992                 }
5993                 if (flags & SCF_WHILEM_VISITED_POS)
5994                     f |= SCF_WHILEM_VISITED_POS;
5995                 next = regnext(scan);
5996                 nscan = NEXTOPER(NEXTOPER(scan));
5997
5998                 /* recurse study_chunk() for lookahead body */
5999                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
6000                                       last, &data_fake, stopparen,
6001                                       recursed_depth, NULL, f, depth+1);
6002                 if (scan->flags) {
6003                     if (   deltanext < 0
6004                         || deltanext > (I32) U8_MAX
6005                         || minnext > (I32)U8_MAX
6006                         || minnext + deltanext > (I32)U8_MAX)
6007                     {
6008                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6009                               (UV)U8_MAX);
6010                     }
6011
6012                     /* The 'next_off' field has been repurposed to count the
6013                      * additional starting positions to try beyond the initial
6014                      * one.  (This leaves it at 0 for non-variable length
6015                      * matches to avoid breakage for those not using this
6016                      * extension) */
6017                     if (deltanext) {
6018                         scan->next_off = deltanext;
6019                         ckWARNexperimental(RExC_parse,
6020                             WARN_EXPERIMENTAL__VLB,
6021                             "Variable length lookbehind is experimental");
6022                     }
6023                     scan->flags = (U8)minnext + deltanext;
6024                 }
6025                 if (data) {
6026                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6027                         pars++;
6028                     if (data_fake.flags & SF_HAS_EVAL)
6029                         data->flags |= SF_HAS_EVAL;
6030                     data->whilem_c = data_fake.whilem_c;
6031                 }
6032                 if (f & SCF_DO_STCLASS_AND) {
6033                     if (flags & SCF_DO_STCLASS_OR) {
6034                         /* OR before, AND after: ideally we would recurse with
6035                          * data_fake to get the AND applied by study of the
6036                          * remainder of the pattern, and then derecurse;
6037                          * *** HACK *** for now just treat as "no information".
6038                          * See [perl #56690].
6039                          */
6040                         ssc_init(pRExC_state, data->start_class);
6041                     }  else {
6042                         /* AND before and after: combine and continue.  These
6043                          * assertions are zero-length, so can match an EMPTY
6044                          * string */
6045                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6046                         ANYOF_FLAGS(data->start_class)
6047                                                    |= SSC_MATCHES_EMPTY_STRING;
6048                     }
6049                 }
6050             }
6051 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
6052             else {
6053                 /* Positive Lookahead/lookbehind
6054                    In this case we can do fixed string optimisation,
6055                    but we must be careful about it. Note in the case of
6056                    lookbehind the positions will be offset by the minimum
6057                    length of the pattern, something we won't know about
6058                    until after the recurse.
6059                 */
6060                 SSize_t deltanext, fake = 0;
6061                 regnode *nscan;
6062                 regnode_ssc intrnl;
6063                 int f = 0;
6064                 /* We use SAVEFREEPV so that when the full compile
6065                     is finished perl will clean up the allocated
6066                     minlens when it's all done. This way we don't
6067                     have to worry about freeing them when we know
6068                     they wont be used, which would be a pain.
6069                  */
6070                 SSize_t *minnextp;
6071                 Newx( minnextp, 1, SSize_t );
6072                 SAVEFREEPV(minnextp);
6073
6074                 if (data) {
6075                     StructCopy(data, &data_fake, scan_data_t);
6076                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
6077                         f |= SCF_DO_SUBSTR;
6078                         if (scan->flags)
6079                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
6080                         data_fake.last_found=newSVsv(data->last_found);
6081                     }
6082                 }
6083                 else
6084                     data_fake.last_closep = &fake;
6085                 data_fake.flags = 0;
6086                 data_fake.substrs[0].flags = 0;
6087                 data_fake.substrs[1].flags = 0;
6088                 data_fake.pos_delta = delta;
6089                 if (is_inf)
6090                     data_fake.flags |= SF_IS_INF;
6091                 if ( flags & SCF_DO_STCLASS && !scan->flags
6092                      && OP(scan) == IFMATCH ) { /* Lookahead */
6093                     ssc_init(pRExC_state, &intrnl);
6094                     data_fake.start_class = &intrnl;
6095                     f |= SCF_DO_STCLASS_AND;
6096                 }
6097                 if (flags & SCF_WHILEM_VISITED_POS)
6098                     f |= SCF_WHILEM_VISITED_POS;
6099                 next = regnext(scan);
6100                 nscan = NEXTOPER(NEXTOPER(scan));
6101
6102                 /* positive lookahead study_chunk() recursion */
6103                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
6104                                         &deltanext, last, &data_fake,
6105                                         stopparen, recursed_depth, NULL,
6106                                         f, depth+1);
6107                 if (scan->flags) {
6108                     assert(0);  /* This code has never been tested since this
6109                                    is normally not compiled */
6110                     if (   deltanext < 0
6111                         || deltanext > (I32) U8_MAX
6112                         || *minnextp > (I32)U8_MAX
6113                         || *minnextp + deltanext > (I32)U8_MAX)
6114                     {
6115                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
6116                               (UV)U8_MAX);
6117                     }
6118
6119                     if (deltanext) {
6120                         scan->next_off = deltanext;
6121                     }
6122                     scan->flags = (U8)*minnextp + deltanext;
6123                 }
6124
6125                 *minnextp += min;
6126
6127                 if (f & SCF_DO_STCLASS_AND) {
6128                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
6129                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
6130                 }
6131                 if (data) {
6132                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6133                         pars++;
6134                     if (data_fake.flags & SF_HAS_EVAL)
6135                         data->flags |= SF_HAS_EVAL;
6136                     data->whilem_c = data_fake.whilem_c;
6137                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
6138                         int i;
6139                         if (RExC_rx->minlen<*minnextp)
6140                             RExC_rx->minlen=*minnextp;
6141                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
6142                         SvREFCNT_dec_NN(data_fake.last_found);
6143
6144                         for (i = 0; i < 2; i++) {
6145                             if (data_fake.substrs[i].minlenp != minlenp) {
6146                                 data->substrs[i].min_offset =
6147                                             data_fake.substrs[i].min_offset;
6148                                 data->substrs[i].max_offset =
6149                                             data_fake.substrs[i].max_offset;
6150                                 data->substrs[i].minlenp =
6151                                             data_fake.substrs[i].minlenp;
6152                                 data->substrs[i].lookbehind += scan->flags;
6153                             }
6154                         }
6155                     }
6156                 }
6157             }
6158 #endif
6159         }
6160
6161         else if (OP(scan) == OPEN) {
6162             if (stopparen != (I32)ARG(scan))
6163                 pars++;
6164         }
6165         else if (OP(scan) == CLOSE) {
6166             if (stopparen == (I32)ARG(scan)) {
6167                 break;
6168             }
6169             if ((I32)ARG(scan) == is_par) {
6170                 next = regnext(scan);
6171
6172                 if ( next && (OP(next) != WHILEM) && next < last)
6173                     is_par = 0;         /* Disable optimization */
6174             }
6175             if (data)
6176                 *(data->last_closep) = ARG(scan);
6177         }
6178         else if (OP(scan) == EVAL) {
6179                 if (data)
6180                     data->flags |= SF_HAS_EVAL;
6181         }
6182         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
6183             if (flags & SCF_DO_SUBSTR) {
6184                 scan_commit(pRExC_state, data, minlenp, is_inf);
6185                 flags &= ~SCF_DO_SUBSTR;
6186             }
6187             if (data && OP(scan)==ACCEPT) {
6188                 data->flags |= SCF_SEEN_ACCEPT;
6189                 if (stopmin > min)
6190                     stopmin = min;
6191             }
6192         }
6193         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
6194         {
6195                 if (flags & SCF_DO_SUBSTR) {
6196                     scan_commit(pRExC_state, data, minlenp, is_inf);
6197                     data->cur_is_floating = 1; /* float */
6198                 }
6199                 is_inf = is_inf_internal = 1;
6200                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
6201                     ssc_anything(data->start_class);
6202                 flags &= ~SCF_DO_STCLASS;
6203         }
6204         else if (OP(scan) == GPOS) {
6205             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
6206                 !(delta || is_inf || (data && data->pos_delta)))
6207             {
6208                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
6209                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
6210                 if (RExC_rx->gofs < (STRLEN)min)
6211                     RExC_rx->gofs = min;
6212             } else {
6213                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
6214                 RExC_rx->gofs = 0;
6215             }
6216         }
6217 #ifdef TRIE_STUDY_OPT
6218 #ifdef FULL_TRIE_STUDY
6219         else if (PL_regkind[OP(scan)] == TRIE) {
6220             /* NOTE - There is similar code to this block above for handling
6221                BRANCH nodes on the initial study.  If you change stuff here
6222                check there too. */
6223             regnode *trie_node= scan;
6224             regnode *tail= regnext(scan);
6225             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6226             SSize_t max1 = 0, min1 = SSize_t_MAX;
6227             regnode_ssc accum;
6228
6229             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
6230                 /* Cannot merge strings after this. */
6231                 scan_commit(pRExC_state, data, minlenp, is_inf);
6232             }
6233             if (flags & SCF_DO_STCLASS)
6234                 ssc_init_zero(pRExC_state, &accum);
6235
6236             if (!trie->jump) {
6237                 min1= trie->minlen;
6238                 max1= trie->maxlen;
6239             } else {
6240                 const regnode *nextbranch= NULL;
6241                 U32 word;
6242
6243                 for ( word=1 ; word <= trie->wordcount ; word++)
6244                 {
6245                     SSize_t deltanext=0, minnext=0, f = 0, fake;
6246                     regnode_ssc this_class;
6247
6248                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
6249                     if (data) {
6250                         data_fake.whilem_c = data->whilem_c;
6251                         data_fake.last_closep = data->last_closep;
6252                     }
6253                     else
6254                         data_fake.last_closep = &fake;
6255                     data_fake.pos_delta = delta;
6256                     if (flags & SCF_DO_STCLASS) {
6257                         ssc_init(pRExC_state, &this_class);
6258                         data_fake.start_class = &this_class;
6259                         f = SCF_DO_STCLASS_AND;
6260                     }
6261                     if (flags & SCF_WHILEM_VISITED_POS)
6262                         f |= SCF_WHILEM_VISITED_POS;
6263
6264                     if (trie->jump[word]) {
6265                         if (!nextbranch)
6266                             nextbranch = trie_node + trie->jump[0];
6267                         scan= trie_node + trie->jump[word];
6268                         /* We go from the jump point to the branch that follows
6269                            it. Note this means we need the vestigal unused
6270                            branches even though they arent otherwise used. */
6271                         /* optimise study_chunk() for TRIE */
6272                         minnext = study_chunk(pRExC_state, &scan, minlenp,
6273                             &deltanext, (regnode *)nextbranch, &data_fake,
6274                             stopparen, recursed_depth, NULL, f, depth+1);
6275                     }
6276                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
6277                         nextbranch= regnext((regnode*)nextbranch);
6278
6279                     if (min1 > (SSize_t)(minnext + trie->minlen))
6280                         min1 = minnext + trie->minlen;
6281                     if (deltanext == SSize_t_MAX) {
6282                         is_inf = is_inf_internal = 1;
6283                         max1 = SSize_t_MAX;
6284                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
6285                         max1 = minnext + deltanext + trie->maxlen;
6286
6287                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
6288                         pars++;
6289                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
6290                         if ( stopmin > min + min1)
6291                             stopmin = min + min1;
6292                         flags &= ~SCF_DO_SUBSTR;
6293                         if (data)
6294                             data->flags |= SCF_SEEN_ACCEPT;
6295                     }
6296                     if (data) {
6297                         if (data_fake.flags & SF_HAS_EVAL)
6298                             data->flags |= SF_HAS_EVAL;
6299                         data->whilem_c = data_fake.whilem_c;
6300                     }
6301                     if (flags & SCF_DO_STCLASS)
6302                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
6303                 }
6304             }
6305             if (flags & SCF_DO_SUBSTR) {
6306                 data->pos_min += min1;
6307                 data->pos_delta += max1 - min1;
6308                 if (max1 != min1 || is_inf)
6309                     data->cur_is_floating = 1; /* float */
6310             }
6311             min += min1;
6312             if (delta != SSize_t_MAX) {
6313                 if (SSize_t_MAX - (max1 - min1) >= delta)
6314                     delta += max1 - min1;
6315                 else
6316                     delta = SSize_t_MAX;
6317             }
6318             if (flags & SCF_DO_STCLASS_OR) {
6319                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6320                 if (min1) {
6321                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6322                     flags &= ~SCF_DO_STCLASS;
6323                 }
6324             }
6325             else if (flags & SCF_DO_STCLASS_AND) {
6326                 if (min1) {
6327                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
6328                     flags &= ~SCF_DO_STCLASS;
6329                 }
6330                 else {
6331                     /* Switch to OR mode: cache the old value of
6332                      * data->start_class */
6333                     INIT_AND_WITHP;
6334                     StructCopy(data->start_class, and_withp, regnode_ssc);
6335                     flags &= ~SCF_DO_STCLASS_AND;
6336                     StructCopy(&accum, data->start_class, regnode_ssc);
6337                     flags |= SCF_DO_STCLASS_OR;
6338                 }
6339             }
6340             scan= tail;
6341             continue;
6342         }
6343 #else
6344         else if (PL_regkind[OP(scan)] == TRIE) {
6345             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
6346             U8*bang=NULL;
6347
6348             min += trie->minlen;
6349             delta += (trie->maxlen - trie->minlen);
6350             flags &= ~SCF_DO_STCLASS; /* xxx */
6351             if (flags & SCF_DO_SUBSTR) {
6352                 /* Cannot expect anything... */
6353                 scan_commit(pRExC_state, data, minlenp, is_inf);
6354                 data->pos_min += trie->minlen;
6355                 data->pos_delta += (trie->maxlen - trie->minlen);
6356                 if (trie->maxlen != trie->minlen)
6357                     data->cur_is_floating = 1; /* float */
6358             }
6359             if (trie->jump) /* no more substrings -- for now /grr*/
6360                flags &= ~SCF_DO_SUBSTR;
6361         }
6362 #endif /* old or new */
6363 #endif /* TRIE_STUDY_OPT */
6364
6365         /* Else: zero-length, ignore. */
6366         scan = regnext(scan);
6367     }
6368
6369   finish:
6370     if (frame) {
6371         /* we need to unwind recursion. */
6372         depth = depth - 1;
6373
6374         DEBUG_STUDYDATA("frame-end", data, depth, is_inf);
6375         DEBUG_PEEP("fend", scan, depth, flags);
6376
6377         /* restore previous context */
6378         last = frame->last_regnode;
6379         scan = frame->next_regnode;
6380         stopparen = frame->stopparen;
6381         recursed_depth = frame->prev_recursed_depth;
6382
6383         RExC_frame_last = frame->prev_frame;
6384         frame = frame->this_prev_frame;
6385         goto fake_study_recurse;
6386     }
6387
6388     assert(!frame);
6389     DEBUG_STUDYDATA("pre-fin", data, depth, is_inf);
6390
6391     *scanp = scan;
6392     *deltap = is_inf_internal ? SSize_t_MAX : delta;
6393
6394     if (flags & SCF_DO_SUBSTR && is_inf)
6395         data->pos_delta = SSize_t_MAX - data->pos_min;
6396     if (is_par > (I32)U8_MAX)
6397         is_par = 0;
6398     if (is_par && pars==1 && data) {
6399         data->flags |= SF_IN_PAR;
6400         data->flags &= ~SF_HAS_PAR;
6401     }
6402     else if (pars && data) {
6403         data->flags |= SF_HAS_PAR;
6404         data->flags &= ~SF_IN_PAR;
6405     }
6406     if (flags & SCF_DO_STCLASS_OR)
6407         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
6408     if (flags & SCF_TRIE_RESTUDY)
6409         data->flags |=  SCF_TRIE_RESTUDY;
6410
6411     DEBUG_STUDYDATA("post-fin", data, depth, is_inf);
6412
6413     {
6414         SSize_t final_minlen= min < stopmin ? min : stopmin;
6415
6416         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
6417             if (final_minlen > SSize_t_MAX - delta)
6418                 RExC_maxlen = SSize_t_MAX;
6419             else if (RExC_maxlen < final_minlen + delta)
6420                 RExC_maxlen = final_minlen + delta;
6421         }
6422         return final_minlen;
6423     }
6424     NOT_REACHED; /* NOTREACHED */
6425 }
6426
6427 STATIC U32
6428 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
6429 {
6430     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
6431
6432     PERL_ARGS_ASSERT_ADD_DATA;
6433
6434     Renewc(RExC_rxi->data,
6435            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6436            char, struct reg_data);
6437     if(count)
6438         Renew(RExC_rxi->data->what, count + n, U8);
6439     else
6440         Newx(RExC_rxi->data->what, n, U8);
6441     RExC_rxi->data->count = count + n;
6442     Copy(s, RExC_rxi->data->what + count, n, U8);
6443     return count;
6444 }
6445
6446 /*XXX: todo make this not included in a non debugging perl, but appears to be
6447  * used anyway there, in 'use re' */
6448 #ifndef PERL_IN_XSUB_RE
6449 void
6450 Perl_reginitcolors(pTHX)
6451 {
6452     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6453     if (s) {
6454         char *t = savepv(s);
6455         int i = 0;
6456         PL_colors[0] = t;
6457         while (++i < 6) {
6458             t = strchr(t, '\t');
6459             if (t) {
6460                 *t = '\0';
6461                 PL_colors[i] = ++t;
6462             }
6463             else
6464                 PL_colors[i] = t = (char *)"";
6465         }
6466     } else {
6467         int i = 0;
6468         while (i < 6)
6469             PL_colors[i++] = (char *)"";
6470     }
6471     PL_colorset = 1;
6472 }
6473 #endif
6474
6475
6476 #ifdef TRIE_STUDY_OPT
6477 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6478     STMT_START {                                            \
6479         if (                                                \
6480               (data.flags & SCF_TRIE_RESTUDY)               \
6481               && ! restudied++                              \
6482         ) {                                                 \
6483             dOsomething;                                    \
6484             goto reStudy;                                   \
6485         }                                                   \
6486     } STMT_END
6487 #else
6488 #define CHECK_RESTUDY_GOTO_butfirst
6489 #endif
6490
6491 /*
6492  * pregcomp - compile a regular expression into internal code
6493  *
6494  * Decides which engine's compiler to call based on the hint currently in
6495  * scope
6496  */
6497
6498 #ifndef PERL_IN_XSUB_RE
6499
6500 /* return the currently in-scope regex engine (or the default if none)  */
6501
6502 regexp_engine const *
6503 Perl_current_re_engine(pTHX)
6504 {
6505     if (IN_PERL_COMPILETIME) {
6506         HV * const table = GvHV(PL_hintgv);
6507         SV **ptr;
6508
6509         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6510             return &PL_core_reg_engine;
6511         ptr = hv_fetchs(table, "regcomp", FALSE);
6512         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6513             return &PL_core_reg_engine;
6514         return INT2PTR(regexp_engine*, SvIV(*ptr));
6515     }
6516     else {
6517         SV *ptr;
6518         if (!PL_curcop->cop_hints_hash)
6519             return &PL_core_reg_engine;
6520         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6521         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6522             return &PL_core_reg_engine;
6523         return INT2PTR(regexp_engine*, SvIV(ptr));
6524     }
6525 }
6526
6527
6528 REGEXP *
6529 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6530 {
6531     regexp_engine const *eng = current_re_engine();
6532     GET_RE_DEBUG_FLAGS_DECL;
6533
6534     PERL_ARGS_ASSERT_PREGCOMP;
6535
6536     /* Dispatch a request to compile a regexp to correct regexp engine. */
6537     DEBUG_COMPILE_r({
6538         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6539                         PTR2UV(eng));
6540     });
6541     return CALLREGCOMP_ENG(eng, pattern, flags);
6542 }
6543 #endif
6544
6545 /* public(ish) entry point for the perl core's own regex compiling code.
6546  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6547  * pattern rather than a list of OPs, and uses the internal engine rather
6548  * than the current one */
6549
6550 REGEXP *
6551 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6552 {
6553     SV *pat = pattern; /* defeat constness! */
6554     PERL_ARGS_ASSERT_RE_COMPILE;
6555     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6556 #ifdef PERL_IN_XSUB_RE
6557                                 &my_reg_engine,
6558 #else
6559                                 &PL_core_reg_engine,
6560 #endif
6561                                 NULL, NULL, rx_flags, 0);
6562 }
6563
6564
6565 static void
6566 S_free_codeblocks(pTHX_ struct reg_code_blocks *cbs)
6567 {
6568     int n;
6569
6570     if (--cbs->refcnt > 0)
6571         return;
6572     for (n = 0; n < cbs->count; n++) {
6573         REGEXP *rx = cbs->cb[n].src_regex;
6574         if (rx) {
6575             cbs->cb[n].src_regex = NULL;
6576             SvREFCNT_dec_NN(rx);
6577         }
6578     }
6579     Safefree(cbs->cb);
6580     Safefree(cbs);
6581 }
6582
6583
6584 static struct reg_code_blocks *
6585 S_alloc_code_blocks(pTHX_  int ncode)
6586 {
6587      struct reg_code_blocks *cbs;
6588     Newx(cbs, 1, struct reg_code_blocks);
6589     cbs->count = ncode;
6590     cbs->refcnt = 1;
6591     SAVEDESTRUCTOR_X(S_free_codeblocks, cbs);
6592     if (ncode)
6593         Newx(cbs->cb, ncode, struct reg_code_block);
6594     else
6595         cbs->cb = NULL;
6596     return cbs;
6597 }
6598
6599
6600 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6601  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6602  * point to the realloced string and length.
6603  *
6604  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6605  * stuff added */
6606
6607 static void
6608 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6609                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6610 {
6611     U8 *const src = (U8*)*pat_p;
6612     U8 *dst, *d;
6613     int n=0;
6614     STRLEN s = 0;
6615     bool do_end = 0;
6616     GET_RE_DEBUG_FLAGS_DECL;
6617
6618     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6619         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6620
6621     /* 1 for each byte + 1 for each byte that expands to two, + trailing NUL */
6622     Newx(dst, *plen_p + variant_under_utf8_count(src, src + *plen_p) + 1, U8);
6623     d = dst;
6624
6625     while (s < *plen_p) {
6626         append_utf8_from_native_byte(src[s], &d);
6627
6628         if (n < num_code_blocks) {
6629             assert(pRExC_state->code_blocks);
6630             if (!do_end && pRExC_state->code_blocks->cb[n].start == s) {
6631                 pRExC_state->code_blocks->cb[n].start = d - dst - 1;
6632                 assert(*(d - 1) == '(');
6633                 do_end = 1;
6634             }
6635             else if (do_end && pRExC_state->code_blocks->cb[n].end == s) {
6636                 pRExC_state->code_blocks->cb[n].end = d - dst - 1;
6637                 assert(*(d - 1) == ')');
6638                 do_end = 0;
6639                 n++;
6640             }
6641         }
6642         s++;
6643     }
6644     *d = '\0';
6645     *plen_p = d - dst;
6646     *pat_p = (char*) dst;
6647     SAVEFREEPV(*pat_p);
6648     RExC_orig_utf8 = RExC_utf8 = 1;
6649 }
6650
6651
6652
6653 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6654  * while recording any code block indices, and handling overloading,
6655  * nested qr// objects etc.  If pat is null, it will allocate a new
6656  * string, or just return the first arg, if there's only one.
6657  *
6658  * Returns the malloced/updated pat.
6659  * patternp and pat_count is the array of SVs to be concatted;
6660  * oplist is the optional list of ops that generated the SVs;
6661  * recompile_p is a pointer to a boolean that will be set if
6662  *   the regex will need to be recompiled.
6663  * delim, if non-null is an SV that will be inserted between each element
6664  */
6665
6666 static SV*
6667 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6668                 SV *pat, SV ** const patternp, int pat_count,
6669                 OP *oplist, bool *recompile_p, SV *delim)
6670 {
6671     SV **svp;
6672     int n = 0;
6673     bool use_delim = FALSE;
6674     bool alloced = FALSE;
6675
6676     /* if we know we have at least two args, create an empty string,
6677      * then concatenate args to that. For no args, return an empty string */
6678     if (!pat && pat_count != 1) {
6679         pat = newSVpvs("");
6680         SAVEFREESV(pat);
6681         alloced = TRUE;
6682     }
6683
6684     for (svp = patternp; svp < patternp + pat_count; svp++) {
6685         SV *sv;
6686         SV *rx  = NULL;
6687         STRLEN orig_patlen = 0;
6688         bool code = 0;
6689         SV *msv = use_delim ? delim : *svp;
6690         if (!msv) msv = &PL_sv_undef;
6691
6692         /* if we've got a delimiter, we go round the loop twice for each
6693          * svp slot (except the last), using the delimiter the second
6694          * time round */
6695         if (use_delim) {
6696             svp--;
6697             use_delim = FALSE;
6698         }
6699         else if (delim)
6700             use_delim = TRUE;
6701
6702         if (SvTYPE(msv) == SVt_PVAV) {
6703             /* we've encountered an interpolated array within
6704              * the pattern, e.g. /...@a..../. Expand the list of elements,
6705              * then recursively append elements.
6706              * The code in this block is based on S_pushav() */
6707
6708             AV *const av = (AV*)msv;
6709             const SSize_t maxarg = AvFILL(av) + 1;
6710             SV **array;
6711
6712             if (oplist) {
6713                 assert(oplist->op_type == OP_PADAV
6714                     || oplist->op_type == OP_RV2AV);
6715                 oplist = OpSIBLING(oplist);
6716             }
6717
6718             if (SvRMAGICAL(av)) {
6719                 SSize_t i;
6720
6721                 Newx(array, maxarg, SV*);
6722                 SAVEFREEPV(array);
6723                 for (i=0; i < maxarg; i++) {
6724                     SV ** const svp = av_fetch(av, i, FALSE);
6725                     array[i] = svp ? *svp : &PL_sv_undef;
6726                 }
6727             }
6728             else
6729                 array = AvARRAY(av);
6730
6731             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6732                                 array, maxarg, NULL, recompile_p,
6733                                 /* $" */
6734                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6735
6736             continue;
6737         }
6738
6739
6740         /* we make the assumption here that each op in the list of
6741          * op_siblings maps to one SV pushed onto the stack,
6742          * except for code blocks, with have both an OP_NULL and
6743          * and OP_CONST.
6744          * This allows us to match up the list of SVs against the
6745          * list of OPs to find the next code block.
6746          *
6747          * Note that       PUSHMARK PADSV PADSV ..
6748          * is optimised to
6749          *                 PADRANGE PADSV  PADSV  ..
6750          * so the alignment still works. */
6751
6752         if (oplist) {
6753             if (oplist->op_type == OP_NULL
6754                 && (oplist->op_flags & OPf_SPECIAL))
6755             {
6756                 assert(n < pRExC_state->code_blocks->count);
6757                 pRExC_state->code_blocks->cb[n].start = pat ? SvCUR(pat) : 0;
6758                 pRExC_state->code_blocks->cb[n].block = oplist;
6759                 pRExC_state->code_blocks->cb[n].src_regex = NULL;
6760                 n++;
6761                 code = 1;
6762                 oplist = OpSIBLING(oplist); /* skip CONST */
6763                 assert(oplist);
6764             }
6765             oplist = OpSIBLING(oplist);;
6766         }
6767
6768         /* apply magic and QR overloading to arg */
6769
6770         SvGETMAGIC(msv);
6771         if (SvROK(msv) && SvAMAGIC(msv)) {
6772             SV *sv = AMG_CALLunary(msv, regexp_amg);
6773             if (sv) {
6774                 if (SvROK(sv))
6775                     sv = SvRV(sv);
6776                 if (SvTYPE(sv) != SVt_REGEXP)
6777                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6778                 msv = sv;
6779             }
6780         }
6781
6782         /* try concatenation overload ... */
6783         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6784                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6785         {
6786             sv_setsv(pat, sv);
6787             /* overloading involved: all bets are off over literal
6788              * code. Pretend we haven't seen it */
6789             if (n)
6790                 pRExC_state->code_blocks->count -= n;
6791             n = 0;
6792         }
6793         else  {
6794             /* ... or failing that, try "" overload */
6795             while (SvAMAGIC(msv)
6796                     && (sv = AMG_CALLunary(msv, string_amg))
6797                     && sv != msv
6798                     &&  !(   SvROK(msv)
6799                           && SvROK(sv)
6800                           && SvRV(msv) == SvRV(sv))
6801             ) {
6802                 msv = sv;
6803                 SvGETMAGIC(msv);
6804             }
6805             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6806                 msv = SvRV(msv);
6807
6808             if (pat) {
6809                 /* this is a partially unrolled
6810                  *     sv_catsv_nomg(pat, msv);
6811                  * that allows us to adjust code block indices if
6812                  * needed */
6813                 STRLEN dlen;
6814                 char *dst = SvPV_force_nomg(pat, dlen);
6815                 orig_patlen = dlen;
6816                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6817                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6818                     sv_setpvn(pat, dst, dlen);
6819                     SvUTF8_on(pat);
6820                 }
6821                 sv_catsv_nomg(pat, msv);
6822                 rx = msv;
6823             }
6824             else {
6825                 /* We have only one SV to process, but we need to verify
6826                  * it is properly null terminated or we will fail asserts
6827                  * later. In theory we probably shouldn't get such SV's,
6828                  * but if we do we should handle it gracefully. */
6829                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) || SvIsCOW_shared_hash(msv) ) {
6830                     /* not a string, or a string with a trailing null */
6831                     pat = msv;
6832                 } else {
6833                     /* a string with no trailing null, we need to copy it
6834                      * so it has a trailing null */
6835                     pat = sv_2mortal(newSVsv(msv));
6836                 }
6837             }
6838
6839             if (code)
6840                 pRExC_state->code_blocks->cb[n-1].end = SvCUR(pat)-1;
6841         }
6842
6843         /* extract any code blocks within any embedded qr//'s */
6844         if (rx && SvTYPE(rx) == SVt_REGEXP
6845             && RX_ENGINE((REGEXP*)rx)->op_comp)
6846         {
6847
6848             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6849             if (ri->code_blocks && ri->code_blocks->count) {
6850                 int i;
6851                 /* the presence of an embedded qr// with code means
6852                  * we should always recompile: the text of the
6853                  * qr// may not have changed, but it may be a
6854                  * different closure than last time */
6855                 *recompile_p = 1;
6856                 if (pRExC_state->code_blocks) {
6857                     int new_count = pRExC_state->code_blocks->count
6858                             + ri->code_blocks->count;
6859                     Renew(pRExC_state->code_blocks->cb,
6860                             new_count, struct reg_code_block);
6861                     pRExC_state->code_blocks->count = new_count;
6862                 }
6863                 else
6864                     pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_
6865                                                     ri->code_blocks->count);
6866
6867                 for (i=0; i < ri->code_blocks->count; i++) {
6868                     struct reg_code_block *src, *dst;
6869                     STRLEN offset =  orig_patlen
6870                         + ReANY((REGEXP *)rx)->pre_prefix;
6871                     assert(n < pRExC_state->code_blocks->count);
6872                     src = &ri->code_blocks->cb[i];
6873                     dst = &pRExC_state->code_blocks->cb[n];
6874                     dst->start      = src->start + offset;
6875                     dst->end        = src->end   + offset;
6876                     dst->block      = src->block;
6877                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6878                                             src->src_regex
6879                                                 ? src->src_regex
6880                                                 : (REGEXP*)rx);
6881                     n++;
6882                 }
6883             }
6884         }
6885     }
6886     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6887     if (alloced)
6888         SvSETMAGIC(pat);
6889
6890     return pat;
6891 }
6892
6893
6894
6895 /* see if there are any run-time code blocks in the pattern.
6896  * False positives are allowed */
6897
6898 static bool
6899 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6900                     char *pat, STRLEN plen)
6901 {
6902     int n = 0;
6903     STRLEN s;
6904
6905     PERL_UNUSED_CONTEXT;
6906
6907     for (s = 0; s < plen; s++) {
6908         if (   pRExC_state->code_blocks
6909             && n < pRExC_state->code_blocks->count
6910             && s == pRExC_state->code_blocks->cb[n].start)
6911         {
6912             s = pRExC_state->code_blocks->cb[n].end;
6913             n++;
6914             continue;
6915         }
6916         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6917          * positives here */
6918         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6919             (pat[s+2] == '{'
6920                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6921         )
6922             return 1;
6923     }
6924     return 0;
6925 }
6926
6927 /* Handle run-time code blocks. We will already have compiled any direct
6928  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6929  * copy of it, but with any literal code blocks blanked out and
6930  * appropriate chars escaped; then feed it into
6931  *
6932  *    eval "qr'modified_pattern'"
6933  *
6934  * For example,
6935  *
6936  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6937  *
6938  * becomes
6939  *
6940  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6941  *
6942  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6943  * and merge them with any code blocks of the original regexp.
6944  *
6945  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6946  * instead, just save the qr and return FALSE; this tells our caller that
6947  * the original pattern needs upgrading to utf8.
6948  */
6949
6950 static bool
6951 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6952     char *pat, STRLEN plen)
6953 {
6954     SV *qr;
6955
6956     GET_RE_DEBUG_FLAGS_DECL;
6957
6958     if (pRExC_state->runtime_code_qr) {
6959         /* this is the second time we've been called; this should
6960          * only happen if the main pattern got upgraded to utf8
6961          * during compilation; re-use the qr we compiled first time
6962          * round (which should be utf8 too)
6963          */
6964         qr = pRExC_state->runtime_code_qr;
6965         pRExC_state->runtime_code_qr = NULL;
6966         assert(RExC_utf8 && SvUTF8(qr));
6967     }
6968     else {
6969         int n = 0;
6970         STRLEN s;
6971         char *p, *newpat;
6972         int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */
6973         SV *sv, *qr_ref;
6974         dSP;
6975
6976         /* determine how many extra chars we need for ' and \ escaping */
6977         for (s = 0; s < plen; s++) {
6978             if (pat[s] == '\'' || pat[s] == '\\')
6979                 newlen++;
6980         }
6981
6982         Newx(newpat, newlen, char);
6983         p = newpat;
6984         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6985
6986         for (s = 0; s < plen; s++) {
6987             if (   pRExC_state->code_blocks
6988                 && n < pRExC_state->code_blocks->count
6989                 && s == pRExC_state->code_blocks->cb[n].start)
6990             {
6991                 /* blank out literal code block so that they aren't
6992                  * recompiled: eg change from/to:
6993                  *     /(?{xyz})/
6994                  *     /(?=====)/
6995                  * and
6996                  *     /(??{xyz})/
6997                  *     /(?======)/
6998                  * and
6999                  *     /(?(?{xyz}))/
7000                  *     /(?(?=====))/
7001                 */
7002                 assert(pat[s]   == '(');
7003                 assert(pat[s+1] == '?');
7004                 *p++ = '(';
7005                 *p++ = '?';
7006                 s += 2;
7007                 while (s < pRExC_state->code_blocks->cb[n].end) {
7008                     *p++ = '=';
7009                     s++;
7010                 }
7011                 *p++ = ')';
7012                 n++;
7013                 continue;
7014             }
7015             if (pat[s] == '\'' || pat[s] == '\\')
7016                 *p++ = '\\';
7017             *p++ = pat[s];
7018         }
7019         *p++ = '\'';
7020         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) {
7021             *p++ = 'x';
7022             if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) {
7023                 *p++ = 'x';
7024             }
7025         }
7026         *p++ = '\0';
7027         DEBUG_COMPILE_r({
7028             Perl_re_printf( aTHX_
7029                 "%sre-parsing pattern for runtime code:%s %s\n",
7030                 PL_colors[4], PL_colors[5], newpat);
7031         });
7032
7033         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
7034         Safefree(newpat);
7035
7036         ENTER;
7037         SAVETMPS;
7038         save_re_context();
7039         PUSHSTACKi(PERLSI_REQUIRE);
7040         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
7041          * parsing qr''; normally only q'' does this. It also alters
7042          * hints handling */
7043         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
7044         SvREFCNT_dec_NN(sv);
7045         SPAGAIN;
7046         qr_ref = POPs;
7047         PUTBACK;
7048         {
7049             SV * const errsv = ERRSV;
7050             if (SvTRUE_NN(errsv))
7051                 /* use croak_sv ? */
7052                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
7053         }
7054         assert(SvROK(qr_ref));
7055         qr = SvRV(qr_ref);
7056         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
7057         /* the leaving below frees the tmp qr_ref.
7058          * Give qr a life of its own */
7059         SvREFCNT_inc(qr);
7060         POPSTACK;
7061         FREETMPS;
7062         LEAVE;
7063
7064     }
7065
7066     if (!RExC_utf8 && SvUTF8(qr)) {
7067         /* first time through; the pattern got upgraded; save the
7068          * qr for the next time through */
7069         assert(!pRExC_state->runtime_code_qr);
7070         pRExC_state->runtime_code_qr = qr;
7071         return 0;
7072     }
7073
7074
7075     /* extract any code blocks within the returned qr//  */
7076
7077
7078     /* merge the main (r1) and run-time (r2) code blocks into one */
7079     {
7080         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
7081         struct reg_code_block *new_block, *dst;
7082         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
7083         int i1 = 0, i2 = 0;
7084         int r1c, r2c;
7085
7086         if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */
7087         {
7088             SvREFCNT_dec_NN(qr);
7089             return 1;
7090         }
7091
7092         if (!r1->code_blocks)
7093             r1->code_blocks = S_alloc_code_blocks(aTHX_ 0);
7094
7095         r1c = r1->code_blocks->count;
7096         r2c = r2->code_blocks->count;
7097
7098         Newx(new_block, r1c + r2c, struct reg_code_block);
7099
7100         dst = new_block;
7101
7102         while (i1 < r1c || i2 < r2c) {
7103             struct reg_code_block *src;
7104             bool is_qr = 0;
7105
7106             if (i1 == r1c) {
7107                 src = &r2->code_blocks->cb[i2++];
7108                 is_qr = 1;
7109             }
7110             else if (i2 == r2c)
7111                 src = &r1->code_blocks->cb[i1++];
7112             else if (  r1->code_blocks->cb[i1].start
7113                      < r2->code_blocks->cb[i2].start)
7114             {
7115                 src = &r1->code_blocks->cb[i1++];
7116                 assert(src->end < r2->code_blocks->cb[i2].start);
7117             }
7118             else {
7119                 assert(  r1->code_blocks->cb[i1].start
7120                        > r2->code_blocks->cb[i2].start);
7121                 src = &r2->code_blocks->cb[i2++];
7122                 is_qr = 1;
7123                 assert(src->end < r1->code_blocks->cb[i1].start);
7124             }
7125
7126             assert(pat[src->start] == '(');
7127             assert(pat[src->end]   == ')');
7128             dst->start      = src->start;
7129             dst->end        = src->end;
7130             dst->block      = src->block;
7131             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
7132                                     : src->src_regex;
7133             dst++;
7134         }
7135         r1->code_blocks->count += r2c;
7136         Safefree(r1->code_blocks->cb);
7137         r1->code_blocks->cb = new_block;
7138     }
7139
7140     SvREFCNT_dec_NN(qr);
7141     return 1;
7142 }
7143
7144
7145 STATIC bool
7146 S_setup_longest(pTHX_ RExC_state_t *pRExC_state,
7147                       struct reg_substr_datum  *rsd,
7148                       struct scan_data_substrs *sub,
7149                       STRLEN longest_length)
7150 {
7151     /* This is the common code for setting up the floating and fixed length
7152      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
7153      * as to whether succeeded or not */
7154
7155     I32 t;
7156     SSize_t ml;
7157     bool eol  = cBOOL(sub->flags & SF_BEFORE_EOL);
7158     bool meol = cBOOL(sub->flags & SF_BEFORE_MEOL);
7159
7160     if (! (longest_length
7161            || (eol /* Can't have SEOL and MULTI */
7162                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
7163           )
7164             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
7165         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
7166     {
7167         return FALSE;
7168     }
7169
7170     /* copy the information about the longest from the reg_scan_data
7171         over to the program. */
7172     if (SvUTF8(sub->str)) {
7173         rsd->substr      = NULL;
7174         rsd->utf8_substr = sub->str;
7175     } else {
7176         rsd->substr      = sub->str;
7177         rsd->utf8_substr = NULL;
7178     }
7179     /* end_shift is how many chars that must be matched that
7180         follow this item. We calculate it ahead of time as once the
7181         lookbehind offset is added in we lose the ability to correctly
7182         calculate it.*/
7183     ml = sub->minlenp ? *(sub->minlenp) : (SSize_t)longest_length;
7184     rsd->end_shift = ml - sub->min_offset
7185         - longest_length
7186             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
7187              * intead? - DAPM
7188             + (SvTAIL(sub->str) != 0)
7189             */
7190         + sub->lookbehind;
7191
7192     t = (eol/* Can't have SEOL and MULTI */
7193          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
7194     fbm_compile(sub->str, t ? FBMcf_TAIL : 0);
7195
7196     return TRUE;
7197 }
7198
7199 STATIC void
7200 S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx)
7201 {
7202     /* Calculates and sets in the compiled pattern 'Rx' the string to compile,
7203      * properly wrapped with the right modifiers */
7204
7205     bool has_p     = ((RExC_rx->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7206     bool has_charset = RExC_utf8 || (get_regex_charset(RExC_rx->extflags)
7207                                                 != REGEX_DEPENDS_CHARSET);
7208
7209     /* The caret is output if there are any defaults: if not all the STD
7210         * flags are set, or if no character set specifier is needed */
7211     bool has_default =
7212                 (((RExC_rx->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7213                 || ! has_charset);
7214     bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7215                                                 == REG_RUN_ON_COMMENT_SEEN);
7216     U8 reganch = (U8)((RExC_rx->extflags & RXf_PMf_STD_PMMOD)
7217                         >> RXf_PMf_STD_PMMOD_SHIFT);
7218     const char *fptr = STD_PAT_MODS;        /*"msixxn"*/
7219     char *p;
7220     STRLEN pat_len = RExC_precomp_end - RExC_precomp;
7221
7222     /* We output all the necessary flags; we never output a minus, as all
7223         * those are defaults, so are
7224         * covered by the caret */
7225     const STRLEN wraplen = pat_len + has_p + has_runon
7226         + has_default       /* If needs a caret */
7227         + PL_bitcount[reganch] /* 1 char for each set standard flag */
7228
7229             /* If needs a character set specifier */
7230         + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7231         + (sizeof("(?:)") - 1);
7232
7233     PERL_ARGS_ASSERT_SET_REGEX_PV;
7234
7235     /* make sure PL_bitcount bounds not exceeded */
7236     assert(sizeof(STD_PAT_MODS) <= 8);
7237
7238     p = sv_grow(MUTABLE_SV(Rx), wraplen + 1); /* +1 for the ending NUL */
7239     SvPOK_on(Rx);
7240     if (RExC_utf8)
7241         SvFLAGS(Rx) |= SVf_UTF8;
7242     *p++='('; *p++='?';
7243
7244     /* If a default, cover it using the caret */
7245     if (has_default) {
7246         *p++= DEFAULT_PAT_MOD;
7247     }
7248     if (has_charset) {
7249         STRLEN len;
7250         const char* name;
7251
7252         name = get_regex_charset_name(RExC_rx->extflags, &len);
7253         if (strEQ(name, DEPENDS_PAT_MODS)) {  /* /d under UTF-8 => /u */
7254             assert(RExC_utf8);
7255             name = UNICODE_PAT_MODS;
7256             len = sizeof(UNICODE_PAT_MODS) - 1;
7257         }
7258         Copy(name, p, len, char);
7259         p += len;
7260     }
7261     if (has_p)
7262         *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7263     {
7264         char ch;
7265         while((ch = *fptr++)) {
7266             if(reganch & 1)
7267                 *p++ = ch;
7268             reganch >>= 1;
7269         }
7270     }
7271
7272     *p++ = ':';
7273     Copy(RExC_precomp, p, pat_len, char);
7274     assert ((RX_WRAPPED(Rx) - p) < 16);
7275     RExC_rx->pre_prefix = p - RX_WRAPPED(Rx);
7276     p += pat_len;
7277
7278     /* Adding a trailing \n causes this to compile properly:
7279             my $R = qr / A B C # D E/x; /($R)/
7280         Otherwise the parens are considered part of the comment */
7281     if (has_runon)
7282         *p++ = '\n';
7283     *p++ = ')';
7284     *p = 0;
7285     SvCUR_set(Rx, p - RX_WRAPPED(Rx));
7286 }
7287
7288 /*
7289  * Perl_re_op_compile - the perl internal RE engine's function to compile a
7290  * regular expression into internal code.
7291  * The pattern may be passed either as:
7292  *    a list of SVs (patternp plus pat_count)
7293  *    a list of OPs (expr)
7294  * If both are passed, the SV list is used, but the OP list indicates
7295  * which SVs are actually pre-compiled code blocks
7296  *
7297  * The SVs in the list have magic and qr overloading applied to them (and
7298  * the list may be modified in-place with replacement SVs in the latter
7299  * case).
7300  *
7301  * If the pattern hasn't changed from old_re, then old_re will be
7302  * returned.
7303  *
7304  * eng is the current engine. If that engine has an op_comp method, then
7305  * handle directly (i.e. we assume that op_comp was us); otherwise, just
7306  * do the initial concatenation of arguments and pass on to the external
7307  * engine.
7308  *
7309  * If is_bare_re is not null, set it to a boolean indicating whether the
7310  * arg list reduced (after overloading) to a single bare regex which has
7311  * been returned (i.e. /$qr/).
7312  *
7313  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
7314  *
7315  * pm_flags contains the PMf_* flags, typically based on those from the
7316  * pm_flags field of the related PMOP. Currently we're only interested in
7317  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
7318  *
7319  * For many years this code had an initial sizing pass that calculated
7320  * (sometimes incorrectly, leading to security holes) the size needed for the
7321  * compiled pattern.  That was changed by commit
7322  * 7c932d07cab18751bfc7515b4320436273a459e2 in 5.29, which reallocs the size, a
7323  * node at a time, as parsing goes along.  Patches welcome to fix any obsolete
7324  * references to this sizing pass.
7325  *
7326  * Now, an initial crude guess as to the size needed is made, based on the
7327  * length of the pattern.  Patches welcome to improve that guess.  That amount
7328  * of space is malloc'd and then immediately freed, and then clawed back node
7329  * by node.  This design is to minimze, to the extent possible, memory churn
7330  * when doing the the reallocs.
7331  *
7332  * A separate parentheses counting pass may be needed in some cases.
7333  * (Previously the sizing pass did this.)  Patches welcome to reduce the number
7334  * of these cases.
7335  *
7336  * The existence of a sizing pass necessitated design decisions that are no
7337  * longer needed.  There are potential areas of simplification.
7338  *
7339  * Beware that the optimization-preparation code in here knows about some
7340  * of the structure of the compiled regexp.  [I'll say.]
7341  */
7342
7343 REGEXP *
7344 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
7345                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
7346                      bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags)
7347 {
7348     dVAR;
7349     REGEXP *Rx;         /* Capital 'R' means points to a REGEXP */
7350     STRLEN plen;
7351     char *exp;
7352     regnode *scan;
7353     I32 flags;
7354     SSize_t minlen = 0;
7355     U32 rx_flags;
7356     SV *pat;
7357     SV** new_patternp = patternp;
7358
7359     /* these are all flags - maybe they should be turned
7360      * into a single int with different bit masks */
7361     I32 sawlookahead = 0;
7362     I32 sawplus = 0;
7363     I32 sawopen = 0;
7364     I32 sawminmod = 0;
7365
7366     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
7367     bool recompile = 0;
7368     bool runtime_code = 0;
7369     scan_data_t data;
7370     RExC_state_t RExC_state;
7371     RExC_state_t * const pRExC_state = &RExC_state;
7372 #ifdef TRIE_STUDY_OPT
7373     int restudied = 0;
7374     RExC_state_t copyRExC_state;
7375 #endif
7376     GET_RE_DEBUG_FLAGS_DECL;
7377
7378     PERL_ARGS_ASSERT_RE_OP_COMPILE;
7379
7380     DEBUG_r(if (!PL_colorset) reginitcolors());
7381
7382     /* Initialize these here instead of as-needed, as is quick and avoids
7383      * having to test them each time otherwise */
7384     if (! PL_InBitmap) {
7385 #ifdef DEBUGGING
7386         char * dump_len_string;
7387 #endif
7388
7389         /* This is calculated here, because the Perl program that generates the
7390          * static global ones doesn't currently have access to
7391          * NUM_ANYOF_CODE_POINTS */
7392         PL_InBitmap = _new_invlist(2);
7393         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
7394                                                     NUM_ANYOF_CODE_POINTS - 1);
7395 #ifdef DEBUGGING
7396         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
7397         if (   ! dump_len_string
7398             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
7399         {
7400             PL_dump_re_max_len = 60;    /* A reasonable default */
7401         }
7402 #endif
7403     }
7404
7405     pRExC_state->warn_text = NULL;
7406     pRExC_state->unlexed_names = NULL;
7407     pRExC_state->code_blocks = NULL;
7408
7409     if (is_bare_re)
7410         *is_bare_re = FALSE;
7411
7412     if (expr && (expr->op_type == OP_LIST ||
7413                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
7414         /* allocate code_blocks if needed */
7415         OP *o;
7416         int ncode = 0;
7417
7418         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
7419             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
7420                 ncode++; /* count of DO blocks */
7421
7422         if (ncode)
7423             pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode);
7424     }
7425
7426     if (!pat_count) {
7427         /* compile-time pattern with just OP_CONSTs and DO blocks */
7428
7429         int n;
7430         OP *o;
7431
7432         /* find how many CONSTs there are */
7433         assert(expr);
7434         n = 0;
7435         if (expr->op_type == OP_CONST)
7436             n = 1;
7437         else
7438             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7439                 if (o->op_type == OP_CONST)
7440                     n++;
7441             }
7442
7443         /* fake up an SV array */
7444
7445         assert(!new_patternp);
7446         Newx(new_patternp, n, SV*);
7447         SAVEFREEPV(new_patternp);
7448         pat_count = n;
7449
7450         n = 0;
7451         if (expr->op_type == OP_CONST)
7452             new_patternp[n] = cSVOPx_sv(expr);
7453         else
7454             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
7455                 if (o->op_type == OP_CONST)
7456                     new_patternp[n++] = cSVOPo_sv;
7457             }
7458
7459     }
7460
7461     DEBUG_PARSE_r(Perl_re_printf( aTHX_
7462         "Assembling pattern from %d elements%s\n", pat_count,
7463             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7464
7465     /* set expr to the first arg op */
7466
7467     if (pRExC_state->code_blocks && pRExC_state->code_blocks->count
7468          && expr->op_type != OP_CONST)
7469     {
7470             expr = cLISTOPx(expr)->op_first;
7471             assert(   expr->op_type == OP_PUSHMARK
7472                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
7473                    || expr->op_type == OP_PADRANGE);
7474             expr = OpSIBLING(expr);
7475     }
7476
7477     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
7478                         expr, &recompile, NULL);
7479
7480     /* handle bare (possibly after overloading) regex: foo =~ $re */
7481     {
7482         SV *re = pat;
7483         if (SvROK(re))
7484             re = SvRV(re);
7485         if (SvTYPE(re) == SVt_REGEXP) {
7486             if (is_bare_re)
7487                 *is_bare_re = TRUE;
7488             SvREFCNT_inc(re);
7489             DEBUG_PARSE_r(Perl_re_printf( aTHX_
7490                 "Precompiled pattern%s\n",
7491                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
7492
7493             return (REGEXP*)re;
7494         }
7495     }
7496
7497     exp = SvPV_nomg(pat, plen);
7498
7499     if (!eng->op_comp) {
7500         if ((SvUTF8(pat) && IN_BYTES)
7501                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
7502         {
7503             /* make a temporary copy; either to convert to bytes,
7504              * or to avoid repeating get-magic / overloaded stringify */
7505             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
7506                                         (IN_BYTES ? 0 : SvUTF8(pat)));
7507         }
7508         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
7509     }
7510
7511     /* ignore the utf8ness if the pattern is 0 length */
7512     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
7513     RExC_uni_semantics = 0;
7514     RExC_contains_locale = 0;
7515     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
7516     RExC_in_script_run = 0;
7517     RExC_study_started = 0;
7518     pRExC_state->runtime_code_qr = NULL;
7519     RExC_frame_head= NULL;
7520     RExC_frame_last= NULL;
7521     RExC_frame_count= 0;
7522     RExC_latest_warn_offset = 0;
7523     RExC_use_BRANCHJ = 0;
7524     RExC_total_parens = 0;
7525     RExC_open_parens = NULL;
7526     RExC_close_parens = NULL;
7527     RExC_paren_names = NULL;
7528     RExC_size = 0;
7529     RExC_seen_d_op = FALSE;
7530 #ifdef DEBUGGING
7531     RExC_paren_name_list = NULL;
7532 #endif
7533
7534     DEBUG_r({
7535         RExC_mysv1= sv_newmortal();
7536         RExC_mysv2= sv_newmortal();
7537     });
7538
7539     DEBUG_COMPILE_r({
7540             SV *dsv= sv_newmortal();
7541             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, PL_dump_re_max_len);
7542             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
7543                           PL_colors[4], PL_colors[5], s);
7544         });
7545
7546     /* we jump here if we have to recompile, e.g., from upgrading the pattern
7547      * to utf8 */
7548
7549     if ((pm_flags & PMf_USE_RE_EVAL)
7550                 /* this second condition covers the non-regex literal case,
7551                  * i.e.  $foo =~ '(?{})'. */
7552                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
7553     )
7554         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
7555
7556   redo_parse:
7557     /* return old regex if pattern hasn't changed */
7558     /* XXX: note in the below we have to check the flags as well as the
7559      * pattern.
7560      *
7561      * Things get a touch tricky as we have to compare the utf8 flag
7562      * independently from the compile flags.  */
7563
7564     if (   old_re
7565         && !recompile
7566         && !!RX_UTF8(old_re) == !!RExC_utf8
7567         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
7568         && RX_PRECOMP(old_re)
7569         && RX_PRELEN(old_re) == plen
7570         && memEQ(RX_PRECOMP(old_re), exp, plen)
7571         && !runtime_code /* with runtime code, always recompile */ )
7572     {
7573         return old_re;
7574     }
7575
7576     /* Allocate the pattern's SV */
7577     RExC_rx_sv = Rx = (REGEXP*) newSV_type(SVt_REGEXP);
7578     RExC_rx = ReANY(Rx);
7579     if ( RExC_rx == NULL )
7580         FAIL("Regexp out of space");
7581
7582     rx_flags = orig_rx_flags;
7583
7584     if (   (UTF || RExC_uni_semantics)
7585         && initial_charset == REGEX_DEPENDS_CHARSET)
7586     {
7587
7588         /* Set to use unicode semantics if the pattern is in utf8 and has the
7589          * 'depends' charset specified, as it means unicode when utf8  */
7590         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7591         RExC_uni_semantics = 1;
7592     }
7593
7594     RExC_pm_flags = pm_flags;
7595
7596     if (runtime_code) {
7597         assert(TAINTING_get || !TAINT_get);
7598         if (TAINT_get)
7599             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
7600
7601         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7602             /* whoops, we have a non-utf8 pattern, whilst run-time code
7603              * got compiled as utf8. Try again with a utf8 pattern */
7604             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7605                 pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7606             goto redo_parse;
7607         }
7608     }
7609     assert(!pRExC_state->runtime_code_qr);
7610
7611     RExC_sawback = 0;
7612
7613     RExC_seen = 0;
7614     RExC_maxlen = 0;
7615     RExC_in_lookbehind = 0;
7616     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7617 #ifdef EBCDIC
7618     RExC_recode_x_to_native = 0;
7619 #endif
7620     RExC_in_multi_char_class = 0;
7621
7622     RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = RExC_precomp = exp;
7623     RExC_precomp_end = RExC_end = exp + plen;
7624     RExC_nestroot = 0;
7625     RExC_whilem_seen = 0;
7626     RExC_end_op = NULL;
7627     RExC_recurse = NULL;
7628     RExC_study_chunk_recursed = NULL;
7629     RExC_study_chunk_recursed_bytes= 0;
7630     RExC_recurse_count = 0;
7631     pRExC_state->code_index = 0;
7632
7633     /* Initialize the string in the compiled pattern.  This is so that there is
7634      * something to output if necessary */
7635     set_regex_pv(pRExC_state, Rx);
7636
7637     DEBUG_PARSE_r({
7638         Perl_re_printf( aTHX_
7639             "Starting parse and generation\n");
7640         RExC_lastnum=0;
7641         RExC_lastparse=NULL;
7642     });
7643
7644     /* Allocate space and zero-initialize. Note, the two step process
7645        of zeroing when in debug mode, thus anything assigned has to
7646        happen after that */
7647     if (!  RExC_size) {
7648
7649         /* On the first pass of the parse, we guess how big this will be.  Then
7650          * we grow in one operation to that amount and then give it back.  As
7651          * we go along, we re-allocate what we need.
7652          *
7653          * XXX Currently the guess is essentially that the pattern will be an
7654          * EXACT node with one byte input, one byte output.  This is crude, and
7655          * better heuristics are welcome.
7656          *
7657          * On any subsequent passes, we guess what we actually computed in the
7658          * latest earlier pass.  Such a pass probably didn't complete so is
7659          * missing stuff.  We could improve those guesses by knowing where the
7660          * parse stopped, and use the length so far plus apply the above
7661          * assumption to what's left. */
7662         RExC_size = STR_SZ(RExC_end - RExC_start);
7663     }
7664
7665     Newxc(RExC_rxi, sizeof(regexp_internal) + RExC_size, char, regexp_internal);
7666     if ( RExC_rxi == NULL )
7667         FAIL("Regexp out of space");
7668
7669     Zero(RExC_rxi, sizeof(regexp_internal) + RExC_size, char);
7670     RXi_SET( RExC_rx, RExC_rxi );
7671
7672     /* We start from 0 (over from 0 in the case this is a reparse.  The first
7673      * node parsed will give back any excess memory we have allocated so far).
7674      * */
7675     RExC_size = 0;
7676
7677     /* non-zero initialization begins here */
7678     RExC_rx->engine= eng;
7679     RExC_rx->extflags = rx_flags;
7680     RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7681
7682     if (pm_flags & PMf_IS_QR) {
7683         RExC_rxi->code_blocks = pRExC_state->code_blocks;
7684         if (RExC_rxi->code_blocks) {
7685             RExC_rxi->code_blocks->refcnt++;
7686         }
7687     }
7688
7689     RExC_rx->intflags = 0;
7690
7691     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7692     RExC_parse = exp;
7693
7694     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7695      * code makes sure the final byte is an uncounted NUL.  But should this
7696      * ever not be the case, lots of things could read beyond the end of the
7697      * buffer: loops like
7698      *      while(isFOO(*RExC_parse)) RExC_parse++;
7699      *      strchr(RExC_parse, "foo");
7700      * etc.  So it is worth noting. */
7701     assert(*RExC_end == '\0');
7702
7703     RExC_naughty = 0;
7704     RExC_npar = 1;
7705     RExC_parens_buf_size = 0;
7706     RExC_emit_start = RExC_rxi->program;
7707     pRExC_state->code_index = 0;
7708
7709     *((char*) RExC_emit_start) = (char) REG_MAGIC;
7710     RExC_emit = 1;
7711
7712     /* Do the parse */
7713     if (reg(pRExC_state, 0, &flags, 1)) {
7714
7715         /* Success!, But we may need to redo the parse knowing how many parens
7716          * there actually are */
7717         if (IN_PARENS_PASS) {
7718             flags |= RESTART_PARSE;
7719         }
7720
7721         /* We have that number in RExC_npar */
7722         RExC_total_parens = RExC_npar;
7723     }
7724     else if (! MUST_RESTART(flags)) {
7725         ReREFCNT_dec(Rx);
7726         Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags);
7727     }
7728
7729     /* Here, we either have success, or we have to redo the parse for some reason */
7730     if (MUST_RESTART(flags)) {
7731
7732         /* It's possible to write a regexp in ascii that represents Unicode
7733         codepoints outside of the byte range, such as via \x{100}. If we
7734         detect such a sequence we have to convert the entire pattern to utf8
7735         and then recompile, as our sizing calculation will have been based
7736         on 1 byte == 1 character, but we will need to use utf8 to encode
7737         at least some part of the pattern, and therefore must convert the whole
7738         thing.
7739         -- dmq */
7740         if (flags & NEED_UTF8) {
7741
7742             /* We have stored the offset of the final warning output so far.
7743              * That must be adjusted.  Any variant characters between the start
7744              * of the pattern and this warning count for 2 bytes in the final,
7745              * so just add them again */
7746             if (UNLIKELY(RExC_latest_warn_offset > 0)) {
7747                 RExC_latest_warn_offset +=
7748                             variant_under_utf8_count((U8 *) exp, (U8 *) exp
7749                                                 + RExC_latest_warn_offset);
7750             }
7751             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7752             pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0);
7753             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse after upgrade\n"));
7754         }
7755         else {
7756             DEBUG_PARSE_r(Perl_re_printf( aTHX_ "Need to redo parse\n"));
7757         }
7758
7759         if (ALL_PARENS_COUNTED) {
7760             /* Make enough room for all the known parens, and zero it */
7761             Renew(RExC_open_parens, RExC_total_parens, regnode_offset);
7762             Zero(RExC_open_parens, RExC_total_parens, regnode_offset);
7763             RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
7764
7765             Renew(RExC_close_parens, RExC_total_parens, regnode_offset);
7766             Zero(RExC_close_parens, RExC_total_parens, regnode_offset);
7767         }
7768         else { /* Parse did not complete.  Reinitialize the parentheses
7769                   structures */
7770             RExC_total_parens = 0;
7771             if (RExC_open_parens) {
7772                 Safefree(RExC_open_parens);
7773                 RExC_open_parens = NULL;
7774             }
7775             if (RExC_close_parens) {
7776                 Safefree(RExC_close_parens);
7777                 RExC_close_parens = NULL;
7778             }
7779         }
7780
7781         /* Clean up what we did in this parse */
7782         SvREFCNT_dec_NN(RExC_rx_sv);
7783
7784         goto redo_parse;
7785     }
7786
7787     /* Here, we have successfully parsed and generated the pattern's program
7788      * for the regex engine.  We are ready to finish things up and look for
7789      * optimizations. */
7790
7791     /* Update the string to compile, with correct modifiers, etc */
7792     set_regex_pv(pRExC_state, Rx);
7793
7794     RExC_rx->nparens = RExC_total_parens - 1;
7795
7796     /* Uses the upper 4 bits of the FLAGS field, so keep within that size */
7797     if (RExC_whilem_seen > 15)
7798         RExC_whilem_seen = 15;
7799
7800     DEBUG_PARSE_r({
7801         Perl_re_printf( aTHX_
7802             "Required size %" IVdf " nodes\n", (IV)RExC_size);
7803         RExC_lastnum=0;
7804         RExC_lastparse=NULL;
7805     });
7806
7807 #ifdef RE_TRACK_PATTERN_OFFSETS
7808     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7809                           "%s %" UVuf " bytes for offset annotations.\n",
7810                           RExC_offsets ? "Got" : "Couldn't get",
7811                           (UV)((RExC_offsets[0] * 2 + 1))));
7812     DEBUG_OFFSETS_r(if (RExC_offsets) {
7813         const STRLEN len = RExC_offsets[0];
7814         STRLEN i;
7815         GET_RE_DEBUG_FLAGS_DECL;
7816         Perl_re_printf( aTHX_
7817                       "Offsets: [%" UVuf "]\n\t", (UV)RExC_offsets[0]);
7818         for (i = 1; i <= len; i++) {
7819             if (RExC_offsets[i*2-1] || RExC_offsets[i*2])
7820                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7821                 (UV)i, (UV)RExC_offsets[i*2-1], (UV)RExC_offsets[i*2]);
7822         }
7823         Perl_re_printf( aTHX_  "\n");
7824     });
7825
7826 #else
7827     SetProgLen(RExC_rxi,RExC_size);
7828 #endif
7829
7830     DEBUG_OPTIMISE_r(
7831         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7832     );
7833
7834     /* XXXX To minimize changes to RE engine we always allocate
7835        3-units-long substrs field. */
7836     Newx(RExC_rx->substrs, 1, struct reg_substr_data);
7837     if (RExC_recurse_count) {
7838         Newx(RExC_recurse, RExC_recurse_count, regnode *);
7839         SAVEFREEPV(RExC_recurse);
7840     }
7841
7842     if (RExC_seen & REG_RECURSE_SEEN) {
7843         /* Note, RExC_total_parens is 1 + the number of parens in a pattern.
7844          * So its 1 if there are no parens. */
7845         RExC_study_chunk_recursed_bytes= (RExC_total_parens >> 3) +
7846                                          ((RExC_total_parens & 0x07) != 0);
7847         Newx(RExC_study_chunk_recursed,
7848              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
7849         SAVEFREEPV(RExC_study_chunk_recursed);
7850     }
7851
7852   reStudy:
7853     RExC_rx->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7854     DEBUG_r(
7855         RExC_study_chunk_recursed_count= 0;
7856     );
7857     Zero(RExC_rx->substrs, 1, struct reg_substr_data);
7858     if (RExC_study_chunk_recursed) {
7859         Zero(RExC_study_chunk_recursed,
7860              RExC_study_chunk_recursed_bytes * RExC_total_parens, U8);
7861     }
7862
7863
7864 #ifdef TRIE_STUDY_OPT
7865     if (!restudied) {
7866         StructCopy(&zero_scan_data, &data, scan_data_t);
7867         copyRExC_state = RExC_state;
7868     } else {
7869         U32 seen=RExC_seen;
7870         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7871
7872         RExC_state = copyRExC_state;
7873         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7874             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7875         else
7876             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7877         StructCopy(&zero_scan_data, &data, scan_data_t);
7878     }
7879 #else
7880     StructCopy(&zero_scan_data, &data, scan_data_t);
7881 #endif
7882
7883     /* Dig out information for optimizations. */
7884     RExC_rx->extflags = RExC_flags; /* was pm_op */
7885     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7886
7887     if (UTF)
7888         SvUTF8_on(Rx);  /* Unicode in it? */
7889     RExC_rxi->regstclass = NULL;
7890     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7891         RExC_rx->intflags |= PREGf_NAUGHTY;
7892     scan = RExC_rxi->program + 1;               /* First BRANCH. */
7893
7894     /* testing for BRANCH here tells us whether there is "must appear"
7895        data in the pattern. If there is then we can use it for optimisations */
7896     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7897                                                   */
7898         SSize_t fake;
7899         STRLEN longest_length[2];
7900         regnode_ssc ch_class; /* pointed to by data */
7901         int stclass_flag;
7902         SSize_t last_close = 0; /* pointed to by data */
7903         regnode *first= scan;
7904         regnode *first_next= regnext(first);
7905         int i;
7906
7907         /*
7908          * Skip introductions and multiplicators >= 1
7909          * so that we can extract the 'meat' of the pattern that must
7910          * match in the large if() sequence following.
7911          * NOTE that EXACT is NOT covered here, as it is normally
7912          * picked up by the optimiser separately.
7913          *
7914          * This is unfortunate as the optimiser isnt handling lookahead
7915          * properly currently.
7916          *
7917          */
7918         while ((OP(first) == OPEN && (sawopen = 1)) ||
7919                /* An OR of *one* alternative - should not happen now. */
7920             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7921             /* for now we can't handle lookbehind IFMATCH*/
7922             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7923             (OP(first) == PLUS) ||
7924             (OP(first) == MINMOD) ||
7925                /* An {n,m} with n>0 */
7926             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7927             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7928         {
7929                 /*
7930                  * the only op that could be a regnode is PLUS, all the rest
7931                  * will be regnode_1 or regnode_2.
7932                  *
7933                  * (yves doesn't think this is true)
7934                  */
7935                 if (OP(first) == PLUS)
7936                     sawplus = 1;
7937                 else {
7938                     if (OP(first) == MINMOD)
7939                         sawminmod = 1;
7940                     first += regarglen[OP(first)];
7941                 }
7942                 first = NEXTOPER(first);
7943                 first_next= regnext(first);
7944         }
7945
7946         /* Starting-point info. */
7947       again:
7948         DEBUG_PEEP("first:", first, 0, 0);
7949         /* Ignore EXACT as we deal with it later. */
7950         if (PL_regkind[OP(first)] == EXACT) {
7951             if (   OP(first) == EXACT
7952                 || OP(first) == EXACT_ONLY8
7953                 || OP(first) == EXACTL)
7954             {
7955                 NOOP;   /* Empty, get anchored substr later. */
7956             }
7957             else
7958                 RExC_rxi->regstclass = first;
7959         }
7960 #ifdef TRIE_STCLASS
7961         else if (PL_regkind[OP(first)] == TRIE &&
7962                 ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0)
7963         {
7964             /* this can happen only on restudy */
7965             RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7966         }
7967 #endif
7968         else if (REGNODE_SIMPLE(OP(first)))
7969             RExC_rxi->regstclass = first;
7970         else if (PL_regkind[OP(first)] == BOUND ||
7971                  PL_regkind[OP(first)] == NBOUND)
7972             RExC_rxi->regstclass = first;
7973         else if (PL_regkind[OP(first)] == BOL) {
7974             RExC_rx->intflags |= (OP(first) == MBOL
7975                            ? PREGf_ANCH_MBOL
7976                            : PREGf_ANCH_SBOL);
7977             first = NEXTOPER(first);
7978             goto again;
7979         }
7980         else if (OP(first) == GPOS) {
7981             RExC_rx->intflags |= PREGf_ANCH_GPOS;
7982             first = NEXTOPER(first);
7983             goto again;
7984         }
7985         else if ((!sawopen || !RExC_sawback) &&
7986             !sawlookahead &&
7987             (OP(first) == STAR &&
7988             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7989             !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks)
7990         {
7991             /* turn .* into ^.* with an implied $*=1 */
7992             const int type =
7993                 (OP(NEXTOPER(first)) == REG_ANY)
7994                     ? PREGf_ANCH_MBOL
7995                     : PREGf_ANCH_SBOL;
7996             RExC_rx->intflags |= (type | PREGf_IMPLICIT);
7997             first = NEXTOPER(first);
7998             goto again;
7999         }
8000         if (sawplus && !sawminmod && !sawlookahead
8001             && (!sawopen || !RExC_sawback)
8002             && !pRExC_state->code_blocks) /* May examine pos and $& */
8003             /* x+ must match at the 1st pos of run of x's */
8004             RExC_rx->intflags |= PREGf_SKIP;
8005
8006         /* Scan is after the zeroth branch, first is atomic matcher. */
8007 #ifdef TRIE_STUDY_OPT
8008         DEBUG_PARSE_r(
8009             if (!restudied)
8010                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8011                               (IV)(first - scan + 1))
8012         );
8013 #else
8014         DEBUG_PARSE_r(
8015             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
8016                 (IV)(first - scan + 1))
8017         );
8018 #endif
8019
8020
8021         /*
8022         * If there's something expensive in the r.e., find the
8023         * longest literal string that must appear and make it the
8024         * regmust.  Resolve ties in favor of later strings, since
8025         * the regstart check works with the beginning of the r.e.
8026         * and avoiding duplication strengthens checking.  Not a
8027         * strong reason, but sufficient in the absence of others.
8028         * [Now we resolve ties in favor of the earlier string if
8029         * it happens that c_offset_min has been invalidated, since the
8030         * earlier string may buy us something the later one won't.]
8031         */
8032
8033         data.substrs[0].str = newSVpvs("");
8034         data.substrs[1].str = newSVpvs("");
8035         data.last_found = newSVpvs("");
8036         data.cur_is_floating = 0; /* initially any found substring is fixed */
8037         ENTER_with_name("study_chunk");
8038         SAVEFREESV(data.substrs[0].str);
8039         SAVEFREESV(data.substrs[1].str);
8040         SAVEFREESV(data.last_found);
8041         first = scan;
8042         if (!RExC_rxi->regstclass) {
8043             ssc_init(pRExC_state, &ch_class);
8044             data.start_class = &ch_class;
8045             stclass_flag = SCF_DO_STCLASS_AND;
8046         } else                          /* XXXX Check for BOUND? */
8047             stclass_flag = 0;
8048         data.last_closep = &last_close;
8049
8050         DEBUG_RExC_seen();
8051         /*
8052          * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/
8053          * (NO top level branches)
8054          */
8055         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
8056                              scan + RExC_size, /* Up to end */
8057             &data, -1, 0, NULL,
8058             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
8059                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
8060             0);
8061
8062
8063         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
8064
8065
8066         if ( RExC_total_parens == 1 && !data.cur_is_floating
8067              && data.last_start_min == 0 && data.last_end > 0
8068              && !RExC_seen_zerolen
8069              && !(RExC_seen & REG_VERBARG_SEEN)
8070              && !(RExC_seen & REG_GPOS_SEEN)
8071         ){
8072             RExC_rx->extflags |= RXf_CHECK_ALL;
8073         }
8074         scan_commit(pRExC_state, &data,&minlen, 0);
8075
8076
8077         /* XXX this is done in reverse order because that's the way the
8078          * code was before it was parameterised. Don't know whether it
8079          * actually needs doing in reverse order. DAPM */
8080         for (i = 1; i >= 0; i--) {
8081             longest_length[i] = CHR_SVLEN(data.substrs[i].str);
8082
8083             if (   !(   i
8084                      && SvCUR(data.substrs[0].str)  /* ok to leave SvCUR */
8085                      &&    data.substrs[0].min_offset
8086                         == data.substrs[1].min_offset
8087                      &&    SvCUR(data.substrs[0].str)
8088                         == SvCUR(data.substrs[1].str)
8089                     )
8090                 && S_setup_longest (aTHX_ pRExC_state,
8091                                         &(RExC_rx->substrs->data[i]),
8092                                         &(data.substrs[i]),
8093                                         longest_length[i]))
8094             {
8095                 RExC_rx->substrs->data[i].min_offset =
8096                         data.substrs[i].min_offset - data.substrs[i].lookbehind;
8097
8098                 RExC_rx->substrs->data[i].max_offset = data.substrs[i].max_offset;
8099                 /* Don't offset infinity */
8100                 if (data.substrs[i].max_offset < SSize_t_MAX)
8101                     RExC_rx->substrs->data[i].max_offset -= data.substrs[i].lookbehind;
8102                 SvREFCNT_inc_simple_void_NN(data.substrs[i].str);
8103             }
8104             else {
8105                 RExC_rx->substrs->data[i].substr      = NULL;
8106                 RExC_rx->substrs->data[i].utf8_substr = NULL;
8107                 longest_length[i] = 0;
8108             }
8109         }
8110
8111         LEAVE_with_name("study_chunk");
8112
8113         if (RExC_rxi->regstclass
8114             && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY))
8115             RExC_rxi->regstclass = NULL;
8116
8117         if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr)
8118               || RExC_rx->substrs->data[0].min_offset)
8119             && stclass_flag
8120             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8121             && is_ssc_worth_it(pRExC_state, data.start_class))
8122         {
8123             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8124
8125             ssc_finalize(pRExC_state, data.start_class);
8126
8127             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8128             StructCopy(data.start_class,
8129                        (regnode_ssc*)RExC_rxi->data->data[n],
8130                        regnode_ssc);
8131             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8132             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8133             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
8134                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8135                       Perl_re_printf( aTHX_
8136                                     "synthetic stclass \"%s\".\n",
8137                                     SvPVX_const(sv));});
8138             data.start_class = NULL;
8139         }
8140
8141         /* A temporary algorithm prefers floated substr to fixed one of
8142          * same length to dig more info. */
8143         i = (longest_length[0] <= longest_length[1]);
8144         RExC_rx->substrs->check_ix = i;
8145         RExC_rx->check_end_shift  = RExC_rx->substrs->data[i].end_shift;
8146         RExC_rx->check_substr     = RExC_rx->substrs->data[i].substr;
8147         RExC_rx->check_utf8       = RExC_rx->substrs->data[i].utf8_substr;
8148         RExC_rx->check_offset_min = RExC_rx->substrs->data[i].min_offset;
8149         RExC_rx->check_offset_max = RExC_rx->substrs->data[i].max_offset;
8150         if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS)))
8151             RExC_rx->intflags |= PREGf_NOSCAN;
8152
8153         if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) {
8154             RExC_rx->extflags |= RXf_USE_INTUIT;
8155             if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8))
8156                 RExC_rx->extflags |= RXf_INTUIT_TAIL;
8157         }
8158
8159         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
8160         if ( (STRLEN)minlen < longest_length[1] )
8161             minlen= longest_length[1];
8162         if ( (STRLEN)minlen < longest_length[0] )
8163             minlen= longest_length[0];
8164         */
8165     }
8166     else {
8167         /* Several toplevels. Best we can is to set minlen. */
8168         SSize_t fake;
8169         regnode_ssc ch_class;
8170         SSize_t last_close = 0;
8171
8172         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
8173
8174         scan = RExC_rxi->program + 1;
8175         ssc_init(pRExC_state, &ch_class);
8176         data.start_class = &ch_class;
8177         data.last_closep = &last_close;
8178
8179         DEBUG_RExC_seen();
8180         /*
8181          * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../
8182          * (patterns WITH top level branches)
8183          */
8184         minlen = study_chunk(pRExC_state,
8185             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
8186             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
8187                                                       ? SCF_TRIE_DOING_RESTUDY
8188                                                       : 0),
8189             0);
8190
8191         CHECK_RESTUDY_GOTO_butfirst(NOOP);
8192
8193         RExC_rx->check_substr = NULL;
8194         RExC_rx->check_utf8 = NULL;
8195         RExC_rx->substrs->data[0].substr      = NULL;
8196         RExC_rx->substrs->data[0].utf8_substr = NULL;
8197         RExC_rx->substrs->data[1].substr      = NULL;
8198         RExC_rx->substrs->data[1].utf8_substr = NULL;
8199
8200         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
8201             && is_ssc_worth_it(pRExC_state, data.start_class))
8202         {
8203             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
8204
8205             ssc_finalize(pRExC_state, data.start_class);
8206
8207             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
8208             StructCopy(data.start_class,
8209                        (regnode_ssc*)RExC_rxi->data->data[n],
8210                        regnode_ssc);
8211             RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n];
8212             RExC_rx->intflags &= ~PREGf_SKIP;   /* Used in find_byclass(). */
8213             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
8214                       regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state);
8215                       Perl_re_printf( aTHX_
8216                                     "synthetic stclass \"%s\".\n",
8217                                     SvPVX_const(sv));});
8218             data.start_class = NULL;
8219         }
8220     }
8221
8222     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
8223         RExC_rx->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
8224         RExC_rx->maxlen = REG_INFTY;
8225     }
8226     else {
8227         RExC_rx->maxlen = RExC_maxlen;
8228     }
8229
8230     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
8231        the "real" pattern. */
8232     DEBUG_OPTIMISE_r({
8233         Perl_re_printf( aTHX_ "minlen: %" IVdf " RExC_rx->minlen:%" IVdf " maxlen:%" IVdf "\n",
8234                       (IV)minlen, (IV)RExC_rx->minlen, (IV)RExC_maxlen);
8235     });
8236     RExC_rx->minlenret = minlen;
8237     if (RExC_rx->minlen < minlen)
8238         RExC_rx->minlen = minlen;
8239
8240     if (RExC_seen & REG_RECURSE_SEEN ) {
8241         RExC_rx->intflags |= PREGf_RECURSE_SEEN;
8242         Newx(RExC_rx->recurse_locinput, RExC_rx->nparens + 1, char *);
8243     }
8244     if (RExC_seen & REG_GPOS_SEEN)
8245         RExC_rx->intflags |= PREGf_GPOS_SEEN;
8246     if (RExC_seen & REG_LOOKBEHIND_SEEN)
8247         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
8248                                                 lookbehind */
8249     if (pRExC_state->code_blocks)
8250         RExC_rx->extflags |= RXf_EVAL_SEEN;
8251     if (RExC_seen & REG_VERBARG_SEEN)
8252     {
8253         RExC_rx->intflags |= PREGf_VERBARG_SEEN;
8254         RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
8255     }
8256     if (RExC_seen & REG_CUTGROUP_SEEN)
8257         RExC_rx->intflags |= PREGf_CUTGROUP_SEEN;
8258     if (pm_flags & PMf_USE_RE_EVAL)
8259         RExC_rx->intflags |= PREGf_USE_RE_EVAL;
8260     if (RExC_paren_names)
8261         RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
8262     else
8263         RXp_PAREN_NAMES(RExC_rx) = NULL;
8264
8265     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
8266      * so it can be used in pp.c */
8267     if (RExC_rx->intflags & PREGf_ANCH)
8268         RExC_rx->extflags |= RXf_IS_ANCHORED;
8269
8270
8271     {
8272         /* this is used to identify "special" patterns that might result
8273          * in Perl NOT calling the regex engine and instead doing the match "itself",
8274          * particularly special cases in split//. By having the regex compiler
8275          * do this pattern matching at a regop level (instead of by inspecting the pattern)
8276          * we avoid weird issues with equivalent patterns resulting in different behavior,
8277          * AND we allow non Perl engines to get the same optimizations by the setting the
8278          * flags appropriately - Yves */
8279         regnode *first = RExC_rxi->program + 1;
8280         U8 fop = OP(first);
8281         regnode *next = regnext(first);
8282         U8 nop = OP(next);
8283
8284         if (PL_regkind[fop] == NOTHING && nop == END)
8285             RExC_rx->extflags |= RXf_NULL;
8286         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
8287             /* when fop is SBOL first->flags will be true only when it was
8288              * produced by parsing /\A/, and not when parsing /^/. This is
8289              * very important for the split code as there we want to
8290              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
8291              * See rt #122761 for more details. -- Yves */
8292             RExC_rx->extflags |= RXf_START_ONLY;
8293         else if (fop == PLUS
8294                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
8295                  && nop == END)
8296             RExC_rx->extflags |= RXf_WHITE;
8297         else if ( RExC_rx->extflags & RXf_SPLIT
8298                   && (fop == EXACT || fop == EXACT_ONLY8 || fop == EXACTL)
8299                   && STR_LEN(first) == 1
8300                   && *(STRING(first)) == ' '
8301                   && nop == END )
8302             RExC_rx->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
8303
8304     }
8305
8306     if (RExC_contains_locale) {
8307         RXp_EXTFLAGS(RExC_rx) |= RXf_TAINTED;
8308     }
8309
8310 #ifdef DEBUGGING
8311     if (RExC_paren_names) {
8312         RExC_rxi->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
8313         RExC_rxi->data->data[RExC_rxi->name_list_idx]
8314                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
8315     } else
8316 #endif
8317     RExC_rxi->name_list_idx = 0;
8318
8319     while ( RExC_recurse_count > 0 ) {
8320         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
8321         /*
8322          * This data structure is set up in study_chunk() and is used
8323          * to calculate the distance between a GOSUB regopcode and
8324          * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's)
8325          * it refers to.
8326          *
8327          * If for some reason someone writes code that optimises
8328          * away a GOSUB opcode then the assert should be changed to
8329          * an if(scan) to guard the ARG2L_SET() - Yves
8330          *
8331          */
8332         assert(scan && OP(scan) == GOSUB);
8333         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - REGNODE_OFFSET(scan));
8334     }
8335
8336     Newxz(RExC_rx->offs, RExC_total_parens, regexp_paren_pair);
8337     /* assume we don't need to swap parens around before we match */
8338     DEBUG_TEST_r({
8339         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
8340             (unsigned long)RExC_study_chunk_recursed_count);
8341     });
8342     DEBUG_DUMP_r({
8343         DEBUG_RExC_seen();
8344         Perl_re_printf( aTHX_ "Final program:\n");
8345         regdump(RExC_rx);
8346     });
8347
8348     if (RExC_open_parens) {
8349         Safefree(RExC_open_parens);
8350         RExC_open_parens = NULL;
8351     }
8352     if (RExC_close_parens) {
8353         Safefree(RExC_close_parens);
8354         RExC_close_parens = NULL;
8355     }
8356
8357 #ifdef USE_ITHREADS
8358     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
8359      * by setting the regexp SV to readonly-only instead. If the
8360      * pattern's been recompiled, the USEDness should remain. */
8361     if (old_re && SvREADONLY(old_re))
8362         SvREADONLY_on(Rx);
8363 #endif
8364     return Rx;
8365 }
8366
8367
8368 SV*
8369 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
8370                     const U32 flags)
8371 {
8372     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
8373
8374     PERL_UNUSED_ARG(value);
8375
8376     if (flags & RXapif_FETCH) {
8377         return reg_named_buff_fetch(rx, key, flags);
8378     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
8379         Perl_croak_no_modify();
8380         return NULL;
8381     } else if (flags & RXapif_EXISTS) {
8382         return reg_named_buff_exists(rx, key, flags)
8383             ? &PL_sv_yes
8384             : &PL_sv_no;
8385     } else if (flags & RXapif_REGNAMES) {
8386         return reg_named_buff_all(rx, flags);
8387     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
8388         return reg_named_buff_scalar(rx, flags);
8389     } else {
8390         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
8391         return NULL;
8392     }
8393 }
8394
8395 SV*
8396 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
8397                          const U32 flags)
8398 {
8399     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
8400     PERL_UNUSED_ARG(lastkey);
8401
8402     if (flags & RXapif_FIRSTKEY)
8403         return reg_named_buff_firstkey(rx, flags);
8404     else if (flags & RXapif_NEXTKEY)
8405         return reg_named_buff_nextkey(rx, flags);
8406     else {
8407         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
8408                                             (int)flags);
8409         return NULL;
8410     }
8411 }
8412
8413 SV*
8414 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
8415                           const U32 flags)
8416 {
8417     SV *ret;
8418     struct regexp *const rx = ReANY(r);
8419
8420     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
8421
8422     if (rx && RXp_PAREN_NAMES(rx)) {
8423         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
8424         if (he_str) {
8425             IV i;
8426             SV* sv_dat=HeVAL(he_str);
8427             I32 *nums=(I32*)SvPVX(sv_dat);
8428             AV * const retarray = (flags & RXapif_ALL) ? newAV() : NULL;
8429             for ( i=0; i<SvIVX(sv_dat); i++ ) {
8430                 if ((I32)(rx->nparens) >= nums[i]
8431                     && rx->offs[nums[i]].start != -1
8432                     && rx->offs[nums[i]].end != -1)
8433                 {
8434                     ret = newSVpvs("");
8435                     CALLREG_NUMBUF_FETCH(r, nums[i], ret);
8436                     if (!retarray)
8437                         return ret;
8438                 } else {
8439                     if (retarray)
8440                         ret = newSVsv(&PL_sv_undef);
8441                 }
8442                 if (retarray)
8443                     av_push(retarray, ret);
8444             }
8445             if (retarray)
8446                 return newRV_noinc(MUTABLE_SV(retarray));
8447         }
8448     }
8449     return NULL;
8450 }
8451
8452 bool
8453 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
8454                            const U32 flags)
8455 {
8456     struct regexp *const rx = ReANY(r);
8457
8458     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
8459
8460     if (rx && RXp_PAREN_NAMES(rx)) {
8461         if (flags & RXapif_ALL) {
8462             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
8463         } else {
8464             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
8465             if (sv) {
8466                 SvREFCNT_dec_NN(sv);
8467                 return TRUE;
8468             } else {
8469                 return FALSE;
8470             }
8471         }
8472     } else {
8473         return FALSE;
8474     }
8475 }
8476
8477 SV*
8478 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
8479 {
8480     struct regexp *const rx = ReANY(r);
8481
8482     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
8483
8484     if ( rx && RXp_PAREN_NAMES(rx) ) {
8485         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
8486
8487         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
8488     } else {
8489         return FALSE;
8490     }
8491 }
8492
8493 SV*
8494 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
8495 {
8496     struct regexp *const rx = ReANY(r);
8497     GET_RE_DEBUG_FLAGS_DECL;
8498
8499     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
8500
8501     if (rx && RXp_PAREN_NAMES(rx)) {
8502         HV *hv = RXp_PAREN_NAMES(rx);
8503         HE *temphe;
8504         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8505             IV i;
8506             IV parno = 0;
8507             SV* sv_dat = HeVAL(temphe);
8508             I32 *nums = (I32*)SvPVX(sv_dat);
8509             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8510                 if ((I32)(rx->lastparen) >= nums[i] &&
8511                     rx->offs[nums[i]].start != -1 &&
8512                     rx->offs[nums[i]].end != -1)
8513                 {
8514                     parno = nums[i];
8515                     break;
8516                 }
8517             }
8518             if (parno || flags & RXapif_ALL) {
8519                 return newSVhek(HeKEY_hek(temphe));
8520             }
8521         }
8522     }
8523     return NULL;
8524 }
8525
8526 SV*
8527 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
8528 {
8529     SV *ret;
8530     AV *av;
8531     SSize_t length;
8532     struct regexp *const rx = ReANY(r);
8533
8534     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
8535
8536     if (rx && RXp_PAREN_NAMES(rx)) {
8537         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
8538             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
8539         } else if (flags & RXapif_ONE) {
8540             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
8541             av = MUTABLE_AV(SvRV(ret));
8542             length = av_tindex(av);
8543             SvREFCNT_dec_NN(ret);
8544             return newSViv(length + 1);
8545         } else {
8546             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8547                                                 (int)flags);
8548             return NULL;
8549         }
8550     }
8551     return &PL_sv_undef;
8552 }
8553
8554 SV*
8555 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8556 {
8557     struct regexp *const rx = ReANY(r);
8558     AV *av = newAV();
8559
8560     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8561
8562     if (rx && RXp_PAREN_NAMES(rx)) {
8563         HV *hv= RXp_PAREN_NAMES(rx);
8564         HE *temphe;
8565         (void)hv_iterinit(hv);
8566         while ( (temphe = hv_iternext_flags(hv, 0)) ) {
8567             IV i;
8568             IV parno = 0;
8569             SV* sv_dat = HeVAL(temphe);
8570             I32 *nums = (I32*)SvPVX(sv_dat);
8571             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8572                 if ((I32)(rx->lastparen) >= nums[i] &&
8573                     rx->offs[nums[i]].start != -1 &&
8574                     rx->offs[nums[i]].end != -1)
8575                 {
8576                     parno = nums[i];
8577                     break;
8578                 }
8579             }
8580             if (parno || flags & RXapif_ALL) {
8581                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8582             }
8583         }
8584     }
8585
8586     return newRV_noinc(MUTABLE_SV(av));
8587 }
8588
8589 void
8590 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8591                              SV * const sv)
8592 {
8593     struct regexp *const rx = ReANY(r);
8594     char *s = NULL;
8595     SSize_t i = 0;
8596     SSize_t s1, t1;
8597     I32 n = paren;
8598
8599     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8600
8601     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8602            || n == RX_BUFF_IDX_CARET_FULLMATCH
8603            || n == RX_BUFF_IDX_CARET_POSTMATCH
8604        )
8605     {
8606         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8607         if (!keepcopy) {
8608             /* on something like
8609              *    $r = qr/.../;
8610              *    /$qr/p;
8611              * the KEEPCOPY is set on the PMOP rather than the regex */
8612             if (PL_curpm && r == PM_GETRE(PL_curpm))
8613                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8614         }
8615         if (!keepcopy)
8616             goto ret_undef;
8617     }
8618
8619     if (!rx->subbeg)
8620         goto ret_undef;
8621
8622     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8623         /* no need to distinguish between them any more */
8624         n = RX_BUFF_IDX_FULLMATCH;
8625
8626     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8627         && rx->offs[0].start != -1)
8628     {
8629         /* $`, ${^PREMATCH} */
8630         i = rx->offs[0].start;
8631         s = rx->subbeg;
8632     }
8633     else
8634     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8635         && rx->offs[0].end != -1)
8636     {
8637         /* $', ${^POSTMATCH} */
8638         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8639         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8640     }
8641     else
8642     if ( 0 <= n && n <= (I32)rx->nparens &&
8643         (s1 = rx->offs[n].start) != -1 &&
8644         (t1 = rx->offs[n].end) != -1)
8645     {
8646         /* $&, ${^MATCH},  $1 ... */
8647         i = t1 - s1;
8648         s = rx->subbeg + s1 - rx->suboffset;
8649     } else {
8650         goto ret_undef;
8651     }
8652
8653     assert(s >= rx->subbeg);
8654     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8655     if (i >= 0) {
8656 #ifdef NO_TAINT_SUPPORT
8657         sv_setpvn(sv, s, i);
8658 #else
8659         const int oldtainted = TAINT_get;
8660         TAINT_NOT;
8661         sv_setpvn(sv, s, i);
8662         TAINT_set(oldtainted);
8663 #endif
8664         if (RXp_MATCH_UTF8(rx))
8665             SvUTF8_on(sv);
8666         else
8667             SvUTF8_off(sv);
8668         if (TAINTING_get) {
8669             if (RXp_MATCH_TAINTED(rx)) {
8670                 if (SvTYPE(sv) >= SVt_PVMG) {
8671                     MAGIC* const mg = SvMAGIC(sv);
8672                     MAGIC* mgt;
8673                     TAINT;
8674                     SvMAGIC_set(sv, mg->mg_moremagic);
8675                     SvTAINT(sv);
8676                     if ((mgt = SvMAGIC(sv))) {
8677                         mg->mg_moremagic = mgt;
8678                         SvMAGIC_set(sv, mg);
8679                     }
8680                 } else {
8681                     TAINT;
8682                     SvTAINT(sv);
8683                 }
8684             } else
8685                 SvTAINTED_off(sv);
8686         }
8687     } else {
8688       ret_undef:
8689         sv_set_undef(sv);
8690         return;
8691     }
8692 }
8693
8694 void
8695 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8696                                                          SV const * const value)
8697 {
8698     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8699
8700     PERL_UNUSED_ARG(rx);
8701     PERL_UNUSED_ARG(paren);
8702     PERL_UNUSED_ARG(value);
8703
8704     if (!PL_localizing)
8705         Perl_croak_no_modify();
8706 }
8707
8708 I32
8709 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8710                               const I32 paren)
8711 {
8712     struct regexp *const rx = ReANY(r);
8713     I32 i;
8714     I32 s1, t1;
8715
8716     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8717
8718     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8719         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8720         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8721     )
8722     {
8723         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8724         if (!keepcopy) {
8725             /* on something like
8726              *    $r = qr/.../;
8727              *    /$qr/p;
8728              * the KEEPCOPY is set on the PMOP rather than the regex */
8729             if (PL_curpm && r == PM_GETRE(PL_curpm))
8730                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8731         }
8732         if (!keepcopy)
8733             goto warn_undef;
8734     }
8735
8736     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8737     switch (paren) {
8738       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8739       case RX_BUFF_IDX_PREMATCH:       /* $` */
8740         if (rx->offs[0].start != -1) {
8741                         i = rx->offs[0].start;
8742                         if (i > 0) {
8743                                 s1 = 0;
8744                                 t1 = i;
8745                                 goto getlen;
8746                         }
8747             }
8748         return 0;
8749
8750       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8751       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8752             if (rx->offs[0].end != -1) {
8753                         i = rx->sublen - rx->offs[0].end;
8754                         if (i > 0) {
8755                                 s1 = rx->offs[0].end;
8756                                 t1 = rx->sublen;
8757                                 goto getlen;
8758                         }
8759             }
8760         return 0;
8761
8762       default: /* $& / ${^MATCH}, $1, $2, ... */
8763             if (paren <= (I32)rx->nparens &&
8764             (s1 = rx->offs[paren].start) != -1 &&
8765             (t1 = rx->offs[paren].end) != -1)
8766             {
8767             i = t1 - s1;
8768             goto getlen;
8769         } else {
8770           warn_undef:
8771             if (ckWARN(WARN_UNINITIALIZED))
8772                 report_uninit((const SV *)sv);
8773             return 0;
8774         }
8775     }
8776   getlen:
8777     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8778         const char * const s = rx->subbeg - rx->suboffset + s1;
8779         const U8 *ep;
8780         STRLEN el;
8781
8782         i = t1 - s1;
8783         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8784                         i = el;
8785     }
8786     return i;
8787 }
8788
8789 SV*
8790 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8791 {
8792     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8793         PERL_UNUSED_ARG(rx);
8794         if (0)
8795             return NULL;
8796         else
8797             return newSVpvs("Regexp");
8798 }
8799
8800 /* Scans the name of a named buffer from the pattern.
8801  * If flags is REG_RSN_RETURN_NULL returns null.
8802  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8803  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8804  * to the parsed name as looked up in the RExC_paren_names hash.
8805  * If there is an error throws a vFAIL().. type exception.
8806  */
8807
8808 #define REG_RSN_RETURN_NULL    0
8809 #define REG_RSN_RETURN_NAME    1
8810 #define REG_RSN_RETURN_DATA    2
8811
8812 STATIC SV*
8813 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8814 {
8815     char *name_start = RExC_parse;
8816     SV* sv_name;
8817
8818     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8819
8820     assert (RExC_parse <= RExC_end);
8821     if (RExC_parse == RExC_end) NOOP;
8822     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8823          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8824           * using do...while */
8825         if (UTF)
8826             do {
8827                 RExC_parse += UTF8SKIP(RExC_parse);
8828             } while (   RExC_parse < RExC_end
8829                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8830         else
8831             do {
8832                 RExC_parse++;
8833             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8834     } else {
8835         RExC_parse++; /* so the <- from the vFAIL is after the offending
8836                          character */
8837         vFAIL("Group name must start with a non-digit word character");
8838     }
8839     sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8840                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8841     if ( flags == REG_RSN_RETURN_NAME)
8842         return sv_name;
8843     else if (flags==REG_RSN_RETURN_DATA) {
8844         HE *he_str = NULL;
8845         SV *sv_dat = NULL;
8846         if ( ! sv_name )      /* should not happen*/
8847             Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8848         if (RExC_paren_names)
8849             he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8850         if ( he_str )
8851             sv_dat = HeVAL(he_str);
8852         if ( ! sv_dat ) {   /* Didn't find group */
8853
8854             /* It might be a forward reference; we can't fail until we
8855                 * know, by completing the parse to get all the groups, and
8856                 * then reparsing */
8857             if (ALL_PARENS_COUNTED)  {
8858                 vFAIL("Reference to nonexistent named group");
8859             }
8860             else {
8861                 REQUIRE_PARENS_PASS;
8862             }
8863         }
8864         return sv_dat;
8865     }
8866
8867     Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8868                      (unsigned long) flags);
8869 }
8870
8871 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8872     if (RExC_lastparse!=RExC_parse) {                           \
8873         Perl_re_printf( aTHX_  "%s",                            \
8874             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8875                 RExC_end - RExC_parse, 16,                      \
8876                 "", "",                                         \
8877                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8878                 PERL_PV_PRETTY_ELLIPSES   |                     \
8879                 PERL_PV_PRETTY_LTGT       |                     \
8880                 PERL_PV_ESCAPE_RE         |                     \
8881                 PERL_PV_PRETTY_EXACTSIZE                        \
8882             )                                                   \
8883         );                                                      \
8884     } else                                                      \
8885         Perl_re_printf( aTHX_ "%16s","");                       \
8886                                                                 \
8887     if (RExC_lastnum!=RExC_emit)                                \
8888        Perl_re_printf( aTHX_ "|%4d", RExC_emit);                \
8889     else                                                        \
8890        Perl_re_printf( aTHX_ "|%4s","");                        \
8891     Perl_re_printf( aTHX_ "|%*s%-4s",                           \
8892         (int)((depth*2)), "",                                   \
8893         (funcname)                                              \
8894     );                                                          \
8895     RExC_lastnum=RExC_emit;                                     \
8896     RExC_lastparse=RExC_parse;                                  \
8897 })
8898
8899
8900
8901 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8902     DEBUG_PARSE_MSG((funcname));                            \
8903     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8904 })
8905 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8906     DEBUG_PARSE_MSG((funcname));                            \
8907     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8908 })
8909
8910 /* This section of code defines the inversion list object and its methods.  The
8911  * interfaces are highly subject to change, so as much as possible is static to
8912  * this file.  An inversion list is here implemented as a malloc'd C UV array
8913  * as an SVt_INVLIST scalar.
8914  *
8915  * An inversion list for Unicode is an array of code points, sorted by ordinal
8916  * number.  Each element gives the code point that begins a range that extends
8917  * up-to but not including the code point given by the next element.  The final
8918  * element gives the first code point of a range that extends to the platform's
8919  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8920  * ...) give ranges whose code points are all in the inversion list.  We say
8921  * that those ranges are in the set.  The odd-numbered elements give ranges
8922  * whose code points are not in the inversion list, and hence not in the set.
8923  * Thus, element [0] is the first code point in the list.  Element [1]
8924  * is the first code point beyond that not in the list; and element [2] is the
8925  * first code point beyond that that is in the list.  In other words, the first
8926  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8927  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8928  * all code points in that range are not in the inversion list.  The third
8929  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8930  * list, and so forth.  Thus every element whose index is divisible by two
8931  * gives the beginning of a range that is in the list, and every element whose
8932  * index is not divisible by two gives the beginning of a range not in the
8933  * list.  If the final element's index is divisible by two, the inversion list
8934  * extends to the platform's infinity; otherwise the highest code point in the
8935  * inversion list is the contents of that element minus 1.
8936  *
8937  * A range that contains just a single code point N will look like
8938  *  invlist[i]   == N
8939  *  invlist[i+1] == N+1
8940  *
8941  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8942  * impossible to represent, so element [i+1] is omitted.  The single element
8943  * inversion list
8944  *  invlist[0] == UV_MAX
8945  * contains just UV_MAX, but is interpreted as matching to infinity.
8946  *
8947  * Taking the complement (inverting) an inversion list is quite simple, if the
8948  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8949  * This implementation reserves an element at the beginning of each inversion
8950  * list to always contain 0; there is an additional flag in the header which
8951  * indicates if the list begins at the 0, or is offset to begin at the next
8952  * element.  This means that the inversion list can be inverted without any
8953  * copying; just flip the flag.
8954  *
8955  * More about inversion lists can be found in "Unicode Demystified"
8956  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8957  *
8958  * The inversion list data structure is currently implemented as an SV pointing
8959  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8960  * array of UV whose memory management is automatically handled by the existing
8961  * facilities for SV's.
8962  *
8963  * Some of the methods should always be private to the implementation, and some
8964  * should eventually be made public */
8965
8966 /* The header definitions are in F<invlist_inline.h> */
8967
8968 #ifndef PERL_IN_XSUB_RE
8969
8970 PERL_STATIC_INLINE UV*
8971 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8972 {
8973     /* Returns a pointer to the first element in the inversion list's array.
8974      * This is called upon initialization of an inversion list.  Where the
8975      * array begins depends on whether the list has the code point U+0000 in it
8976      * or not.  The other parameter tells it whether the code that follows this
8977      * call is about to put a 0 in the inversion list or not.  The first
8978      * element is either the element reserved for 0, if TRUE, or the element
8979      * after it, if FALSE */
8980
8981     bool* offset = get_invlist_offset_addr(invlist);
8982     UV* zero_addr = (UV *) SvPVX(invlist);
8983
8984     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8985
8986     /* Must be empty */
8987     assert(! _invlist_len(invlist));
8988
8989     *zero_addr = 0;
8990
8991     /* 1^1 = 0; 1^0 = 1 */
8992     *offset = 1 ^ will_have_0;
8993     return zero_addr + *offset;
8994 }
8995
8996 PERL_STATIC_INLINE void
8997 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8998 {
8999     /* Sets the current number of elements stored in the inversion list.
9000      * Updates SvCUR correspondingly */
9001     PERL_UNUSED_CONTEXT;
9002     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
9003
9004     assert(is_invlist(invlist));
9005
9006     SvCUR_set(invlist,
9007               (len == 0)
9008                ? 0
9009                : TO_INTERNAL_SIZE(len + offset));
9010     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
9011 }
9012
9013 STATIC void
9014 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
9015 {
9016     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
9017      * steals the list from 'src', so 'src' is made to have a NULL list.  This
9018      * is similar to what SvSetMagicSV() would do, if it were implemented on
9019      * inversion lists, though this routine avoids a copy */
9020
9021     const UV src_len          = _invlist_len(src);
9022     const bool src_offset     = *get_invlist_offset_addr(src);
9023     const STRLEN src_byte_len = SvLEN(src);
9024     char * array              = SvPVX(src);
9025
9026     const int oldtainted = TAINT_get;
9027
9028     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
9029
9030     assert(is_invlist(src));
9031     assert(is_invlist(dest));
9032     assert(! invlist_is_iterating(src));
9033     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
9034
9035     /* Make sure it ends in the right place with a NUL, as our inversion list
9036      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
9037      * asserts it */
9038     array[src_byte_len - 1] = '\0';
9039
9040     TAINT_NOT;      /* Otherwise it breaks */
9041     sv_usepvn_flags(dest,
9042                     (char *) array,
9043                     src_byte_len - 1,
9044
9045                     /* This flag is documented to cause a copy to be avoided */
9046                     SV_HAS_TRAILING_NUL);
9047     TAINT_set(oldtainted);
9048     SvPV_set(src, 0);
9049     SvLEN_set(src, 0);
9050     SvCUR_set(src, 0);
9051
9052     /* Finish up copying over the other fields in an inversion list */
9053     *get_invlist_offset_addr(dest) = src_offset;
9054     invlist_set_len(dest, src_len, src_offset);
9055     *get_invlist_previous_index_addr(dest) = 0;
9056     invlist_iterfinish(dest);
9057 }
9058
9059 PERL_STATIC_INLINE IV*
9060 S_get_invlist_previous_index_addr(SV* invlist)
9061 {
9062     /* Return the address of the IV that is reserved to hold the cached index
9063      * */
9064     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
9065
9066     assert(is_invlist(invlist));
9067
9068     return &(((XINVLIST*) SvANY(invlist))->prev_index);
9069 }
9070
9071 PERL_STATIC_INLINE IV
9072 S_invlist_previous_index(SV* const invlist)
9073 {
9074     /* Returns cached index of previous search */
9075
9076     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
9077
9078     return *get_invlist_previous_index_addr(invlist);
9079 }
9080
9081 PERL_STATIC_INLINE void
9082 S_invlist_set_previous_index(SV* const invlist, const IV index)
9083 {
9084     /* Caches <index> for later retrieval */
9085
9086     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
9087
9088     assert(index == 0 || index < (int) _invlist_len(invlist));
9089
9090     *get_invlist_previous_index_addr(invlist) = index;
9091 }
9092
9093 PERL_STATIC_INLINE void
9094 S_invlist_trim(SV* invlist)
9095 {
9096     /* Free the not currently-being-used space in an inversion list */
9097
9098     /* But don't free up the space needed for the 0 UV that is always at the
9099      * beginning of the list, nor the trailing NUL */
9100     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
9101
9102     PERL_ARGS_ASSERT_INVLIST_TRIM;
9103
9104     assert(is_invlist(invlist));
9105
9106     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
9107 }
9108
9109 PERL_STATIC_INLINE void
9110 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
9111 {
9112     PERL_ARGS_ASSERT_INVLIST_CLEAR;
9113
9114     assert(is_invlist(invlist));
9115
9116     invlist_set_len(invlist, 0, 0);
9117     invlist_trim(invlist);
9118 }
9119
9120 #endif /* ifndef PERL_IN_XSUB_RE */
9121
9122 PERL_STATIC_INLINE bool
9123 S_invlist_is_iterating(SV* const invlist)
9124 {
9125     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
9126
9127     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
9128 }
9129
9130 #ifndef PERL_IN_XSUB_RE
9131
9132 PERL_STATIC_INLINE UV
9133 S_invlist_max(SV* const invlist)
9134 {
9135     /* Returns the maximum number of elements storable in the inversion list's
9136      * array, without having to realloc() */
9137
9138     PERL_ARGS_ASSERT_INVLIST_MAX;
9139
9140     assert(is_invlist(invlist));
9141
9142     /* Assumes worst case, in which the 0 element is not counted in the
9143      * inversion list, so subtracts 1 for that */
9144     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
9145            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
9146            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
9147 }
9148
9149 STATIC void
9150 S_initialize_invlist_guts(pTHX_ SV* invlist, const Size_t initial_size)
9151 {
9152     PERL_ARGS_ASSERT_INITIALIZE_INVLIST_GUTS;
9153
9154     /* First 1 is in case the zero element isn't in the list; second 1 is for
9155      * trailing NUL */
9156     SvGROW(invlist, TO_INTERNAL_SIZE(initial_size + 1) + 1);
9157     invlist_set_len(invlist, 0, 0);
9158
9159     /* Force iterinit() to be used to get iteration to work */
9160     invlist_iterfinish(invlist);
9161
9162     *get_invlist_previous_index_addr(invlist) = 0;
9163 }
9164
9165 SV*
9166 Perl__new_invlist(pTHX_ IV initial_size)
9167 {
9168
9169     /* Return a pointer to a newly constructed inversion list, with enough
9170      * space to store 'initial_size' elements.  If that number is negative, a
9171      * system default is used instead */
9172
9173     SV* new_list;
9174
9175     if (initial_size < 0) {
9176         initial_size = 10;
9177     }
9178
9179     new_list = newSV_type(SVt_INVLIST);
9180     initialize_invlist_guts(new_list, initial_size);
9181
9182     return new_list;
9183 }
9184
9185 SV*
9186 Perl__new_invlist_C_array(pTHX_ const UV* const list)
9187 {
9188     /* Return a pointer to a newly constructed inversion list, initialized to
9189      * point to <list>, which has to be in the exact correct inversion list
9190      * form, including internal fields.  Thus this is a dangerous routine that
9191      * should not be used in the wrong hands.  The passed in 'list' contains
9192      * several header fields at the beginning that are not part of the
9193      * inversion list body proper */
9194
9195     const STRLEN length = (STRLEN) list[0];
9196     const UV version_id =          list[1];
9197     const bool offset   =    cBOOL(list[2]);
9198 #define HEADER_LENGTH 3
9199     /* If any of the above changes in any way, you must change HEADER_LENGTH
9200      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
9201      *      perl -E 'say int(rand 2**31-1)'
9202      */
9203 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
9204                                         data structure type, so that one being
9205                                         passed in can be validated to be an
9206                                         inversion list of the correct vintage.
9207                                        */
9208
9209     SV* invlist = newSV_type(SVt_INVLIST);
9210
9211     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
9212
9213     if (version_id != INVLIST_VERSION_ID) {
9214         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
9215     }
9216
9217     /* The generated array passed in includes header elements that aren't part
9218      * of the list proper, so start it just after them */
9219     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
9220
9221     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
9222                                shouldn't touch it */
9223
9224     *(get_invlist_offset_addr(invlist)) = offset;
9225
9226     /* The 'length' passed to us is the physical number of elements in the
9227      * inversion list.  But if there is an offset the logical number is one
9228      * less than that */
9229     invlist_set_len(invlist, length  - offset, offset);
9230
9231     invlist_set_previous_index(invlist, 0);
9232
9233     /* Initialize the iteration pointer. */
9234     invlist_iterfinish(invlist);
9235
9236     SvREADONLY_on(invlist);
9237
9238     return invlist;
9239 }
9240
9241 STATIC void
9242 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
9243 {
9244     /* Grow the maximum size of an inversion list */
9245
9246     PERL_ARGS_ASSERT_INVLIST_EXTEND;
9247
9248     assert(is_invlist(invlist));
9249
9250     /* Add one to account for the zero element at the beginning which may not
9251      * be counted by the calling parameters */
9252     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
9253 }
9254
9255 STATIC void
9256 S__append_range_to_invlist(pTHX_ SV* const invlist,
9257                                  const UV start, const UV end)
9258 {
9259    /* Subject to change or removal.  Append the range from 'start' to 'end' at
9260     * the end of the inversion list.  The range must be above any existing
9261     * ones. */
9262
9263     UV* array;
9264     UV max = invlist_max(invlist);
9265     UV len = _invlist_len(invlist);
9266     bool offset;
9267
9268     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
9269
9270     if (len == 0) { /* Empty lists must be initialized */
9271         offset = start != 0;
9272         array = _invlist_array_init(invlist, ! offset);
9273     }
9274     else {
9275         /* Here, the existing list is non-empty. The current max entry in the
9276          * list is generally the first value not in the set, except when the
9277          * set extends to the end of permissible values, in which case it is
9278          * the first entry in that final set, and so this call is an attempt to
9279          * append out-of-order */
9280
9281         UV final_element = len - 1;
9282         array = invlist_array(invlist);
9283         if (   array[final_element] > start
9284             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
9285         {
9286             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",
9287                      array[final_element], start,
9288                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
9289         }
9290
9291         /* Here, it is a legal append.  If the new range begins 1 above the end
9292          * of the range below it, it is extending the range below it, so the
9293          * new first value not in the set is one greater than the newly
9294          * extended range.  */
9295         offset = *get_invlist_offset_addr(invlist);
9296         if (array[final_element] == start) {
9297             if (end != UV_MAX) {
9298                 array[final_element] = end + 1;
9299             }
9300             else {
9301                 /* But if the end is the maximum representable on the machine,
9302                  * assume that infinity was actually what was meant.  Just let
9303                  * the range that this would extend to have no end */
9304                 invlist_set_len(invlist, len - 1, offset);
9305             }
9306             return;
9307         }
9308     }
9309
9310     /* Here the new range doesn't extend any existing set.  Add it */
9311
9312     len += 2;   /* Includes an element each for the start and end of range */
9313
9314     /* If wll overflow the existing space, extend, which may cause the array to
9315      * be moved */
9316     if (max < len) {
9317         invlist_extend(invlist, len);
9318
9319         /* Have to set len here to avoid assert failure in invlist_array() */
9320         invlist_set_len(invlist, len, offset);
9321
9322         array = invlist_array(invlist);
9323     }
9324     else {
9325         invlist_set_len(invlist, len, offset);
9326     }
9327
9328     /* The next item on the list starts the range, the one after that is
9329      * one past the new range.  */
9330     array[len - 2] = start;
9331     if (end != UV_MAX) {
9332         array[len - 1] = end + 1;
9333     }
9334     else {
9335         /* But if the end is the maximum representable on the machine, just let
9336          * the range have no end */
9337         invlist_set_len(invlist, len - 1, offset);
9338     }
9339 }
9340
9341 SSize_t
9342 Perl__invlist_search(SV* const invlist, const UV cp)
9343 {
9344     /* Searches the inversion list for the entry that contains the input code
9345      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
9346      * return value is the index into the list's array of the range that
9347      * contains <cp>, that is, 'i' such that
9348      *  array[i] <= cp < array[i+1]
9349      */
9350
9351     IV low = 0;
9352     IV mid;
9353     IV high = _invlist_len(invlist);
9354     const IV highest_element = high - 1;
9355     const UV* array;
9356
9357     PERL_ARGS_ASSERT__INVLIST_SEARCH;
9358
9359     /* If list is empty, return failure. */
9360     if (high == 0) {
9361         return -1;
9362     }
9363
9364     /* (We can't get the array unless we know the list is non-empty) */
9365     array = invlist_array(invlist);
9366
9367     mid = invlist_previous_index(invlist);
9368     assert(mid >=0);
9369     if (mid > highest_element) {
9370         mid = highest_element;
9371     }
9372
9373     /* <mid> contains the cache of the result of the previous call to this
9374      * function (0 the first time).  See if this call is for the same result,
9375      * or if it is for mid-1.  This is under the theory that calls to this
9376      * function will often be for related code points that are near each other.
9377      * And benchmarks show that caching gives better results.  We also test
9378      * here if the code point is within the bounds of the list.  These tests
9379      * replace others that would have had to be made anyway to make sure that
9380      * the array bounds were not exceeded, and these give us extra information
9381      * at the same time */
9382     if (cp >= array[mid]) {
9383         if (cp >= array[highest_element]) {
9384             return highest_element;
9385         }
9386
9387         /* Here, array[mid] <= cp < array[highest_element].  This means that
9388          * the final element is not the answer, so can exclude it; it also
9389          * means that <mid> is not the final element, so can refer to 'mid + 1'
9390          * safely */
9391         if (cp < array[mid + 1]) {
9392             return mid;
9393         }
9394         high--;
9395         low = mid + 1;
9396     }
9397     else { /* cp < aray[mid] */
9398         if (cp < array[0]) { /* Fail if outside the array */
9399             return -1;
9400         }
9401         high = mid;
9402         if (cp >= array[mid - 1]) {
9403             goto found_entry;
9404         }
9405     }
9406
9407     /* Binary search.  What we are looking for is <i> such that
9408      *  array[i] <= cp < array[i+1]
9409      * The loop below converges on the i+1.  Note that there may not be an
9410      * (i+1)th element in the array, and things work nonetheless */
9411     while (low < high) {
9412         mid = (low + high) / 2;
9413         assert(mid <= highest_element);
9414         if (array[mid] <= cp) { /* cp >= array[mid] */
9415             low = mid + 1;
9416
9417             /* We could do this extra test to exit the loop early.
9418             if (cp < array[low]) {
9419                 return mid;
9420             }
9421             */
9422         }
9423         else { /* cp < array[mid] */
9424             high = mid;
9425         }
9426     }
9427
9428   found_entry:
9429     high--;
9430     invlist_set_previous_index(invlist, high);
9431     return high;
9432 }
9433
9434 void
9435 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9436                                          const bool complement_b, SV** output)
9437 {
9438     /* Take the union of two inversion lists and point '*output' to it.  On
9439      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9440      * even 'a' or 'b').  If to an inversion list, the contents of the original
9441      * list will be replaced by the union.  The first list, 'a', may be
9442      * NULL, in which case a copy of the second list is placed in '*output'.
9443      * If 'complement_b' is TRUE, the union is taken of the complement
9444      * (inversion) of 'b' instead of b itself.
9445      *
9446      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9447      * Richard Gillam, published by Addison-Wesley, and explained at some
9448      * length there.  The preface says to incorporate its examples into your
9449      * code at your own risk.
9450      *
9451      * The algorithm is like a merge sort. */
9452
9453     const UV* array_a;    /* a's array */
9454     const UV* array_b;
9455     UV len_a;       /* length of a's array */
9456     UV len_b;
9457
9458     SV* u;                      /* the resulting union */
9459     UV* array_u;
9460     UV len_u = 0;
9461
9462     UV i_a = 0;             /* current index into a's array */
9463     UV i_b = 0;
9464     UV i_u = 0;
9465
9466     /* running count, as explained in the algorithm source book; items are
9467      * stopped accumulating and are output when the count changes to/from 0.
9468      * The count is incremented when we start a range that's in an input's set,
9469      * and decremented when we start a range that's not in a set.  So this
9470      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9471      * and hence nothing goes into the union; 1, just one of the inputs is in
9472      * its set (and its current range gets added to the union); and 2 when both
9473      * inputs are in their sets.  */
9474     UV count = 0;
9475
9476     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9477     assert(a != b);
9478     assert(*output == NULL || is_invlist(*output));
9479
9480     len_b = _invlist_len(b);
9481     if (len_b == 0) {
9482
9483         /* Here, 'b' is empty, hence it's complement is all possible code
9484          * points.  So if the union includes the complement of 'b', it includes
9485          * everything, and we need not even look at 'a'.  It's easiest to
9486          * create a new inversion list that matches everything.  */
9487         if (complement_b) {
9488             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9489
9490             if (*output == NULL) { /* If the output didn't exist, just point it
9491                                       at the new list */
9492                 *output = everything;
9493             }
9494             else { /* Otherwise, replace its contents with the new list */
9495                 invlist_replace_list_destroys_src(*output, everything);
9496                 SvREFCNT_dec_NN(everything);
9497             }
9498
9499             return;
9500         }
9501
9502         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9503          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9504          * output will be empty */
9505
9506         if (a == NULL || _invlist_len(a) == 0) {
9507             if (*output == NULL) {
9508                 *output = _new_invlist(0);
9509             }
9510             else {
9511                 invlist_clear(*output);
9512             }
9513             return;
9514         }
9515
9516         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9517          * union.  We can just return a copy of 'a' if '*output' doesn't point
9518          * to an existing list */
9519         if (*output == NULL) {
9520             *output = invlist_clone(a, NULL);
9521             return;
9522         }
9523
9524         /* If the output is to overwrite 'a', we have a no-op, as it's
9525          * already in 'a' */
9526         if (*output == a) {
9527             return;
9528         }
9529
9530         /* Here, '*output' is to be overwritten by 'a' */
9531         u = invlist_clone(a, NULL);
9532         invlist_replace_list_destroys_src(*output, u);
9533         SvREFCNT_dec_NN(u);
9534
9535         return;
9536     }
9537
9538     /* Here 'b' is not empty.  See about 'a' */
9539
9540     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9541
9542         /* Here, 'a' is empty (and b is not).  That means the union will come
9543          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9544          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9545          * the clone */
9546
9547         SV ** dest = (*output == NULL) ? output : &u;
9548         *dest = invlist_clone(b, NULL);
9549         if (complement_b) {
9550             _invlist_invert(*dest);
9551         }
9552
9553         if (dest == &u) {
9554             invlist_replace_list_destroys_src(*output, u);
9555             SvREFCNT_dec_NN(u);
9556         }
9557
9558         return;
9559     }
9560
9561     /* Here both lists exist and are non-empty */
9562     array_a = invlist_array(a);
9563     array_b = invlist_array(b);
9564
9565     /* If are to take the union of 'a' with the complement of b, set it
9566      * up so are looking at b's complement. */
9567     if (complement_b) {
9568
9569         /* To complement, we invert: if the first element is 0, remove it.  To
9570          * do this, we just pretend the array starts one later */
9571         if (array_b[0] == 0) {
9572             array_b++;
9573             len_b--;
9574         }
9575         else {
9576
9577             /* But if the first element is not zero, we pretend the list starts
9578              * at the 0 that is always stored immediately before the array. */
9579             array_b--;
9580             len_b++;
9581         }
9582     }
9583
9584     /* Size the union for the worst case: that the sets are completely
9585      * disjoint */
9586     u = _new_invlist(len_a + len_b);
9587
9588     /* Will contain U+0000 if either component does */
9589     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9590                                       || (len_b > 0 && array_b[0] == 0));
9591
9592     /* Go through each input list item by item, stopping when have exhausted
9593      * one of them */
9594     while (i_a < len_a && i_b < len_b) {
9595         UV cp;      /* The element to potentially add to the union's array */
9596         bool cp_in_set;   /* is it in the the input list's set or not */
9597
9598         /* We need to take one or the other of the two inputs for the union.
9599          * Since we are merging two sorted lists, we take the smaller of the
9600          * next items.  In case of a tie, we take first the one that is in its
9601          * set.  If we first took the one not in its set, it would decrement
9602          * the count, possibly to 0 which would cause it to be output as ending
9603          * the range, and the next time through we would take the same number,
9604          * and output it again as beginning the next range.  By doing it the
9605          * opposite way, there is no possibility that the count will be
9606          * momentarily decremented to 0, and thus the two adjoining ranges will
9607          * be seamlessly merged.  (In a tie and both are in the set or both not
9608          * in the set, it doesn't matter which we take first.) */
9609         if (       array_a[i_a] < array_b[i_b]
9610             || (   array_a[i_a] == array_b[i_b]
9611                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9612         {
9613             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9614             cp = array_a[i_a++];
9615         }
9616         else {
9617             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9618             cp = array_b[i_b++];
9619         }
9620
9621         /* Here, have chosen which of the two inputs to look at.  Only output
9622          * if the running count changes to/from 0, which marks the
9623          * beginning/end of a range that's in the set */
9624         if (cp_in_set) {
9625             if (count == 0) {
9626                 array_u[i_u++] = cp;
9627             }
9628             count++;
9629         }
9630         else {
9631             count--;
9632             if (count == 0) {
9633                 array_u[i_u++] = cp;
9634             }
9635         }
9636     }
9637
9638
9639     /* The loop above increments the index into exactly one of the input lists
9640      * each iteration, and ends when either index gets to its list end.  That
9641      * means the other index is lower than its end, and so something is
9642      * remaining in that one.  We decrement 'count', as explained below, if
9643      * that list is in its set.  (i_a and i_b each currently index the element
9644      * beyond the one we care about.) */
9645     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9646         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9647     {
9648         count--;
9649     }
9650
9651     /* Above we decremented 'count' if the list that had unexamined elements in
9652      * it was in its set.  This has made it so that 'count' being non-zero
9653      * means there isn't anything left to output; and 'count' equal to 0 means
9654      * that what is left to output is precisely that which is left in the
9655      * non-exhausted input list.
9656      *
9657      * To see why, note first that the exhausted input obviously has nothing
9658      * left to add to the union.  If it was in its set at its end, that means
9659      * the set extends from here to the platform's infinity, and hence so does
9660      * the union and the non-exhausted set is irrelevant.  The exhausted set
9661      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9662      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9663      * 'count' remains at 1.  This is consistent with the decremented 'count'
9664      * != 0 meaning there's nothing left to add to the union.
9665      *
9666      * But if the exhausted input wasn't in its set, it contributed 0 to
9667      * 'count', and the rest of the union will be whatever the other input is.
9668      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9669      * otherwise it gets decremented to 0.  This is consistent with 'count'
9670      * == 0 meaning the remainder of the union is whatever is left in the
9671      * non-exhausted list. */
9672     if (count != 0) {
9673         len_u = i_u;
9674     }
9675     else {
9676         IV copy_count = len_a - i_a;
9677         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9678             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9679         }
9680         else { /* The non-exhausted input is b */
9681             copy_count = len_b - i_b;
9682             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9683         }
9684         len_u = i_u + copy_count;
9685     }
9686
9687     /* Set the result to the final length, which can change the pointer to
9688      * array_u, so re-find it.  (Note that it is unlikely that this will
9689      * change, as we are shrinking the space, not enlarging it) */
9690     if (len_u != _invlist_len(u)) {
9691         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9692         invlist_trim(u);
9693         array_u = invlist_array(u);
9694     }
9695
9696     if (*output == NULL) {  /* Simply return the new inversion list */
9697         *output = u;
9698     }
9699     else {
9700         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9701          * could instead free '*output', and then set it to 'u', but experience
9702          * has shown [perl #127392] that if the input is a mortal, we can get a
9703          * huge build-up of these during regex compilation before they get
9704          * freed. */
9705         invlist_replace_list_destroys_src(*output, u);
9706         SvREFCNT_dec_NN(u);
9707     }
9708
9709     return;
9710 }
9711
9712 void
9713 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9714                                                const bool complement_b, SV** i)
9715 {
9716     /* Take the intersection of two inversion lists and point '*i' to it.  On
9717      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9718      * even 'a' or 'b').  If to an inversion list, the contents of the original
9719      * list will be replaced by the intersection.  The first list, 'a', may be
9720      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9721      * TRUE, the result will be the intersection of 'a' and the complement (or
9722      * inversion) of 'b' instead of 'b' directly.
9723      *
9724      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9725      * Richard Gillam, published by Addison-Wesley, and explained at some
9726      * length there.  The preface says to incorporate its examples into your
9727      * code at your own risk.  In fact, it had bugs
9728      *
9729      * The algorithm is like a merge sort, and is essentially the same as the
9730      * union above
9731      */
9732
9733     const UV* array_a;          /* a's array */
9734     const UV* array_b;
9735     UV len_a;   /* length of a's array */
9736     UV len_b;
9737
9738     SV* r;                   /* the resulting intersection */
9739     UV* array_r;
9740     UV len_r = 0;
9741
9742     UV i_a = 0;             /* current index into a's array */
9743     UV i_b = 0;
9744     UV i_r = 0;
9745
9746     /* running count of how many of the two inputs are postitioned at ranges
9747      * that are in their sets.  As explained in the algorithm source book,
9748      * items are stopped accumulating and are output when the count changes
9749      * to/from 2.  The count is incremented when we start a range that's in an
9750      * input's set, and decremented when we start a range that's not in a set.
9751      * Only when it is 2 are we in the intersection. */
9752     UV count = 0;
9753
9754     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9755     assert(a != b);
9756     assert(*i == NULL || is_invlist(*i));
9757
9758     /* Special case if either one is empty */
9759     len_a = (a == NULL) ? 0 : _invlist_len(a);
9760     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9761         if (len_a != 0 && complement_b) {
9762
9763             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9764              * must be empty.  Here, also we are using 'b's complement, which
9765              * hence must be every possible code point.  Thus the intersection
9766              * is simply 'a'. */
9767
9768             if (*i == a) {  /* No-op */
9769                 return;
9770             }
9771
9772             if (*i == NULL) {
9773                 *i = invlist_clone(a, NULL);
9774                 return;
9775             }
9776
9777             r = invlist_clone(a, NULL);
9778             invlist_replace_list_destroys_src(*i, r);
9779             SvREFCNT_dec_NN(r);
9780             return;
9781         }
9782
9783         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9784          * intersection must be empty */
9785         if (*i == NULL) {
9786             *i = _new_invlist(0);
9787             return;
9788         }
9789
9790         invlist_clear(*i);
9791         return;
9792     }
9793
9794     /* Here both lists exist and are non-empty */
9795     array_a = invlist_array(a);
9796     array_b = invlist_array(b);
9797
9798     /* If are to take the intersection of 'a' with the complement of b, set it
9799      * up so are looking at b's complement. */
9800     if (complement_b) {
9801
9802         /* To complement, we invert: if the first element is 0, remove it.  To
9803          * do this, we just pretend the array starts one later */
9804         if (array_b[0] == 0) {
9805             array_b++;
9806             len_b--;
9807         }
9808         else {
9809
9810             /* But if the first element is not zero, we pretend the list starts
9811              * at the 0 that is always stored immediately before the array. */
9812             array_b--;
9813             len_b++;
9814         }
9815     }
9816
9817     /* Size the intersection for the worst case: that the intersection ends up
9818      * fragmenting everything to be completely disjoint */
9819     r= _new_invlist(len_a + len_b);
9820
9821     /* Will contain U+0000 iff both components do */
9822     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9823                                      && len_b > 0 && array_b[0] == 0);
9824
9825     /* Go through each list item by item, stopping when have exhausted one of
9826      * them */
9827     while (i_a < len_a && i_b < len_b) {
9828         UV cp;      /* The element to potentially add to the intersection's
9829                        array */
9830         bool cp_in_set; /* Is it in the input list's set or not */
9831
9832         /* We need to take one or the other of the two inputs for the
9833          * intersection.  Since we are merging two sorted lists, we take the
9834          * smaller of the next items.  In case of a tie, we take first the one
9835          * that is not in its set (a difference from the union algorithm).  If
9836          * we first took the one in its set, it would increment the count,
9837          * possibly to 2 which would cause it to be output as starting a range
9838          * in the intersection, and the next time through we would take that
9839          * same number, and output it again as ending the set.  By doing the
9840          * opposite of this, there is no possibility that the count will be
9841          * momentarily incremented to 2.  (In a tie and both are in the set or
9842          * both not in the set, it doesn't matter which we take first.) */
9843         if (       array_a[i_a] < array_b[i_b]
9844             || (   array_a[i_a] == array_b[i_b]
9845                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9846         {
9847             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9848             cp = array_a[i_a++];
9849         }
9850         else {
9851             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9852             cp= array_b[i_b++];
9853         }
9854
9855         /* Here, have chosen which of the two inputs to look at.  Only output
9856          * if the running count changes to/from 2, which marks the
9857          * beginning/end of a range that's in the intersection */
9858         if (cp_in_set) {
9859             count++;
9860             if (count == 2) {
9861                 array_r[i_r++] = cp;
9862             }
9863         }
9864         else {
9865             if (count == 2) {
9866                 array_r[i_r++] = cp;
9867             }
9868             count--;
9869         }
9870
9871     }
9872
9873     /* The loop above increments the index into exactly one of the input lists
9874      * each iteration, and ends when either index gets to its list end.  That
9875      * means the other index is lower than its end, and so something is
9876      * remaining in that one.  We increment 'count', as explained below, if the
9877      * exhausted list was in its set.  (i_a and i_b each currently index the
9878      * element beyond the one we care about.) */
9879     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9880         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9881     {
9882         count++;
9883     }
9884
9885     /* Above we incremented 'count' if the exhausted list was in its set.  This
9886      * has made it so that 'count' being below 2 means there is nothing left to
9887      * output; otheriwse what's left to add to the intersection is precisely
9888      * that which is left in the non-exhausted input list.
9889      *
9890      * To see why, note first that the exhausted input obviously has nothing
9891      * left to affect the intersection.  If it was in its set at its end, that
9892      * means the set extends from here to the platform's infinity, and hence
9893      * anything in the non-exhausted's list will be in the intersection, and
9894      * anything not in it won't be.  Hence, the rest of the intersection is
9895      * precisely what's in the non-exhausted list  The exhausted set also
9896      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9897      * it means 'count' is now at least 2.  This is consistent with the
9898      * incremented 'count' being >= 2 means to add the non-exhausted list to
9899      * the intersection.
9900      *
9901      * But if the exhausted input wasn't in its set, it contributed 0 to
9902      * 'count', and the intersection can't include anything further; the
9903      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9904      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9905      * further to add to the intersection. */
9906     if (count < 2) { /* Nothing left to put in the intersection. */
9907         len_r = i_r;
9908     }
9909     else { /* copy the non-exhausted list, unchanged. */
9910         IV copy_count = len_a - i_a;
9911         if (copy_count > 0) {   /* a is the one with stuff left */
9912             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9913         }
9914         else {  /* b is the one with stuff left */
9915             copy_count = len_b - i_b;
9916             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9917         }
9918         len_r = i_r + copy_count;
9919     }
9920
9921     /* Set the result to the final length, which can change the pointer to
9922      * array_r, so re-find it.  (Note that it is unlikely that this will
9923      * change, as we are shrinking the space, not enlarging it) */
9924     if (len_r != _invlist_len(r)) {
9925         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9926         invlist_trim(r);
9927         array_r = invlist_array(r);
9928     }
9929
9930     if (*i == NULL) { /* Simply return the calculated intersection */
9931         *i = r;
9932     }
9933     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9934               instead free '*i', and then set it to 'r', but experience has
9935               shown [perl #127392] that if the input is a mortal, we can get a
9936               huge build-up of these during regex compilation before they get
9937               freed. */
9938         if (len_r) {
9939             invlist_replace_list_destroys_src(*i, r);
9940         }
9941         else {
9942             invlist_clear(*i);
9943         }
9944         SvREFCNT_dec_NN(r);
9945     }
9946
9947     return;
9948 }
9949
9950 SV*
9951 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9952 {
9953     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9954      * set.  A pointer to the inversion list is returned.  This may actually be
9955      * a new list, in which case the passed in one has been destroyed.  The
9956      * passed-in inversion list can be NULL, in which case a new one is created
9957      * with just the one range in it.  The new list is not necessarily
9958      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9959      * result of this function.  The gain would not be large, and in many
9960      * cases, this is called multiple times on a single inversion list, so
9961      * anything freed may almost immediately be needed again.
9962      *
9963      * This used to mostly call the 'union' routine, but that is much more
9964      * heavyweight than really needed for a single range addition */
9965
9966     UV* array;              /* The array implementing the inversion list */
9967     UV len;                 /* How many elements in 'array' */
9968     SSize_t i_s;            /* index into the invlist array where 'start'
9969                                should go */
9970     SSize_t i_e = 0;        /* And the index where 'end' should go */
9971     UV cur_highest;         /* The highest code point in the inversion list
9972                                upon entry to this function */
9973
9974     /* This range becomes the whole inversion list if none already existed */
9975     if (invlist == NULL) {
9976         invlist = _new_invlist(2);
9977         _append_range_to_invlist(invlist, start, end);
9978         return invlist;
9979     }
9980
9981     /* Likewise, if the inversion list is currently empty */
9982     len = _invlist_len(invlist);
9983     if (len == 0) {
9984         _append_range_to_invlist(invlist, start, end);
9985         return invlist;
9986     }
9987
9988     /* Starting here, we have to know the internals of the list */
9989     array = invlist_array(invlist);
9990
9991     /* If the new range ends higher than the current highest ... */
9992     cur_highest = invlist_highest(invlist);
9993     if (end > cur_highest) {
9994
9995         /* If the whole range is higher, we can just append it */
9996         if (start > cur_highest) {
9997             _append_range_to_invlist(invlist, start, end);
9998             return invlist;
9999         }
10000
10001         /* Otherwise, add the portion that is higher ... */
10002         _append_range_to_invlist(invlist, cur_highest + 1, end);
10003
10004         /* ... and continue on below to handle the rest.  As a result of the
10005          * above append, we know that the index of the end of the range is the
10006          * final even numbered one of the array.  Recall that the final element
10007          * always starts a range that extends to infinity.  If that range is in
10008          * the set (meaning the set goes from here to infinity), it will be an
10009          * even index, but if it isn't in the set, it's odd, and the final
10010          * range in the set is one less, which is even. */
10011         if (end == UV_MAX) {
10012             i_e = len;
10013         }
10014         else {
10015             i_e = len - 2;
10016         }
10017     }
10018
10019     /* We have dealt with appending, now see about prepending.  If the new
10020      * range starts lower than the current lowest ... */
10021     if (start < array[0]) {
10022
10023         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
10024          * Let the union code handle it, rather than having to know the
10025          * trickiness in two code places.  */
10026         if (UNLIKELY(start == 0)) {
10027             SV* range_invlist;
10028
10029             range_invlist = _new_invlist(2);
10030             _append_range_to_invlist(range_invlist, start, end);
10031
10032             _invlist_union(invlist, range_invlist, &invlist);
10033
10034             SvREFCNT_dec_NN(range_invlist);
10035
10036             return invlist;
10037         }
10038
10039         /* If the whole new range comes before the first entry, and doesn't
10040          * extend it, we have to insert it as an additional range */
10041         if (end < array[0] - 1) {
10042             i_s = i_e = -1;
10043             goto splice_in_new_range;
10044         }
10045
10046         /* Here the new range adjoins the existing first range, extending it
10047          * downwards. */
10048         array[0] = start;
10049
10050         /* And continue on below to handle the rest.  We know that the index of
10051          * the beginning of the range is the first one of the array */
10052         i_s = 0;
10053     }
10054     else { /* Not prepending any part of the new range to the existing list.
10055             * Find where in the list it should go.  This finds i_s, such that:
10056             *     invlist[i_s] <= start < array[i_s+1]
10057             */
10058         i_s = _invlist_search(invlist, start);
10059     }
10060
10061     /* At this point, any extending before the beginning of the inversion list
10062      * and/or after the end has been done.  This has made it so that, in the
10063      * code below, each endpoint of the new range is either in a range that is
10064      * in the set, or is in a gap between two ranges that are.  This means we
10065      * don't have to worry about exceeding the array bounds.
10066      *
10067      * Find where in the list the new range ends (but we can skip this if we
10068      * have already determined what it is, or if it will be the same as i_s,
10069      * which we already have computed) */
10070     if (i_e == 0) {
10071         i_e = (start == end)
10072               ? i_s
10073               : _invlist_search(invlist, end);
10074     }
10075
10076     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
10077      * is a range that goes to infinity there is no element at invlist[i_e+1],
10078      * so only the first relation holds. */
10079
10080     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10081
10082         /* Here, the ranges on either side of the beginning of the new range
10083          * are in the set, and this range starts in the gap between them.
10084          *
10085          * The new range extends the range above it downwards if the new range
10086          * ends at or above that range's start */
10087         const bool extends_the_range_above = (   end == UV_MAX
10088                                               || end + 1 >= array[i_s+1]);
10089
10090         /* The new range extends the range below it upwards if it begins just
10091          * after where that range ends */
10092         if (start == array[i_s]) {
10093
10094             /* If the new range fills the entire gap between the other ranges,
10095              * they will get merged together.  Other ranges may also get
10096              * merged, depending on how many of them the new range spans.  In
10097              * the general case, we do the merge later, just once, after we
10098              * figure out how many to merge.  But in the case where the new
10099              * range exactly spans just this one gap (possibly extending into
10100              * the one above), we do the merge here, and an early exit.  This
10101              * is done here to avoid having to special case later. */
10102             if (i_e - i_s <= 1) {
10103
10104                 /* If i_e - i_s == 1, it means that the new range terminates
10105                  * within the range above, and hence 'extends_the_range_above'
10106                  * must be true.  (If the range above it extends to infinity,
10107                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
10108                  * will be 0, so no harm done.) */
10109                 if (extends_the_range_above) {
10110                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
10111                     invlist_set_len(invlist,
10112                                     len - 2,
10113                                     *(get_invlist_offset_addr(invlist)));
10114                     return invlist;
10115                 }
10116
10117                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
10118                  * to the same range, and below we are about to decrement i_s
10119                  * */
10120                 i_e--;
10121             }
10122
10123             /* Here, the new range is adjacent to the one below.  (It may also
10124              * span beyond the range above, but that will get resolved later.)
10125              * Extend the range below to include this one. */
10126             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
10127             i_s--;
10128             start = array[i_s];
10129         }
10130         else if (extends_the_range_above) {
10131
10132             /* Here the new range only extends the range above it, but not the
10133              * one below.  It merges with the one above.  Again, we keep i_e
10134              * and i_s in sync if they point to the same range */
10135             if (i_e == i_s) {
10136                 i_e++;
10137             }
10138             i_s++;
10139             array[i_s] = start;
10140         }
10141     }
10142
10143     /* Here, we've dealt with the new range start extending any adjoining
10144      * existing ranges.
10145      *
10146      * If the new range extends to infinity, it is now the final one,
10147      * regardless of what was there before */
10148     if (UNLIKELY(end == UV_MAX)) {
10149         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
10150         return invlist;
10151     }
10152
10153     /* If i_e started as == i_s, it has also been dealt with,
10154      * and been updated to the new i_s, which will fail the following if */
10155     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
10156
10157         /* Here, the ranges on either side of the end of the new range are in
10158          * the set, and this range ends in the gap between them.
10159          *
10160          * If this range is adjacent to (hence extends) the range above it, it
10161          * becomes part of that range; likewise if it extends the range below,
10162          * it becomes part of that range */
10163         if (end + 1 == array[i_e+1]) {
10164             i_e++;
10165             array[i_e] = start;
10166         }
10167         else if (start <= array[i_e]) {
10168             array[i_e] = end + 1;
10169             i_e--;
10170         }
10171     }
10172
10173     if (i_s == i_e) {
10174
10175         /* If the range fits entirely in an existing range (as possibly already
10176          * extended above), it doesn't add anything new */
10177         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
10178             return invlist;
10179         }
10180
10181         /* Here, no part of the range is in the list.  Must add it.  It will
10182          * occupy 2 more slots */
10183       splice_in_new_range:
10184
10185         invlist_extend(invlist, len + 2);
10186         array = invlist_array(invlist);
10187         /* Move the rest of the array down two slots. Don't include any
10188          * trailing NUL */
10189         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
10190
10191         /* Do the actual splice */
10192         array[i_e+1] = start;
10193         array[i_e+2] = end + 1;
10194         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
10195         return invlist;
10196     }
10197
10198     /* Here the new range crossed the boundaries of a pre-existing range.  The
10199      * code above has adjusted things so that both ends are in ranges that are
10200      * in the set.  This means everything in between must also be in the set.
10201      * Just squash things together */
10202     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
10203     invlist_set_len(invlist,
10204                     len - i_e + i_s,
10205                     *(get_invlist_offset_addr(invlist)));
10206
10207     return invlist;
10208 }
10209
10210 SV*
10211 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
10212                                  UV** other_elements_ptr)
10213 {
10214     /* Create and return an inversion list whose contents are to be populated
10215      * by the caller.  The caller gives the number of elements (in 'size') and
10216      * the very first element ('element0').  This function will set
10217      * '*other_elements_ptr' to an array of UVs, where the remaining elements
10218      * are to be placed.
10219      *
10220      * Obviously there is some trust involved that the caller will properly
10221      * fill in the other elements of the array.
10222      *
10223      * (The first element needs to be passed in, as the underlying code does
10224      * things differently depending on whether it is zero or non-zero) */
10225
10226     SV* invlist = _new_invlist(size);
10227     bool offset;
10228
10229     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
10230
10231     invlist = add_cp_to_invlist(invlist, element0);
10232     offset = *get_invlist_offset_addr(invlist);
10233
10234     invlist_set_len(invlist, size, offset);
10235     *other_elements_ptr = invlist_array(invlist) + 1;
10236     return invlist;
10237 }
10238
10239 #endif
10240
10241 PERL_STATIC_INLINE SV*
10242 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
10243     return _add_range_to_invlist(invlist, cp, cp);
10244 }
10245
10246 #ifndef PERL_IN_XSUB_RE
10247 void
10248 Perl__invlist_invert(pTHX_ SV* const invlist)
10249 {
10250     /* Complement the input inversion list.  This adds a 0 if the list didn't
10251      * have a zero; removes it otherwise.  As described above, the data
10252      * structure is set up so that this is very efficient */
10253
10254     PERL_ARGS_ASSERT__INVLIST_INVERT;
10255
10256     assert(! invlist_is_iterating(invlist));
10257
10258     /* The inverse of matching nothing is matching everything */
10259     if (_invlist_len(invlist) == 0) {
10260         _append_range_to_invlist(invlist, 0, UV_MAX);
10261         return;
10262     }
10263
10264     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
10265 }
10266
10267 SV*
10268 Perl_invlist_clone(pTHX_ SV* const invlist, SV* new_invlist)
10269 {
10270     /* Return a new inversion list that is a copy of the input one, which is
10271      * unchanged.  The new list will not be mortal even if the old one was. */
10272
10273     const STRLEN nominal_length = _invlist_len(invlist);
10274     const STRLEN physical_length = SvCUR(invlist);
10275     const bool offset = *(get_invlist_offset_addr(invlist));
10276
10277     PERL_ARGS_ASSERT_INVLIST_CLONE;
10278
10279     if (new_invlist == NULL) {
10280         new_invlist = _new_invlist(nominal_length);
10281     }
10282     else {
10283         sv_upgrade(new_invlist, SVt_INVLIST);
10284         initialize_invlist_guts(new_invlist, nominal_length);
10285     }
10286
10287     *(get_invlist_offset_addr(new_invlist)) = offset;
10288     invlist_set_len(new_invlist, nominal_length, offset);
10289     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
10290
10291     return new_invlist;
10292 }
10293
10294 #endif
10295
10296 PERL_STATIC_INLINE STRLEN*
10297 S_get_invlist_iter_addr(SV* invlist)
10298 {
10299     /* Return the address of the UV that contains the current iteration
10300      * position */
10301
10302     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
10303
10304     assert(is_invlist(invlist));
10305
10306     return &(((XINVLIST*) SvANY(invlist))->iterator);
10307 }
10308
10309 PERL_STATIC_INLINE void
10310 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
10311 {
10312     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
10313
10314     *get_invlist_iter_addr(invlist) = 0;
10315 }
10316
10317 PERL_STATIC_INLINE void
10318 S_invlist_iterfinish(SV* invlist)
10319 {
10320     /* Terminate iterator for invlist.  This is to catch development errors.
10321      * Any iteration that is interrupted before completed should call this
10322      * function.  Functions that add code points anywhere else but to the end
10323      * of an inversion list assert that they are not in the middle of an
10324      * iteration.  If they were, the addition would make the iteration
10325      * problematical: if the iteration hadn't reached the place where things
10326      * were being added, it would be ok */
10327
10328     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
10329
10330     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
10331 }
10332
10333 STATIC bool
10334 S_invlist_iternext(SV* invlist, UV* start, UV* end)
10335 {
10336     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
10337      * This call sets in <*start> and <*end>, the next range in <invlist>.
10338      * Returns <TRUE> if successful and the next call will return the next
10339      * range; <FALSE> if was already at the end of the list.  If the latter,
10340      * <*start> and <*end> are unchanged, and the next call to this function
10341      * will start over at the beginning of the list */
10342
10343     STRLEN* pos = get_invlist_iter_addr(invlist);
10344     UV len = _invlist_len(invlist);
10345     UV *array;
10346
10347     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
10348
10349     if (*pos >= len) {
10350         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
10351         return FALSE;
10352     }
10353
10354     array = invlist_array(invlist);
10355
10356     *start = array[(*pos)++];
10357
10358     if (*pos >= len) {
10359         *end = UV_MAX;
10360     }
10361     else {
10362         *end = array[(*pos)++] - 1;
10363     }
10364
10365     return TRUE;
10366 }
10367
10368 PERL_STATIC_INLINE UV
10369 S_invlist_highest(SV* const invlist)
10370 {
10371     /* Returns the highest code point that matches an inversion list.  This API
10372      * has an ambiguity, as it returns 0 under either the highest is actually
10373      * 0, or if the list is empty.  If this distinction matters to you, check
10374      * for emptiness before calling this function */
10375
10376     UV len = _invlist_len(invlist);
10377     UV *array;
10378
10379     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
10380
10381     if (len == 0) {
10382         return 0;
10383     }
10384
10385     array = invlist_array(invlist);
10386
10387     /* The last element in the array in the inversion list always starts a
10388      * range that goes to infinity.  That range may be for code points that are
10389      * matched in the inversion list, or it may be for ones that aren't
10390      * matched.  In the latter case, the highest code point in the set is one
10391      * less than the beginning of this range; otherwise it is the final element
10392      * of this range: infinity */
10393     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
10394            ? UV_MAX
10395            : array[len - 1] - 1;
10396 }
10397
10398 STATIC SV *
10399 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
10400 {
10401     /* Get the contents of an inversion list into a string SV so that they can
10402      * be printed out.  If 'traditional_style' is TRUE, it uses the format
10403      * traditionally done for debug tracing; otherwise it uses a format
10404      * suitable for just copying to the output, with blanks between ranges and
10405      * a dash between range components */
10406
10407     UV start, end;
10408     SV* output;
10409     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
10410     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
10411
10412     if (traditional_style) {
10413         output = newSVpvs("\n");
10414     }
10415     else {
10416         output = newSVpvs("");
10417     }
10418
10419     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
10420
10421     assert(! invlist_is_iterating(invlist));
10422
10423     invlist_iterinit(invlist);
10424     while (invlist_iternext(invlist, &start, &end)) {
10425         if (end == UV_MAX) {
10426             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c",
10427                                           start, intra_range_delimiter,
10428                                                  inter_range_delimiter);
10429         }
10430         else if (end != start) {
10431             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
10432                                           start,
10433                                                    intra_range_delimiter,
10434                                                   end, inter_range_delimiter);
10435         }
10436         else {
10437             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
10438                                           start, inter_range_delimiter);
10439         }
10440     }
10441
10442     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
10443         SvCUR_set(output, SvCUR(output) - 1);
10444     }
10445
10446     return output;
10447 }
10448
10449 #ifndef PERL_IN_XSUB_RE
10450 void
10451 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
10452                          const char * const indent, SV* const invlist)
10453 {
10454     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
10455      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
10456      * the string 'indent'.  The output looks like this:
10457          [0] 0x000A .. 0x000D
10458          [2] 0x0085
10459          [4] 0x2028 .. 0x2029
10460          [6] 0x3104 .. INFTY
10461      * This means that the first range of code points matched by the list are
10462      * 0xA through 0xD; the second range contains only the single code point
10463      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10464      * are used to define each range (except if the final range extends to
10465      * infinity, only a single element is needed).  The array index of the
10466      * first element for the corresponding range is given in brackets. */
10467
10468     UV start, end;
10469     STRLEN count = 0;
10470
10471     PERL_ARGS_ASSERT__INVLIST_DUMP;
10472
10473     if (invlist_is_iterating(invlist)) {
10474         Perl_dump_indent(aTHX_ level, file,
10475              "%sCan't dump inversion list because is in middle of iterating\n",
10476              indent);
10477         return;
10478     }
10479
10480     invlist_iterinit(invlist);
10481     while (invlist_iternext(invlist, &start, &end)) {
10482         if (end == UV_MAX) {
10483             Perl_dump_indent(aTHX_ level, file,
10484                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n",
10485                                    indent, (UV)count, start);
10486         }
10487         else if (end != start) {
10488             Perl_dump_indent(aTHX_ level, file,
10489                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10490                                 indent, (UV)count, start,         end);
10491         }
10492         else {
10493             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10494                                             indent, (UV)count, start);
10495         }
10496         count += 2;
10497     }
10498 }
10499
10500 #endif
10501
10502 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10503 bool
10504 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10505 {
10506     /* Return a boolean as to if the two passed in inversion lists are
10507      * identical.  The final argument, if TRUE, says to take the complement of
10508      * the second inversion list before doing the comparison */
10509
10510     const UV len_a = _invlist_len(a);
10511     UV len_b = _invlist_len(b);
10512
10513     const UV* array_a = NULL;
10514     const UV* array_b = NULL;
10515
10516     PERL_ARGS_ASSERT__INVLISTEQ;
10517
10518     /* This code avoids accessing the arrays unless it knows the length is
10519      * non-zero */
10520
10521     if (len_a == 0) {
10522         if (len_b == 0) {
10523             return ! complement_b;
10524         }
10525     }
10526     else {
10527         array_a = invlist_array(a);
10528     }
10529
10530     if (len_b != 0) {
10531         array_b = invlist_array(b);
10532     }
10533
10534     /* If are to compare 'a' with the complement of b, set it
10535      * up so are looking at b's complement. */
10536     if (complement_b) {
10537
10538         /* The complement of nothing is everything, so <a> would have to have
10539          * just one element, starting at zero (ending at infinity) */
10540         if (len_b == 0) {
10541             return (len_a == 1 && array_a[0] == 0);
10542         }
10543         if (array_b[0] == 0) {
10544
10545             /* Otherwise, to complement, we invert.  Here, the first element is
10546              * 0, just remove it.  To do this, we just pretend the array starts
10547              * one later */
10548
10549             array_b++;
10550             len_b--;
10551         }
10552         else {
10553
10554             /* But if the first element is not zero, we pretend the list starts
10555              * at the 0 that is always stored immediately before the array. */
10556             array_b--;
10557             len_b++;
10558         }
10559     }
10560
10561     return    len_a == len_b
10562            && memEQ(array_a, array_b, len_a * sizeof(array_a[0]));
10563
10564 }
10565 #endif
10566
10567 /*
10568  * As best we can, determine the characters that can match the start of
10569  * the given EXACTF-ish node.  This is for use in creating ssc nodes, so there
10570  * can be false positive matches
10571  *
10572  * Returns the invlist as a new SV*; it is the caller's responsibility to
10573  * call SvREFCNT_dec() when done with it.
10574  */
10575 STATIC SV*
10576 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10577 {
10578     dVAR;
10579     const U8 * s = (U8*)STRING(node);
10580     SSize_t bytelen = STR_LEN(node);
10581     UV uc;
10582     /* Start out big enough for 2 separate code points */
10583     SV* invlist = _new_invlist(4);
10584
10585     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10586
10587     if (! UTF) {
10588         uc = *s;
10589
10590         /* We punt and assume can match anything if the node begins
10591          * with a multi-character fold.  Things are complicated.  For
10592          * example, /ffi/i could match any of:
10593          *  "\N{LATIN SMALL LIGATURE FFI}"
10594          *  "\N{LATIN SMALL LIGATURE FF}I"
10595          *  "F\N{LATIN SMALL LIGATURE FI}"
10596          *  plus several other things; and making sure we have all the
10597          *  possibilities is hard. */
10598         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10599             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10600         }
10601         else {
10602             /* Any Latin1 range character can potentially match any
10603              * other depending on the locale, and in Turkic locales, U+130 and
10604              * U+131 */
10605             if (OP(node) == EXACTFL) {
10606                 _invlist_union(invlist, PL_Latin1, &invlist);
10607                 invlist = add_cp_to_invlist(invlist,
10608                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10609                 invlist = add_cp_to_invlist(invlist,
10610                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10611             }
10612             else {
10613                 /* But otherwise, it matches at least itself.  We can
10614                  * quickly tell if it has a distinct fold, and if so,
10615                  * it matches that as well */
10616                 invlist = add_cp_to_invlist(invlist, uc);
10617                 if (IS_IN_SOME_FOLD_L1(uc))
10618                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10619             }
10620
10621             /* Some characters match above-Latin1 ones under /i.  This
10622              * is true of EXACTFL ones when the locale is UTF-8 */
10623             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10624                 && (! isASCII(uc) || (OP(node) != EXACTFAA
10625                                     && OP(node) != EXACTFAA_NO_TRIE)))
10626             {
10627                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10628             }
10629         }
10630     }
10631     else {  /* Pattern is UTF-8 */
10632         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10633         const U8* e = s + bytelen;
10634         IV fc;
10635
10636         fc = uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10637
10638         /* The only code points that aren't folded in a UTF EXACTFish
10639          * node are are the problematic ones in EXACTFL nodes */
10640         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10641             /* We need to check for the possibility that this EXACTFL
10642              * node begins with a multi-char fold.  Therefore we fold
10643              * the first few characters of it so that we can make that
10644              * check */
10645             U8 *d = folded;
10646             int i;
10647
10648             fc = -1;
10649             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10650                 if (isASCII(*s)) {
10651                     *(d++) = (U8) toFOLD(*s);
10652                     if (fc < 0) {       /* Save the first fold */
10653                         fc = *(d-1);
10654                     }
10655                     s++;
10656                 }
10657                 else {
10658                     STRLEN len;
10659                     UV fold = toFOLD_utf8_safe(s, e, d, &len);
10660                     if (fc < 0) {       /* Save the first fold */
10661                         fc = fold;
10662                     }
10663                     d += len;
10664                     s += UTF8SKIP(s);
10665                 }
10666             }
10667
10668             /* And set up so the code below that looks in this folded
10669              * buffer instead of the node's string */
10670             e = d;
10671             s = folded;
10672         }
10673
10674         /* When we reach here 's' points to the fold of the first
10675          * character(s) of the node; and 'e' points to far enough along
10676          * the folded string to be just past any possible multi-char
10677          * fold.
10678          *
10679          * Unlike the non-UTF-8 case, the macro for determining if a
10680          * string is a multi-char fold requires all the characters to
10681          * already be folded.  This is because of all the complications
10682          * if not.  Note that they are folded anyway, except in EXACTFL
10683          * nodes.  Like the non-UTF case above, we punt if the node
10684          * begins with a multi-char fold  */
10685
10686         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10687             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10688         }
10689         else {  /* Single char fold */
10690             unsigned int k;
10691             unsigned int first_fold;
10692             const unsigned int * remaining_folds;
10693             Size_t folds_count;
10694
10695             /* It matches itself */
10696             invlist = add_cp_to_invlist(invlist, fc);
10697
10698             /* ... plus all the things that fold to it, which are found in
10699              * PL_utf8_foldclosures */
10700             folds_count = _inverse_folds(fc, &first_fold,
10701                                                 &remaining_folds);
10702             for (k = 0; k < folds_count; k++) {
10703                 UV c = (k == 0) ? first_fold : remaining_folds[k-1];
10704
10705                 /* /aa doesn't allow folds between ASCII and non- */
10706                 if (   (OP(node) == EXACTFAA || OP(node) == EXACTFAA_NO_TRIE)
10707                     && isASCII(c) != isASCII(fc))
10708                 {
10709                     continue;
10710                 }
10711
10712                 invlist = add_cp_to_invlist(invlist, c);
10713             }
10714
10715             if (OP(node) == EXACTFL) {
10716
10717                 /* If either [iI] are present in an EXACTFL node the above code
10718                  * should have added its normal case pair, but under a Turkish
10719                  * locale they could match instead the case pairs from it.  Add
10720                  * those as potential matches as well */
10721                 if (isALPHA_FOLD_EQ(fc, 'I')) {
10722                     invlist = add_cp_to_invlist(invlist,
10723                                                 LATIN_SMALL_LETTER_DOTLESS_I);
10724                     invlist = add_cp_to_invlist(invlist,
10725                                         LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
10726                 }
10727                 else if (fc == LATIN_SMALL_LETTER_DOTLESS_I) {
10728                     invlist = add_cp_to_invlist(invlist, 'I');
10729                 }
10730                 else if (fc == LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE) {
10731                     invlist = add_cp_to_invlist(invlist, 'i');
10732                 }
10733             }
10734         }
10735     }
10736
10737     return invlist;
10738 }
10739
10740 #undef HEADER_LENGTH
10741 #undef TO_INTERNAL_SIZE
10742 #undef FROM_INTERNAL_SIZE
10743 #undef INVLIST_VERSION_ID
10744
10745 /* End of inversion list object */
10746
10747 STATIC void
10748 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10749 {
10750     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10751      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10752      * should point to the first flag; it is updated on output to point to the
10753      * final ')' or ':'.  There needs to be at least one flag, or this will
10754      * abort */
10755
10756     /* for (?g), (?gc), and (?o) warnings; warning
10757        about (?c) will warn about (?g) -- japhy    */
10758
10759 #define WASTED_O  0x01
10760 #define WASTED_G  0x02
10761 #define WASTED_C  0x04
10762 #define WASTED_GC (WASTED_G|WASTED_C)
10763     I32 wastedflags = 0x00;
10764     U32 posflags = 0, negflags = 0;
10765     U32 *flagsp = &posflags;
10766     char has_charset_modifier = '\0';
10767     regex_charset cs;
10768     bool has_use_defaults = FALSE;
10769     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10770     int x_mod_count = 0;
10771
10772     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10773
10774     /* '^' as an initial flag sets certain defaults */
10775     if (UCHARAT(RExC_parse) == '^') {
10776         RExC_parse++;
10777         has_use_defaults = TRUE;
10778         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10779         cs = (RExC_uni_semantics)
10780              ? REGEX_UNICODE_CHARSET
10781              : REGEX_DEPENDS_CHARSET;
10782         set_regex_charset(&RExC_flags, cs);
10783     }
10784     else {
10785         cs = get_regex_charset(RExC_flags);
10786         if (   cs == REGEX_DEPENDS_CHARSET
10787             && RExC_uni_semantics)
10788         {
10789             cs = REGEX_UNICODE_CHARSET;
10790         }
10791     }
10792
10793     while (RExC_parse < RExC_end) {
10794         /* && strchr("iogcmsx", *RExC_parse) */
10795         /* (?g), (?gc) and (?o) are useless here
10796            and must be globally applied -- japhy */
10797         switch (*RExC_parse) {
10798
10799             /* Code for the imsxn flags */
10800             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10801
10802             case LOCALE_PAT_MOD:
10803                 if (has_charset_modifier) {
10804                     goto excess_modifier;
10805                 }
10806                 else if (flagsp == &negflags) {
10807                     goto neg_modifier;
10808                 }
10809                 cs = REGEX_LOCALE_CHARSET;
10810                 has_charset_modifier = LOCALE_PAT_MOD;
10811                 break;
10812             case UNICODE_PAT_MOD:
10813                 if (has_charset_modifier) {
10814                     goto excess_modifier;
10815                 }
10816                 else if (flagsp == &negflags) {
10817                     goto neg_modifier;
10818                 }
10819                 cs = REGEX_UNICODE_CHARSET;
10820                 has_charset_modifier = UNICODE_PAT_MOD;
10821                 break;
10822             case ASCII_RESTRICT_PAT_MOD:
10823                 if (flagsp == &negflags) {
10824                     goto neg_modifier;
10825                 }
10826                 if (has_charset_modifier) {
10827                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10828                         goto excess_modifier;
10829                     }
10830                     /* Doubled modifier implies more restricted */
10831                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10832                 }
10833                 else {
10834                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10835                 }
10836                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10837                 break;
10838             case DEPENDS_PAT_MOD:
10839                 if (has_use_defaults) {
10840                     goto fail_modifiers;
10841                 }
10842                 else if (flagsp == &negflags) {
10843                     goto neg_modifier;
10844                 }
10845                 else if (has_charset_modifier) {
10846                     goto excess_modifier;
10847                 }
10848
10849                 /* The dual charset means unicode semantics if the
10850                  * pattern (or target, not known until runtime) are
10851                  * utf8, or something in the pattern indicates unicode
10852                  * semantics */
10853                 cs = (RExC_uni_semantics)
10854                      ? REGEX_UNICODE_CHARSET
10855                      : REGEX_DEPENDS_CHARSET;
10856                 has_charset_modifier = DEPENDS_PAT_MOD;
10857                 break;
10858               excess_modifier:
10859                 RExC_parse++;
10860                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10861                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10862                 }
10863                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10864                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10865                                         *(RExC_parse - 1));
10866                 }
10867                 else {
10868                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10869                 }
10870                 NOT_REACHED; /*NOTREACHED*/
10871               neg_modifier:
10872                 RExC_parse++;
10873                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10874                                     *(RExC_parse - 1));
10875                 NOT_REACHED; /*NOTREACHED*/
10876             case ONCE_PAT_MOD: /* 'o' */
10877             case GLOBAL_PAT_MOD: /* 'g' */
10878                 if (ckWARN(WARN_REGEXP)) {
10879                     const I32 wflagbit = *RExC_parse == 'o'
10880                                          ? WASTED_O
10881                                          : WASTED_G;
10882                     if (! (wastedflags & wflagbit) ) {
10883                         wastedflags |= wflagbit;
10884                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10885                         vWARN5(
10886                             RExC_parse + 1,
10887                             "Useless (%s%c) - %suse /%c modifier",
10888                             flagsp == &negflags ? "?-" : "?",
10889                             *RExC_parse,
10890                             flagsp == &negflags ? "don't " : "",
10891                             *RExC_parse
10892                         );
10893                     }
10894                 }
10895                 break;
10896
10897             case CONTINUE_PAT_MOD: /* 'c' */
10898                 if (ckWARN(WARN_REGEXP)) {
10899                     if (! (wastedflags & WASTED_C) ) {
10900                         wastedflags |= WASTED_GC;
10901                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10902                         vWARN3(
10903                             RExC_parse + 1,
10904                             "Useless (%sc) - %suse /gc modifier",
10905                             flagsp == &negflags ? "?-" : "?",
10906                             flagsp == &negflags ? "don't " : ""
10907                         );
10908                     }
10909                 }
10910                 break;
10911             case KEEPCOPY_PAT_MOD: /* 'p' */
10912                 if (flagsp == &negflags) {
10913                     ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10914                 } else {
10915                     *flagsp |= RXf_PMf_KEEPCOPY;
10916                 }
10917                 break;
10918             case '-':
10919                 /* A flag is a default iff it is following a minus, so
10920                  * if there is a minus, it means will be trying to
10921                  * re-specify a default which is an error */
10922                 if (has_use_defaults || flagsp == &negflags) {
10923                     goto fail_modifiers;
10924                 }
10925                 flagsp = &negflags;
10926                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10927                 x_mod_count = 0;
10928                 break;
10929             case ':':
10930             case ')':
10931
10932                 if ((posflags & (RXf_PMf_EXTENDED|RXf_PMf_EXTENDED_MORE)) == RXf_PMf_EXTENDED) {
10933                     negflags |= RXf_PMf_EXTENDED_MORE;
10934                 }
10935                 RExC_flags |= posflags;
10936
10937                 if (negflags & RXf_PMf_EXTENDED) {
10938                     negflags |= RXf_PMf_EXTENDED_MORE;
10939                 }
10940                 RExC_flags &= ~negflags;
10941                 set_regex_charset(&RExC_flags, cs);
10942
10943                 return;
10944             default:
10945               fail_modifiers:
10946                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
10947                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10948                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10949                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10950                 NOT_REACHED; /*NOTREACHED*/
10951         }
10952
10953         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10954     }
10955
10956     vFAIL("Sequence (?... not terminated");
10957 }
10958
10959 /*
10960  - reg - regular expression, i.e. main body or parenthesized thing
10961  *
10962  * Caller must absorb opening parenthesis.
10963  *
10964  * Combining parenthesis handling with the base level of regular expression
10965  * is a trifle forced, but the need to tie the tails of the branches to what
10966  * follows makes it hard to avoid.
10967  */
10968 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10969 #ifdef DEBUGGING
10970 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10971 #else
10972 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10973 #endif
10974
10975 PERL_STATIC_INLINE regnode_offset
10976 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10977                              I32 *flagp,
10978                              char * parse_start,
10979                              char ch
10980                       )
10981 {
10982     regnode_offset ret;
10983     char* name_start = RExC_parse;
10984     U32 num = 0;
10985     SV *sv_dat = reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
10986     GET_RE_DEBUG_FLAGS_DECL;
10987
10988     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10989
10990     if (RExC_parse == name_start || *RExC_parse != ch) {
10991         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10992         vFAIL2("Sequence %.3s... not terminated", parse_start);
10993     }
10994
10995     if (sv_dat) {
10996         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10997         RExC_rxi->data->data[num]=(void*)sv_dat;
10998         SvREFCNT_inc_simple_void_NN(sv_dat);
10999     }
11000     RExC_sawback = 1;
11001     ret = reganode(pRExC_state,
11002                    ((! FOLD)
11003                      ? REFN
11004                      : (ASCII_FOLD_RESTRICTED)
11005                        ? REFFAN
11006                        : (AT_LEAST_UNI_SEMANTICS)
11007                          ? REFFUN
11008                          : (LOC)
11009                            ? REFFLN
11010                            : REFFN),
11011                     num);
11012     *flagp |= HASWIDTH;
11013
11014     Set_Node_Offset(REGNODE_p(ret), parse_start+1);
11015     Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
11016
11017     nextchar(pRExC_state);
11018     return ret;
11019 }
11020
11021 /* On success, returns the offset at which any next node should be placed into
11022  * the regex engine program being compiled.
11023  *
11024  * Returns 0 otherwise, with *flagp set to indicate why:
11025  *  TRYAGAIN        at the end of (?) that only sets flags.
11026  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
11027  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
11028  *  Otherwise would only return 0 if regbranch() returns 0, which cannot
11029  *  happen.  */
11030 STATIC regnode_offset
11031 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth)
11032     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
11033      * 2 is like 1, but indicates that nextchar() has been called to advance
11034      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
11035      * this flag alerts us to the need to check for that */
11036 {
11037     regnode_offset ret = 0;    /* Will be the head of the group. */
11038     regnode_offset br;
11039     regnode_offset lastbr;
11040     regnode_offset ender = 0;
11041     I32 parno = 0;
11042     I32 flags;
11043     U32 oregflags = RExC_flags;
11044     bool have_branch = 0;
11045     bool is_open = 0;
11046     I32 freeze_paren = 0;
11047     I32 after_freeze = 0;
11048     I32 num; /* numeric backreferences */
11049     SV * max_open;  /* Max number of unclosed parens */
11050
11051     char * parse_start = RExC_parse; /* MJD */
11052     char * const oregcomp_parse = RExC_parse;
11053
11054     GET_RE_DEBUG_FLAGS_DECL;
11055
11056     PERL_ARGS_ASSERT_REG;
11057     DEBUG_PARSE("reg ");
11058
11059
11060     max_open = get_sv(RE_COMPILE_RECURSION_LIMIT, GV_ADD);
11061     assert(max_open);
11062     if (!SvIOK(max_open)) {
11063         sv_setiv(max_open, RE_COMPILE_RECURSION_INIT);
11064     }
11065     if (depth > 4 * (UV) SvIV(max_open)) { /* We increase depth by 4 for each
11066                                               open paren */
11067         vFAIL("Too many nested open parens");
11068     }
11069
11070     *flagp = 0;                         /* Tentatively. */
11071
11072     /* Having this true makes it feasible to have a lot fewer tests for the
11073      * parse pointer being in scope.  For example, we can write
11074      *      while(isFOO(*RExC_parse)) RExC_parse++;
11075      * instead of
11076      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
11077      */
11078     assert(*RExC_end == '\0');
11079
11080     /* Make an OPEN node, if parenthesized. */
11081     if (paren) {
11082
11083         /* Under /x, space and comments can be gobbled up between the '(' and
11084          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
11085          * intervening space, as the sequence is a token, and a token should be
11086          * indivisible */
11087         bool has_intervening_patws = (paren == 2)
11088                                   && *(RExC_parse - 1) != '(';
11089
11090         if (RExC_parse >= RExC_end) {
11091             vFAIL("Unmatched (");
11092         }
11093
11094         if (paren == 'r') {     /* Atomic script run */
11095             paren = '>';
11096             goto parse_rest;
11097         }
11098         else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */
11099             char *start_verb = RExC_parse + 1;
11100             STRLEN verb_len;
11101             char *start_arg = NULL;
11102             unsigned char op = 0;
11103             int arg_required = 0;
11104             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
11105             bool has_upper = FALSE;
11106
11107             if (has_intervening_patws) {
11108                 RExC_parse++;   /* past the '*' */
11109
11110                 /* For strict backwards compatibility, don't change the message
11111                  * now that we also have lowercase operands */
11112                 if (isUPPER(*RExC_parse)) {
11113                     vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
11114                 }
11115                 else {
11116                     vFAIL("In '(*...)', the '(' and '*' must be adjacent");
11117                 }
11118             }
11119             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
11120                 if ( *RExC_parse == ':' ) {
11121                     start_arg = RExC_parse + 1;
11122                     break;
11123                 }
11124                 else if (! UTF) {
11125                     if (isUPPER(*RExC_parse)) {
11126                         has_upper = TRUE;
11127                     }
11128                     RExC_parse++;
11129                 }
11130                 else {
11131                     RExC_parse += UTF8SKIP(RExC_parse);
11132                 }
11133             }
11134             verb_len = RExC_parse - start_verb;
11135             if ( start_arg ) {
11136                 if (RExC_parse >= RExC_end) {
11137                     goto unterminated_verb_pattern;
11138                 }
11139
11140                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11141                 while ( RExC_parse < RExC_end && *RExC_parse != ')' ) {
11142                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11143                 }
11144                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11145                   unterminated_verb_pattern:
11146                     if (has_upper) {
11147                         vFAIL("Unterminated verb pattern argument");
11148                     }
11149                     else {
11150                         vFAIL("Unterminated '(*...' argument");
11151                     }
11152                 }
11153             } else {
11154                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) {
11155                     if (has_upper) {
11156                         vFAIL("Unterminated verb pattern");
11157                     }
11158                     else {
11159                         vFAIL("Unterminated '(*...' construct");
11160                     }
11161                 }
11162             }
11163
11164             /* Here, we know that RExC_parse < RExC_end */
11165
11166             switch ( *start_verb ) {
11167             case 'A':  /* (*ACCEPT) */
11168                 if ( memEQs(start_verb, verb_len,"ACCEPT") ) {
11169                     op = ACCEPT;
11170                     internal_argval = RExC_nestroot;
11171                 }
11172                 break;
11173             case 'C':  /* (*COMMIT) */
11174                 if ( memEQs(start_verb, verb_len,"COMMIT") )
11175                     op = COMMIT;
11176                 break;
11177             case 'F':  /* (*FAIL) */
11178                 if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) {
11179                     op = OPFAIL;
11180                 }
11181                 break;
11182             case ':':  /* (*:NAME) */
11183             case 'M':  /* (*MARK:NAME) */
11184                 if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) {
11185                     op = MARKPOINT;
11186                     arg_required = 1;
11187                 }
11188                 break;
11189             case 'P':  /* (*PRUNE) */
11190                 if ( memEQs(start_verb, verb_len,"PRUNE") )
11191                     op = PRUNE;
11192                 break;
11193             case 'S':   /* (*SKIP) */
11194                 if ( memEQs(start_verb, verb_len,"SKIP") )
11195                     op = SKIP;
11196                 break;
11197             case 'T':  /* (*THEN) */
11198                 /* [19:06] <TimToady> :: is then */
11199                 if ( memEQs(start_verb, verb_len,"THEN") ) {
11200                     op = CUTGROUP;
11201                     RExC_seen |= REG_CUTGROUP_SEEN;
11202                 }
11203                 break;
11204             case 'a':
11205                 if (   memEQs(start_verb, verb_len, "asr")
11206                     || memEQs(start_verb, verb_len, "atomic_script_run"))
11207                 {
11208                     paren = 'r';        /* Mnemonic: recursed run */
11209                     goto script_run;
11210                 }
11211                 else if (memEQs(start_verb, verb_len, "atomic")) {
11212                     paren = 't';    /* AtOMIC */
11213                     goto alpha_assertions;
11214                 }
11215                 break;
11216             case 'p':
11217                 if (   memEQs(start_verb, verb_len, "plb")
11218                     || memEQs(start_verb, verb_len, "positive_lookbehind"))
11219                 {
11220                     paren = 'b';
11221                     goto lookbehind_alpha_assertions;
11222                 }
11223                 else if (   memEQs(start_verb, verb_len, "pla")
11224                          || memEQs(start_verb, verb_len, "positive_lookahead"))
11225                 {
11226                     paren = 'a';
11227                     goto alpha_assertions;
11228                 }
11229                 break;
11230             case 'n':
11231                 if (   memEQs(start_verb, verb_len, "nlb")
11232                     || memEQs(start_verb, verb_len, "negative_lookbehind"))
11233                 {
11234                     paren = 'B';
11235                     goto lookbehind_alpha_assertions;
11236                 }
11237                 else if (   memEQs(start_verb, verb_len, "nla")
11238                          || memEQs(start_verb, verb_len, "negative_lookahead"))
11239                 {
11240                     paren = 'A';
11241                     goto alpha_assertions;
11242                 }
11243                 break;
11244             case 's':
11245                 if (   memEQs(start_verb, verb_len, "sr")
11246                     || memEQs(start_verb, verb_len, "script_run"))
11247                 {
11248                     regnode_offset atomic;
11249
11250                     paren = 's';
11251
11252                    script_run:
11253
11254                     /* This indicates Unicode rules. */
11255                     REQUIRE_UNI_RULES(flagp, 0);
11256
11257                     if (! start_arg) {
11258                         goto no_colon;
11259                     }
11260
11261                     RExC_parse = start_arg;
11262
11263                     if (RExC_in_script_run) {
11264
11265                         /*  Nested script runs are treated as no-ops, because
11266                          *  if the nested one fails, the outer one must as
11267                          *  well.  It could fail sooner, and avoid (??{} with
11268                          *  side effects, but that is explicitly documented as
11269                          *  undefined behavior. */
11270
11271                         ret = 0;
11272
11273                         if (paren == 's') {
11274                             paren = ':';
11275                             goto parse_rest;
11276                         }
11277
11278                         /* But, the atomic part of a nested atomic script run
11279                          * isn't a no-op, but can be treated just like a '(?>'
11280                          * */
11281                         paren = '>';
11282                         goto parse_rest;
11283                     }
11284
11285                     /* By doing this here, we avoid extra warnings for nested
11286                      * script runs */
11287                     ckWARNexperimental(RExC_parse,
11288                         WARN_EXPERIMENTAL__SCRIPT_RUN,
11289                         "The script_run feature is experimental");
11290
11291                     if (paren == 's') {
11292                         /* Here, we're starting a new regular script run */
11293                         ret = reg_node(pRExC_state, SROPEN);
11294                         RExC_in_script_run = 1;
11295                         is_open = 1;
11296                         goto parse_rest;
11297                     }
11298
11299                     /* Here, we are starting an atomic script run.  This is
11300                      * handled by recursing to deal with the atomic portion
11301                      * separately, enclosed in SROPEN ... SRCLOSE nodes */
11302
11303                     ret = reg_node(pRExC_state, SROPEN);
11304
11305                     RExC_in_script_run = 1;
11306
11307                     atomic = reg(pRExC_state, 'r', &flags, depth);
11308                     if (flags & (RESTART_PARSE|NEED_UTF8)) {
11309                         *flagp = flags & (RESTART_PARSE|NEED_UTF8);
11310                         return 0;
11311                     }
11312
11313                     REGTAIL(pRExC_state, ret, atomic);
11314
11315                     REGTAIL(pRExC_state, atomic,
11316                            reg_node(pRExC_state, SRCLOSE));
11317
11318                     RExC_in_script_run = 0;
11319                     return ret;
11320                 }
11321
11322                 break;
11323
11324             lookbehind_alpha_assertions:
11325                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11326                 RExC_in_lookbehind++;
11327                 /*FALLTHROUGH*/
11328
11329             alpha_assertions:
11330                 ckWARNexperimental(RExC_parse,
11331                         WARN_EXPERIMENTAL__ALPHA_ASSERTIONS,
11332                         "The alpha_assertions feature is experimental");
11333
11334                 RExC_seen_zerolen++;
11335
11336                 if (! start_arg) {
11337                     goto no_colon;
11338                 }
11339
11340                 /* An empty negative lookahead assertion simply is failure */
11341                 if (paren == 'A' && RExC_parse == start_arg) {
11342                     ret=reganode(pRExC_state, OPFAIL, 0);
11343                     nextchar(pRExC_state);
11344                     return ret;
11345                 }
11346
11347                 RExC_parse = start_arg;
11348                 goto parse_rest;
11349
11350               no_colon:
11351                 vFAIL2utf8f(
11352                 "'(*%" UTF8f "' requires a terminating ':'",
11353                 UTF8fARG(UTF, verb_len, start_verb));
11354                 NOT_REACHED; /*NOTREACHED*/
11355
11356             } /* End of switch */
11357             if ( ! op ) {
11358                 RExC_parse += UTF
11359                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11360                               : 1;
11361                 if (has_upper || verb_len == 0) {
11362                     vFAIL2utf8f(
11363                     "Unknown verb pattern '%" UTF8f "'",
11364                     UTF8fARG(UTF, verb_len, start_verb));
11365                 }
11366                 else {
11367                     vFAIL2utf8f(
11368                     "Unknown '(*...)' construct '%" UTF8f "'",
11369                     UTF8fARG(UTF, verb_len, start_verb));
11370                 }
11371             }
11372             if ( RExC_parse == start_arg ) {
11373                 start_arg = NULL;
11374             }
11375             if ( arg_required && !start_arg ) {
11376                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
11377                     verb_len, start_verb);
11378             }
11379             if (internal_argval == -1) {
11380                 ret = reganode(pRExC_state, op, 0);
11381             } else {
11382                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
11383             }
11384             RExC_seen |= REG_VERBARG_SEEN;
11385             if (start_arg) {
11386                 SV *sv = newSVpvn( start_arg,
11387                                     RExC_parse - start_arg);
11388                 ARG(REGNODE_p(ret)) = add_data( pRExC_state,
11389                                         STR_WITH_LEN("S"));
11390                 RExC_rxi->data->data[ARG(REGNODE_p(ret))]=(void*)sv;
11391                 FLAGS(REGNODE_p(ret)) = 1;
11392             } else {
11393                 FLAGS(REGNODE_p(ret)) = 0;
11394             }
11395             if ( internal_argval != -1 )
11396                 ARG2L_SET(REGNODE_p(ret), internal_argval);
11397             nextchar(pRExC_state);
11398             return ret;
11399         }
11400         else if (*RExC_parse == '?') { /* (?...) */
11401             bool is_logical = 0;
11402             const char * const seqstart = RExC_parse;
11403             const char * endptr;
11404             if (has_intervening_patws) {
11405                 RExC_parse++;
11406                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
11407             }
11408
11409             RExC_parse++;           /* past the '?' */
11410             paren = *RExC_parse;    /* might be a trailing NUL, if not
11411                                        well-formed */
11412             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11413             if (RExC_parse > RExC_end) {
11414                 paren = '\0';
11415             }
11416             ret = 0;                    /* For look-ahead/behind. */
11417             switch (paren) {
11418
11419             case 'P':   /* (?P...) variants for those used to PCRE/Python */
11420                 paren = *RExC_parse;
11421                 if ( paren == '<') {    /* (?P<...>) named capture */
11422                     RExC_parse++;
11423                     if (RExC_parse >= RExC_end) {
11424                         vFAIL("Sequence (?P<... not terminated");
11425                     }
11426                     goto named_capture;
11427                 }
11428                 else if (paren == '>') {   /* (?P>name) named recursion */
11429                     RExC_parse++;
11430                     if (RExC_parse >= RExC_end) {
11431                         vFAIL("Sequence (?P>... not terminated");
11432                     }
11433                     goto named_recursion;
11434                 }
11435                 else if (paren == '=') {   /* (?P=...)  named backref */
11436                     RExC_parse++;
11437                     return handle_named_backref(pRExC_state, flagp,
11438                                                 parse_start, ')');
11439                 }
11440                 RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11441                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11442                 vFAIL3("Sequence (%.*s...) not recognized",
11443                                 RExC_parse-seqstart, seqstart);
11444                 NOT_REACHED; /*NOTREACHED*/
11445             case '<':           /* (?<...) */
11446                 if (*RExC_parse == '!')
11447                     paren = ',';
11448                 else if (*RExC_parse != '=')
11449               named_capture:
11450                 {               /* (?<...>) */
11451                     char *name_start;
11452                     SV *svname;
11453                     paren= '>';
11454                 /* FALLTHROUGH */
11455             case '\'':          /* (?'...') */
11456                     name_start = RExC_parse;
11457                     svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME);
11458                     if (   RExC_parse == name_start
11459                         || RExC_parse >= RExC_end
11460                         || *RExC_parse != paren)
11461                     {
11462                         vFAIL2("Sequence (?%c... not terminated",
11463                             paren=='>' ? '<' : paren);
11464                     }
11465                     {
11466                         HE *he_str;
11467                         SV *sv_dat = NULL;
11468                         if (!svname) /* shouldn't happen */
11469                             Perl_croak(aTHX_
11470                                 "panic: reg_scan_name returned NULL");
11471                         if (!RExC_paren_names) {
11472                             RExC_paren_names= newHV();
11473                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
11474 #ifdef DEBUGGING
11475                             RExC_paren_name_list= newAV();
11476                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
11477 #endif
11478                         }
11479                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
11480                         if ( he_str )
11481                             sv_dat = HeVAL(he_str);
11482                         if ( ! sv_dat ) {
11483                             /* croak baby croak */
11484                             Perl_croak(aTHX_
11485                                 "panic: paren_name hash element allocation failed");
11486                         } else if ( SvPOK(sv_dat) ) {
11487                             /* (?|...) can mean we have dupes so scan to check
11488                                its already been stored. Maybe a flag indicating
11489                                we are inside such a construct would be useful,
11490                                but the arrays are likely to be quite small, so
11491                                for now we punt -- dmq */
11492                             IV count = SvIV(sv_dat);
11493                             I32 *pv = (I32*)SvPVX(sv_dat);
11494                             IV i;
11495                             for ( i = 0 ; i < count ; i++ ) {
11496                                 if ( pv[i] == RExC_npar ) {
11497                                     count = 0;
11498                                     break;
11499                                 }
11500                             }
11501                             if ( count ) {
11502                                 pv = (I32*)SvGROW(sv_dat,
11503                                                 SvCUR(sv_dat) + sizeof(I32)+1);
11504                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
11505                                 pv[count] = RExC_npar;
11506                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
11507                             }
11508                         } else {
11509                             (void)SvUPGRADE(sv_dat, SVt_PVNV);
11510                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
11511                                                                 sizeof(I32));
11512                             SvIOK_on(sv_dat);
11513                             SvIV_set(sv_dat, 1);
11514                         }
11515 #ifdef DEBUGGING
11516                         /* Yes this does cause a memory leak in debugging Perls
11517                          * */
11518                         if (!av_store(RExC_paren_name_list,
11519                                       RExC_npar, SvREFCNT_inc_NN(svname)))
11520                             SvREFCNT_dec_NN(svname);
11521 #endif
11522
11523                         /*sv_dump(sv_dat);*/
11524                     }
11525                     nextchar(pRExC_state);
11526                     paren = 1;
11527                     goto capturing_parens;
11528                 }
11529
11530                 RExC_seen |= REG_LOOKBEHIND_SEEN;
11531                 RExC_in_lookbehind++;
11532                 RExC_parse++;
11533                 if (RExC_parse >= RExC_end) {
11534                     vFAIL("Sequence (?... not terminated");
11535                 }
11536
11537                 /* FALLTHROUGH */
11538             case '=':           /* (?=...) */
11539                 RExC_seen_zerolen++;
11540                 break;
11541             case '!':           /* (?!...) */
11542                 RExC_seen_zerolen++;
11543                 /* check if we're really just a "FAIL" assertion */
11544                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11545                                         FALSE /* Don't force to /x */ );
11546                 if (*RExC_parse == ')') {
11547                     ret=reganode(pRExC_state, OPFAIL, 0);
11548                     nextchar(pRExC_state);
11549                     return ret;
11550                 }
11551                 break;
11552             case '|':           /* (?|...) */
11553                 /* branch reset, behave like a (?:...) except that
11554                    buffers in alternations share the same numbers */
11555                 paren = ':';
11556                 after_freeze = freeze_paren = RExC_npar;
11557
11558                 /* XXX This construct currently requires an extra pass.
11559                  * Investigation would be required to see if that could be
11560                  * changed */
11561                 REQUIRE_PARENS_PASS;
11562                 break;
11563             case ':':           /* (?:...) */
11564             case '>':           /* (?>...) */
11565                 break;
11566             case '$':           /* (?$...) */
11567             case '@':           /* (?@...) */
11568                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
11569                 break;
11570             case '0' :           /* (?0) */
11571             case 'R' :           /* (?R) */
11572                 if (RExC_parse == RExC_end || *RExC_parse != ')')
11573                     FAIL("Sequence (?R) not terminated");
11574                 num = 0;
11575                 RExC_seen |= REG_RECURSE_SEEN;
11576
11577                 /* XXX These constructs currently require an extra pass.
11578                  * It probably could be changed */
11579                 REQUIRE_PARENS_PASS;
11580
11581                 *flagp |= POSTPONED;
11582                 goto gen_recurse_regop;
11583                 /*notreached*/
11584             /* named and numeric backreferences */
11585             case '&':            /* (?&NAME) */
11586                 parse_start = RExC_parse - 1;
11587               named_recursion:
11588                 {
11589                     SV *sv_dat = reg_scan_name(pRExC_state,
11590                                                REG_RSN_RETURN_DATA);
11591                    num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
11592                 }
11593                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
11594                     vFAIL("Sequence (?&... not terminated");
11595                 goto gen_recurse_regop;
11596                 /* NOTREACHED */
11597             case '+':
11598                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11599                     RExC_parse++;
11600                     vFAIL("Illegal pattern");
11601                 }
11602                 goto parse_recursion;
11603                 /* NOTREACHED*/
11604             case '-': /* (?-1) */
11605                 if (! inRANGE(RExC_parse[0], '1', '9')) {
11606                     RExC_parse--; /* rewind to let it be handled later */
11607                     goto parse_flags;
11608                 }
11609                 /* FALLTHROUGH */
11610             case '1': case '2': case '3': case '4': /* (?1) */
11611             case '5': case '6': case '7': case '8': case '9':
11612                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
11613               parse_recursion:
11614                 {
11615                     bool is_neg = FALSE;
11616                     UV unum;
11617                     parse_start = RExC_parse - 1; /* MJD */
11618                     if (*RExC_parse == '-') {
11619                         RExC_parse++;
11620                         is_neg = TRUE;
11621                     }
11622                     endptr = RExC_end;
11623                     if (grok_atoUV(RExC_parse, &unum, &endptr)
11624                         && unum <= I32_MAX
11625                     ) {
11626                         num = (I32)unum;
11627                         RExC_parse = (char*)endptr;
11628                     } else
11629                         num = I32_MAX;
11630                     if (is_neg) {
11631                         /* Some limit for num? */
11632                         num = -num;
11633                     }
11634                 }
11635                 if (*RExC_parse!=')')
11636                     vFAIL("Expecting close bracket");
11637
11638               gen_recurse_regop:
11639                 if ( paren == '-' ) {
11640                     /*
11641                     Diagram of capture buffer numbering.
11642                     Top line is the normal capture buffer numbers
11643                     Bottom line is the negative indexing as from
11644                     the X (the (?-2))
11645
11646                     +   1 2    3 4 5 X          6 7
11647                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
11648                     -   5 4    3 2 1 X          x x
11649
11650                     */
11651                     num = RExC_npar + num;
11652                     if (num < 1)  {
11653
11654                         /* It might be a forward reference; we can't fail until
11655                          * we know, by completing the parse to get all the
11656                          * groups, and then reparsing */
11657                         if (ALL_PARENS_COUNTED)  {
11658                             RExC_parse++;
11659                             vFAIL("Reference to nonexistent group");
11660                         }
11661                         else {
11662                             REQUIRE_PARENS_PASS;
11663                         }
11664                     }
11665                 } else if ( paren == '+' ) {
11666                     num = RExC_npar + num - 1;
11667                 }
11668                 /* We keep track how many GOSUB items we have produced.
11669                    To start off the ARG2L() of the GOSUB holds its "id",
11670                    which is used later in conjunction with RExC_recurse
11671                    to calculate the offset we need to jump for the GOSUB,
11672                    which it will store in the final representation.
11673                    We have to defer the actual calculation until much later
11674                    as the regop may move.
11675                  */
11676
11677                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
11678                 if (num >= RExC_npar) {
11679
11680                     /* It might be a forward reference; we can't fail until we
11681                      * know, by completing the parse to get all the groups, and
11682                      * then reparsing */
11683                     if (ALL_PARENS_COUNTED)  {
11684                         if (num >= RExC_total_parens) {
11685                             RExC_parse++;
11686                             vFAIL("Reference to nonexistent group");
11687                         }
11688                     }
11689                     else {
11690                         REQUIRE_PARENS_PASS;
11691                     }
11692                 }
11693                 RExC_recurse_count++;
11694                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11695                     "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
11696                             22, "|    |", (int)(depth * 2 + 1), "",
11697                             (UV)ARG(REGNODE_p(ret)),
11698                             (IV)ARG2L(REGNODE_p(ret))));
11699                 RExC_seen |= REG_RECURSE_SEEN;
11700
11701                 Set_Node_Length(REGNODE_p(ret),
11702                                 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */
11703                 Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */
11704
11705                 *flagp |= POSTPONED;
11706                 assert(*RExC_parse == ')');
11707                 nextchar(pRExC_state);
11708                 return ret;
11709
11710             /* NOTREACHED */
11711
11712             case '?':           /* (??...) */
11713                 is_logical = 1;
11714                 if (*RExC_parse != '{') {
11715                     RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end);
11716                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11717                     vFAIL2utf8f(
11718                         "Sequence (%" UTF8f "...) not recognized",
11719                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11720                     NOT_REACHED; /*NOTREACHED*/
11721                 }
11722                 *flagp |= POSTPONED;
11723                 paren = '{';
11724                 RExC_parse++;
11725                 /* FALLTHROUGH */
11726             case '{':           /* (?{...}) */
11727             {
11728                 U32 n = 0;
11729                 struct reg_code_block *cb;
11730                 OP * o;
11731
11732                 RExC_seen_zerolen++;
11733
11734                 if (   !pRExC_state->code_blocks
11735                     || pRExC_state->code_index
11736                                         >= pRExC_state->code_blocks->count
11737                     || pRExC_state->code_blocks->cb[pRExC_state->code_index].start
11738                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11739                             - RExC_start)
11740                 ) {
11741                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11742                         FAIL("panic: Sequence (?{...}): no code block found\n");
11743                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11744                 }
11745                 /* this is a pre-compiled code block (?{...}) */
11746                 cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index];
11747                 RExC_parse = RExC_start + cb->end;
11748                 o = cb->block;
11749                 if (cb->src_regex) {
11750                     n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11751                     RExC_rxi->data->data[n] =
11752                         (void*)SvREFCNT_inc((SV*)cb->src_regex);
11753                     RExC_rxi->data->data[n+1] = (void*)o;
11754                 }
11755                 else {
11756                     n = add_data(pRExC_state,
11757                             (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11758                     RExC_rxi->data->data[n] = (void*)o;
11759                 }
11760                 pRExC_state->code_index++;
11761                 nextchar(pRExC_state);
11762
11763                 if (is_logical) {
11764                     regnode_offset eval;
11765                     ret = reg_node(pRExC_state, LOGICAL);
11766
11767                     eval = reg2Lanode(pRExC_state, EVAL,
11768                                        n,
11769
11770                                        /* for later propagation into (??{})
11771                                         * return value */
11772                                        RExC_flags & RXf_PMf_COMPILETIME
11773                                       );
11774                     FLAGS(REGNODE_p(ret)) = 2;
11775                     REGTAIL(pRExC_state, ret, eval);
11776                     /* deal with the length of this later - MJD */
11777                     return ret;
11778                 }
11779                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11780                 Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1);
11781                 Set_Node_Offset(REGNODE_p(ret), parse_start);
11782                 return ret;
11783             }
11784             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11785             {
11786                 int is_define= 0;
11787                 const int DEFINE_len = sizeof("DEFINE") - 1;
11788                 if (    RExC_parse < RExC_end - 1
11789                     && (   (       RExC_parse[0] == '?'        /* (?(?...)) */
11790                             && (   RExC_parse[1] == '='
11791                                 || RExC_parse[1] == '!'
11792                                 || RExC_parse[1] == '<'
11793                                 || RExC_parse[1] == '{'))
11794                         || (       RExC_parse[0] == '*'        /* (?(*...)) */
11795                             && (   memBEGINs(RExC_parse + 1,
11796                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11797                                          "pla:")
11798                                 || memBEGINs(RExC_parse + 1,
11799                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11800                                          "plb:")
11801                                 || memBEGINs(RExC_parse + 1,
11802                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11803                                          "nla:")
11804                                 || memBEGINs(RExC_parse + 1,
11805                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11806                                          "nlb:")
11807                                 || memBEGINs(RExC_parse + 1,
11808                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11809                                          "positive_lookahead:")
11810                                 || memBEGINs(RExC_parse + 1,
11811                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11812                                          "positive_lookbehind:")
11813                                 || memBEGINs(RExC_parse + 1,
11814                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11815                                          "negative_lookahead:")
11816                                 || memBEGINs(RExC_parse + 1,
11817                                          (Size_t) (RExC_end - (RExC_parse + 1)),
11818                                          "negative_lookbehind:"))))
11819                 ) { /* Lookahead or eval. */
11820                     I32 flag;
11821                     regnode_offset tail;
11822
11823                     ret = reg_node(pRExC_state, LOGICAL);
11824                     FLAGS(REGNODE_p(ret)) = 1;
11825
11826                     tail = reg(pRExC_state, 1, &flag, depth+1);
11827                     RETURN_FAIL_ON_RESTART(flag, flagp);
11828                     REGTAIL(pRExC_state, ret, tail);
11829                     goto insert_if;
11830                 }
11831                 else if (   RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11832                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11833                 {
11834                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11835                     char *name_start= RExC_parse++;
11836                     U32 num = 0;
11837                     SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA);
11838                     if (   RExC_parse == name_start
11839                         || RExC_parse >= RExC_end
11840                         || *RExC_parse != ch)
11841                     {
11842                         vFAIL2("Sequence (?(%c... not terminated",
11843                             (ch == '>' ? '<' : ch));
11844                     }
11845                     RExC_parse++;
11846                     if (sv_dat) {
11847                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11848                         RExC_rxi->data->data[num]=(void*)sv_dat;
11849                         SvREFCNT_inc_simple_void_NN(sv_dat);
11850                     }
11851                     ret = reganode(pRExC_state, GROUPPN, num);
11852                     goto insert_if_check_paren;
11853                 }
11854                 else if (memBEGINs(RExC_parse,
11855                                    (STRLEN) (RExC_end - RExC_parse),
11856                                    "DEFINE"))
11857                 {
11858                     ret = reganode(pRExC_state, DEFINEP, 0);
11859                     RExC_parse += DEFINE_len;
11860                     is_define = 1;
11861                     goto insert_if_check_paren;
11862                 }
11863                 else if (RExC_parse[0] == 'R') {
11864                     RExC_parse++;
11865                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11866                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11867                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11868                      */
11869                     parno = 0;
11870                     if (RExC_parse[0] == '0') {
11871                         parno = 1;
11872                         RExC_parse++;
11873                     }
11874                     else if (inRANGE(RExC_parse[0], '1', '9')) {
11875                         UV uv;
11876                         endptr = RExC_end;
11877                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11878                             && uv <= I32_MAX
11879                         ) {
11880                             parno = (I32)uv + 1;
11881                             RExC_parse = (char*)endptr;
11882                         }
11883                         /* else "Switch condition not recognized" below */
11884                     } else if (RExC_parse[0] == '&') {
11885                         SV *sv_dat;
11886                         RExC_parse++;
11887                         sv_dat = reg_scan_name(pRExC_state,
11888                                                REG_RSN_RETURN_DATA);
11889                         if (sv_dat)
11890                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11891                     }
11892                     ret = reganode(pRExC_state, INSUBP, parno);
11893                     goto insert_if_check_paren;
11894                 }
11895                 else if (inRANGE(RExC_parse[0], '1', '9')) {
11896                     /* (?(1)...) */
11897                     char c;
11898                     UV uv;
11899                     endptr = RExC_end;
11900                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11901                         && uv <= I32_MAX
11902                     ) {
11903                         parno = (I32)uv;
11904                         RExC_parse = (char*)endptr;
11905                     }
11906                     else {
11907                         vFAIL("panic: grok_atoUV returned FALSE");
11908                     }
11909                     ret = reganode(pRExC_state, GROUPP, parno);
11910
11911                  insert_if_check_paren:
11912                     if (UCHARAT(RExC_parse) != ')') {
11913                         RExC_parse += UTF
11914                                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11915                                       : 1;
11916                         vFAIL("Switch condition not recognized");
11917                     }
11918                     nextchar(pRExC_state);
11919                   insert_if:
11920                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11921                     br = regbranch(pRExC_state, &flags, 1, depth+1);
11922                     if (br == 0) {
11923                         RETURN_FAIL_ON_RESTART(flags,flagp);
11924                         FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
11925                               (UV) flags);
11926                     } else
11927                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11928                                                           LONGJMP, 0));
11929                     c = UCHARAT(RExC_parse);
11930                     nextchar(pRExC_state);
11931                     if (flags&HASWIDTH)
11932                         *flagp |= HASWIDTH;
11933                     if (c == '|') {
11934                         if (is_define)
11935                             vFAIL("(?(DEFINE)....) does not allow branches");
11936
11937                         /* Fake one for optimizer.  */
11938                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11939
11940                         if (!regbranch(pRExC_state, &flags, 1, depth+1)) {
11941                             RETURN_FAIL_ON_RESTART(flags, flagp);
11942                             FAIL2("panic: regbranch returned failure, flags=%#" UVxf,
11943                                   (UV) flags);
11944                         }
11945                         REGTAIL(pRExC_state, ret, lastbr);
11946                         if (flags&HASWIDTH)
11947                             *flagp |= HASWIDTH;
11948                         c = UCHARAT(RExC_parse);
11949                         nextchar(pRExC_state);
11950                     }
11951                     else
11952                         lastbr = 0;
11953                     if (c != ')') {
11954                         if (RExC_parse >= RExC_end)
11955                             vFAIL("Switch (?(condition)... not terminated");
11956                         else
11957                             vFAIL("Switch (?(condition)... contains too many branches");
11958                     }
11959                     ender = reg_node(pRExC_state, TAIL);
11960                     REGTAIL(pRExC_state, br, ender);
11961                     if (lastbr) {
11962                         REGTAIL(pRExC_state, lastbr, ender);
11963                         REGTAIL(pRExC_state, REGNODE_OFFSET(
11964                                                 NEXTOPER(
11965                                                 NEXTOPER(REGNODE_p(lastbr)))),
11966                                              ender);
11967                     }
11968                     else
11969                         REGTAIL(pRExC_state, ret, ender);
11970 #if 0  /* Removing this doesn't cause failures in the test suite -- khw */
11971                     RExC_size++; /* XXX WHY do we need this?!!
11972                                     For large programs it seems to be required
11973                                     but I can't figure out why. -- dmq*/
11974 #endif
11975                     return ret;
11976                 }
11977                 RExC_parse += UTF
11978                               ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
11979                               : 1;
11980                 vFAIL("Unknown switch condition (?(...))");
11981             }
11982             case '[':           /* (?[ ... ]) */
11983                 return handle_regex_sets(pRExC_state, NULL, flagp, depth+1,
11984                                          oregcomp_parse);
11985             case 0: /* A NUL */
11986                 RExC_parse--; /* for vFAIL to print correctly */
11987                 vFAIL("Sequence (? incomplete");
11988                 break;
11989
11990             case ')':
11991                 if (RExC_strict) {  /* [perl #132851] */
11992                     ckWARNreg(RExC_parse, "Empty (?) without any modifiers");
11993                 }
11994                 /* FALLTHROUGH */
11995             default: /* e.g., (?i) */
11996                 RExC_parse = (char *) seqstart + 1;
11997               parse_flags:
11998                 parse_lparen_question_flags(pRExC_state);
11999                 if (UCHARAT(RExC_parse) != ':') {
12000                     if (RExC_parse < RExC_end)
12001                         nextchar(pRExC_state);
12002                     *flagp = TRYAGAIN;
12003                     return 0;
12004                 }
12005                 paren = ':';
12006                 nextchar(pRExC_state);
12007                 ret = 0;
12008                 goto parse_rest;
12009             } /* end switch */
12010         }
12011         else {
12012             if (*RExC_parse == '{') {
12013                 ckWARNregdep(RExC_parse + 1,
12014                             "Unescaped left brace in regex is "
12015                             "deprecated here (and will be fatal "
12016                             "in Perl 5.32), passed through");
12017             }
12018             /* Not bothering to indent here, as the above 'else' is temporary
12019              * */
12020         if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
12021           capturing_parens:
12022             parno = RExC_npar;
12023             RExC_npar++;
12024             if (! ALL_PARENS_COUNTED) {
12025                 /* If we are in our first pass through (and maybe only pass),
12026                  * we  need to allocate memory for the capturing parentheses
12027                  * data structures.
12028                  */
12029
12030                 if (!RExC_parens_buf_size) {
12031                     /* first guess at number of parens we might encounter */
12032                     RExC_parens_buf_size = 10;
12033
12034                     /* setup RExC_open_parens, which holds the address of each
12035                      * OPEN tag, and to make things simpler for the 0 index the
12036                      * start of the program - this is used later for offsets */
12037                     Newxz(RExC_open_parens, RExC_parens_buf_size,
12038                             regnode_offset);
12039                     RExC_open_parens[0] = 1;    /* +1 for REG_MAGIC */
12040
12041                     /* setup RExC_close_parens, which holds the address of each
12042                      * CLOSE tag, and to make things simpler for the 0 index
12043                      * the end of the program - this is used later for offsets
12044                      * */
12045                     Newxz(RExC_close_parens, RExC_parens_buf_size,
12046                             regnode_offset);
12047                     /* we dont know where end op starts yet, so we dont need to
12048                      * set RExC_close_parens[0] like we do RExC_open_parens[0]
12049                      * above */
12050                 }
12051                 else if (RExC_npar > RExC_parens_buf_size) {
12052                     I32 old_size = RExC_parens_buf_size;
12053
12054                     RExC_parens_buf_size *= 2;
12055
12056                     Renew(RExC_open_parens, RExC_parens_buf_size,
12057                             regnode_offset);
12058                     Zero(RExC_open_parens + old_size,
12059                             RExC_parens_buf_size - old_size, regnode_offset);
12060
12061                     Renew(RExC_close_parens, RExC_parens_buf_size,
12062                             regnode_offset);
12063                     Zero(RExC_close_parens + old_size,
12064                             RExC_parens_buf_size - old_size, regnode_offset);
12065                 }
12066             }
12067
12068             ret = reganode(pRExC_state, OPEN, parno);
12069             if (!RExC_nestroot)
12070                 RExC_nestroot = parno;
12071             if (RExC_open_parens && !RExC_open_parens[parno])
12072             {
12073                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12074                     "%*s%*s Setting open paren #%" IVdf " to %d\n",
12075                     22, "|    |", (int)(depth * 2 + 1), "",
12076                     (IV)parno, ret));
12077                 RExC_open_parens[parno]= ret;
12078             }
12079
12080             Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
12081             Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */
12082             is_open = 1;
12083         } else {
12084             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
12085             paren = ':';
12086             ret = 0;
12087         }
12088         }
12089     }
12090     else                        /* ! paren */
12091         ret = 0;
12092
12093    parse_rest:
12094     /* Pick up the branches, linking them together. */
12095     parse_start = RExC_parse;   /* MJD */
12096     br = regbranch(pRExC_state, &flags, 1, depth+1);
12097
12098     /*     branch_len = (paren != 0); */
12099
12100     if (br == 0) {
12101         RETURN_FAIL_ON_RESTART(flags, flagp);
12102         FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12103     }
12104     if (*RExC_parse == '|') {
12105         if (RExC_use_BRANCHJ) {
12106             reginsert(pRExC_state, BRANCHJ, br, depth+1);
12107         }
12108         else {                  /* MJD */
12109             reginsert(pRExC_state, BRANCH, br, depth+1);
12110             Set_Node_Length(REGNODE_p(br), paren != 0);
12111             Set_Node_Offset_To_R(br, parse_start-RExC_start);
12112         }
12113         have_branch = 1;
12114     }
12115     else if (paren == ':') {
12116         *flagp |= flags&SIMPLE;
12117     }
12118     if (is_open) {                              /* Starts with OPEN. */
12119         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
12120     }
12121     else if (paren != '?')              /* Not Conditional */
12122         ret = br;
12123     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
12124     lastbr = br;
12125     while (*RExC_parse == '|') {
12126         if (RExC_use_BRANCHJ) {
12127             ender = reganode(pRExC_state, LONGJMP, 0);
12128
12129             /* Append to the previous. */
12130             REGTAIL(pRExC_state,
12131                     REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))),
12132                     ender);
12133         }
12134         nextchar(pRExC_state);
12135         if (freeze_paren) {
12136             if (RExC_npar > after_freeze)
12137                 after_freeze = RExC_npar;
12138             RExC_npar = freeze_paren;
12139         }
12140         br = regbranch(pRExC_state, &flags, 0, depth+1);
12141
12142         if (br == 0) {
12143             RETURN_FAIL_ON_RESTART(flags, flagp);
12144             FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags);
12145         }
12146         if (!  REGTAIL(pRExC_state, lastbr, br)) {  /* BRANCH -> BRANCH. */
12147             REQUIRE_BRANCHJ(flagp, 0);
12148         }
12149         lastbr = br;
12150         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
12151     }
12152
12153     if (have_branch || paren != ':') {
12154         regnode * br;
12155
12156         /* Make a closing node, and hook it on the end. */
12157         switch (paren) {
12158         case ':':
12159             ender = reg_node(pRExC_state, TAIL);
12160             break;
12161         case 1: case 2:
12162             ender = reganode(pRExC_state, CLOSE, parno);
12163             if ( RExC_close_parens ) {
12164                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12165                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
12166                         22, "|    |", (int)(depth * 2 + 1), "",
12167                         (IV)parno, ender));
12168                 RExC_close_parens[parno]= ender;
12169                 if (RExC_nestroot == parno)
12170                     RExC_nestroot = 0;
12171             }
12172             Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */
12173             Set_Node_Length(REGNODE_p(ender), 1); /* MJD */
12174             break;
12175         case 's':
12176             ender = reg_node(pRExC_state, SRCLOSE);
12177             RExC_in_script_run = 0;
12178             break;
12179         case '<':
12180         case 'a':
12181         case 'A':
12182         case 'b':
12183         case 'B':
12184         case ',':
12185         case '=':
12186         case '!':
12187             *flagp &= ~HASWIDTH;
12188             /* FALLTHROUGH */
12189         case 't':   /* aTomic */
12190         case '>':
12191             ender = reg_node(pRExC_state, SUCCEED);
12192             break;
12193         case 0:
12194             ender = reg_node(pRExC_state, END);
12195             assert(!RExC_end_op); /* there can only be one! */
12196             RExC_end_op = REGNODE_p(ender);
12197             if (RExC_close_parens) {
12198                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
12199                     "%*s%*s Setting close paren #0 (END) to %d\n",
12200                     22, "|    |", (int)(depth * 2 + 1), "",
12201                     ender));
12202
12203                 RExC_close_parens[0]= ender;
12204             }
12205             break;
12206         }
12207         DEBUG_PARSE_r(
12208             DEBUG_PARSE_MSG("lsbr");
12209             regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state);
12210             regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender), NULL, pRExC_state);
12211             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12212                           SvPV_nolen_const(RExC_mysv1),
12213                           (IV)lastbr,
12214                           SvPV_nolen_const(RExC_mysv2),
12215                           (IV)ender,
12216                           (IV)(ender - lastbr)
12217             );
12218         );
12219         if (! REGTAIL(pRExC_state, lastbr, ender)) {
12220             REQUIRE_BRANCHJ(flagp, 0);
12221         }
12222
12223         if (have_branch) {
12224             char is_nothing= 1;
12225             if (depth==1)
12226                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
12227
12228             /* Hook the tails of the branches to the closing node. */
12229             for (br = REGNODE_p(ret); br; br = regnext(br)) {
12230                 const U8 op = PL_regkind[OP(br)];
12231                 if (op == BRANCH) {
12232                     if (! REGTAIL_STUDY(pRExC_state,
12233                                         REGNODE_OFFSET(NEXTOPER(br)),
12234                                         ender))
12235                     {
12236                         REQUIRE_BRANCHJ(flagp, 0);
12237                     }
12238                     if ( OP(NEXTOPER(br)) != NOTHING
12239                          || regnext(NEXTOPER(br)) != REGNODE_p(ender))
12240                         is_nothing= 0;
12241                 }
12242                 else if (op == BRANCHJ) {
12243                     REGTAIL_STUDY(pRExC_state,
12244                                   REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))),
12245                                   ender);
12246                     /* for now we always disable this optimisation * /
12247                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
12248                          || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender))
12249                     */
12250                         is_nothing= 0;
12251                 }
12252             }
12253             if (is_nothing) {
12254                 regnode * ret_as_regnode = REGNODE_p(ret);
12255                 br= PL_regkind[OP(ret_as_regnode)] != BRANCH
12256                                ? regnext(ret_as_regnode)
12257                                : ret_as_regnode;
12258                 DEBUG_PARSE_r(
12259                     DEBUG_PARSE_MSG("NADA");
12260                     regprop(RExC_rx, RExC_mysv1, ret_as_regnode,
12261                                      NULL, pRExC_state);
12262                     regprop(RExC_rx, RExC_mysv2, REGNODE_p(ender),
12263                                      NULL, pRExC_state);
12264                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
12265                                   SvPV_nolen_const(RExC_mysv1),
12266                                   (IV)REG_NODE_NUM(ret_as_regnode),
12267                                   SvPV_nolen_const(RExC_mysv2),
12268                                   (IV)ender,
12269                                   (IV)(ender - ret)
12270                     );
12271                 );
12272                 OP(br)= NOTHING;
12273                 if (OP(REGNODE_p(ender)) == TAIL) {
12274                     NEXT_OFF(br)= 0;
12275                     RExC_emit= REGNODE_OFFSET(br) + 1;
12276                 } else {
12277                     regnode *opt;
12278                     for ( opt= br + 1; opt < REGNODE_p(ender) ; opt++ )
12279                         OP(opt)= OPTIMIZED;
12280                     NEXT_OFF(br)= REGNODE_p(ender) - br;
12281                 }
12282             }
12283         }
12284     }
12285
12286     {
12287         const char *p;
12288          /* Even/odd or x=don't care: 010101x10x */
12289         static const char parens[] = "=!aA<,>Bbt";
12290          /* flag below is set to 0 up through 'A'; 1 for larger */
12291
12292         if (paren && (p = strchr(parens, paren))) {
12293             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
12294             int flag = (p - parens) > 3;
12295
12296             if (paren == '>' || paren == 't') {
12297                 node = SUSPEND, flag = 0;
12298             }
12299
12300             reginsert(pRExC_state, node, ret, depth+1);
12301             Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12302             Set_Node_Offset(REGNODE_p(ret), parse_start + 1);
12303             FLAGS(REGNODE_p(ret)) = flag;
12304             if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL)))
12305             {
12306                 REQUIRE_BRANCHJ(flagp, 0);
12307             }
12308         }
12309     }
12310
12311     /* Check for proper termination. */
12312     if (paren) {
12313         /* restore original flags, but keep (?p) and, if we've encountered
12314          * something in the parse that changes /d rules into /u, keep the /u */
12315         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
12316         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
12317             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
12318         }
12319         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
12320             RExC_parse = oregcomp_parse;
12321             vFAIL("Unmatched (");
12322         }
12323         nextchar(pRExC_state);
12324     }
12325     else if (!paren && RExC_parse < RExC_end) {
12326         if (*RExC_parse == ')') {
12327             RExC_parse++;
12328             vFAIL("Unmatched )");
12329         }
12330         else
12331             FAIL("Junk on end of regexp");      /* "Can't happen". */
12332         NOT_REACHED; /* NOTREACHED */
12333     }
12334
12335     if (RExC_in_lookbehind) {
12336         RExC_in_lookbehind--;
12337     }
12338     if (after_freeze > RExC_npar)
12339         RExC_npar = after_freeze;
12340     return(ret);
12341 }
12342
12343 /*
12344  - regbranch - one alternative of an | operator
12345  *
12346  * Implements the concatenation operator.
12347  *
12348  * On success, returns the offset at which any next node should be placed into
12349  * the regex engine program being compiled.
12350  *
12351  * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
12352  * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
12353  * UTF-8
12354  */
12355 STATIC regnode_offset
12356 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
12357 {
12358     regnode_offset ret;
12359     regnode_offset chain = 0;
12360     regnode_offset latest;
12361     I32 flags = 0, c = 0;
12362     GET_RE_DEBUG_FLAGS_DECL;
12363
12364     PERL_ARGS_ASSERT_REGBRANCH;
12365
12366     DEBUG_PARSE("brnc");
12367
12368     if (first)
12369         ret = 0;
12370     else {
12371         if (RExC_use_BRANCHJ)
12372             ret = reganode(pRExC_state, BRANCHJ, 0);
12373         else {
12374             ret = reg_node(pRExC_state, BRANCH);
12375             Set_Node_Length(REGNODE_p(ret), 1);
12376         }
12377     }
12378
12379     *flagp = WORST;                     /* Tentatively. */
12380
12381     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
12382                             FALSE /* Don't force to /x */ );
12383     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
12384         flags &= ~TRYAGAIN;
12385         latest = regpiece(pRExC_state, &flags, depth+1);
12386         if (latest == 0) {
12387             if (flags & TRYAGAIN)
12388                 continue;
12389             RETURN_FAIL_ON_RESTART(flags, flagp);
12390             FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags);
12391         }
12392         else if (ret == 0)
12393             ret = latest;
12394         *flagp |= flags&(HASWIDTH|POSTPONED);
12395         if (chain == 0)         /* First piece. */
12396             *flagp |= flags&SPSTART;
12397         else {
12398             /* FIXME adding one for every branch after the first is probably
12399              * excessive now we have TRIE support. (hv) */
12400             MARK_NAUGHTY(1);
12401             if (! REGTAIL(pRExC_state, chain, latest)) {
12402                 /* XXX We could just redo this branch, but figuring out what
12403                  * bookkeeping needs to be reset is a pain, and it's likely
12404                  * that other branches that goto END will also be too large */
12405                 REQUIRE_BRANCHJ(flagp, 0);
12406             }
12407         }
12408         chain = latest;
12409         c++;
12410     }
12411     if (chain == 0) {   /* Loop ran zero times. */
12412         chain = reg_node(pRExC_state, NOTHING);
12413         if (ret == 0)
12414             ret = chain;
12415     }
12416     if (c == 1) {
12417         *flagp |= flags&SIMPLE;
12418     }
12419
12420     return ret;
12421 }
12422
12423 /*
12424  - regpiece - something followed by possible quantifier * + ? {n,m}
12425  *
12426  * Note that the branching code sequences used for ? and the general cases
12427  * of * and + are somewhat optimized:  they use the same NOTHING node as
12428  * both the endmarker for their branch list and the body of the last branch.
12429  * It might seem that this node could be dispensed with entirely, but the
12430  * endmarker role is not redundant.
12431  *
12432  * On success, returns the offset at which any next node should be placed into
12433  * the regex engine program being compiled.
12434  *
12435  * Returns 0 otherwise, with *flagp set to indicate why:
12436  *  TRYAGAIN        if regatom() returns 0 with TRYAGAIN.
12437  *  RESTART_PARSE   if the parse needs to be restarted, or'd with
12438  *                  NEED_UTF8 if the pattern needs to be upgraded to UTF-8.
12439  */
12440 STATIC regnode_offset
12441 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12442 {
12443     regnode_offset ret;
12444     char op;
12445     char *next;
12446     I32 flags;
12447     const char * const origparse = RExC_parse;
12448     I32 min;
12449     I32 max = REG_INFTY;
12450 #ifdef RE_TRACK_PATTERN_OFFSETS
12451     char *parse_start;
12452 #endif
12453     const char *maxpos = NULL;
12454     UV uv;
12455
12456     /* Save the original in case we change the emitted regop to a FAIL. */
12457     const regnode_offset orig_emit = RExC_emit;
12458
12459     GET_RE_DEBUG_FLAGS_DECL;
12460
12461     PERL_ARGS_ASSERT_REGPIECE;
12462
12463     DEBUG_PARSE("piec");
12464
12465     ret = regatom(pRExC_state, &flags, depth+1);
12466     if (ret == 0) {
12467         RETURN_FAIL_ON_RESTART_OR_FLAGS(flags, flagp, TRYAGAIN);
12468         FAIL2("panic: regatom returned failure, flags=%#" UVxf, (UV) flags);
12469     }
12470
12471     op = *RExC_parse;
12472
12473     if (op == '{' && regcurly(RExC_parse)) {
12474         maxpos = NULL;
12475 #ifdef RE_TRACK_PATTERN_OFFSETS
12476         parse_start = RExC_parse; /* MJD */
12477 #endif
12478         next = RExC_parse + 1;
12479         while (isDIGIT(*next) || *next == ',') {
12480             if (*next == ',') {
12481                 if (maxpos)
12482                     break;
12483                 else
12484                     maxpos = next;
12485             }
12486             next++;
12487         }
12488         if (*next == '}') {             /* got one */
12489             const char* endptr;
12490             if (!maxpos)
12491                 maxpos = next;
12492             RExC_parse++;
12493             if (isDIGIT(*RExC_parse)) {
12494                 endptr = RExC_end;
12495                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
12496                     vFAIL("Invalid quantifier in {,}");
12497                 if (uv >= REG_INFTY)
12498                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12499                 min = (I32)uv;
12500             } else {
12501                 min = 0;
12502             }
12503             if (*maxpos == ',')
12504                 maxpos++;
12505             else
12506                 maxpos = RExC_parse;
12507             if (isDIGIT(*maxpos)) {
12508                 endptr = RExC_end;
12509                 if (!grok_atoUV(maxpos, &uv, &endptr))
12510                     vFAIL("Invalid quantifier in {,}");
12511                 if (uv >= REG_INFTY)
12512                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
12513                 max = (I32)uv;
12514             } else {
12515                 max = REG_INFTY;                /* meaning "infinity" */
12516             }
12517             RExC_parse = next;
12518             nextchar(pRExC_state);
12519             if (max < min) {    /* If can't match, warn and optimize to fail
12520                                    unconditionally */
12521                 reginsert(pRExC_state, OPFAIL, orig_emit, depth+1);
12522                 ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
12523                 NEXT_OFF(REGNODE_p(orig_emit)) =
12524                                     regarglen[OPFAIL] + NODE_STEP_REGNODE;
12525                 return ret;
12526             }
12527             else if (min == max && *RExC_parse == '?')
12528             {
12529                 ckWARN2reg(RExC_parse + 1,
12530                            "Useless use of greediness modifier '%c'",
12531                            *RExC_parse);
12532             }
12533
12534           do_curly:
12535             if ((flags&SIMPLE)) {
12536                 if (min == 0 && max == REG_INFTY) {
12537                     reginsert(pRExC_state, STAR, ret, depth+1);
12538                     MARK_NAUGHTY(4);
12539                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12540                     goto nest_check;
12541                 }
12542                 if (min == 1 && max == REG_INFTY) {
12543                     reginsert(pRExC_state, PLUS, ret, depth+1);
12544                     MARK_NAUGHTY(3);
12545                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12546                     goto nest_check;
12547                 }
12548                 MARK_NAUGHTY_EXP(2, 2);
12549                 reginsert(pRExC_state, CURLY, ret, depth+1);
12550                 Set_Node_Offset(REGNODE_p(ret), parse_start+1); /* MJD */
12551                 Set_Node_Cur_Length(REGNODE_p(ret), parse_start);
12552             }
12553             else {
12554                 const regnode_offset w = reg_node(pRExC_state, WHILEM);
12555
12556                 FLAGS(REGNODE_p(w)) = 0;
12557                 REGTAIL(pRExC_state, ret, w);
12558                 if (RExC_use_BRANCHJ) {
12559                     reginsert(pRExC_state, LONGJMP, ret, depth+1);
12560                     reginsert(pRExC_state, NOTHING, ret, depth+1);
12561                     NEXT_OFF(REGNODE_p(ret)) = 3;       /* Go over LONGJMP. */
12562                 }
12563                 reginsert(pRExC_state, CURLYX, ret, depth+1);
12564                                 /* MJD hk */
12565                 Set_Node_Offset(REGNODE_p(ret), parse_start+1);
12566                 Set_Node_Length(REGNODE_p(ret),
12567                                 op == '{' ? (RExC_parse - parse_start) : 1);
12568
12569                 if (RExC_use_BRANCHJ)
12570                     NEXT_OFF(REGNODE_p(ret)) = 3;   /* Go over NOTHING to
12571                                                        LONGJMP. */
12572                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
12573                 RExC_whilem_seen++;
12574                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
12575             }
12576             FLAGS(REGNODE_p(ret)) = 0;
12577
12578             if (min > 0)
12579                 *flagp = WORST;
12580             if (max > 0)
12581                 *flagp |= HASWIDTH;
12582             ARG1_SET(REGNODE_p(ret), (U16)min);
12583             ARG2_SET(REGNODE_p(ret), (U16)max);
12584             if (max == REG_INFTY)
12585                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
12586
12587             goto nest_check;
12588         }
12589     }
12590
12591     if (!ISMULT1(op)) {
12592         *flagp = flags;
12593         return(ret);
12594     }
12595
12596 #if 0                           /* Now runtime fix should be reliable. */
12597
12598     /* if this is reinstated, don't forget to put this back into perldiag:
12599
12600             =item Regexp *+ operand could be empty at {#} in regex m/%s/
12601
12602            (F) The part of the regexp subject to either the * or + quantifier
12603            could match an empty string. The {#} shows in the regular
12604            expression about where the problem was discovered.
12605
12606     */
12607
12608     if (!(flags&HASWIDTH) && op != '?')
12609       vFAIL("Regexp *+ operand could be empty");
12610 #endif
12611
12612 #ifdef RE_TRACK_PATTERN_OFFSETS
12613     parse_start = RExC_parse;
12614 #endif
12615     nextchar(pRExC_state);
12616
12617     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
12618
12619     if (op == '*') {
12620         min = 0;
12621         goto do_curly;
12622     }
12623     else if (op == '+') {
12624         min = 1;
12625         goto do_curly;
12626     }
12627     else if (op == '?') {
12628         min = 0; max = 1;
12629         goto do_curly;
12630     }
12631   nest_check:
12632     if (!(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
12633         ckWARN2reg(RExC_parse,
12634                    "%" UTF8f " matches null string many times",
12635                    UTF8fARG(UTF, (RExC_parse >= origparse
12636                                  ? RExC_parse - origparse
12637                                  : 0),
12638                    origparse));
12639     }
12640
12641     if (*RExC_parse == '?') {
12642         nextchar(pRExC_state);
12643         reginsert(pRExC_state, MINMOD, ret, depth+1);
12644         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
12645     }
12646     else if (*RExC_parse == '+') {
12647         regnode_offset ender;
12648         nextchar(pRExC_state);
12649         ender = reg_node(pRExC_state, SUCCEED);
12650         REGTAIL(pRExC_state, ret, ender);
12651         reginsert(pRExC_state, SUSPEND, ret, depth+1);
12652         ender = reg_node(pRExC_state, TAIL);
12653         REGTAIL(pRExC_state, ret, ender);
12654     }
12655
12656     if (ISMULT2(RExC_parse)) {
12657         RExC_parse++;
12658         vFAIL("Nested quantifiers");
12659     }
12660
12661     return(ret);
12662 }
12663
12664 STATIC bool
12665 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
12666                 regnode_offset * node_p,
12667                 UV * code_point_p,
12668                 int * cp_count,
12669                 I32 * flagp,
12670                 const bool strict,
12671                 const U32 depth
12672     )
12673 {
12674  /* This routine teases apart the various meanings of \N and returns
12675   * accordingly.  The input parameters constrain which meaning(s) is/are valid
12676   * in the current context.
12677   *
12678   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
12679   *
12680   * If <code_point_p> is not NULL, the context is expecting the result to be a
12681   * single code point.  If this \N instance turns out to a single code point,
12682   * the function returns TRUE and sets *code_point_p to that code point.
12683   *
12684   * If <node_p> is not NULL, the context is expecting the result to be one of
12685   * the things representable by a regnode.  If this \N instance turns out to be
12686   * one such, the function generates the regnode, returns TRUE and sets *node_p
12687   * to point to the offset of that regnode into the regex engine program being
12688   * compiled.
12689   *
12690   * If this instance of \N isn't legal in any context, this function will
12691   * generate a fatal error and not return.
12692   *
12693   * On input, RExC_parse should point to the first char following the \N at the
12694   * time of the call.  On successful return, RExC_parse will have been updated
12695   * to point to just after the sequence identified by this routine.  Also
12696   * *flagp has been updated as needed.
12697   *
12698   * When there is some problem with the current context and this \N instance,
12699   * the function returns FALSE, without advancing RExC_parse, nor setting
12700   * *node_p, nor *code_point_p, nor *flagp.
12701   *
12702   * If <cp_count> is not NULL, the caller wants to know the length (in code
12703   * points) that this \N sequence matches.  This is set, and the input is
12704   * parsed for errors, even if the function returns FALSE, as detailed below.
12705   *
12706   * There are 6 possibilities here, as detailed in the next 6 paragraphs.
12707   *
12708   * Probably the most common case is for the \N to specify a single code point.
12709   * *cp_count will be set to 1, and *code_point_p will be set to that code
12710   * point.
12711   *
12712   * Another possibility is for the input to be an empty \N{}.  This is no
12713   * longer accepted, and will generate a fatal error.
12714   *
12715   * Another possibility is for a custom charnames handler to be in effect which
12716   * translates the input name to an empty string.  *cp_count will be set to 0.
12717   * *node_p will be set to a generated NOTHING node.
12718   *
12719   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
12720   * set to 0. *node_p will be set to a generated REG_ANY node.
12721   *
12722   * The fifth possibility is that \N resolves to a sequence of more than one
12723   * code points.  *cp_count will be set to the number of code points in the
12724   * sequence. *node_p will be set to a generated node returned by this
12725   * function calling S_reg().
12726   *
12727   * The final possibility is that it is premature to be calling this function;
12728   * the parse needs to be restarted.  This can happen when this changes from
12729   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
12730   * latter occurs only when the fifth possibility would otherwise be in
12731   * effect, and is because one of those code points requires the pattern to be
12732   * recompiled as UTF-8.  The function returns FALSE, and sets the
12733   * RESTART_PARSE and NEED_UTF8 flags in *flagp, as appropriate.  When this
12734   * happens, the caller needs to desist from continuing parsing, and return
12735   * this information to its caller.  This is not set for when there is only one
12736   * code point, as this can be called as part of an ANYOF node, and they can
12737   * store above-Latin1 code points without the pattern having to be in UTF-8.
12738   *
12739   * For non-single-quoted regexes, the tokenizer has resolved character and
12740   * sequence names inside \N{...} into their Unicode values, normalizing the
12741   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
12742   * hex-represented code points in the sequence.  This is done there because
12743   * the names can vary based on what charnames pragma is in scope at the time,
12744   * so we need a way to take a snapshot of what they resolve to at the time of
12745   * the original parse. [perl #56444].
12746   *
12747   * That parsing is skipped for single-quoted regexes, so here we may get
12748   * '\N{NAME}', which is parsed now.  If the single-quoted regex is something
12749   * like '\N{U+41}', that code point is Unicode, and has to be translated into
12750   * the native character set for non-ASCII platforms.  The other possibilities
12751   * are already native, so no translation is done. */
12752
12753     char * endbrace;    /* points to '}' following the name */
12754     char* p = RExC_parse; /* Temporary */
12755
12756     SV * substitute_parse = NULL;
12757     char *orig_end;
12758     char *save_start;
12759     I32 flags;
12760
12761     GET_RE_DEBUG_FLAGS_DECL;
12762
12763     PERL_ARGS_ASSERT_GROK_BSLASH_N;
12764
12765     GET_RE_DEBUG_FLAGS;
12766
12767     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
12768     assert(! (node_p && cp_count));               /* At most 1 should be set */
12769
12770     if (cp_count) {     /* Initialize return for the most common case */
12771         *cp_count = 1;
12772     }
12773
12774     /* The [^\n] meaning of \N ignores spaces and comments under the /x
12775      * modifier.  The other meanings do not, so use a temporary until we find
12776      * out which we are being called with */
12777     skip_to_be_ignored_text(pRExC_state, &p,
12778                             FALSE /* Don't force to /x */ );
12779
12780     /* Disambiguate between \N meaning a named character versus \N meaning
12781      * [^\n].  The latter is assumed when the {...} following the \N is a legal
12782      * quantifier, or if there is no '{' at all */
12783     if (*p != '{' || regcurly(p)) {
12784         RExC_parse = p;
12785         if (cp_count) {
12786             *cp_count = -1;
12787         }
12788
12789         if (! node_p) {
12790             return FALSE;
12791         }
12792
12793         *node_p = reg_node(pRExC_state, REG_ANY);
12794         *flagp |= HASWIDTH|SIMPLE;
12795         MARK_NAUGHTY(1);
12796         Set_Node_Length(REGNODE_p(*(node_p)), 1); /* MJD */
12797         return TRUE;
12798     }
12799
12800     /* The test above made sure that the next real character is a '{', but
12801      * under the /x modifier, it could be separated by space (or a comment and
12802      * \n) and this is not allowed (for consistency with \x{...} and the
12803      * tokenizer handling of \N{NAME}). */
12804     if (*RExC_parse != '{') {
12805         vFAIL("Missing braces on \\N{}");
12806     }
12807
12808     RExC_parse++;       /* Skip past the '{' */
12809
12810     endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
12811     if (! endbrace) { /* no trailing brace */
12812         vFAIL2("Missing right brace on \\%c{}", 'N');
12813     }
12814
12815     /* Here, we have decided it should be a named character or sequence.  These
12816      * imply Unicode semantics */
12817     REQUIRE_UNI_RULES(flagp, FALSE);
12818
12819     /* \N{_} is what toke.c returns to us to indicate a name that evaluates to
12820      * nothing at all (not allowed under strict) */
12821     if (endbrace - RExC_parse == 1 && *RExC_parse == '_') {
12822         RExC_parse = endbrace;
12823         if (strict) {
12824             RExC_parse++;   /* Position after the "}" */
12825             vFAIL("Zero length \\N{}");
12826         }
12827
12828         if (cp_count) {
12829             *cp_count = 0;
12830         }
12831         nextchar(pRExC_state);
12832         if (! node_p) {
12833             return FALSE;
12834         }
12835
12836         *node_p = reg_node(pRExC_state, NOTHING);
12837         return TRUE;
12838     }
12839
12840     if (endbrace - RExC_parse < 2 || ! strBEGINs(RExC_parse, "U+")) {
12841
12842         /* Here, the name isn't of the form  U+....  This can happen if the
12843          * pattern is single-quoted, so didn't get evaluated in toke.c.  Now
12844          * is the time to find out what the name means */
12845
12846         const STRLEN name_len = endbrace - RExC_parse;
12847         SV *  value_sv;     /* What does this name evaluate to */
12848         SV ** value_svp;
12849         const U8 * value;   /* string of name's value */
12850         STRLEN value_len;   /* and its length */
12851
12852         /*  RExC_unlexed_names is a hash of names that weren't evaluated by
12853          *  toke.c, and their values. Make sure is initialized */
12854         if (! RExC_unlexed_names) {
12855             RExC_unlexed_names = newHV();
12856         }
12857
12858         /* If we have already seen this name in this pattern, use that.  This
12859          * allows us to only call the charnames handler once per name per
12860          * pattern.  A broken or malicious handler could return something
12861          * different each time, which could cause the results to vary depending
12862          * on if something gets added or subtracted from the pattern that
12863          * causes the number of passes to change, for example */
12864         if ((value_svp = hv_fetch(RExC_unlexed_names, RExC_parse,
12865                                                       name_len, 0)))
12866         {
12867             value_sv = *value_svp;
12868         }
12869         else { /* Otherwise we have to go out and get the name */
12870             const char * error_msg = NULL;
12871             value_sv = get_and_check_backslash_N_name(RExC_parse, endbrace,
12872                                                       UTF,
12873                                                       &error_msg);
12874             if (error_msg) {
12875                 RExC_parse = endbrace;
12876                 vFAIL(error_msg);
12877             }
12878
12879             /* If no error message, should have gotten a valid return */
12880             assert (value_sv);
12881
12882             /* Save the name's meaning for later use */
12883             if (! hv_store(RExC_unlexed_names, RExC_parse, name_len,
12884                            value_sv, 0))
12885             {
12886                 Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
12887             }
12888         }
12889
12890         /* Here, we have the value the name evaluates to in 'value_sv' */
12891         value = (U8 *) SvPV(value_sv, value_len);
12892
12893         /* See if the result is one code point vs 0 or multiple */
12894         if (value_len > 0 && value_len <= (UV) ((SvUTF8(value_sv))
12895                                                ? UTF8SKIP(value)
12896                                                : 1))
12897         {
12898             /* Here, exactly one code point.  If that isn't what is wanted,
12899              * fail */
12900             if (! code_point_p) {
12901                 RExC_parse = p;
12902                 return FALSE;
12903             }
12904
12905             /* Convert from string to numeric code point */
12906             *code_point_p = (SvUTF8(value_sv))
12907                             ? valid_utf8_to_uvchr(value, NULL)
12908                             : *value;
12909
12910             /* Have parsed this entire single code point \N{...}.  *cp_count
12911              * has already been set to 1, so don't do it again. */
12912             RExC_parse = endbrace;
12913             nextchar(pRExC_state);
12914             return TRUE;
12915         } /* End of is a single code point */
12916
12917         /* Count the code points, if caller desires.  The API says to do this
12918          * even if we will later return FALSE */
12919         if (cp_count) {
12920             *cp_count = 0;
12921
12922             *cp_count = (SvUTF8(value_sv))
12923                         ? utf8_length(value, value + value_len)
12924                         : value_len;
12925         }
12926
12927         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12928          * But don't back the pointer up if the caller wants to know how many
12929          * code points there are (they need to handle it themselves in this
12930          * case).  */
12931         if (! node_p) {
12932             if (! cp_count) {
12933                 RExC_parse = p;
12934             }
12935             return FALSE;
12936         }
12937
12938         /* Convert this to a sub-pattern of the form "(?: ... )", and then call
12939          * reg recursively to parse it.  That way, it retains its atomicness,
12940          * while not having to worry about any special handling that some code
12941          * points may have. */
12942
12943         substitute_parse = newSVpvs("?:");
12944         sv_catsv(substitute_parse, value_sv);
12945         sv_catpv(substitute_parse, ")");
12946
12947 #ifdef EBCDIC
12948         /* The value should already be native, so no need to convert on EBCDIC
12949          * platforms.*/
12950         assert(! RExC_recode_x_to_native);
12951 #endif
12952
12953     }
12954     else {   /* \N{U+...} */
12955         Size_t count = 0;   /* code point count kept internally */
12956
12957         /* We can get to here when the input is \N{U+...} or when toke.c has
12958          * converted a name to the \N{U+...} form.  This include changing a
12959          * name that evaluates to multiple code points to \N{U+c1.c2.c3 ...} */
12960
12961         RExC_parse += 2;    /* Skip past the 'U+' */
12962
12963         /* Code points are separated by dots.  The '}' terminates the whole
12964          * thing. */
12965
12966         do {    /* Loop until the ending brace */
12967             UV cp = 0;
12968             char * start_digit;     /* The first of the current code point */
12969             if (! isXDIGIT(*RExC_parse)) {
12970                 RExC_parse++;
12971                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
12972             }
12973
12974             start_digit = RExC_parse;
12975             count++;
12976
12977             /* Loop through the hex digits of the current code point */
12978             do {
12979                 /* Adding this digit will shift the result 4 bits.  If that
12980                  * result would be above the legal max, it's overflow */
12981                 if (cp > MAX_LEGAL_CP >> 4) {
12982
12983                     /* Find the end of the code point */
12984                     do {
12985                         RExC_parse ++;
12986                     } while (isXDIGIT(*RExC_parse) || *RExC_parse == '_');
12987
12988                     /* Be sure to synchronize this message with the similar one
12989                      * in utf8.c */
12990                     vFAIL4("Use of code point 0x%.*s is not allowed; the"
12991                         " permissible max is 0x%" UVxf,
12992                         (int) (RExC_parse - start_digit), start_digit,
12993                         MAX_LEGAL_CP);
12994                 }
12995
12996                 /* Accumulate this (valid) digit into the running total */
12997                 cp  = (cp << 4) + READ_XDIGIT(RExC_parse);
12998
12999                 /* READ_XDIGIT advanced the input pointer.  Ignore a single
13000                  * underscore separator */
13001                 if (*RExC_parse == '_' && isXDIGIT(RExC_parse[1])) {
13002                     RExC_parse++;
13003                 }
13004             } while (isXDIGIT(*RExC_parse));
13005
13006             /* Here, have accumulated the next code point */
13007             if (RExC_parse >= endbrace) {   /* If done ... */
13008                 if (count != 1) {
13009                     goto do_concat;
13010                 }
13011
13012                 /* Here, is a single code point; fail if doesn't want that */
13013                 if (! code_point_p) {
13014                     RExC_parse = p;
13015                     return FALSE;
13016                 }
13017
13018                 /* A single code point is easy to handle; just return it */
13019                 *code_point_p = UNI_TO_NATIVE(cp);
13020                 RExC_parse = endbrace;
13021                 nextchar(pRExC_state);
13022                 return TRUE;
13023             }
13024
13025             /* Here, the only legal thing would be a multiple character
13026              * sequence (of the form "\N{U+c1.c2. ... }".   So the next
13027              * character must be a dot (and the one after that can't be the
13028              * endbrace, or we'd have something like \N{U+100.} ) */
13029             if (*RExC_parse != '.' || RExC_parse + 1 >= endbrace) {
13030                 RExC_parse += (RExC_orig_utf8)  /* point to after 1st invalid */
13031                                 ? UTF8SKIP(RExC_parse)
13032                                 : 1;
13033                 if (RExC_parse >= endbrace) { /* Guard against malformed utf8 */
13034                     RExC_parse = endbrace;
13035                 }
13036                 vFAIL("Invalid hexadecimal number in \\N{U+...}");
13037             }
13038
13039             /* Here, looks like its really a multiple character sequence.  Fail
13040              * if that's not what the caller wants.  But continue with counting
13041              * and error checking if they still want a count */
13042             if (! node_p && ! cp_count) {
13043                 return FALSE;
13044             }
13045
13046             /* What is done here is to convert this to a sub-pattern of the
13047              * form \x{char1}\x{char2}...  and then call reg recursively to
13048              * parse it (enclosing in "(?: ... )" ).  That way, it retains its
13049              * atomicness, while not having to worry about special handling
13050              * that some code points may have.  We don't create a subpattern,
13051              * but go through the motions of code point counting and error
13052              * checking, if the caller doesn't want a node returned. */
13053
13054             if (node_p && count == 1) {
13055                 substitute_parse = newSVpvs("?:");
13056             }
13057
13058           do_concat:
13059
13060             if (node_p) {
13061                 /* Convert to notation the rest of the code understands */
13062                 sv_catpvs(substitute_parse, "\\x{");
13063                 sv_catpvn(substitute_parse, start_digit,
13064                                             RExC_parse - start_digit);
13065                 sv_catpvs(substitute_parse, "}");
13066             }
13067
13068             /* Move to after the dot (or ending brace the final time through.)
13069              * */
13070             RExC_parse++;
13071             count++;
13072
13073         } while (RExC_parse < endbrace);
13074
13075         if (! node_p) { /* Doesn't want the node */
13076             assert (cp_count);
13077
13078             *cp_count = count;
13079             return FALSE;
13080         }
13081
13082         sv_catpvs(substitute_parse, ")");
13083
13084 #ifdef EBCDIC
13085         /* The values are Unicode, and therefore have to be converted to native
13086          * on a non-Unicode (meaning non-ASCII) platform. */
13087         RExC_recode_x_to_native = 1;
13088 #endif
13089
13090     }
13091
13092     /* Here, we have the string the name evaluates to, ready to be parsed,
13093      * stored in 'substitute_parse' as a series of valid "\x{...}\x{...}"
13094      * constructs.  This can be called from within a substitute parse already.
13095      * The error reporting mechanism doesn't work for 2 levels of this, but the
13096      * code above has validated this new construct, so there should be no
13097      * errors generated by the below.  And this isn' an exact copy, so the
13098      * mechanism to seamlessly deal with this won't work, so turn off warnings
13099      * during it */
13100     save_start = RExC_start;
13101     orig_end = RExC_end;
13102
13103     RExC_parse = RExC_start = SvPVX(substitute_parse);
13104     RExC_end = RExC_parse + SvCUR(substitute_parse);
13105     TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
13106
13107     *node_p = reg(pRExC_state, 1, &flags, depth+1);
13108
13109     /* Restore the saved values */
13110     RESTORE_WARNINGS;
13111     RExC_start = save_start;
13112     RExC_parse = endbrace;
13113     RExC_end = orig_end;
13114 #ifdef EBCDIC
13115     RExC_recode_x_to_native = 0;
13116 #endif
13117
13118     SvREFCNT_dec_NN(substitute_parse);
13119
13120     if (! *node_p) {
13121         RETURN_FAIL_ON_RESTART(flags, flagp);
13122         FAIL2("panic: reg returned failure to grok_bslash_N, flags=%#" UVxf,
13123             (UV) flags);
13124     }
13125     *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
13126
13127     nextchar(pRExC_state);
13128
13129     return TRUE;
13130 }
13131
13132
13133 PERL_STATIC_INLINE U8
13134 S_compute_EXACTish(RExC_state_t *pRExC_state)
13135 {
13136     U8 op;
13137
13138     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
13139
13140     if (! FOLD) {
13141         return (LOC)
13142                 ? EXACTL
13143                 : EXACT;
13144     }
13145
13146     op = get_regex_charset(RExC_flags);
13147     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
13148         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
13149                  been, so there is no hole */
13150     }
13151
13152     return op + EXACTF;
13153 }
13154
13155 STATIC bool
13156 S_new_regcurly(const char *s, const char *e)
13157 {
13158     /* This is a temporary function designed to match the most lenient form of
13159      * a {m,n} quantifier we ever envision, with either number omitted, and
13160      * spaces anywhere between/before/after them.
13161      *
13162      * If this function fails, then the string it matches is very unlikely to
13163      * ever be considered a valid quantifier, so we can allow the '{' that
13164      * begins it to be considered as a literal */
13165
13166     bool has_min = FALSE;
13167     bool has_max = FALSE;
13168
13169     PERL_ARGS_ASSERT_NEW_REGCURLY;
13170
13171     if (s >= e || *s++ != '{')
13172         return FALSE;
13173
13174     while (s < e && isSPACE(*s)) {
13175         s++;
13176     }
13177     while (s < e && isDIGIT(*s)) {
13178         has_min = TRUE;
13179         s++;
13180     }
13181     while (s < e && isSPACE(*s)) {
13182         s++;
13183     }
13184
13185     if (*s == ',') {
13186         s++;
13187         while (s < e && isSPACE(*s)) {
13188             s++;
13189         }
13190         while (s < e && isDIGIT(*s)) {
13191             has_max = TRUE;
13192             s++;
13193         }
13194         while (s < e && isSPACE(*s)) {
13195             s++;
13196         }
13197     }
13198
13199     return s < e && *s == '}' && (has_min || has_max);
13200 }
13201
13202 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
13203  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
13204
13205 static I32
13206 S_backref_value(char *p, char *e)
13207 {
13208     const char* endptr = e;
13209     UV val;
13210     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
13211         return (I32)val;
13212     return I32_MAX;
13213 }
13214
13215
13216 /*
13217  - regatom - the lowest level
13218
13219    Try to identify anything special at the start of the current parse position.
13220    If there is, then handle it as required. This may involve generating a
13221    single regop, such as for an assertion; or it may involve recursing, such as
13222    to handle a () structure.
13223
13224    If the string doesn't start with something special then we gobble up
13225    as much literal text as we can.  If we encounter a quantifier, we have to
13226    back off the final literal character, as that quantifier applies to just it
13227    and not to the whole string of literals.
13228
13229    Once we have been able to handle whatever type of thing started the
13230    sequence, we return the offset into the regex engine program being compiled
13231    at which any  next regnode should be placed.
13232
13233    Returns 0, setting *flagp to TRYAGAIN if reg() returns 0 with TRYAGAIN.
13234    Returns 0, setting *flagp to RESTART_PARSE if the parse needs to be
13235    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
13236    Otherwise does not return 0.
13237
13238    Note: we have to be careful with escapes, as they can be both literal
13239    and special, and in the case of \10 and friends, context determines which.
13240
13241    A summary of the code structure is:
13242
13243    switch (first_byte) {
13244         cases for each special:
13245             handle this special;
13246             break;
13247         case '\\':
13248             switch (2nd byte) {
13249                 cases for each unambiguous special:
13250                     handle this special;
13251                     break;
13252                 cases for each ambigous special/literal:
13253                     disambiguate;
13254                     if (special)  handle here
13255                     else goto defchar;
13256                 default: // unambiguously literal:
13257                     goto defchar;
13258             }
13259         default:  // is a literal char
13260             // FALL THROUGH
13261         defchar:
13262             create EXACTish node for literal;
13263             while (more input and node isn't full) {
13264                 switch (input_byte) {
13265                    cases for each special;
13266                        make sure parse pointer is set so that the next call to
13267                            regatom will see this special first
13268                        goto loopdone; // EXACTish node terminated by prev. char
13269                    default:
13270                        append char to EXACTISH node;
13271                 }
13272                 get next input byte;
13273             }
13274         loopdone:
13275    }
13276    return the generated node;
13277
13278    Specifically there are two separate switches for handling
13279    escape sequences, with the one for handling literal escapes requiring
13280    a dummy entry for all of the special escapes that are actually handled
13281    by the other.
13282
13283 */
13284
13285 STATIC regnode_offset
13286 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
13287 {
13288     dVAR;
13289     regnode_offset ret = 0;
13290     I32 flags = 0;
13291     char *parse_start;
13292     U8 op;
13293     int invert = 0;
13294     U8 arg;
13295
13296     GET_RE_DEBUG_FLAGS_DECL;
13297
13298     *flagp = WORST;             /* Tentatively. */
13299
13300     DEBUG_PARSE("atom");
13301
13302     PERL_ARGS_ASSERT_REGATOM;
13303
13304   tryagain:
13305     parse_start = RExC_parse;
13306     assert(RExC_parse < RExC_end);
13307     switch ((U8)*RExC_parse) {
13308     case '^':
13309         RExC_seen_zerolen++;
13310         nextchar(pRExC_state);
13311         if (RExC_flags & RXf_PMf_MULTILINE)
13312             ret = reg_node(pRExC_state, MBOL);
13313         else
13314             ret = reg_node(pRExC_state, SBOL);
13315         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13316         break;
13317     case '$':
13318         nextchar(pRExC_state);
13319         if (*RExC_parse)
13320             RExC_seen_zerolen++;
13321         if (RExC_flags & RXf_PMf_MULTILINE)
13322             ret = reg_node(pRExC_state, MEOL);
13323         else
13324             ret = reg_node(pRExC_state, SEOL);
13325         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13326         break;
13327     case '.':
13328         nextchar(pRExC_state);
13329         if (RExC_flags & RXf_PMf_SINGLELINE)
13330             ret = reg_node(pRExC_state, SANY);
13331         else
13332             ret = reg_node(pRExC_state, REG_ANY);
13333         *flagp |= HASWIDTH|SIMPLE;
13334         MARK_NAUGHTY(1);
13335         Set_Node_Length(REGNODE_p(ret), 1); /* MJD */
13336         break;
13337     case '[':
13338     {
13339         char * const oregcomp_parse = ++RExC_parse;
13340         ret = regclass(pRExC_state, flagp, depth+1,
13341                        FALSE, /* means parse the whole char class */
13342                        TRUE, /* allow multi-char folds */
13343                        FALSE, /* don't silence non-portable warnings. */
13344                        (bool) RExC_strict,
13345                        TRUE, /* Allow an optimized regnode result */
13346                        NULL);
13347         if (ret == 0) {
13348             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13349             FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13350                   (UV) *flagp);
13351         }
13352         if (*RExC_parse != ']') {
13353             RExC_parse = oregcomp_parse;
13354             vFAIL("Unmatched [");
13355         }
13356         nextchar(pRExC_state);
13357         Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */
13358         break;
13359     }
13360     case '(':
13361         nextchar(pRExC_state);
13362         ret = reg(pRExC_state, 2, &flags, depth+1);
13363         if (ret == 0) {
13364                 if (flags & TRYAGAIN) {
13365                     if (RExC_parse >= RExC_end) {
13366                          /* Make parent create an empty node if needed. */
13367                         *flagp |= TRYAGAIN;
13368                         return(0);
13369                     }
13370                     goto tryagain;
13371                 }
13372                 RETURN_FAIL_ON_RESTART(flags, flagp);
13373                 FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf,
13374                                                                  (UV) flags);
13375         }
13376         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
13377         break;
13378     case '|':
13379     case ')':
13380         if (flags & TRYAGAIN) {
13381             *flagp |= TRYAGAIN;
13382             return 0;
13383         }
13384         vFAIL("Internal urp");
13385                                 /* Supposed to be caught earlier. */
13386         break;
13387     case '?':
13388     case '+':
13389     case '*':
13390         RExC_parse++;
13391         vFAIL("Quantifier follows nothing");
13392         break;
13393     case '\\':
13394         /* Special Escapes
13395
13396            This switch handles escape sequences that resolve to some kind
13397            of special regop and not to literal text. Escape sequences that
13398            resolve to literal text are handled below in the switch marked
13399            "Literal Escapes".
13400
13401            Every entry in this switch *must* have a corresponding entry
13402            in the literal escape switch. However, the opposite is not
13403            required, as the default for this switch is to jump to the
13404            literal text handling code.
13405         */
13406         RExC_parse++;
13407         switch ((U8)*RExC_parse) {
13408         /* Special Escapes */
13409         case 'A':
13410             RExC_seen_zerolen++;
13411             ret = reg_node(pRExC_state, SBOL);
13412             /* SBOL is shared with /^/ so we set the flags so we can tell
13413              * /\A/ from /^/ in split. */
13414             FLAGS(REGNODE_p(ret)) = 1;
13415             *flagp |= SIMPLE;
13416             goto finish_meta_pat;
13417         case 'G':
13418             ret = reg_node(pRExC_state, GPOS);
13419             RExC_seen |= REG_GPOS_SEEN;
13420             *flagp |= SIMPLE;
13421             goto finish_meta_pat;
13422         case 'K':
13423             RExC_seen_zerolen++;
13424             ret = reg_node(pRExC_state, KEEPS);
13425             *flagp |= SIMPLE;
13426             /* XXX:dmq : disabling in-place substitution seems to
13427              * be necessary here to avoid cases of memory corruption, as
13428              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
13429              */
13430             RExC_seen |= REG_LOOKBEHIND_SEEN;
13431             goto finish_meta_pat;
13432         case 'Z':
13433             ret = reg_node(pRExC_state, SEOL);
13434             *flagp |= SIMPLE;
13435             RExC_seen_zerolen++;                /* Do not optimize RE away */
13436             goto finish_meta_pat;
13437         case 'z':
13438             ret = reg_node(pRExC_state, EOS);
13439             *flagp |= SIMPLE;
13440             RExC_seen_zerolen++;                /* Do not optimize RE away */
13441             goto finish_meta_pat;
13442         case 'C':
13443             vFAIL("\\C no longer supported");
13444         case 'X':
13445             ret = reg_node(pRExC_state, CLUMP);
13446             *flagp |= HASWIDTH;
13447             goto finish_meta_pat;
13448
13449         case 'W':
13450             invert = 1;
13451             /* FALLTHROUGH */
13452         case 'w':
13453             arg = ANYOF_WORDCHAR;
13454             goto join_posix;
13455
13456         case 'B':
13457             invert = 1;
13458             /* FALLTHROUGH */
13459         case 'b':
13460           {
13461             U8 flags = 0;
13462             regex_charset charset = get_regex_charset(RExC_flags);
13463
13464             RExC_seen_zerolen++;
13465             RExC_seen |= REG_LOOKBEHIND_SEEN;
13466             op = BOUND + charset;
13467
13468             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
13469                 flags = TRADITIONAL_BOUND;
13470                 if (op > BOUNDA) {  /* /aa is same as /a */
13471                     op = BOUNDA;
13472                 }
13473             }
13474             else {
13475                 STRLEN length;
13476                 char name = *RExC_parse;
13477                 char * endbrace = NULL;
13478                 RExC_parse += 2;
13479                 endbrace = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
13480
13481                 if (! endbrace) {
13482                     vFAIL2("Missing right brace on \\%c{}", name);
13483                 }
13484                 /* XXX Need to decide whether to take spaces or not.  Should be
13485                  * consistent with \p{}, but that currently is SPACE, which
13486                  * means vertical too, which seems wrong
13487                  * while (isBLANK(*RExC_parse)) {
13488                     RExC_parse++;
13489                 }*/
13490                 if (endbrace == RExC_parse) {
13491                     RExC_parse++;  /* After the '}' */
13492                     vFAIL2("Empty \\%c{}", name);
13493                 }
13494                 length = endbrace - RExC_parse;
13495                 /*while (isBLANK(*(RExC_parse + length - 1))) {
13496                     length--;
13497                 }*/
13498                 switch (*RExC_parse) {
13499                     case 'g':
13500                         if (    length != 1
13501                             && (memNEs(RExC_parse + 1, length - 1, "cb")))
13502                         {
13503                             goto bad_bound_type;
13504                         }
13505                         flags = GCB_BOUND;
13506                         break;
13507                     case 'l':
13508                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13509                             goto bad_bound_type;
13510                         }
13511                         flags = LB_BOUND;
13512                         break;
13513                     case 's':
13514                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13515                             goto bad_bound_type;
13516                         }
13517                         flags = SB_BOUND;
13518                         break;
13519                     case 'w':
13520                         if (length != 2 || *(RExC_parse + 1) != 'b') {
13521                             goto bad_bound_type;
13522                         }
13523                         flags = WB_BOUND;
13524                         break;
13525                     default:
13526                       bad_bound_type:
13527                         RExC_parse = endbrace;
13528                         vFAIL2utf8f(
13529                             "'%" UTF8f "' is an unknown bound type",
13530                             UTF8fARG(UTF, length, endbrace - length));
13531                         NOT_REACHED; /*NOTREACHED*/
13532                 }
13533                 RExC_parse = endbrace;
13534                 REQUIRE_UNI_RULES(flagp, 0);
13535
13536                 if (op == BOUND) {
13537                     op = BOUNDU;
13538                 }
13539                 else if (op >= BOUNDA) {  /* /aa is same as /a */
13540                     op = BOUNDU;
13541                     length += 4;
13542
13543                     /* Don't have to worry about UTF-8, in this message because
13544                      * to get here the contents of the \b must be ASCII */
13545                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
13546                               "Using /u for '%.*s' instead of /%s",
13547                               (unsigned) length,
13548                               endbrace - length + 1,
13549                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
13550                               ? ASCII_RESTRICT_PAT_MODS
13551                               : ASCII_MORE_RESTRICT_PAT_MODS);
13552                 }
13553             }
13554
13555             if (op == BOUND) {
13556                 RExC_seen_d_op = TRUE;
13557             }
13558             else if (op == BOUNDL) {
13559                 RExC_contains_locale = 1;
13560             }
13561
13562             if (invert) {
13563                 op += NBOUND - BOUND;
13564             }
13565
13566             ret = reg_node(pRExC_state, op);
13567             FLAGS(REGNODE_p(ret)) = flags;
13568
13569             *flagp |= SIMPLE;
13570
13571             goto finish_meta_pat;
13572           }
13573
13574         case 'D':
13575             invert = 1;
13576             /* FALLTHROUGH */
13577         case 'd':
13578             arg = ANYOF_DIGIT;
13579             if (! DEPENDS_SEMANTICS) {
13580                 goto join_posix;
13581             }
13582
13583             /* \d doesn't have any matches in the upper Latin1 range, hence /d
13584              * is equivalent to /u.  Changing to /u saves some branches at
13585              * runtime */
13586             op = POSIXU;
13587             goto join_posix_op_known;
13588
13589         case 'R':
13590             ret = reg_node(pRExC_state, LNBREAK);
13591             *flagp |= HASWIDTH|SIMPLE;
13592             goto finish_meta_pat;
13593
13594         case 'H':
13595             invert = 1;
13596             /* FALLTHROUGH */
13597         case 'h':
13598             arg = ANYOF_BLANK;
13599             op = POSIXU;
13600             goto join_posix_op_known;
13601
13602         case 'V':
13603             invert = 1;
13604             /* FALLTHROUGH */
13605         case 'v':
13606             arg = ANYOF_VERTWS;
13607             op = POSIXU;
13608             goto join_posix_op_known;
13609
13610         case 'S':
13611             invert = 1;
13612             /* FALLTHROUGH */
13613         case 's':
13614             arg = ANYOF_SPACE;
13615
13616           join_posix:
13617
13618             op = POSIXD + get_regex_charset(RExC_flags);
13619             if (op > POSIXA) {  /* /aa is same as /a */
13620                 op = POSIXA;
13621             }
13622             else if (op == POSIXL) {
13623                 RExC_contains_locale = 1;
13624             }
13625             else if (op == POSIXD) {
13626                 RExC_seen_d_op = TRUE;
13627             }
13628
13629           join_posix_op_known:
13630
13631             if (invert) {
13632                 op += NPOSIXD - POSIXD;
13633             }
13634
13635             ret = reg_node(pRExC_state, op);
13636             FLAGS(REGNODE_p(ret)) = namedclass_to_classnum(arg);
13637
13638             *flagp |= HASWIDTH|SIMPLE;
13639             /* FALLTHROUGH */
13640
13641           finish_meta_pat:
13642             if (   UCHARAT(RExC_parse + 1) == '{'
13643                 && UNLIKELY(! new_regcurly(RExC_parse + 1, RExC_end)))
13644             {
13645                 RExC_parse += 2;
13646                 vFAIL("Unescaped left brace in regex is illegal here");
13647             }
13648             nextchar(pRExC_state);
13649             Set_Node_Length(REGNODE_p(ret), 2); /* MJD */
13650             break;
13651         case 'p':
13652         case 'P':
13653             RExC_parse--;
13654
13655             ret = regclass(pRExC_state, flagp, depth+1,
13656                            TRUE, /* means just parse this element */
13657                            FALSE, /* don't allow multi-char folds */
13658                            FALSE, /* don't silence non-portable warnings.  It
13659                                      would be a bug if these returned
13660                                      non-portables */
13661                            (bool) RExC_strict,
13662                            TRUE, /* Allow an optimized regnode result */
13663                            NULL);
13664             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13665             /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
13666              * multi-char folds are allowed.  */
13667             if (!ret)
13668                 FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf,
13669                       (UV) *flagp);
13670
13671             RExC_parse--;
13672
13673             Set_Node_Offset(REGNODE_p(ret), parse_start);
13674             Set_Node_Cur_Length(REGNODE_p(ret), parse_start - 2);
13675             nextchar(pRExC_state);
13676             break;
13677         case 'N':
13678             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
13679              * \N{...} evaluates to a sequence of more than one code points).
13680              * The function call below returns a regnode, which is our result.
13681              * The parameters cause it to fail if the \N{} evaluates to a
13682              * single code point; we handle those like any other literal.  The
13683              * reason that the multicharacter case is handled here and not as
13684              * part of the EXACtish code is because of quantifiers.  In
13685              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
13686              * this way makes that Just Happen. dmq.
13687              * join_exact() will join this up with adjacent EXACTish nodes
13688              * later on, if appropriate. */
13689             ++RExC_parse;
13690             if (grok_bslash_N(pRExC_state,
13691                               &ret,     /* Want a regnode returned */
13692                               NULL,     /* Fail if evaluates to a single code
13693                                            point */
13694                               NULL,     /* Don't need a count of how many code
13695                                            points */
13696                               flagp,
13697                               RExC_strict,
13698                               depth)
13699             ) {
13700                 break;
13701             }
13702
13703             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
13704
13705             /* Here, evaluates to a single code point.  Go get that */
13706             RExC_parse = parse_start;
13707             goto defchar;
13708
13709         case 'k':    /* Handle \k<NAME> and \k'NAME' */
13710       parse_named_seq:
13711         {
13712             char ch;
13713             if (   RExC_parse >= RExC_end - 1
13714                 || ((   ch = RExC_parse[1]) != '<'
13715                                       && ch != '\''
13716                                       && ch != '{'))
13717             {
13718                 RExC_parse++;
13719                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
13720                 vFAIL2("Sequence %.2s... not terminated", parse_start);
13721             } else {
13722                 RExC_parse += 2;
13723                 ret = handle_named_backref(pRExC_state,
13724                                            flagp,
13725                                            parse_start,
13726                                            (ch == '<')
13727                                            ? '>'
13728                                            : (ch == '{')
13729                                              ? '}'
13730                                              : '\'');
13731             }
13732             break;
13733         }
13734         case 'g':
13735         case '1': case '2': case '3': case '4':
13736         case '5': case '6': case '7': case '8': case '9':
13737             {
13738                 I32 num;
13739                 bool hasbrace = 0;
13740
13741                 if (*RExC_parse == 'g') {
13742                     bool isrel = 0;
13743
13744                     RExC_parse++;
13745                     if (*RExC_parse == '{') {
13746                         RExC_parse++;
13747                         hasbrace = 1;
13748                     }
13749                     if (*RExC_parse == '-') {
13750                         RExC_parse++;
13751                         isrel = 1;
13752                     }
13753                     if (hasbrace && !isDIGIT(*RExC_parse)) {
13754                         if (isrel) RExC_parse--;
13755                         RExC_parse -= 2;
13756                         goto parse_named_seq;
13757                     }
13758
13759                     if (RExC_parse >= RExC_end) {
13760                         goto unterminated_g;
13761                     }
13762                     num = S_backref_value(RExC_parse, RExC_end);
13763                     if (num == 0)
13764                         vFAIL("Reference to invalid group 0");
13765                     else if (num == I32_MAX) {
13766                          if (isDIGIT(*RExC_parse))
13767                             vFAIL("Reference to nonexistent group");
13768                         else
13769                           unterminated_g:
13770                             vFAIL("Unterminated \\g... pattern");
13771                     }
13772
13773                     if (isrel) {
13774                         num = RExC_npar - num;
13775                         if (num < 1)
13776                             vFAIL("Reference to nonexistent or unclosed group");
13777                     }
13778                 }
13779                 else {
13780                     num = S_backref_value(RExC_parse, RExC_end);
13781                     /* bare \NNN might be backref or octal - if it is larger
13782                      * than or equal RExC_npar then it is assumed to be an
13783                      * octal escape. Note RExC_npar is +1 from the actual
13784                      * number of parens. */
13785                     /* Note we do NOT check if num == I32_MAX here, as that is
13786                      * handled by the RExC_npar check */
13787
13788                     if (
13789                         /* any numeric escape < 10 is always a backref */
13790                         num > 9
13791                         /* any numeric escape < RExC_npar is a backref */
13792                         && num >= RExC_npar
13793                         /* cannot be an octal escape if it starts with 8 */
13794                         && *RExC_parse != '8'
13795                         /* cannot be an octal escape it it starts with 9 */
13796                         && *RExC_parse != '9'
13797                     ) {
13798                         /* Probably not meant to be a backref, instead likely
13799                          * to be an octal character escape, e.g. \35 or \777.
13800                          * The above logic should make it obvious why using
13801                          * octal escapes in patterns is problematic. - Yves */
13802                         RExC_parse = parse_start;
13803                         goto defchar;
13804                     }
13805                 }
13806
13807                 /* At this point RExC_parse points at a numeric escape like
13808                  * \12 or \88 or something similar, which we should NOT treat
13809                  * as an octal escape. It may or may not be a valid backref
13810                  * escape. For instance \88888888 is unlikely to be a valid
13811                  * backref. */
13812                 while (isDIGIT(*RExC_parse))
13813                     RExC_parse++;
13814                 if (hasbrace) {
13815                     if (*RExC_parse != '}')
13816                         vFAIL("Unterminated \\g{...} pattern");
13817                     RExC_parse++;
13818                 }
13819                 if (num >= (I32)RExC_npar) {
13820
13821                     /* It might be a forward reference; we can't fail until we
13822                      * know, by completing the parse to get all the groups, and
13823                      * then reparsing */
13824                     if (ALL_PARENS_COUNTED)  {
13825                         if (num >= RExC_total_parens)  {
13826                             vFAIL("Reference to nonexistent group");
13827                         }
13828                     }
13829                     else {
13830                         REQUIRE_PARENS_PASS;
13831                     }
13832                 }
13833                 RExC_sawback = 1;
13834                 ret = reganode(pRExC_state,
13835                                ((! FOLD)
13836                                  ? REF
13837                                  : (ASCII_FOLD_RESTRICTED)
13838                                    ? REFFA
13839                                    : (AT_LEAST_UNI_SEMANTICS)
13840                                      ? REFFU
13841                                      : (LOC)
13842                                        ? REFFL
13843                                        : REFF),
13844                                 num);
13845                 if (OP(REGNODE_p(ret)) == REFF) {
13846                     RExC_seen_d_op = TRUE;
13847                 }
13848                 *flagp |= HASWIDTH;
13849
13850                 /* override incorrect value set in reganode MJD */
13851                 Set_Node_Offset(REGNODE_p(ret), parse_start);
13852                 Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1);
13853                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13854                                         FALSE /* Don't force to /x */ );
13855             }
13856             break;
13857         case '\0':
13858             if (RExC_parse >= RExC_end)
13859                 FAIL("Trailing \\");
13860             /* FALLTHROUGH */
13861         default:
13862             /* Do not generate "unrecognized" warnings here, we fall
13863                back into the quick-grab loop below */
13864             RExC_parse = parse_start;
13865             goto defchar;
13866         } /* end of switch on a \foo sequence */
13867         break;
13868
13869     case '#':
13870
13871         /* '#' comments should have been spaced over before this function was
13872          * called */
13873         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13874         /*
13875         if (RExC_flags & RXf_PMf_EXTENDED) {
13876             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13877             if (RExC_parse < RExC_end)
13878                 goto tryagain;
13879         }
13880         */
13881
13882         /* FALLTHROUGH */
13883
13884     default:
13885           defchar: {
13886
13887             /* Here, we have determined that the next thing is probably a
13888              * literal character.  RExC_parse points to the first byte of its
13889              * definition.  (It still may be an escape sequence that evaluates
13890              * to a single character) */
13891
13892             STRLEN len = 0;
13893             UV ender = 0;
13894             char *p;
13895             char *s;
13896
13897 /* This allows us to fill a node with just enough spare so that if the final
13898  * character folds, its expansion is guaranteed to fit */
13899 #define MAX_NODE_STRING_SIZE (255-UTF8_MAXBYTES_CASE)
13900
13901             char *s0;
13902             U8 upper_parse = MAX_NODE_STRING_SIZE;
13903
13904             /* We start out as an EXACT node, even if under /i, until we find a
13905              * character which is in a fold.  The algorithm now segregates into
13906              * separate nodes, characters that fold from those that don't under
13907              * /i.  (This hopefully will create nodes that are fixed strings
13908              * even under /i, giving the optimizer something to grab on to.)
13909              * So, if a node has something in it and the next character is in
13910              * the opposite category, that node is closed up, and the function
13911              * returns.  Then regatom is called again, and a new node is
13912              * created for the new category. */
13913             U8 node_type = EXACT;
13914
13915             /* Assume the node will be fully used; the excess is given back at
13916              * the end.  We can't make any other length assumptions, as a byte
13917              * input sequence could shrink down. */
13918             Ptrdiff_t initial_size = STR_SZ(256);
13919
13920             bool next_is_quantifier;
13921             char * oldp = NULL;
13922
13923             /* We can convert EXACTF nodes to EXACTFU if they contain only
13924              * characters that match identically regardless of the target
13925              * string's UTF8ness.  The reason to do this is that EXACTF is not
13926              * trie-able, EXACTFU is, and EXACTFU requires fewer operations at
13927              * runtime.
13928              *
13929              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13930              * contain only above-Latin1 characters (hence must be in UTF8),
13931              * which don't participate in folds with Latin1-range characters,
13932              * as the latter's folds aren't known until runtime. */
13933             bool maybe_exactfu = FOLD && (DEPENDS_SEMANTICS || LOC);
13934
13935             /* Single-character EXACTish nodes are almost always SIMPLE.  This
13936              * allows us to override this as encountered */
13937             U8 maybe_SIMPLE = SIMPLE;
13938
13939             /* Does this node contain something that can't match unless the
13940              * target string is (also) in UTF-8 */
13941             bool requires_utf8_target = FALSE;
13942
13943             /* The sequence 'ss' is problematic in non-UTF-8 patterns. */
13944             bool has_ss = FALSE;
13945
13946             /* So is the MICRO SIGN */
13947             bool has_micro_sign = FALSE;
13948
13949             /* Allocate an EXACT node.  The node_type may change below to
13950              * another EXACTish node, but since the size of the node doesn't
13951              * change, it works */
13952             ret = regnode_guts(pRExC_state, node_type, initial_size, "exact");
13953             FILL_NODE(ret, node_type);
13954             RExC_emit++;
13955
13956             s = STRING(REGNODE_p(ret));
13957
13958             s0 = s;
13959
13960           reparse:
13961
13962             /* This breaks under rare circumstances.  If folding, we do not
13963              * want to split a node at a character that is a non-final in a
13964              * multi-char fold, as an input string could just happen to want to
13965              * match across the node boundary.  The code at the end of the loop
13966              * looks for this, and backs off until it finds not such a
13967              * character, but it is possible (though extremely, extremely
13968              * unlikely) for all characters in the node to be non-final fold
13969              * ones, in which case we just leave the node fully filled, and
13970              * hope that it doesn't match the string in just the wrong place */
13971
13972             assert( ! UTF     /* Is at the beginning of a character */
13973                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13974                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13975
13976             /* Here, we have a literal character.  Find the maximal string of
13977              * them in the input that we can fit into a single EXACTish node.
13978              * We quit at the first non-literal or when the node gets full, or
13979              * under /i the categorization of folding/non-folding character
13980              * changes */
13981             for (p = RExC_parse; len < upper_parse && p < RExC_end; ) {
13982
13983                 /* In most cases each iteration adds one byte to the output.
13984                  * The exceptions override this */
13985                 Size_t added_len = 1;
13986
13987                 oldp = p;
13988
13989                 /* White space has already been ignored */
13990                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13991                        || ! is_PATWS_safe((p), RExC_end, UTF));
13992
13993                 switch ((U8)*p) {
13994                 case '^':
13995                 case '$':
13996                 case '.':
13997                 case '[':
13998                 case '(':
13999                 case ')':
14000                 case '|':
14001                     goto loopdone;
14002                 case '\\':
14003                     /* Literal Escapes Switch
14004
14005                        This switch is meant to handle escape sequences that
14006                        resolve to a literal character.
14007
14008                        Every escape sequence that represents something
14009                        else, like an assertion or a char class, is handled
14010                        in the switch marked 'Special Escapes' above in this
14011                        routine, but also has an entry here as anything that
14012                        isn't explicitly mentioned here will be treated as
14013                        an unescaped equivalent literal.
14014                     */
14015
14016                     switch ((U8)*++p) {
14017
14018                     /* These are all the special escapes. */
14019                     case 'A':             /* Start assertion */
14020                     case 'b': case 'B':   /* Word-boundary assertion*/
14021                     case 'C':             /* Single char !DANGEROUS! */
14022                     case 'd': case 'D':   /* digit class */
14023                     case 'g': case 'G':   /* generic-backref, pos assertion */
14024                     case 'h': case 'H':   /* HORIZWS */
14025                     case 'k': case 'K':   /* named backref, keep marker */
14026                     case 'p': case 'P':   /* Unicode property */
14027                               case 'R':   /* LNBREAK */
14028                     case 's': case 'S':   /* space class */
14029                     case 'v': case 'V':   /* VERTWS */
14030                     case 'w': case 'W':   /* word class */
14031                     case 'X':             /* eXtended Unicode "combining
14032                                              character sequence" */
14033                     case 'z': case 'Z':   /* End of line/string assertion */
14034                         --p;
14035                         goto loopdone;
14036
14037                     /* Anything after here is an escape that resolves to a
14038                        literal. (Except digits, which may or may not)
14039                      */
14040                     case 'n':
14041                         ender = '\n';
14042                         p++;
14043                         break;
14044                     case 'N': /* Handle a single-code point named character. */
14045                         RExC_parse = p + 1;
14046                         if (! grok_bslash_N(pRExC_state,
14047                                             NULL,   /* Fail if evaluates to
14048                                                        anything other than a
14049                                                        single code point */
14050                                             &ender, /* The returned single code
14051                                                        point */
14052                                             NULL,   /* Don't need a count of
14053                                                        how many code points */
14054                                             flagp,
14055                                             RExC_strict,
14056                                             depth)
14057                         ) {
14058                             if (*flagp & NEED_UTF8)
14059                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
14060                             RETURN_FAIL_ON_RESTART_FLAGP(flagp);
14061
14062                             /* Here, it wasn't a single code point.  Go close
14063                              * up this EXACTish node.  The switch() prior to
14064                              * this switch handles the other cases */
14065                             RExC_parse = p = oldp;
14066                             goto loopdone;
14067                         }
14068                         p = RExC_parse;
14069                         RExC_parse = parse_start;
14070
14071                         /* The \N{} means the pattern, if previously /d,
14072                          * becomes /u.  That means it can't be an EXACTF node,
14073                          * but an EXACTFU */
14074                         if (node_type == EXACTF) {
14075                             node_type = EXACTFU;
14076
14077                             /* If the node already contains something that
14078                              * differs between EXACTF and EXACTFU, reparse it
14079                              * as EXACTFU */
14080                             if (! maybe_exactfu) {
14081                                 len = 0;
14082                                 s = s0;
14083                                 goto reparse;
14084                             }
14085                         }
14086
14087                         break;
14088                     case 'r':
14089                         ender = '\r';
14090                         p++;
14091                         break;
14092                     case 't':
14093                         ender = '\t';
14094                         p++;
14095                         break;
14096                     case 'f':
14097                         ender = '\f';
14098                         p++;
14099                         break;
14100                     case 'e':
14101                         ender = ESC_NATIVE;
14102                         p++;
14103                         break;
14104                     case 'a':
14105                         ender = '\a';
14106                         p++;
14107                         break;
14108                     case 'o':
14109                         {
14110                             UV result;
14111                             const char* error_msg;
14112
14113                             bool valid = grok_bslash_o(&p,
14114                                                        RExC_end,
14115                                                        &result,
14116                                                        &error_msg,
14117                                                        TO_OUTPUT_WARNINGS(p),
14118                                                        (bool) RExC_strict,
14119                                                        TRUE, /* Output warnings
14120                                                                 for non-
14121                                                                 portables */
14122                                                        UTF);
14123                             if (! valid) {
14124                                 RExC_parse = p; /* going to die anyway; point
14125                                                    to exact spot of failure */
14126                                 vFAIL(error_msg);
14127                             }
14128                             UPDATE_WARNINGS_LOC(p - 1);
14129                             ender = result;
14130                             break;
14131                         }
14132                     case 'x':
14133                         {
14134                             UV result = UV_MAX; /* initialize to erroneous
14135                                                    value */
14136                             const char* error_msg;
14137
14138                             bool valid = grok_bslash_x(&p,
14139                                                        RExC_end,
14140                                                        &result,
14141                                                        &error_msg,
14142                                                        TO_OUTPUT_WARNINGS(p),
14143                                                        (bool) RExC_strict,
14144                                                        TRUE, /* Silence warnings
14145                                                                 for non-
14146                                                                 portables */
14147                                                        UTF);
14148                             if (! valid) {
14149                                 RExC_parse = p; /* going to die anyway; point
14150                                                    to exact spot of failure */
14151                                 vFAIL(error_msg);
14152                             }
14153                             UPDATE_WARNINGS_LOC(p - 1);
14154                             ender = result;
14155
14156                             if (ender < 0x100) {
14157 #ifdef EBCDIC
14158                                 if (RExC_recode_x_to_native) {
14159                                     ender = LATIN1_TO_NATIVE(ender);
14160                                 }
14161 #endif
14162                             }
14163                             break;
14164                         }
14165                     case 'c':
14166                         p++;
14167                         ender = grok_bslash_c(*p, TO_OUTPUT_WARNINGS(p));
14168                         UPDATE_WARNINGS_LOC(p);
14169                         p++;
14170                         break;
14171                     case '8': case '9': /* must be a backreference */
14172                         --p;
14173                         /* we have an escape like \8 which cannot be an octal escape
14174                          * so we exit the loop, and let the outer loop handle this
14175                          * escape which may or may not be a legitimate backref. */
14176                         goto loopdone;
14177                     case '1': case '2': case '3':case '4':
14178                     case '5': case '6': case '7':
14179                         /* When we parse backslash escapes there is ambiguity
14180                          * between backreferences and octal escapes. Any escape
14181                          * from \1 - \9 is a backreference, any multi-digit
14182                          * escape which does not start with 0 and which when
14183                          * evaluated as decimal could refer to an already
14184                          * parsed capture buffer is a back reference. Anything
14185                          * else is octal.
14186                          *
14187                          * Note this implies that \118 could be interpreted as
14188                          * 118 OR as "\11" . "8" depending on whether there
14189                          * were 118 capture buffers defined already in the
14190                          * pattern.  */
14191
14192                         /* NOTE, RExC_npar is 1 more than the actual number of
14193                          * parens we have seen so far, hence the "<" as opposed
14194                          * to "<=" */
14195                         if ( !isDIGIT(p[1]) || S_backref_value(p, RExC_end) < RExC_npar)
14196                         {  /* Not to be treated as an octal constant, go
14197                                    find backref */
14198                             --p;
14199                             goto loopdone;
14200                         }
14201                         /* FALLTHROUGH */
14202                     case '0':
14203                         {
14204                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
14205                             STRLEN numlen = 3;
14206                             ender = grok_oct(p, &numlen, &flags, NULL);
14207                             p += numlen;
14208                             if (   isDIGIT(*p)  /* like \08, \178 */
14209                                 && ckWARN(WARN_REGEXP)
14210                                 && numlen < 3)
14211                             {
14212                                 reg_warn_non_literal_string(
14213                                          p + 1,
14214                                          form_short_octal_warning(p, numlen));
14215                             }
14216                         }
14217                         break;
14218                     case '\0':
14219                         if (p >= RExC_end)
14220                             FAIL("Trailing \\");
14221                         /* FALLTHROUGH */
14222                     default:
14223                         if (isALPHANUMERIC(*p)) {
14224                             /* An alpha followed by '{' is going to fail next
14225                              * iteration, so don't output this warning in that
14226                              * case */
14227                             if (! isALPHA(*p) || *(p + 1) != '{') {
14228                                 ckWARN2reg(p + 1, "Unrecognized escape \\%.1s"
14229                                                   " passed through", p);
14230                             }
14231                         }
14232                         goto normal_default;
14233                     } /* End of switch on '\' */
14234                     break;
14235                 case '{':
14236                     /* Trying to gain new uses for '{' without breaking too
14237                      * much existing code is hard.  The solution currently
14238                      * adopted is:
14239                      *  1)  If there is no ambiguity that a '{' should always
14240                      *      be taken literally, at the start of a construct, we
14241                      *      just do so.
14242                      *  2)  If the literal '{' conflicts with our desired use
14243                      *      of it as a metacharacter, we die.  The deprecation
14244                      *      cycles for this have come and gone.
14245                      *  3)  If there is ambiguity, we raise a simple warning.
14246                      *      This could happen, for example, if the user
14247                      *      intended it to introduce a quantifier, but slightly
14248                      *      misspelled the quantifier.  Without this warning,
14249                      *      the quantifier would silently be taken as a literal
14250                      *      string of characters instead of a meta construct */
14251                     if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) {
14252                         if (      RExC_strict
14253                             || (  p > parse_start + 1
14254                                 && isALPHA_A(*(p - 1))
14255                                 && *(p - 2) == '\\')
14256                             || new_regcurly(p, RExC_end))
14257                         {
14258                             RExC_parse = p + 1;
14259                             vFAIL("Unescaped left brace in regex is "
14260                                   "illegal here");
14261                         }
14262                         ckWARNreg(p + 1, "Unescaped left brace in regex is"
14263                                          " passed through");
14264                     }
14265                     goto normal_default;
14266                 case '}':
14267                 case ']':
14268                     if (p > RExC_parse && RExC_strict) {
14269                         ckWARN2reg(p + 1, "Unescaped literal '%c'", *p);
14270                     }
14271                     /*FALLTHROUGH*/
14272                 default:    /* A literal character */
14273                   normal_default:
14274                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
14275                         STRLEN numlen;
14276                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
14277                                                &numlen, UTF8_ALLOW_DEFAULT);
14278                         p += numlen;
14279                     }
14280                     else
14281                         ender = (U8) *p++;
14282                     break;
14283                 } /* End of switch on the literal */
14284
14285                 /* Here, have looked at the literal character, and <ender>
14286                  * contains its ordinal; <p> points to the character after it.
14287                  * */
14288
14289                 if (ender > 255) {
14290                     REQUIRE_UTF8(flagp);
14291                 }
14292
14293                 /* We need to check if the next non-ignored thing is a
14294                  * quantifier.  Move <p> to after anything that should be
14295                  * ignored, which, as a side effect, positions <p> for the next
14296                  * loop iteration */
14297                 skip_to_be_ignored_text(pRExC_state, &p,
14298                                         FALSE /* Don't force to /x */ );
14299
14300                 /* If the next thing is a quantifier, it applies to this
14301                  * character only, which means that this character has to be in
14302                  * its own node and can't just be appended to the string in an
14303                  * existing node, so if there are already other characters in
14304                  * the node, close the node with just them, and set up to do
14305                  * this character again next time through, when it will be the
14306                  * only thing in its new node */
14307
14308                 next_is_quantifier =    LIKELY(p < RExC_end)
14309                                      && UNLIKELY(ISMULT2(p));
14310
14311                 if (next_is_quantifier && LIKELY(len)) {
14312                     p = oldp;
14313                     goto loopdone;
14314                 }
14315
14316                 /* Ready to add 'ender' to the node */
14317
14318                 if (! FOLD) {  /* The simple case, just append the literal */
14319
14320                       not_fold_common:
14321                         if (UVCHR_IS_INVARIANT(ender) || ! UTF) {
14322                             *(s++) = (char) ender;
14323                         }
14324                         else {
14325                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
14326                             added_len = (char *) new_s - s;
14327                             s = (char *) new_s;
14328
14329                             if (ender > 255)  {
14330                                 requires_utf8_target = TRUE;
14331                             }
14332                         }
14333                 }
14334                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
14335
14336                     /* Here are folding under /l, and the code point is
14337                      * problematic.  If this is the first character in the
14338                      * node, change the node type to folding.   Otherwise, if
14339                      * this is the first problematic character, close up the
14340                      * existing node, so can start a new node with this one */
14341                     if (! len) {
14342                         node_type = EXACTFL;
14343                         RExC_contains_locale = 1;
14344                     }
14345                     else if (node_type == EXACT) {
14346                         p = oldp;
14347                         goto loopdone;
14348                     }
14349
14350                     /* This problematic code point means we can't simplify
14351                      * things */
14352                     maybe_exactfu = FALSE;
14353
14354                     /* Here, we are adding a problematic fold character.
14355                      * "Problematic" in this context means that its fold isn't
14356                      * known until runtime.  (The non-problematic code points
14357                      * are the above-Latin1 ones that fold to also all
14358                      * above-Latin1.  Their folds don't vary no matter what the
14359                      * locale is.) But here we have characters whose fold
14360                      * depends on the locale.  We just add in the unfolded
14361                      * character, and wait until runtime to fold it */
14362                     goto not_fold_common;
14363                 }
14364                 else /* regular fold; see if actually is in a fold */
14365                      if (   (ender < 256 && ! IS_IN_SOME_FOLD_L1(ender))
14366                          || (ender > 255
14367                             && ! _invlist_contains_cp(PL_in_some_fold, ender)))
14368                 {
14369                     /* Here, folding, but the character isn't in a fold.
14370                      *
14371                      * Start a new node if previous characters in the node were
14372                      * folded */
14373                     if (len && node_type != EXACT) {
14374                         p = oldp;
14375                         goto loopdone;
14376                     }
14377
14378                     /* Here, continuing a node with non-folded characters.  Add
14379                      * this one */
14380                     goto not_fold_common;
14381                 }
14382                 else {  /* Here, does participate in some fold */
14383
14384                     /* If this is the first character in the node, change its
14385                      * type to folding.  Otherwise, if this is the first
14386                      * folding character in the node, close up the existing
14387                      * node, so can start a new node with this one.  */
14388                     if (! len) {
14389                         node_type = compute_EXACTish(pRExC_state);
14390                     }
14391                     else if (node_type == EXACT) {
14392                         p = oldp;
14393                         goto loopdone;
14394                     }
14395
14396                     if (UTF) {  /* Use the folded value */
14397                         if (UVCHR_IS_INVARIANT(ender)) {
14398                             *(s)++ = (U8) toFOLD(ender);
14399                         }
14400                         else {
14401                             ender = _to_uni_fold_flags(
14402                                     ender,
14403                                     (U8 *) s,
14404                                     &added_len,
14405                                     FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
14406                                                     ? FOLD_FLAGS_NOMIX_ASCII
14407                                                     : 0));
14408                             s += added_len;
14409
14410                             if (   ender > 255
14411                                 && LIKELY(ender != GREEK_SMALL_LETTER_MU))
14412                             {
14413                                 /* U+B5 folds to the MU, so its possible for a
14414                                  * non-UTF-8 target to match it */
14415                                 requires_utf8_target = TRUE;
14416                             }
14417                         }
14418                     }
14419                     else {
14420
14421                         /* Here is non-UTF8.  First, see if the character's
14422                          * fold differs between /d and /u. */
14423                         if (PL_fold[ender] != PL_fold_latin1[ender]) {
14424                             maybe_exactfu = FALSE;
14425                         }
14426
14427 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
14428    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
14429                                       || UNICODE_DOT_DOT_VERSION > 0)
14430
14431                         /* On non-ancient Unicode versions, this includes the
14432                          * multi-char fold SHARP S to 'ss' */
14433
14434                         if (   UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)
14435                                  || (   isALPHA_FOLD_EQ(ender, 's')
14436                                      && len > 0
14437                                      && isALPHA_FOLD_EQ(*(s-1), 's')))
14438                         {
14439                             /* Here, we have one of the following:
14440                              *  a)  a SHARP S.  This folds to 'ss' only under
14441                              *      /u rules.  If we are in that situation,
14442                              *      fold the SHARP S to 'ss'.  See the comments
14443                              *      for join_exact() as to why we fold this
14444                              *      non-UTF at compile time, and no others.
14445                              *  b)  'ss'.  When under /u, there's nothing
14446                              *      special needed to be done here.  The
14447                              *      previous iteration handled the first 's',
14448                              *      and this iteration will handle the second.
14449                              *      If, on the otherhand it's not /u, we have
14450                              *      to exclude the possibility of moving to /u,
14451                              *      so that we won't generate an unwanted
14452                              *      match, unless, at runtime, the target
14453                              *      string is in UTF-8.
14454                              * */
14455
14456                             has_ss = TRUE;
14457                             maybe_exactfu = FALSE;  /* Can't generate an
14458                                                        EXACTFU node (unless we
14459                                                        already are in one) */
14460                             if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
14461                                 maybe_SIMPLE = 0;
14462                                 if (node_type == EXACTFU) {
14463                                     *(s++) = 's';
14464
14465                                     /* Let the code below add in the extra 's' */
14466                                     ender = 's';
14467                                     added_len = 2;
14468                                 }
14469                             }
14470                         }
14471 #endif
14472
14473                         else if (UNLIKELY(ender == MICRO_SIGN)) {
14474                             has_micro_sign = TRUE;
14475                         }
14476
14477                         *(s++) = (DEPENDS_SEMANTICS)
14478                                  ? (char) toFOLD(ender)
14479
14480                                    /* Under /u, the fold of any character in
14481                                     * the 0-255 range happens to be its
14482                                     * lowercase equivalent, except for LATIN
14483                                     * SMALL LETTER SHARP S, which was handled
14484                                     * above, and the MICRO SIGN, whose fold
14485                                     * requires UTF-8 to represent.  */
14486                                  : (char) toLOWER_L1(ender);
14487                     }
14488                 } /* End of adding current character to the node */
14489
14490                 len += added_len;
14491
14492                 if (next_is_quantifier) {
14493
14494                     /* Here, the next input is a quantifier, and to get here,
14495                      * the current character is the only one in the node. */
14496                     goto loopdone;
14497                 }
14498
14499             } /* End of loop through literal characters */
14500
14501             /* Here we have either exhausted the input or ran out of room in
14502              * the node.  (If we encountered a character that can't be in the
14503              * node, transfer is made directly to <loopdone>, and so we
14504              * wouldn't have fallen off the end of the loop.)  In the latter
14505              * case, we artificially have to split the node into two, because
14506              * we just don't have enough space to hold everything.  This
14507              * creates a problem if the final character participates in a
14508              * multi-character fold in the non-final position, as a match that
14509              * should have occurred won't, due to the way nodes are matched,
14510              * and our artificial boundary.  So back off until we find a non-
14511              * problematic character -- one that isn't at the beginning or
14512              * middle of such a fold.  (Either it doesn't participate in any
14513              * folds, or appears only in the final position of all the folds it
14514              * does participate in.)  A better solution with far fewer false
14515              * positives, and that would fill the nodes more completely, would
14516              * be to actually have available all the multi-character folds to
14517              * test against, and to back-off only far enough to be sure that
14518              * this node isn't ending with a partial one.  <upper_parse> is set
14519              * further below (if we need to reparse the node) to include just
14520              * up through that final non-problematic character that this code
14521              * identifies, so when it is set to less than the full node, we can
14522              * skip the rest of this */
14523             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
14524                 PERL_UINT_FAST8_T backup_count = 0;
14525
14526                 const STRLEN full_len = len;
14527
14528                 assert(len >= MAX_NODE_STRING_SIZE);
14529
14530                 /* Here, <s> points to just beyond where we have output the
14531                  * final character of the node.  Look backwards through the
14532                  * string until find a non- problematic character */
14533
14534                 if (! UTF) {
14535
14536                     /* This has no multi-char folds to non-UTF characters */
14537                     if (ASCII_FOLD_RESTRICTED) {
14538                         goto loopdone;
14539                     }
14540
14541                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) {
14542                         backup_count++;
14543                     }
14544                     len = s - s0 + 1;
14545                 }
14546                 else {
14547
14548                     /* Point to the first byte of the final character */
14549                     s = (char *) utf8_hop_back((U8 *) s, -1, (U8 *) s0);
14550
14551                     while (s >= s0) {   /* Search backwards until find
14552                                            a non-problematic char */
14553                         if (UTF8_IS_INVARIANT(*s)) {
14554
14555                             /* There are no ascii characters that participate
14556                              * in multi-char folds under /aa.  In EBCDIC, the
14557                              * non-ascii invariants are all control characters,
14558                              * so don't ever participate in any folds. */
14559                             if (ASCII_FOLD_RESTRICTED
14560                                 || ! IS_NON_FINAL_FOLD(*s))
14561                             {
14562                                 break;
14563                             }
14564                         }
14565                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
14566                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
14567                                                                   *s, *(s+1))))
14568                             {
14569                                 break;
14570                             }
14571                         }
14572                         else if (! _invlist_contains_cp(
14573                                         PL_NonFinalFold,
14574                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
14575                         {
14576                             break;
14577                         }
14578
14579                         /* Here, the current character is problematic in that
14580                          * it does occur in the non-final position of some
14581                          * fold, so try the character before it, but have to
14582                          * special case the very first byte in the string, so
14583                          * we don't read outside the string */
14584                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
14585                         backup_count++;
14586                     } /* End of loop backwards through the string */
14587
14588                     /* If there were only problematic characters in the string,
14589                      * <s> will point to before s0, in which case the length
14590                      * should be 0, otherwise include the length of the
14591                      * non-problematic character just found */
14592                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
14593                 }
14594
14595                 /* Here, have found the final character, if any, that is
14596                  * non-problematic as far as ending the node without splitting
14597                  * it across a potential multi-char fold.  <len> contains the
14598                  * number of bytes in the node up-to and including that
14599                  * character, or is 0 if there is no such character, meaning
14600                  * the whole node contains only problematic characters.  In
14601                  * this case, give up and just take the node as-is.  We can't
14602                  * do any better */
14603                 if (len == 0) {
14604                     len = full_len;
14605
14606                 } else {
14607
14608                     /* Here, the node does contain some characters that aren't
14609                      * problematic.  If we didn't have to backup any, then the
14610                      * final character in the node is non-problematic, and we
14611                      * can take the node as-is */
14612                     if (backup_count == 0) {
14613                         goto loopdone;
14614                     }
14615                     else if (backup_count == 1) {
14616
14617                         /* If the final character is problematic, but the
14618                          * penultimate is not, back-off that last character to
14619                          * later start a new node with it */
14620                         p = oldp;
14621                         goto loopdone;
14622                     }
14623
14624                     /* Here, the final non-problematic character is earlier
14625                      * in the input than the penultimate character.  What we do
14626                      * is reparse from the beginning, going up only as far as
14627                      * this final ok one, thus guaranteeing that the node ends
14628                      * in an acceptable character.  The reason we reparse is
14629                      * that we know how far in the character is, but we don't
14630                      * know how to correlate its position with the input parse.
14631                      * An alternate implementation would be to build that
14632                      * correlation as we go along during the original parse,
14633                      * but that would entail extra work for every node, whereas
14634                      * this code gets executed only when the string is too
14635                      * large for the node, and the final two characters are
14636                      * problematic, an infrequent occurrence.  Yet another
14637                      * possible strategy would be to save the tail of the
14638                      * string, and the next time regatom is called, initialize
14639                      * with that.  The problem with this is that unless you
14640                      * back off one more character, you won't be guaranteed
14641                      * regatom will get called again, unless regbranch,
14642                      * regpiece ... are also changed.  If you do back off that
14643                      * extra character, so that there is input guaranteed to
14644                      * force calling regatom, you can't handle the case where
14645                      * just the first character in the node is acceptable.  I
14646                      * (khw) decided to try this method which doesn't have that
14647                      * pitfall; if performance issues are found, we can do a
14648                      * combination of the current approach plus that one */
14649                     upper_parse = len;
14650                     len = 0;
14651                     s = s0;
14652                     goto reparse;
14653                 }
14654             }   /* End of verifying node ends with an appropriate char */
14655
14656           loopdone:   /* Jumped to when encounters something that shouldn't be
14657                          in the node */
14658
14659             /* Free up any over-allocated space; cast is to silence bogus
14660              * warning in MS VC */
14661             change_engine_size(pRExC_state,
14662                                 - (Ptrdiff_t) (initial_size - STR_SZ(len)));
14663
14664             /* I (khw) don't know if you can get here with zero length, but the
14665              * old code handled this situation by creating a zero-length EXACT
14666              * node.  Might as well be NOTHING instead */
14667             if (len == 0) {
14668                 OP(REGNODE_p(ret)) = NOTHING;
14669             }
14670             else {
14671
14672                 /* If the node type is EXACT here, check to see if it
14673                  * should be EXACTL, or EXACT_ONLY8. */
14674                 if (node_type == EXACT) {
14675                     if (LOC) {
14676                         node_type = EXACTL;
14677                     }
14678                     else if (requires_utf8_target) {
14679                         node_type = EXACT_ONLY8;
14680                     }
14681                 } else if (FOLD) {
14682                     if (    UNLIKELY(has_micro_sign || has_ss)
14683                         && (node_type == EXACTFU || (   node_type == EXACTF
14684                                                      && maybe_exactfu)))
14685                     {   /* These two conditions are problematic in non-UTF-8
14686                            EXACTFU nodes. */
14687                         assert(! UTF);
14688                         node_type = EXACTFUP;
14689                     }
14690                     else if (node_type == EXACTFL) {
14691
14692                         /* 'maybe_exactfu' is deliberately set above to
14693                          * indicate this node type, where all code points in it
14694                          * are above 255 */
14695                         if (maybe_exactfu) {
14696                             node_type = EXACTFLU8;
14697                         }
14698                     }
14699                     else if (node_type == EXACTF) {  /* Means is /di */
14700
14701                         /* If 'maybe_exactfu' is clear, then we need to stay
14702                          * /di.  If it is set, it means there are no code
14703                          * points that match differently depending on UTF8ness
14704                          * of the target string, so it can become an EXACTFU
14705                          * node */
14706                         if (! maybe_exactfu) {
14707                             RExC_seen_d_op = TRUE;
14708                         }
14709                         else if (   isALPHA_FOLD_EQ(* STRING(REGNODE_p(ret)), 's')
14710                                  || isALPHA_FOLD_EQ(ender, 's'))
14711                         {
14712                             /* But, if the node begins or ends in an 's' we
14713                              * have to defer changing it into an EXACTFU, as
14714                              * the node could later get joined with another one
14715                              * that ends or begins with 's' creating an 'ss'
14716                              * sequence which would then wrongly match the
14717                              * sharp s without the target being UTF-8.  We
14718                              * create a special node that we resolve later when
14719                              * we join nodes together */
14720
14721                             node_type = EXACTFU_S_EDGE;
14722                         }
14723                         else {
14724                             node_type = EXACTFU;
14725                         }
14726                     }
14727
14728                     if (requires_utf8_target && node_type == EXACTFU) {
14729                         node_type = EXACTFU_ONLY8;
14730                     }
14731                 }
14732
14733                 OP(REGNODE_p(ret)) = node_type;
14734                 STR_LEN(REGNODE_p(ret)) = len;
14735                 RExC_emit += STR_SZ(len);
14736
14737                 /* If the node isn't a single character, it can't be SIMPLE */
14738                 if (len > (Size_t) ((UTF) ? UVCHR_SKIP(ender) : 1)) {
14739                     maybe_SIMPLE = 0;
14740                 }
14741
14742                 *flagp |= HASWIDTH | maybe_SIMPLE;
14743             }
14744
14745             Set_Node_Length(REGNODE_p(ret), p - parse_start - 1);
14746             RExC_parse = p;
14747
14748             {
14749                 /* len is STRLEN which is unsigned, need to copy to signed */
14750                 IV iv = len;
14751                 if (iv < 0)
14752                     vFAIL("Internal disaster");
14753             }
14754
14755         } /* End of label 'defchar:' */
14756         break;
14757     } /* End of giant switch on input character */
14758
14759     /* Position parse to next real character */
14760     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14761                                             FALSE /* Don't force to /x */ );
14762     if (   *RExC_parse == '{'
14763         && OP(REGNODE_p(ret)) != SBOL && ! regcurly(RExC_parse))
14764     {
14765         if (RExC_strict || new_regcurly(RExC_parse, RExC_end)) {
14766             RExC_parse++;
14767             vFAIL("Unescaped left brace in regex is illegal here");
14768         }
14769         ckWARNreg(RExC_parse + 1, "Unescaped left brace in regex is"
14770                                   " passed through");
14771     }
14772
14773     return(ret);
14774 }
14775
14776
14777 STATIC void
14778 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
14779 {
14780     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
14781      * sets up the bitmap and any flags, removing those code points from the
14782      * inversion list, setting it to NULL should it become completely empty */
14783
14784     dVAR;
14785
14786     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
14787     assert(PL_regkind[OP(node)] == ANYOF);
14788
14789     /* There is no bitmap for this node type */
14790     if (OP(node) == ANYOFH) {
14791         return;
14792     }
14793
14794     ANYOF_BITMAP_ZERO(node);
14795     if (*invlist_ptr) {
14796
14797         /* This gets set if we actually need to modify things */
14798         bool change_invlist = FALSE;
14799
14800         UV start, end;
14801
14802         /* Start looking through *invlist_ptr */
14803         invlist_iterinit(*invlist_ptr);
14804         while (invlist_iternext(*invlist_ptr, &start, &end)) {
14805             UV high;
14806             int i;
14807
14808             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
14809                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
14810             }
14811
14812             /* Quit if are above what we should change */
14813             if (start >= NUM_ANYOF_CODE_POINTS) {
14814                 break;
14815             }
14816
14817             change_invlist = TRUE;
14818
14819             /* Set all the bits in the range, up to the max that we are doing */
14820             high = (end < NUM_ANYOF_CODE_POINTS - 1)
14821                    ? end
14822                    : NUM_ANYOF_CODE_POINTS - 1;
14823             for (i = start; i <= (int) high; i++) {
14824                 if (! ANYOF_BITMAP_TEST(node, i)) {
14825                     ANYOF_BITMAP_SET(node, i);
14826                 }
14827             }
14828         }
14829         invlist_iterfinish(*invlist_ptr);
14830
14831         /* Done with loop; remove any code points that are in the bitmap from
14832          * *invlist_ptr; similarly for code points above the bitmap if we have
14833          * a flag to match all of them anyways */
14834         if (change_invlist) {
14835             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
14836         }
14837         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
14838             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
14839         }
14840
14841         /* If have completely emptied it, remove it completely */
14842         if (_invlist_len(*invlist_ptr) == 0) {
14843             SvREFCNT_dec_NN(*invlist_ptr);
14844             *invlist_ptr = NULL;
14845         }
14846     }
14847 }
14848
14849 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
14850    Character classes ([:foo:]) can also be negated ([:^foo:]).
14851    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
14852    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
14853    but trigger failures because they are currently unimplemented. */
14854
14855 #define POSIXCC_DONE(c)   ((c) == ':')
14856 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
14857 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
14858 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
14859
14860 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
14861 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
14862 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
14863
14864 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
14865
14866 /* 'posix_warnings' and 'warn_text' are names of variables in the following
14867  * routine. q.v. */
14868 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
14869         if (posix_warnings) {                                               \
14870             if (! RExC_warn_text ) RExC_warn_text =                         \
14871                                          (AV *) sv_2mortal((SV *) newAV()); \
14872             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                     \
14873                                              WARNING_PREFIX                 \
14874                                              text                           \
14875                                              REPORT_LOCATION,               \
14876                                              REPORT_LOCATION_ARGS(p)));     \
14877         }                                                                   \
14878     } STMT_END
14879 #define CLEAR_POSIX_WARNINGS()                                              \
14880     STMT_START {                                                            \
14881         if (posix_warnings && RExC_warn_text)                               \
14882             av_clear(RExC_warn_text);                                       \
14883     } STMT_END
14884
14885 #define CLEAR_POSIX_WARNINGS_AND_RETURN(ret)                                \
14886     STMT_START {                                                            \
14887         CLEAR_POSIX_WARNINGS();                                             \
14888         return ret;                                                         \
14889     } STMT_END
14890
14891 STATIC int
14892 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
14893
14894     const char * const s,      /* Where the putative posix class begins.
14895                                   Normally, this is one past the '['.  This
14896                                   parameter exists so it can be somewhere
14897                                   besides RExC_parse. */
14898     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
14899                                   NULL */
14900     AV ** posix_warnings,      /* Where to place any generated warnings, or
14901                                   NULL */
14902     const bool check_only      /* Don't die if error */
14903 )
14904 {
14905     /* This parses what the caller thinks may be one of the three POSIX
14906      * constructs:
14907      *  1) a character class, like [:blank:]
14908      *  2) a collating symbol, like [. .]
14909      *  3) an equivalence class, like [= =]
14910      * In the latter two cases, it croaks if it finds a syntactically legal
14911      * one, as these are not handled by Perl.
14912      *
14913      * The main purpose is to look for a POSIX character class.  It returns:
14914      *  a) the class number
14915      *      if it is a completely syntactically and semantically legal class.
14916      *      'updated_parse_ptr', if not NULL, is set to point to just after the
14917      *      closing ']' of the class
14918      *  b) OOB_NAMEDCLASS
14919      *      if it appears that one of the three POSIX constructs was meant, but
14920      *      its specification was somehow defective.  'updated_parse_ptr', if
14921      *      not NULL, is set to point to the character just after the end
14922      *      character of the class.  See below for handling of warnings.
14923      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
14924      *      if it  doesn't appear that a POSIX construct was intended.
14925      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
14926      *      raised.
14927      *
14928      * In b) there may be errors or warnings generated.  If 'check_only' is
14929      * TRUE, then any errors are discarded.  Warnings are returned to the
14930      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
14931      * instead it is NULL, warnings are suppressed.
14932      *
14933      * The reason for this function, and its complexity is that a bracketed
14934      * character class can contain just about anything.  But it's easy to
14935      * mistype the very specific posix class syntax but yielding a valid
14936      * regular bracketed class, so it silently gets compiled into something
14937      * quite unintended.
14938      *
14939      * The solution adopted here maintains backward compatibility except that
14940      * it adds a warning if it looks like a posix class was intended but
14941      * improperly specified.  The warning is not raised unless what is input
14942      * very closely resembles one of the 14 legal posix classes.  To do this,
14943      * it uses fuzzy parsing.  It calculates how many single-character edits it
14944      * would take to transform what was input into a legal posix class.  Only
14945      * if that number is quite small does it think that the intention was a
14946      * posix class.  Obviously these are heuristics, and there will be cases
14947      * where it errs on one side or another, and they can be tweaked as
14948      * experience informs.
14949      *
14950      * The syntax for a legal posix class is:
14951      *
14952      * qr/(?xa: \[ : \^? [[:lower:]]{4,6} : \] )/
14953      *
14954      * What this routine considers syntactically to be an intended posix class
14955      * is this (the comments indicate some restrictions that the pattern
14956      * doesn't show):
14957      *
14958      *  qr/(?x: \[?                         # The left bracket, possibly
14959      *                                      # omitted
14960      *          \h*                         # possibly followed by blanks
14961      *          (?: \^ \h* )?               # possibly a misplaced caret
14962      *          [:;]?                       # The opening class character,
14963      *                                      # possibly omitted.  A typo
14964      *                                      # semi-colon can also be used.
14965      *          \h*
14966      *          \^?                         # possibly a correctly placed
14967      *                                      # caret, but not if there was also
14968      *                                      # a misplaced one
14969      *          \h*
14970      *          .{3,15}                     # The class name.  If there are
14971      *                                      # deviations from the legal syntax,
14972      *                                      # its edit distance must be close
14973      *                                      # to a real class name in order
14974      *                                      # for it to be considered to be
14975      *                                      # an intended posix class.
14976      *          \h*
14977      *          [[:punct:]]?                # The closing class character,
14978      *                                      # possibly omitted.  If not a colon
14979      *                                      # nor semi colon, the class name
14980      *                                      # must be even closer to a valid
14981      *                                      # one
14982      *          \h*
14983      *          \]?                         # The right bracket, possibly
14984      *                                      # omitted.
14985      *     )/
14986      *
14987      * In the above, \h must be ASCII-only.
14988      *
14989      * These are heuristics, and can be tweaked as field experience dictates.
14990      * There will be cases when someone didn't intend to specify a posix class
14991      * that this warns as being so.  The goal is to minimize these, while
14992      * maximizing the catching of things intended to be a posix class that
14993      * aren't parsed as such.
14994      */
14995
14996     const char* p             = s;
14997     const char * const e      = RExC_end;
14998     unsigned complement       = 0;      /* If to complement the class */
14999     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
15000     bool has_opening_bracket  = FALSE;
15001     bool has_opening_colon    = FALSE;
15002     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
15003                                                    valid class */
15004     const char * possible_end = NULL;   /* used for a 2nd parse pass */
15005     const char* name_start;             /* ptr to class name first char */
15006
15007     /* If the number of single-character typos the input name is away from a
15008      * legal name is no more than this number, it is considered to have meant
15009      * the legal name */
15010     int max_distance          = 2;
15011
15012     /* to store the name.  The size determines the maximum length before we
15013      * decide that no posix class was intended.  Should be at least
15014      * sizeof("alphanumeric") */
15015     UV input_text[15];
15016     STATIC_ASSERT_DECL(C_ARRAY_LENGTH(input_text) >= sizeof "alphanumeric");
15017
15018     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
15019
15020     CLEAR_POSIX_WARNINGS();
15021
15022     if (p >= e) {
15023         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
15024     }
15025
15026     if (*(p - 1) != '[') {
15027         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
15028         found_problem = TRUE;
15029     }
15030     else {
15031         has_opening_bracket = TRUE;
15032     }
15033
15034     /* They could be confused and think you can put spaces between the
15035      * components */
15036     if (isBLANK(*p)) {
15037         found_problem = TRUE;
15038
15039         do {
15040             p++;
15041         } while (p < e && isBLANK(*p));
15042
15043         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15044     }
15045
15046     /* For [. .] and [= =].  These are quite different internally from [: :],
15047      * so they are handled separately.  */
15048     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
15049                                             and 1 for at least one char in it
15050                                           */
15051     {
15052         const char open_char  = *p;
15053         const char * temp_ptr = p + 1;
15054
15055         /* These two constructs are not handled by perl, and if we find a
15056          * syntactically valid one, we croak.  khw, who wrote this code, finds
15057          * this explanation of them very unclear:
15058          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
15059          * And searching the rest of the internet wasn't very helpful either.
15060          * It looks like just about any byte can be in these constructs,
15061          * depending on the locale.  But unless the pattern is being compiled
15062          * under /l, which is very rare, Perl runs under the C or POSIX locale.
15063          * In that case, it looks like [= =] isn't allowed at all, and that
15064          * [. .] could be any single code point, but for longer strings the
15065          * constituent characters would have to be the ASCII alphabetics plus
15066          * the minus-hyphen.  Any sensible locale definition would limit itself
15067          * to these.  And any portable one definitely should.  Trying to parse
15068          * the general case is a nightmare (see [perl #127604]).  So, this code
15069          * looks only for interiors of these constructs that match:
15070          *      qr/.|[-\w]{2,}/
15071          * Using \w relaxes the apparent rules a little, without adding much
15072          * danger of mistaking something else for one of these constructs.
15073          *
15074          * [. .] in some implementations described on the internet is usable to
15075          * escape a character that otherwise is special in bracketed character
15076          * classes.  For example [.].] means a literal right bracket instead of
15077          * the ending of the class
15078          *
15079          * [= =] can legitimately contain a [. .] construct, but we don't
15080          * handle this case, as that [. .] construct will later get parsed
15081          * itself and croak then.  And [= =] is checked for even when not under
15082          * /l, as Perl has long done so.
15083          *
15084          * The code below relies on there being a trailing NUL, so it doesn't
15085          * have to keep checking if the parse ptr < e.
15086          */
15087         if (temp_ptr[1] == open_char) {
15088             temp_ptr++;
15089         }
15090         else while (    temp_ptr < e
15091                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
15092         {
15093             temp_ptr++;
15094         }
15095
15096         if (*temp_ptr == open_char) {
15097             temp_ptr++;
15098             if (*temp_ptr == ']') {
15099                 temp_ptr++;
15100                 if (! found_problem && ! check_only) {
15101                     RExC_parse = (char *) temp_ptr;
15102                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
15103                             "extensions", open_char, open_char);
15104                 }
15105
15106                 /* Here, the syntax wasn't completely valid, or else the call
15107                  * is to check-only */
15108                 if (updated_parse_ptr) {
15109                     *updated_parse_ptr = (char *) temp_ptr;
15110                 }
15111
15112                 CLEAR_POSIX_WARNINGS_AND_RETURN(OOB_NAMEDCLASS);
15113             }
15114         }
15115
15116         /* If we find something that started out to look like one of these
15117          * constructs, but isn't, we continue below so that it can be checked
15118          * for being a class name with a typo of '.' or '=' instead of a colon.
15119          * */
15120     }
15121
15122     /* Here, we think there is a possibility that a [: :] class was meant, and
15123      * we have the first real character.  It could be they think the '^' comes
15124      * first */
15125     if (*p == '^') {
15126         found_problem = TRUE;
15127         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
15128         complement = 1;
15129         p++;
15130
15131         if (isBLANK(*p)) {
15132             found_problem = TRUE;
15133
15134             do {
15135                 p++;
15136             } while (p < e && isBLANK(*p));
15137
15138             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15139         }
15140     }
15141
15142     /* But the first character should be a colon, which they could have easily
15143      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
15144      * distinguish from a colon, so treat that as a colon).  */
15145     if (*p == ':') {
15146         p++;
15147         has_opening_colon = TRUE;
15148     }
15149     else if (*p == ';') {
15150         found_problem = TRUE;
15151         p++;
15152         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15153         has_opening_colon = TRUE;
15154     }
15155     else {
15156         found_problem = TRUE;
15157         ADD_POSIX_WARNING(p, "there must be a starting ':'");
15158
15159         /* Consider an initial punctuation (not one of the recognized ones) to
15160          * be a left terminator */
15161         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
15162             p++;
15163         }
15164     }
15165
15166     /* They may think that you can put spaces between the components */
15167     if (isBLANK(*p)) {
15168         found_problem = TRUE;
15169
15170         do {
15171             p++;
15172         } while (p < e && isBLANK(*p));
15173
15174         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15175     }
15176
15177     if (*p == '^') {
15178
15179         /* We consider something like [^:^alnum:]] to not have been intended to
15180          * be a posix class, but XXX maybe we should */
15181         if (complement) {
15182             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15183         }
15184
15185         complement = 1;
15186         p++;
15187     }
15188
15189     /* Again, they may think that you can put spaces between the components */
15190     if (isBLANK(*p)) {
15191         found_problem = TRUE;
15192
15193         do {
15194             p++;
15195         } while (p < e && isBLANK(*p));
15196
15197         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15198     }
15199
15200     if (*p == ']') {
15201
15202         /* XXX This ']' may be a typo, and something else was meant.  But
15203          * treating it as such creates enough complications, that that
15204          * possibility isn't currently considered here.  So we assume that the
15205          * ']' is what is intended, and if we've already found an initial '[',
15206          * this leaves this construct looking like [:] or [:^], which almost
15207          * certainly weren't intended to be posix classes */
15208         if (has_opening_bracket) {
15209             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15210         }
15211
15212         /* But this function can be called when we parse the colon for
15213          * something like qr/[alpha:]]/, so we back up to look for the
15214          * beginning */
15215         p--;
15216
15217         if (*p == ';') {
15218             found_problem = TRUE;
15219             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15220         }
15221         else if (*p != ':') {
15222
15223             /* XXX We are currently very restrictive here, so this code doesn't
15224              * consider the possibility that, say, /[alpha.]]/ was intended to
15225              * be a posix class. */
15226             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15227         }
15228
15229         /* Here we have something like 'foo:]'.  There was no initial colon,
15230          * and we back up over 'foo.  XXX Unlike the going forward case, we
15231          * don't handle typos of non-word chars in the middle */
15232         has_opening_colon = FALSE;
15233         p--;
15234
15235         while (p > RExC_start && isWORDCHAR(*p)) {
15236             p--;
15237         }
15238         p++;
15239
15240         /* Here, we have positioned ourselves to where we think the first
15241          * character in the potential class is */
15242     }
15243
15244     /* Now the interior really starts.  There are certain key characters that
15245      * can end the interior, or these could just be typos.  To catch both
15246      * cases, we may have to do two passes.  In the first pass, we keep on
15247      * going unless we come to a sequence that matches
15248      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
15249      * This means it takes a sequence to end the pass, so two typos in a row if
15250      * that wasn't what was intended.  If the class is perfectly formed, just
15251      * this one pass is needed.  We also stop if there are too many characters
15252      * being accumulated, but this number is deliberately set higher than any
15253      * real class.  It is set high enough so that someone who thinks that
15254      * 'alphanumeric' is a correct name would get warned that it wasn't.
15255      * While doing the pass, we keep track of where the key characters were in
15256      * it.  If we don't find an end to the class, and one of the key characters
15257      * was found, we redo the pass, but stop when we get to that character.
15258      * Thus the key character was considered a typo in the first pass, but a
15259      * terminator in the second.  If two key characters are found, we stop at
15260      * the second one in the first pass.  Again this can miss two typos, but
15261      * catches a single one
15262      *
15263      * In the first pass, 'possible_end' starts as NULL, and then gets set to
15264      * point to the first key character.  For the second pass, it starts as -1.
15265      * */
15266
15267     name_start = p;
15268   parse_name:
15269     {
15270         bool has_blank               = FALSE;
15271         bool has_upper               = FALSE;
15272         bool has_terminating_colon   = FALSE;
15273         bool has_terminating_bracket = FALSE;
15274         bool has_semi_colon          = FALSE;
15275         unsigned int name_len        = 0;
15276         int punct_count              = 0;
15277
15278         while (p < e) {
15279
15280             /* Squeeze out blanks when looking up the class name below */
15281             if (isBLANK(*p) ) {
15282                 has_blank = TRUE;
15283                 found_problem = TRUE;
15284                 p++;
15285                 continue;
15286             }
15287
15288             /* The name will end with a punctuation */
15289             if (isPUNCT(*p)) {
15290                 const char * peek = p + 1;
15291
15292                 /* Treat any non-']' punctuation followed by a ']' (possibly
15293                  * with intervening blanks) as trying to terminate the class.
15294                  * ']]' is very likely to mean a class was intended (but
15295                  * missing the colon), but the warning message that gets
15296                  * generated shows the error position better if we exit the
15297                  * loop at the bottom (eventually), so skip it here. */
15298                 if (*p != ']') {
15299                     if (peek < e && isBLANK(*peek)) {
15300                         has_blank = TRUE;
15301                         found_problem = TRUE;
15302                         do {
15303                             peek++;
15304                         } while (peek < e && isBLANK(*peek));
15305                     }
15306
15307                     if (peek < e && *peek == ']') {
15308                         has_terminating_bracket = TRUE;
15309                         if (*p == ':') {
15310                             has_terminating_colon = TRUE;
15311                         }
15312                         else if (*p == ';') {
15313                             has_semi_colon = TRUE;
15314                             has_terminating_colon = TRUE;
15315                         }
15316                         else {
15317                             found_problem = TRUE;
15318                         }
15319                         p = peek + 1;
15320                         goto try_posix;
15321                     }
15322                 }
15323
15324                 /* Here we have punctuation we thought didn't end the class.
15325                  * Keep track of the position of the key characters that are
15326                  * more likely to have been class-enders */
15327                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
15328
15329                     /* Allow just one such possible class-ender not actually
15330                      * ending the class. */
15331                     if (possible_end) {
15332                         break;
15333                     }
15334                     possible_end = p;
15335                 }
15336
15337                 /* If we have too many punctuation characters, no use in
15338                  * keeping going */
15339                 if (++punct_count > max_distance) {
15340                     break;
15341                 }
15342
15343                 /* Treat the punctuation as a typo. */
15344                 input_text[name_len++] = *p;
15345                 p++;
15346             }
15347             else if (isUPPER(*p)) { /* Use lowercase for lookup */
15348                 input_text[name_len++] = toLOWER(*p);
15349                 has_upper = TRUE;
15350                 found_problem = TRUE;
15351                 p++;
15352             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
15353                 input_text[name_len++] = *p;
15354                 p++;
15355             }
15356             else {
15357                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
15358                 p+= UTF8SKIP(p);
15359             }
15360
15361             /* The declaration of 'input_text' is how long we allow a potential
15362              * class name to be, before saying they didn't mean a class name at
15363              * all */
15364             if (name_len >= C_ARRAY_LENGTH(input_text)) {
15365                 break;
15366             }
15367         }
15368
15369         /* We get to here when the possible class name hasn't been properly
15370          * terminated before:
15371          *   1) we ran off the end of the pattern; or
15372          *   2) found two characters, each of which might have been intended to
15373          *      be the name's terminator
15374          *   3) found so many punctuation characters in the purported name,
15375          *      that the edit distance to a valid one is exceeded
15376          *   4) we decided it was more characters than anyone could have
15377          *      intended to be one. */
15378
15379         found_problem = TRUE;
15380
15381         /* In the final two cases, we know that looking up what we've
15382          * accumulated won't lead to a match, even a fuzzy one. */
15383         if (   name_len >= C_ARRAY_LENGTH(input_text)
15384             || punct_count > max_distance)
15385         {
15386             /* If there was an intermediate key character that could have been
15387              * an intended end, redo the parse, but stop there */
15388             if (possible_end && possible_end != (char *) -1) {
15389                 possible_end = (char *) -1; /* Special signal value to say
15390                                                we've done a first pass */
15391                 p = name_start;
15392                 goto parse_name;
15393             }
15394
15395             /* Otherwise, it can't have meant to have been a class */
15396             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15397         }
15398
15399         /* If we ran off the end, and the final character was a punctuation
15400          * one, back up one, to look at that final one just below.  Later, we
15401          * will restore the parse pointer if appropriate */
15402         if (name_len && p == e && isPUNCT(*(p-1))) {
15403             p--;
15404             name_len--;
15405         }
15406
15407         if (p < e && isPUNCT(*p)) {
15408             if (*p == ']') {
15409                 has_terminating_bracket = TRUE;
15410
15411                 /* If this is a 2nd ']', and the first one is just below this
15412                  * one, consider that to be the real terminator.  This gives a
15413                  * uniform and better positioning for the warning message  */
15414                 if (   possible_end
15415                     && possible_end != (char *) -1
15416                     && *possible_end == ']'
15417                     && name_len && input_text[name_len - 1] == ']')
15418                 {
15419                     name_len--;
15420                     p = possible_end;
15421
15422                     /* And this is actually equivalent to having done the 2nd
15423                      * pass now, so set it to not try again */
15424                     possible_end = (char *) -1;
15425                 }
15426             }
15427             else {
15428                 if (*p == ':') {
15429                     has_terminating_colon = TRUE;
15430                 }
15431                 else if (*p == ';') {
15432                     has_semi_colon = TRUE;
15433                     has_terminating_colon = TRUE;
15434                 }
15435                 p++;
15436             }
15437         }
15438
15439     try_posix:
15440
15441         /* Here, we have a class name to look up.  We can short circuit the
15442          * stuff below for short names that can't possibly be meant to be a
15443          * class name.  (We can do this on the first pass, as any second pass
15444          * will yield an even shorter name) */
15445         if (name_len < 3) {
15446             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15447         }
15448
15449         /* Find which class it is.  Initially switch on the length of the name.
15450          * */
15451         switch (name_len) {
15452             case 4:
15453                 if (memEQs(name_start, 4, "word")) {
15454                     /* this is not POSIX, this is the Perl \w */
15455                     class_number = ANYOF_WORDCHAR;
15456                 }
15457                 break;
15458             case 5:
15459                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
15460                  *                        graph lower print punct space upper
15461                  * Offset 4 gives the best switch position.  */
15462                 switch (name_start[4]) {
15463                     case 'a':
15464                         if (memBEGINs(name_start, 5, "alph")) /* alpha */
15465                             class_number = ANYOF_ALPHA;
15466                         break;
15467                     case 'e':
15468                         if (memBEGINs(name_start, 5, "spac")) /* space */
15469                             class_number = ANYOF_SPACE;
15470                         break;
15471                     case 'h':
15472                         if (memBEGINs(name_start, 5, "grap")) /* graph */
15473                             class_number = ANYOF_GRAPH;
15474                         break;
15475                     case 'i':
15476                         if (memBEGINs(name_start, 5, "asci")) /* ascii */
15477                             class_number = ANYOF_ASCII;
15478                         break;
15479                     case 'k':
15480                         if (memBEGINs(name_start, 5, "blan")) /* blank */
15481                             class_number = ANYOF_BLANK;
15482                         break;
15483                     case 'l':
15484                         if (memBEGINs(name_start, 5, "cntr")) /* cntrl */
15485                             class_number = ANYOF_CNTRL;
15486                         break;
15487                     case 'm':
15488                         if (memBEGINs(name_start, 5, "alnu")) /* alnum */
15489                             class_number = ANYOF_ALPHANUMERIC;
15490                         break;
15491                     case 'r':
15492                         if (memBEGINs(name_start, 5, "lowe")) /* lower */
15493                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
15494                         else if (memBEGINs(name_start, 5, "uppe")) /* upper */
15495                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
15496                         break;
15497                     case 't':
15498                         if (memBEGINs(name_start, 5, "digi")) /* digit */
15499                             class_number = ANYOF_DIGIT;
15500                         else if (memBEGINs(name_start, 5, "prin")) /* print */
15501                             class_number = ANYOF_PRINT;
15502                         else if (memBEGINs(name_start, 5, "punc")) /* punct */
15503                             class_number = ANYOF_PUNCT;
15504                         break;
15505                 }
15506                 break;
15507             case 6:
15508                 if (memEQs(name_start, 6, "xdigit"))
15509                     class_number = ANYOF_XDIGIT;
15510                 break;
15511         }
15512
15513         /* If the name exactly matches a posix class name the class number will
15514          * here be set to it, and the input almost certainly was meant to be a
15515          * posix class, so we can skip further checking.  If instead the syntax
15516          * is exactly correct, but the name isn't one of the legal ones, we
15517          * will return that as an error below.  But if neither of these apply,
15518          * it could be that no posix class was intended at all, or that one
15519          * was, but there was a typo.  We tease these apart by doing fuzzy
15520          * matching on the name */
15521         if (class_number == OOB_NAMEDCLASS && found_problem) {
15522             const UV posix_names[][6] = {
15523                                                 { 'a', 'l', 'n', 'u', 'm' },
15524                                                 { 'a', 'l', 'p', 'h', 'a' },
15525                                                 { 'a', 's', 'c', 'i', 'i' },
15526                                                 { 'b', 'l', 'a', 'n', 'k' },
15527                                                 { 'c', 'n', 't', 'r', 'l' },
15528                                                 { 'd', 'i', 'g', 'i', 't' },
15529                                                 { 'g', 'r', 'a', 'p', 'h' },
15530                                                 { 'l', 'o', 'w', 'e', 'r' },
15531                                                 { 'p', 'r', 'i', 'n', 't' },
15532                                                 { 'p', 'u', 'n', 'c', 't' },
15533                                                 { 's', 'p', 'a', 'c', 'e' },
15534                                                 { 'u', 'p', 'p', 'e', 'r' },
15535                                                 { 'w', 'o', 'r', 'd' },
15536                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
15537                                             };
15538             /* The names of the above all have added NULs to make them the same
15539              * size, so we need to also have the real lengths */
15540             const UV posix_name_lengths[] = {
15541                                                 sizeof("alnum") - 1,
15542                                                 sizeof("alpha") - 1,
15543                                                 sizeof("ascii") - 1,
15544                                                 sizeof("blank") - 1,
15545                                                 sizeof("cntrl") - 1,
15546                                                 sizeof("digit") - 1,
15547                                                 sizeof("graph") - 1,
15548                                                 sizeof("lower") - 1,
15549                                                 sizeof("print") - 1,
15550                                                 sizeof("punct") - 1,
15551                                                 sizeof("space") - 1,
15552                                                 sizeof("upper") - 1,
15553                                                 sizeof("word")  - 1,
15554                                                 sizeof("xdigit")- 1
15555                                             };
15556             unsigned int i;
15557             int temp_max = max_distance;    /* Use a temporary, so if we
15558                                                reparse, we haven't changed the
15559                                                outer one */
15560
15561             /* Use a smaller max edit distance if we are missing one of the
15562              * delimiters */
15563             if (   has_opening_bracket + has_opening_colon < 2
15564                 || has_terminating_bracket + has_terminating_colon < 2)
15565             {
15566                 temp_max--;
15567             }
15568
15569             /* See if the input name is close to a legal one */
15570             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
15571
15572                 /* Short circuit call if the lengths are too far apart to be
15573                  * able to match */
15574                 if (abs( (int) (name_len - posix_name_lengths[i]))
15575                     > temp_max)
15576                 {
15577                     continue;
15578                 }
15579
15580                 if (edit_distance(input_text,
15581                                   posix_names[i],
15582                                   name_len,
15583                                   posix_name_lengths[i],
15584                                   temp_max
15585                                  )
15586                     > -1)
15587                 { /* If it is close, it probably was intended to be a class */
15588                     goto probably_meant_to_be;
15589                 }
15590             }
15591
15592             /* Here the input name is not close enough to a valid class name
15593              * for us to consider it to be intended to be a posix class.  If
15594              * we haven't already done so, and the parse found a character that
15595              * could have been terminators for the name, but which we absorbed
15596              * as typos during the first pass, repeat the parse, signalling it
15597              * to stop at that character */
15598             if (possible_end && possible_end != (char *) -1) {
15599                 possible_end = (char *) -1;
15600                 p = name_start;
15601                 goto parse_name;
15602             }
15603
15604             /* Here neither pass found a close-enough class name */
15605             CLEAR_POSIX_WARNINGS_AND_RETURN(NOT_MEANT_TO_BE_A_POSIX_CLASS);
15606         }
15607
15608     probably_meant_to_be:
15609
15610         /* Here we think that a posix specification was intended.  Update any
15611          * parse pointer */
15612         if (updated_parse_ptr) {
15613             *updated_parse_ptr = (char *) p;
15614         }
15615
15616         /* If a posix class name was intended but incorrectly specified, we
15617          * output or return the warnings */
15618         if (found_problem) {
15619
15620             /* We set flags for these issues in the parse loop above instead of
15621              * adding them to the list of warnings, because we can parse it
15622              * twice, and we only want one warning instance */
15623             if (has_upper) {
15624                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
15625             }
15626             if (has_blank) {
15627                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
15628             }
15629             if (has_semi_colon) {
15630                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
15631             }
15632             else if (! has_terminating_colon) {
15633                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
15634             }
15635             if (! has_terminating_bracket) {
15636                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
15637             }
15638
15639             if (   posix_warnings
15640                 && RExC_warn_text
15641                 && av_top_index(RExC_warn_text) > -1)
15642             {
15643                 *posix_warnings = RExC_warn_text;
15644             }
15645         }
15646         else if (class_number != OOB_NAMEDCLASS) {
15647             /* If it is a known class, return the class.  The class number
15648              * #defines are structured so each complement is +1 to the normal
15649              * one */
15650             CLEAR_POSIX_WARNINGS_AND_RETURN(class_number + complement);
15651         }
15652         else if (! check_only) {
15653
15654             /* Here, it is an unrecognized class.  This is an error (unless the
15655             * call is to check only, which we've already handled above) */
15656             const char * const complement_string = (complement)
15657                                                    ? "^"
15658                                                    : "";
15659             RExC_parse = (char *) p;
15660             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
15661                         complement_string,
15662                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
15663         }
15664     }
15665
15666     return OOB_NAMEDCLASS;
15667 }
15668 #undef ADD_POSIX_WARNING
15669
15670 STATIC unsigned  int
15671 S_regex_set_precedence(const U8 my_operator) {
15672
15673     /* Returns the precedence in the (?[...]) construct of the input operator,
15674      * specified by its character representation.  The precedence follows
15675      * general Perl rules, but it extends this so that ')' and ']' have (low)
15676      * precedence even though they aren't really operators */
15677
15678     switch (my_operator) {
15679         case '!':
15680             return 5;
15681         case '&':
15682             return 4;
15683         case '^':
15684         case '|':
15685         case '+':
15686         case '-':
15687             return 3;
15688         case ')':
15689             return 2;
15690         case ']':
15691             return 1;
15692     }
15693
15694     NOT_REACHED; /* NOTREACHED */
15695     return 0;   /* Silence compiler warning */
15696 }
15697
15698 STATIC regnode_offset
15699 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
15700                     I32 *flagp, U32 depth,
15701                     char * const oregcomp_parse)
15702 {
15703     /* Handle the (?[...]) construct to do set operations */
15704
15705     U8 curchar;                     /* Current character being parsed */
15706     UV start, end;                  /* End points of code point ranges */
15707     SV* final = NULL;               /* The end result inversion list */
15708     SV* result_string;              /* 'final' stringified */
15709     AV* stack;                      /* stack of operators and operands not yet
15710                                        resolved */
15711     AV* fence_stack = NULL;         /* A stack containing the positions in
15712                                        'stack' of where the undealt-with left
15713                                        parens would be if they were actually
15714                                        put there */
15715     /* The 'volatile' is a workaround for an optimiser bug
15716      * in Solaris Studio 12.3. See RT #127455 */
15717     volatile IV fence = 0;          /* Position of where most recent undealt-
15718                                        with left paren in stack is; -1 if none.
15719                                      */
15720     STRLEN len;                     /* Temporary */
15721     regnode_offset node;                  /* Temporary, and final regnode returned by
15722                                        this function */
15723     const bool save_fold = FOLD;    /* Temporary */
15724     char *save_end, *save_parse;    /* Temporaries */
15725     const bool in_locale = LOC;     /* we turn off /l during processing */
15726
15727     GET_RE_DEBUG_FLAGS_DECL;
15728
15729     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
15730
15731     DEBUG_PARSE("xcls");
15732
15733     if (in_locale) {
15734         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
15735     }
15736
15737     /* The use of this operator implies /u.  This is required so that the
15738      * compile time values are valid in all runtime cases */
15739     REQUIRE_UNI_RULES(flagp, 0);
15740
15741     ckWARNexperimental(RExC_parse,
15742                        WARN_EXPERIMENTAL__REGEX_SETS,
15743                        "The regex_sets feature is experimental");
15744
15745     /* Everything in this construct is a metacharacter.  Operands begin with
15746      * either a '\' (for an escape sequence), or a '[' for a bracketed
15747      * character class.  Any other character should be an operator, or
15748      * parenthesis for grouping.  Both types of operands are handled by calling
15749      * regclass() to parse them.  It is called with a parameter to indicate to
15750      * return the computed inversion list.  The parsing here is implemented via
15751      * a stack.  Each entry on the stack is a single character representing one
15752      * of the operators; or else a pointer to an operand inversion list. */
15753
15754 #define IS_OPERATOR(a) SvIOK(a)
15755 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
15756
15757     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
15758      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
15759      * with pronouncing it called it Reverse Polish instead, but now that YOU
15760      * know how to pronounce it you can use the correct term, thus giving due
15761      * credit to the person who invented it, and impressing your geek friends.
15762      * Wikipedia says that the pronounciation of "Ł" has been changing so that
15763      * it is now more like an English initial W (as in wonk) than an L.)
15764      *
15765      * This means that, for example, 'a | b & c' is stored on the stack as
15766      *
15767      * c  [4]
15768      * b  [3]
15769      * &  [2]
15770      * a  [1]
15771      * |  [0]
15772      *
15773      * where the numbers in brackets give the stack [array] element number.
15774      * In this implementation, parentheses are not stored on the stack.
15775      * Instead a '(' creates a "fence" so that the part of the stack below the
15776      * fence is invisible except to the corresponding ')' (this allows us to
15777      * replace testing for parens, by using instead subtraction of the fence
15778      * position).  As new operands are processed they are pushed onto the stack
15779      * (except as noted in the next paragraph).  New operators of higher
15780      * precedence than the current final one are inserted on the stack before
15781      * the lhs operand (so that when the rhs is pushed next, everything will be
15782      * in the correct positions shown above.  When an operator of equal or
15783      * lower precedence is encountered in parsing, all the stacked operations
15784      * of equal or higher precedence are evaluated, leaving the result as the
15785      * top entry on the stack.  This makes higher precedence operations
15786      * evaluate before lower precedence ones, and causes operations of equal
15787      * precedence to left associate.
15788      *
15789      * The only unary operator '!' is immediately pushed onto the stack when
15790      * encountered.  When an operand is encountered, if the top of the stack is
15791      * a '!", the complement is immediately performed, and the '!' popped.  The
15792      * resulting value is treated as a new operand, and the logic in the
15793      * previous paragraph is executed.  Thus in the expression
15794      *      [a] + ! [b]
15795      * the stack looks like
15796      *
15797      * !
15798      * a
15799      * +
15800      *
15801      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
15802      * becomes
15803      *
15804      * !b
15805      * a
15806      * +
15807      *
15808      * A ')' is treated as an operator with lower precedence than all the
15809      * aforementioned ones, which causes all operations on the stack above the
15810      * corresponding '(' to be evaluated down to a single resultant operand.
15811      * Then the fence for the '(' is removed, and the operand goes through the
15812      * algorithm above, without the fence.
15813      *
15814      * A separate stack is kept of the fence positions, so that the position of
15815      * the latest so-far unbalanced '(' is at the top of it.
15816      *
15817      * The ']' ending the construct is treated as the lowest operator of all,
15818      * so that everything gets evaluated down to a single operand, which is the
15819      * result */
15820
15821     sv_2mortal((SV *)(stack = newAV()));
15822     sv_2mortal((SV *)(fence_stack = newAV()));
15823
15824     while (RExC_parse < RExC_end) {
15825         I32 top_index;              /* Index of top-most element in 'stack' */
15826         SV** top_ptr;               /* Pointer to top 'stack' element */
15827         SV* current = NULL;         /* To contain the current inversion list
15828                                        operand */
15829         SV* only_to_avoid_leaks;
15830
15831         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
15832                                 TRUE /* Force /x */ );
15833         if (RExC_parse >= RExC_end) {   /* Fail */
15834             break;
15835         }
15836
15837         curchar = UCHARAT(RExC_parse);
15838
15839 redo_curchar:
15840
15841 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15842                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
15843         DEBUG_U(dump_regex_sets_structures(pRExC_state,
15844                                            stack, fence, fence_stack));
15845 #endif
15846
15847         top_index = av_tindex_skip_len_mg(stack);
15848
15849         switch (curchar) {
15850             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
15851             char stacked_operator;  /* The topmost operator on the 'stack'. */
15852             SV* lhs;                /* Operand to the left of the operator */
15853             SV* rhs;                /* Operand to the right of the operator */
15854             SV* fence_ptr;          /* Pointer to top element of the fence
15855                                        stack */
15856
15857             case '(':
15858
15859                 if (   RExC_parse < RExC_end - 2
15860                     && UCHARAT(RExC_parse + 1) == '?'
15861                     && UCHARAT(RExC_parse + 2) == '^')
15862                 {
15863                     /* If is a '(?', could be an embedded '(?^flags:(?[...])'.
15864                      * This happens when we have some thing like
15865                      *
15866                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
15867                      *   ...
15868                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
15869                      *
15870                      * Here we would be handling the interpolated
15871                      * '$thai_or_lao'.  We handle this by a recursive call to
15872                      * ourselves which returns the inversion list the
15873                      * interpolated expression evaluates to.  We use the flags
15874                      * from the interpolated pattern. */
15875                     U32 save_flags = RExC_flags;
15876                     const char * save_parse;
15877
15878                     RExC_parse += 2;        /* Skip past the '(?' */
15879                     save_parse = RExC_parse;
15880
15881                     /* Parse the flags for the '(?'.  We already know the first
15882                      * flag to parse is a '^' */
15883                     parse_lparen_question_flags(pRExC_state);
15884
15885                     if (   RExC_parse >= RExC_end - 4
15886                         || UCHARAT(RExC_parse) != ':'
15887                         || UCHARAT(++RExC_parse) != '('
15888                         || UCHARAT(++RExC_parse) != '?'
15889                         || UCHARAT(++RExC_parse) != '[')
15890                     {
15891
15892                         /* In combination with the above, this moves the
15893                          * pointer to the point just after the first erroneous
15894                          * character. */
15895                         if (RExC_parse >= RExC_end - 4) {
15896                             RExC_parse = RExC_end;
15897                         }
15898                         else if (RExC_parse != save_parse) {
15899                             RExC_parse += (UTF)
15900                                           ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
15901                                           : 1;
15902                         }
15903                         vFAIL("Expecting '(?flags:(?[...'");
15904                     }
15905
15906                     /* Recurse, with the meat of the embedded expression */
15907                     RExC_parse++;
15908                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15909                                                     depth+1, oregcomp_parse);
15910
15911                     /* Here, 'current' contains the embedded expression's
15912                      * inversion list, and RExC_parse points to the trailing
15913                      * ']'; the next character should be the ')' */
15914                     RExC_parse++;
15915                     if (UCHARAT(RExC_parse) != ')')
15916                         vFAIL("Expecting close paren for nested extended charclass");
15917
15918                     /* Then the ')' matching the original '(' handled by this
15919                      * case: statement */
15920                     RExC_parse++;
15921                     if (UCHARAT(RExC_parse) != ')')
15922                         vFAIL("Expecting close paren for wrapper for nested extended charclass");
15923
15924                     RExC_flags = save_flags;
15925                     goto handle_operand;
15926                 }
15927
15928                 /* A regular '('.  Look behind for illegal syntax */
15929                 if (top_index - fence >= 0) {
15930                     /* If the top entry on the stack is an operator, it had
15931                      * better be a '!', otherwise the entry below the top
15932                      * operand should be an operator */
15933                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15934                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15935                         || (   IS_OPERAND(*top_ptr)
15936                             && (   top_index - fence < 1
15937                                 || ! (stacked_ptr = av_fetch(stack,
15938                                                              top_index - 1,
15939                                                              FALSE))
15940                                 || ! IS_OPERATOR(*stacked_ptr))))
15941                     {
15942                         RExC_parse++;
15943                         vFAIL("Unexpected '(' with no preceding operator");
15944                     }
15945                 }
15946
15947                 /* Stack the position of this undealt-with left paren */
15948                 av_push(fence_stack, newSViv(fence));
15949                 fence = top_index + 1;
15950                 break;
15951
15952             case '\\':
15953                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
15954                  * multi-char folds are allowed.  */
15955                 if (!regclass(pRExC_state, flagp, depth+1,
15956                               TRUE, /* means parse just the next thing */
15957                               FALSE, /* don't allow multi-char folds */
15958                               FALSE, /* don't silence non-portable warnings.  */
15959                               TRUE,  /* strict */
15960                               FALSE, /* Require return to be an ANYOF */
15961                               &current))
15962                 {
15963                     goto regclass_failed;
15964                 }
15965
15966                 /* regclass() will return with parsing just the \ sequence,
15967                  * leaving the parse pointer at the next thing to parse */
15968                 RExC_parse--;
15969                 goto handle_operand;
15970
15971             case '[':   /* Is a bracketed character class */
15972             {
15973                 /* See if this is a [:posix:] class. */
15974                 bool is_posix_class = (OOB_NAMEDCLASS
15975                             < handle_possible_posix(pRExC_state,
15976                                                 RExC_parse + 1,
15977                                                 NULL,
15978                                                 NULL,
15979                                                 TRUE /* checking only */));
15980                 /* If it is a posix class, leave the parse pointer at the '['
15981                  * to fool regclass() into thinking it is part of a
15982                  * '[[:posix:]]'. */
15983                 if (! is_posix_class) {
15984                     RExC_parse++;
15985                 }
15986
15987                 /* regclass() can only return RESTART_PARSE and NEED_UTF8 if
15988                  * multi-char folds are allowed.  */
15989                 if (!regclass(pRExC_state, flagp, depth+1,
15990                                 is_posix_class, /* parse the whole char
15991                                                     class only if not a
15992                                                     posix class */
15993                                 FALSE, /* don't allow multi-char folds */
15994                                 TRUE, /* silence non-portable warnings. */
15995                                 TRUE, /* strict */
15996                                 FALSE, /* Require return to be an ANYOF */
15997                                 &current))
15998                 {
15999                     goto regclass_failed;
16000                 }
16001
16002                 if (! current) {
16003                     break;
16004                 }
16005
16006                 /* function call leaves parse pointing to the ']', except if we
16007                  * faked it */
16008                 if (is_posix_class) {
16009                     RExC_parse--;
16010                 }
16011
16012                 goto handle_operand;
16013             }
16014
16015             case ']':
16016                 if (top_index >= 1) {
16017                     goto join_operators;
16018                 }
16019
16020                 /* Only a single operand on the stack: are done */
16021                 goto done;
16022
16023             case ')':
16024                 if (av_tindex_skip_len_mg(fence_stack) < 0) {
16025                     if (UCHARAT(RExC_parse - 1) == ']')  {
16026                         break;
16027                     }
16028                     RExC_parse++;
16029                     vFAIL("Unexpected ')'");
16030                 }
16031
16032                 /* If nothing after the fence, is missing an operand */
16033                 if (top_index - fence < 0) {
16034                     RExC_parse++;
16035                     goto bad_syntax;
16036                 }
16037                 /* If at least two things on the stack, treat this as an
16038                   * operator */
16039                 if (top_index - fence >= 1) {
16040                     goto join_operators;
16041                 }
16042
16043                 /* Here only a single thing on the fenced stack, and there is a
16044                  * fence.  Get rid of it */
16045                 fence_ptr = av_pop(fence_stack);
16046                 assert(fence_ptr);
16047                 fence = SvIV(fence_ptr);
16048                 SvREFCNT_dec_NN(fence_ptr);
16049                 fence_ptr = NULL;
16050
16051                 if (fence < 0) {
16052                     fence = 0;
16053                 }
16054
16055                 /* Having gotten rid of the fence, we pop the operand at the
16056                  * stack top and process it as a newly encountered operand */
16057                 current = av_pop(stack);
16058                 if (IS_OPERAND(current)) {
16059                     goto handle_operand;
16060                 }
16061
16062                 RExC_parse++;
16063                 goto bad_syntax;
16064
16065             case '&':
16066             case '|':
16067             case '+':
16068             case '-':
16069             case '^':
16070
16071                 /* These binary operators should have a left operand already
16072                  * parsed */
16073                 if (   top_index - fence < 0
16074                     || top_index - fence == 1
16075                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
16076                     || ! IS_OPERAND(*top_ptr))
16077                 {
16078                     goto unexpected_binary;
16079                 }
16080
16081                 /* If only the one operand is on the part of the stack visible
16082                  * to us, we just place this operator in the proper position */
16083                 if (top_index - fence < 2) {
16084
16085                     /* Place the operator before the operand */
16086
16087                     SV* lhs = av_pop(stack);
16088                     av_push(stack, newSVuv(curchar));
16089                     av_push(stack, lhs);
16090                     break;
16091                 }
16092
16093                 /* But if there is something else on the stack, we need to
16094                  * process it before this new operator if and only if the
16095                  * stacked operation has equal or higher precedence than the
16096                  * new one */
16097
16098              join_operators:
16099
16100                 /* The operator on the stack is supposed to be below both its
16101                  * operands */
16102                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
16103                     || IS_OPERAND(*stacked_ptr))
16104                 {
16105                     /* But if not, it's legal and indicates we are completely
16106                      * done if and only if we're currently processing a ']',
16107                      * which should be the final thing in the expression */
16108                     if (curchar == ']') {
16109                         goto done;
16110                     }
16111
16112                   unexpected_binary:
16113                     RExC_parse++;
16114                     vFAIL2("Unexpected binary operator '%c' with no "
16115                            "preceding operand", curchar);
16116                 }
16117                 stacked_operator = (char) SvUV(*stacked_ptr);
16118
16119                 if (regex_set_precedence(curchar)
16120                     > regex_set_precedence(stacked_operator))
16121                 {
16122                     /* Here, the new operator has higher precedence than the
16123                      * stacked one.  This means we need to add the new one to
16124                      * the stack to await its rhs operand (and maybe more
16125                      * stuff).  We put it before the lhs operand, leaving
16126                      * untouched the stacked operator and everything below it
16127                      * */
16128                     lhs = av_pop(stack);
16129                     assert(IS_OPERAND(lhs));
16130
16131                     av_push(stack, newSVuv(curchar));
16132                     av_push(stack, lhs);
16133                     break;
16134                 }
16135
16136                 /* Here, the new operator has equal or lower precedence than
16137                  * what's already there.  This means the operation already
16138                  * there should be performed now, before the new one. */
16139
16140                 rhs = av_pop(stack);
16141                 if (! IS_OPERAND(rhs)) {
16142
16143                     /* This can happen when a ! is not followed by an operand,
16144                      * like in /(?[\t &!])/ */
16145                     goto bad_syntax;
16146                 }
16147
16148                 lhs = av_pop(stack);
16149
16150                 if (! IS_OPERAND(lhs)) {
16151
16152                     /* This can happen when there is an empty (), like in
16153                      * /(?[[0]+()+])/ */
16154                     goto bad_syntax;
16155                 }
16156
16157                 switch (stacked_operator) {
16158                     case '&':
16159                         _invlist_intersection(lhs, rhs, &rhs);
16160                         break;
16161
16162                     case '|':
16163                     case '+':
16164                         _invlist_union(lhs, rhs, &rhs);
16165                         break;
16166
16167                     case '-':
16168                         _invlist_subtract(lhs, rhs, &rhs);
16169                         break;
16170
16171                     case '^':   /* The union minus the intersection */
16172                     {
16173                         SV* i = NULL;
16174                         SV* u = NULL;
16175
16176                         _invlist_union(lhs, rhs, &u);
16177                         _invlist_intersection(lhs, rhs, &i);
16178                         _invlist_subtract(u, i, &rhs);
16179                         SvREFCNT_dec_NN(i);
16180                         SvREFCNT_dec_NN(u);
16181                         break;
16182                     }
16183                 }
16184                 SvREFCNT_dec(lhs);
16185
16186                 /* Here, the higher precedence operation has been done, and the
16187                  * result is in 'rhs'.  We overwrite the stacked operator with
16188                  * the result.  Then we redo this code to either push the new
16189                  * operator onto the stack or perform any higher precedence
16190                  * stacked operation */
16191                 only_to_avoid_leaks = av_pop(stack);
16192                 SvREFCNT_dec(only_to_avoid_leaks);
16193                 av_push(stack, rhs);
16194                 goto redo_curchar;
16195
16196             case '!':   /* Highest priority, right associative */
16197
16198                 /* If what's already at the top of the stack is another '!",
16199                  * they just cancel each other out */
16200                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
16201                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
16202                 {
16203                     only_to_avoid_leaks = av_pop(stack);
16204                     SvREFCNT_dec(only_to_avoid_leaks);
16205                 }
16206                 else { /* Otherwise, since it's right associative, just push
16207                           onto the stack */
16208                     av_push(stack, newSVuv(curchar));
16209                 }
16210                 break;
16211
16212             default:
16213                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16214                 if (RExC_parse >= RExC_end) {
16215                     break;
16216                 }
16217                 vFAIL("Unexpected character");
16218
16219           handle_operand:
16220
16221             /* Here 'current' is the operand.  If something is already on the
16222              * stack, we have to check if it is a !.  But first, the code above
16223              * may have altered the stack in the time since we earlier set
16224              * 'top_index'.  */
16225
16226             top_index = av_tindex_skip_len_mg(stack);
16227             if (top_index - fence >= 0) {
16228                 /* If the top entry on the stack is an operator, it had better
16229                  * be a '!', otherwise the entry below the top operand should
16230                  * be an operator */
16231                 top_ptr = av_fetch(stack, top_index, FALSE);
16232                 assert(top_ptr);
16233                 if (IS_OPERATOR(*top_ptr)) {
16234
16235                     /* The only permissible operator at the top of the stack is
16236                      * '!', which is applied immediately to this operand. */
16237                     curchar = (char) SvUV(*top_ptr);
16238                     if (curchar != '!') {
16239                         SvREFCNT_dec(current);
16240                         vFAIL2("Unexpected binary operator '%c' with no "
16241                                 "preceding operand", curchar);
16242                     }
16243
16244                     _invlist_invert(current);
16245
16246                     only_to_avoid_leaks = av_pop(stack);
16247                     SvREFCNT_dec(only_to_avoid_leaks);
16248
16249                     /* And we redo with the inverted operand.  This allows
16250                      * handling multiple ! in a row */
16251                     goto handle_operand;
16252                 }
16253                           /* Single operand is ok only for the non-binary ')'
16254                            * operator */
16255                 else if ((top_index - fence == 0 && curchar != ')')
16256                          || (top_index - fence > 0
16257                              && (! (stacked_ptr = av_fetch(stack,
16258                                                            top_index - 1,
16259                                                            FALSE))
16260                                  || IS_OPERAND(*stacked_ptr))))
16261                 {
16262                     SvREFCNT_dec(current);
16263                     vFAIL("Operand with no preceding operator");
16264                 }
16265             }
16266
16267             /* Here there was nothing on the stack or the top element was
16268              * another operand.  Just add this new one */
16269             av_push(stack, current);
16270
16271         } /* End of switch on next parse token */
16272
16273         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16274     } /* End of loop parsing through the construct */
16275
16276     vFAIL("Syntax error in (?[...])");
16277
16278   done:
16279
16280     if (RExC_parse >= RExC_end || RExC_parse[1] != ')') {
16281         if (RExC_parse < RExC_end) {
16282             RExC_parse++;
16283         }
16284
16285         vFAIL("Unexpected ']' with no following ')' in (?[...");
16286     }
16287
16288     if (av_tindex_skip_len_mg(fence_stack) >= 0) {
16289         vFAIL("Unmatched (");
16290     }
16291
16292     if (av_tindex_skip_len_mg(stack) < 0   /* Was empty */
16293         || ((final = av_pop(stack)) == NULL)
16294         || ! IS_OPERAND(final)
16295         || ! is_invlist(final)
16296         || av_tindex_skip_len_mg(stack) >= 0)  /* More left on stack */
16297     {
16298       bad_syntax:
16299         SvREFCNT_dec(final);
16300         vFAIL("Incomplete expression within '(?[ ])'");
16301     }
16302
16303     /* Here, 'final' is the resultant inversion list from evaluating the
16304      * expression.  Return it if so requested */
16305     if (return_invlist) {
16306         *return_invlist = final;
16307         return END;
16308     }
16309
16310     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
16311      * expecting a string of ranges and individual code points */
16312     invlist_iterinit(final);
16313     result_string = newSVpvs("");
16314     while (invlist_iternext(final, &start, &end)) {
16315         if (start == end) {
16316             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
16317         }
16318         else {
16319             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
16320                                                      start,          end);
16321         }
16322     }
16323
16324     /* About to generate an ANYOF (or similar) node from the inversion list we
16325      * have calculated */
16326     save_parse = RExC_parse;
16327     RExC_parse = SvPV(result_string, len);
16328     save_end = RExC_end;
16329     RExC_end = RExC_parse + len;
16330     TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE;
16331
16332     /* We turn off folding around the call, as the class we have constructed
16333      * already has all folding taken into consideration, and we don't want
16334      * regclass() to add to that */
16335     RExC_flags &= ~RXf_PMf_FOLD;
16336     /* regclass() can only return RESTART_PARSE and NEED_UTF8 if multi-char
16337      * folds are allowed.  */
16338     node = regclass(pRExC_state, flagp, depth+1,
16339                     FALSE, /* means parse the whole char class */
16340                     FALSE, /* don't allow multi-char folds */
16341                     TRUE, /* silence non-portable warnings.  The above may very
16342                              well have generated non-portable code points, but
16343                              they're valid on this machine */
16344                     FALSE, /* similarly, no need for strict */
16345                     FALSE, /* Require return to be an ANYOF */
16346                     NULL
16347                 );
16348
16349     RESTORE_WARNINGS;
16350     RExC_parse = save_parse + 1;
16351     RExC_end = save_end;
16352     SvREFCNT_dec_NN(final);
16353     SvREFCNT_dec_NN(result_string);
16354
16355     if (save_fold) {
16356         RExC_flags |= RXf_PMf_FOLD;
16357     }
16358
16359     if (!node)
16360         goto regclass_failed;
16361
16362     /* Fix up the node type if we are in locale.  (We have pretended we are
16363      * under /u for the purposes of regclass(), as this construct will only
16364      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
16365      * as to cause any warnings about bad locales to be output in regexec.c),
16366      * and add the flag that indicates to check if not in a UTF-8 locale.  The
16367      * reason we above forbid optimization into something other than an ANYOF
16368      * node is simply to minimize the number of code changes in regexec.c.
16369      * Otherwise we would have to create new EXACTish node types and deal with
16370      * them.  This decision could be revisited should this construct become
16371      * popular.
16372      *
16373      * (One might think we could look at the resulting ANYOF node and suppress
16374      * the flag if everything is above 255, as those would be UTF-8 only,
16375      * but this isn't true, as the components that led to that result could
16376      * have been locale-affected, and just happen to cancel each other out
16377      * under UTF-8 locales.) */
16378     if (in_locale) {
16379         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
16380
16381         assert(OP(REGNODE_p(node)) == ANYOF);
16382
16383         OP(REGNODE_p(node)) = ANYOFL;
16384         ANYOF_FLAGS(REGNODE_p(node))
16385                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
16386     }
16387
16388     nextchar(pRExC_state);
16389     Set_Node_Length(REGNODE_p(node), RExC_parse - oregcomp_parse + 1); /* MJD */
16390     return node;
16391
16392   regclass_failed:
16393     FAIL2("panic: regclass returned failure to handle_sets, " "flags=%#" UVxf,
16394                                                                 (UV) *flagp);
16395 }
16396
16397 #ifdef ENABLE_REGEX_SETS_DEBUGGING
16398
16399 STATIC void
16400 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
16401                              AV * stack, const IV fence, AV * fence_stack)
16402 {   /* Dumps the stacks in handle_regex_sets() */
16403
16404     const SSize_t stack_top = av_tindex_skip_len_mg(stack);
16405     const SSize_t fence_stack_top = av_tindex_skip_len_mg(fence_stack);
16406     SSize_t i;
16407
16408     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
16409
16410     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
16411
16412     if (stack_top < 0) {
16413         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
16414     }
16415     else {
16416         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
16417         for (i = stack_top; i >= 0; i--) {
16418             SV ** element_ptr = av_fetch(stack, i, FALSE);
16419             if (! element_ptr) {
16420             }
16421
16422             if (IS_OPERATOR(*element_ptr)) {
16423                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
16424                                             (int) i, (int) SvIV(*element_ptr));
16425             }
16426             else {
16427                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
16428                 sv_dump(*element_ptr);
16429             }
16430         }
16431     }
16432
16433     if (fence_stack_top < 0) {
16434         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
16435     }
16436     else {
16437         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
16438         for (i = fence_stack_top; i >= 0; i--) {
16439             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
16440             if (! element_ptr) {
16441             }
16442
16443             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
16444                                             (int) i, (int) SvIV(*element_ptr));
16445         }
16446     }
16447 }
16448
16449 #endif
16450
16451 #undef IS_OPERATOR
16452 #undef IS_OPERAND
16453
16454 STATIC void
16455 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
16456 {
16457     /* This adds the Latin1/above-Latin1 folding rules.
16458      *
16459      * This should be called only for a Latin1-range code points, cp, which is
16460      * known to be involved in a simple fold with other code points above
16461      * Latin1.  It would give false results if /aa has been specified.
16462      * Multi-char folds are outside the scope of this, and must be handled
16463      * specially. */
16464
16465     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
16466
16467     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
16468
16469     /* The rules that are valid for all Unicode versions are hard-coded in */
16470     switch (cp) {
16471         case 'k':
16472         case 'K':
16473           *invlist =
16474              add_cp_to_invlist(*invlist, KELVIN_SIGN);
16475             break;
16476         case 's':
16477         case 'S':
16478           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
16479             break;
16480         case MICRO_SIGN:
16481           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
16482           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
16483             break;
16484         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
16485         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
16486           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
16487             break;
16488         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
16489           *invlist = add_cp_to_invlist(*invlist,
16490                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
16491             break;
16492
16493         default:    /* Other code points are checked against the data for the
16494                        current Unicode version */
16495           {
16496             Size_t folds_count;
16497             unsigned int first_fold;
16498             const unsigned int * remaining_folds;
16499             UV folded_cp;
16500
16501             if (isASCII(cp)) {
16502                 folded_cp = toFOLD(cp);
16503             }
16504             else {
16505                 U8 dummy_fold[UTF8_MAXBYTES_CASE+1];
16506                 Size_t dummy_len;
16507                 folded_cp = _to_fold_latin1(cp, dummy_fold, &dummy_len, 0);
16508             }
16509
16510             if (folded_cp > 255) {
16511                 *invlist = add_cp_to_invlist(*invlist, folded_cp);
16512             }
16513
16514             folds_count = _inverse_folds(folded_cp, &first_fold,
16515                                                     &remaining_folds);
16516             if (folds_count == 0) {
16517
16518                 /* Use deprecated warning to increase the chances of this being
16519                  * output */
16520                 ckWARN2reg_d(RExC_parse,
16521                         "Perl folding rules are not up-to-date for 0x%02X;"
16522                         " please use the perlbug utility to report;", cp);
16523             }
16524             else {
16525                 unsigned int i;
16526
16527                 if (first_fold > 255) {
16528                     *invlist = add_cp_to_invlist(*invlist, first_fold);
16529                 }
16530                 for (i = 0; i < folds_count - 1; i++) {
16531                     if (remaining_folds[i] > 255) {
16532                         *invlist = add_cp_to_invlist(*invlist,
16533                                                     remaining_folds[i]);
16534                     }
16535                 }
16536             }
16537             break;
16538          }
16539     }
16540 }
16541
16542 STATIC void
16543 S_output_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings)
16544 {
16545     /* Output the elements of the array given by '*posix_warnings' as REGEXP
16546      * warnings. */
16547
16548     SV * msg;
16549     const bool first_is_fatal = ckDEAD(packWARN(WARN_REGEXP));
16550
16551     PERL_ARGS_ASSERT_OUTPUT_POSIX_WARNINGS;
16552
16553     if (! TO_OUTPUT_WARNINGS(RExC_parse)) {
16554         return;
16555     }
16556
16557     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
16558         if (first_is_fatal) {           /* Avoid leaking this */
16559             av_undef(posix_warnings);   /* This isn't necessary if the
16560                                             array is mortal, but is a
16561                                             fail-safe */
16562             (void) sv_2mortal(msg);
16563             PREPARE_TO_DIE;
16564         }
16565         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
16566         SvREFCNT_dec_NN(msg);
16567     }
16568
16569     UPDATE_WARNINGS_LOC(RExC_parse);
16570 }
16571
16572 STATIC AV *
16573 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
16574 {
16575     /* This adds the string scalar <multi_string> to the array
16576      * <multi_char_matches>.  <multi_string> is known to have exactly
16577      * <cp_count> code points in it.  This is used when constructing a
16578      * bracketed character class and we find something that needs to match more
16579      * than a single character.
16580      *
16581      * <multi_char_matches> is actually an array of arrays.  Each top-level
16582      * element is an array that contains all the strings known so far that are
16583      * the same length.  And that length (in number of code points) is the same
16584      * as the index of the top-level array.  Hence, the [2] element is an
16585      * array, each element thereof is a string containing TWO code points;
16586      * while element [3] is for strings of THREE characters, and so on.  Since
16587      * this is for multi-char strings there can never be a [0] nor [1] element.
16588      *
16589      * When we rewrite the character class below, we will do so such that the
16590      * longest strings are written first, so that it prefers the longest
16591      * matching strings first.  This is done even if it turns out that any
16592      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
16593      * Christiansen has agreed that this is ok.  This makes the test for the
16594      * ligature 'ffi' come before the test for 'ff', for example */
16595
16596     AV* this_array;
16597     AV** this_array_ptr;
16598
16599     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
16600
16601     if (! multi_char_matches) {
16602         multi_char_matches = newAV();
16603     }
16604
16605     if (av_exists(multi_char_matches, cp_count)) {
16606         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
16607         this_array = *this_array_ptr;
16608     }
16609     else {
16610         this_array = newAV();
16611         av_store(multi_char_matches, cp_count,
16612                  (SV*) this_array);
16613     }
16614     av_push(this_array, multi_string);
16615
16616     return multi_char_matches;
16617 }
16618
16619 /* The names of properties whose definitions are not known at compile time are
16620  * stored in this SV, after a constant heading.  So if the length has been
16621  * changed since initialization, then there is a run-time definition. */
16622 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
16623                                         (SvCUR(listsv) != initial_listsv_len)
16624
16625 /* There is a restricted set of white space characters that are legal when
16626  * ignoring white space in a bracketed character class.  This generates the
16627  * code to skip them.
16628  *
16629  * There is a line below that uses the same white space criteria but is outside
16630  * this macro.  Both here and there must use the same definition */
16631 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
16632     STMT_START {                                                        \
16633         if (do_skip) {                                                  \
16634             while (isBLANK_A(UCHARAT(p)))                               \
16635             {                                                           \
16636                 p++;                                                    \
16637             }                                                           \
16638         }                                                               \
16639     } STMT_END
16640
16641 STATIC regnode_offset
16642 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
16643                  const bool stop_at_1,  /* Just parse the next thing, don't
16644                                            look for a full character class */
16645                  bool allow_mutiple_chars,
16646                  const bool silence_non_portable,   /* Don't output warnings
16647                                                        about too large
16648                                                        characters */
16649                  const bool strict,
16650                  bool optimizable,                  /* ? Allow a non-ANYOF return
16651                                                        node */
16652                  SV** ret_invlist  /* Return an inversion list, not a node */
16653           )
16654 {
16655     /* parse a bracketed class specification.  Most of these will produce an
16656      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
16657      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
16658      * under /i with multi-character folds: it will be rewritten following the
16659      * paradigm of this example, where the <multi-fold>s are characters which
16660      * fold to multiple character sequences:
16661      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
16662      * gets effectively rewritten as:
16663      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
16664      * reg() gets called (recursively) on the rewritten version, and this
16665      * function will return what it constructs.  (Actually the <multi-fold>s
16666      * aren't physically removed from the [abcdefghi], it's just that they are
16667      * ignored in the recursion by means of a flag:
16668      * <RExC_in_multi_char_class>.)
16669      *
16670      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
16671      * characters, with the corresponding bit set if that character is in the
16672      * list.  For characters above this, an inversion list is used.  There
16673      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
16674      * determinable at compile time
16675      *
16676      * On success, returns the offset at which any next node should be placed
16677      * into the regex engine program being compiled.
16678      *
16679      * Returns 0 otherwise, setting flagp to RESTART_PARSE if the parse needs
16680      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to
16681      * UTF-8
16682      */
16683
16684     dVAR;
16685     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
16686     IV range = 0;
16687     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
16688     regnode_offset ret = -1;    /* Initialized to an illegal value */
16689     STRLEN numlen;
16690     int namedclass = OOB_NAMEDCLASS;
16691     char *rangebegin = NULL;
16692     SV *listsv = NULL;      /* List of \p{user-defined} whose definitions
16693                                aren't available at the time this was called */
16694     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
16695                                       than just initialized.  */
16696     SV* properties = NULL;    /* Code points that match \p{} \P{} */
16697     SV* posixes = NULL;     /* Code points that match classes like [:word:],
16698                                extended beyond the Latin1 range.  These have to
16699                                be kept separate from other code points for much
16700                                of this function because their handling  is
16701                                different under /i, and for most classes under
16702                                /d as well */
16703     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
16704                                separate for a while from the non-complemented
16705                                versions because of complications with /d
16706                                matching */
16707     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
16708                                   treated more simply than the general case,
16709                                   leading to less compilation and execution
16710                                   work */
16711     UV element_count = 0;   /* Number of distinct elements in the class.
16712                                Optimizations may be possible if this is tiny */
16713     AV * multi_char_matches = NULL; /* Code points that fold to more than one
16714                                        character; used under /i */
16715     UV n;
16716     char * stop_ptr = RExC_end;    /* where to stop parsing */
16717
16718     /* ignore unescaped whitespace? */
16719     const bool skip_white = cBOOL(   ret_invlist
16720                                   || (RExC_flags & RXf_PMf_EXTENDED_MORE));
16721
16722     /* inversion list of code points this node matches only when the target
16723      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
16724      * /d) */
16725     SV* upper_latin1_only_utf8_matches = NULL;
16726
16727     /* Inversion list of code points this node matches regardless of things
16728      * like locale, folding, utf8ness of the target string */
16729     SV* cp_list = NULL;
16730
16731     /* Like cp_list, but code points on this list need to be checked for things
16732      * that fold to/from them under /i */
16733     SV* cp_foldable_list = NULL;
16734
16735     /* Like cp_list, but code points on this list are valid only when the
16736      * runtime locale is UTF-8 */
16737     SV* only_utf8_locale_list = NULL;
16738
16739     /* In a range, if one of the endpoints is non-character-set portable,
16740      * meaning that it hard-codes a code point that may mean a different
16741      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
16742      * mnemonic '\t' which each mean the same character no matter which
16743      * character set the platform is on. */
16744     unsigned int non_portable_endpoint = 0;
16745
16746     /* Is the range unicode? which means on a platform that isn't 1-1 native
16747      * to Unicode (i.e. non-ASCII), each code point in it should be considered
16748      * to be a Unicode value.  */
16749     bool unicode_range = FALSE;
16750     bool invert = FALSE;    /* Is this class to be complemented */
16751
16752     bool warn_super = ALWAYS_WARN_SUPER;
16753
16754     const char * orig_parse = RExC_parse;
16755
16756     /* This variable is used to mark where the end in the input is of something
16757      * that looks like a POSIX construct but isn't.  During the parse, when
16758      * something looks like it could be such a construct is encountered, it is
16759      * checked for being one, but not if we've already checked this area of the
16760      * input.  Only after this position is reached do we check again */
16761     char *not_posix_region_end = RExC_parse - 1;
16762
16763     AV* posix_warnings = NULL;
16764     const bool do_posix_warnings = ckWARN(WARN_REGEXP);
16765     U8 op = END;    /* The returned node-type, initialized to an impossible
16766                        one.  */
16767     U8 anyof_flags = 0;   /* flag bits if the node is an ANYOF-type */
16768     U32 posixl = 0;       /* bit field of posix classes matched under /l */
16769
16770
16771 /* Flags as to what things aren't knowable until runtime.  (Note that these are
16772  * mutually exclusive.) */
16773 #define HAS_USER_DEFINED_PROPERTY 0x01   /* /u any user-defined properties that
16774                                             haven't been defined as of yet */
16775 #define HAS_D_RUNTIME_DEPENDENCY  0x02   /* /d if the target being matched is
16776                                             UTF-8 or not */
16777 #define HAS_L_RUNTIME_DEPENDENCY   0x04 /* /l what the posix classes match and
16778                                             what gets folded */
16779     U32 has_runtime_dependency = 0;     /* OR of the above flags */
16780
16781     GET_RE_DEBUG_FLAGS_DECL;
16782
16783     PERL_ARGS_ASSERT_REGCLASS;
16784 #ifndef DEBUGGING
16785     PERL_UNUSED_ARG(depth);
16786 #endif
16787
16788
16789     /* If wants an inversion list returned, we can't optimize to something
16790      * else. */
16791     if (ret_invlist) {
16792         optimizable = FALSE;
16793     }
16794
16795     DEBUG_PARSE("clas");
16796
16797 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
16798     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
16799                                    && UNICODE_DOT_DOT_VERSION == 0)
16800     allow_mutiple_chars = FALSE;
16801 #endif
16802
16803     /* We include the /i status at the beginning of this so that we can
16804      * know it at runtime */
16805     listsv = sv_2mortal(Perl_newSVpvf(aTHX_ "#%d\n", cBOOL(FOLD)));
16806     initial_listsv_len = SvCUR(listsv);
16807     SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
16808
16809     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16810
16811     assert(RExC_parse <= RExC_end);
16812
16813     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
16814         RExC_parse++;
16815         invert = TRUE;
16816         allow_mutiple_chars = FALSE;
16817         MARK_NAUGHTY(1);
16818         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16819     }
16820
16821     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
16822     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
16823         int maybe_class = handle_possible_posix(pRExC_state,
16824                                                 RExC_parse,
16825                                                 &not_posix_region_end,
16826                                                 NULL,
16827                                                 TRUE /* checking only */);
16828         if (maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
16829             ckWARN4reg(not_posix_region_end,
16830                     "POSIX syntax [%c %c] belongs inside character classes%s",
16831                     *RExC_parse, *RExC_parse,
16832                     (maybe_class == OOB_NAMEDCLASS)
16833                     ? ((POSIXCC_NOTYET(*RExC_parse))
16834                         ? " (but this one isn't implemented)"
16835                         : " (but this one isn't fully valid)")
16836                     : ""
16837                     );
16838         }
16839     }
16840
16841     /* If the caller wants us to just parse a single element, accomplish this
16842      * by faking the loop ending condition */
16843     if (stop_at_1 && RExC_end > RExC_parse) {
16844         stop_ptr = RExC_parse + 1;
16845     }
16846
16847     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
16848     if (UCHARAT(RExC_parse) == ']')
16849         goto charclassloop;
16850
16851     while (1) {
16852
16853         if (   posix_warnings
16854             && av_tindex_skip_len_mg(posix_warnings) >= 0
16855             && RExC_parse > not_posix_region_end)
16856         {
16857             /* Warnings about posix class issues are considered tentative until
16858              * we are far enough along in the parse that we can no longer
16859              * change our mind, at which point we output them.  This is done
16860              * each time through the loop so that a later class won't zap them
16861              * before they have been dealt with. */
16862             output_posix_warnings(pRExC_state, posix_warnings);
16863         }
16864
16865         if  (RExC_parse >= stop_ptr) {
16866             break;
16867         }
16868
16869         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16870
16871         if  (UCHARAT(RExC_parse) == ']') {
16872             break;
16873         }
16874
16875       charclassloop:
16876
16877         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
16878         save_value = value;
16879         save_prevvalue = prevvalue;
16880
16881         if (!range) {
16882             rangebegin = RExC_parse;
16883             element_count++;
16884             non_portable_endpoint = 0;
16885         }
16886         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
16887             value = utf8n_to_uvchr((U8*)RExC_parse,
16888                                    RExC_end - RExC_parse,
16889                                    &numlen, UTF8_ALLOW_DEFAULT);
16890             RExC_parse += numlen;
16891         }
16892         else
16893             value = UCHARAT(RExC_parse++);
16894
16895         if (value == '[') {
16896             char * posix_class_end;
16897             namedclass = handle_possible_posix(pRExC_state,
16898                                                RExC_parse,
16899                                                &posix_class_end,
16900                                                do_posix_warnings ? &posix_warnings : NULL,
16901                                                FALSE    /* die if error */);
16902             if (namedclass > OOB_NAMEDCLASS) {
16903
16904                 /* If there was an earlier attempt to parse this particular
16905                  * posix class, and it failed, it was a false alarm, as this
16906                  * successful one proves */
16907                 if (   posix_warnings
16908                     && av_tindex_skip_len_mg(posix_warnings) >= 0
16909                     && not_posix_region_end >= RExC_parse
16910                     && not_posix_region_end <= posix_class_end)
16911                 {
16912                     av_undef(posix_warnings);
16913                 }
16914
16915                 RExC_parse = posix_class_end;
16916             }
16917             else if (namedclass == OOB_NAMEDCLASS) {
16918                 not_posix_region_end = posix_class_end;
16919             }
16920             else {
16921                 namedclass = OOB_NAMEDCLASS;
16922             }
16923         }
16924         else if (   RExC_parse - 1 > not_posix_region_end
16925                  && MAYBE_POSIXCC(value))
16926         {
16927             (void) handle_possible_posix(
16928                         pRExC_state,
16929                         RExC_parse - 1,  /* -1 because parse has already been
16930                                             advanced */
16931                         &not_posix_region_end,
16932                         do_posix_warnings ? &posix_warnings : NULL,
16933                         TRUE /* checking only */);
16934         }
16935         else if (  strict && ! skip_white
16936                  && (   _generic_isCC(value, _CC_VERTSPACE)
16937                      || is_VERTWS_cp_high(value)))
16938         {
16939             vFAIL("Literal vertical space in [] is illegal except under /x");
16940         }
16941         else if (value == '\\') {
16942             /* Is a backslash; get the code point of the char after it */
16943
16944             if (RExC_parse >= RExC_end) {
16945                 vFAIL("Unmatched [");
16946             }
16947
16948             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16949                 value = utf8n_to_uvchr((U8*)RExC_parse,
16950                                    RExC_end - RExC_parse,
16951                                    &numlen, UTF8_ALLOW_DEFAULT);
16952                 RExC_parse += numlen;
16953             }
16954             else
16955                 value = UCHARAT(RExC_parse++);
16956
16957             /* Some compilers cannot handle switching on 64-bit integer
16958              * values, therefore value cannot be an UV.  Yes, this will
16959              * be a problem later if we want switch on Unicode.
16960              * A similar issue a little bit later when switching on
16961              * namedclass. --jhi */
16962
16963             /* If the \ is escaping white space when white space is being
16964              * skipped, it means that that white space is wanted literally, and
16965              * is already in 'value'.  Otherwise, need to translate the escape
16966              * into what it signifies. */
16967             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16968
16969             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16970             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16971             case 's':   namedclass = ANYOF_SPACE;       break;
16972             case 'S':   namedclass = ANYOF_NSPACE;      break;
16973             case 'd':   namedclass = ANYOF_DIGIT;       break;
16974             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16975             case 'v':   namedclass = ANYOF_VERTWS;      break;
16976             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16977             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16978             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16979             case 'N':  /* Handle \N{NAME} in class */
16980                 {
16981                     const char * const backslash_N_beg = RExC_parse - 2;
16982                     int cp_count;
16983
16984                     if (! grok_bslash_N(pRExC_state,
16985                                         NULL,      /* No regnode */
16986                                         &value,    /* Yes single value */
16987                                         &cp_count, /* Multiple code pt count */
16988                                         flagp,
16989                                         strict,
16990                                         depth)
16991                     ) {
16992
16993                         if (*flagp & NEED_UTF8)
16994                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16995
16996                         RETURN_FAIL_ON_RESTART_FLAGP(flagp);
16997
16998                         if (cp_count < 0) {
16999                             vFAIL("\\N in a character class must be a named character: \\N{...}");
17000                         }
17001                         else if (cp_count == 0) {
17002                             ckWARNreg(RExC_parse,
17003                               "Ignoring zero length \\N{} in character class");
17004                         }
17005                         else { /* cp_count > 1 */
17006                             assert(cp_count > 1);
17007                             if (! RExC_in_multi_char_class) {
17008                                 if ( ! allow_mutiple_chars
17009                                     || invert
17010                                     || range
17011                                     || *RExC_parse == '-')
17012                                 {
17013                                     if (strict) {
17014                                         RExC_parse--;
17015                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
17016                                     }
17017                                     ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
17018                                     break; /* <value> contains the first code
17019                                               point. Drop out of the switch to
17020                                               process it */
17021                                 }
17022                                 else {
17023                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
17024                                                  RExC_parse - backslash_N_beg);
17025                                     multi_char_matches
17026                                         = add_multi_match(multi_char_matches,
17027                                                           multi_char_N,
17028                                                           cp_count);
17029                                 }
17030                             }
17031                         } /* End of cp_count != 1 */
17032
17033                         /* This element should not be processed further in this
17034                          * class */
17035                         element_count--;
17036                         value = save_value;
17037                         prevvalue = save_prevvalue;
17038                         continue;   /* Back to top of loop to get next char */
17039                     }
17040
17041                     /* Here, is a single code point, and <value> contains it */
17042                     unicode_range = TRUE;   /* \N{} are Unicode */
17043                 }
17044                 break;
17045             case 'p':
17046             case 'P':
17047                 {
17048                 char *e;
17049
17050                 /* \p means they want Unicode semantics */
17051                 REQUIRE_UNI_RULES(flagp, 0);
17052
17053                 if (RExC_parse >= RExC_end)
17054                     vFAIL2("Empty \\%c", (U8)value);
17055                 if (*RExC_parse == '{') {
17056                     const U8 c = (U8)value;
17057                     e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse);
17058                     if (!e) {
17059                         RExC_parse++;
17060                         vFAIL2("Missing right brace on \\%c{}", c);
17061                     }
17062
17063                     RExC_parse++;
17064
17065                     /* White space is allowed adjacent to the braces and after
17066                      * any '^', even when not under /x */
17067                     while (isSPACE(*RExC_parse)) {
17068                          RExC_parse++;
17069                     }
17070
17071                     if (UCHARAT(RExC_parse) == '^') {
17072
17073                         /* toggle.  (The rhs xor gets the single bit that
17074                          * differs between P and p; the other xor inverts just
17075                          * that bit) */
17076                         value ^= 'P' ^ 'p';
17077
17078                         RExC_parse++;
17079                         while (isSPACE(*RExC_parse)) {
17080                             RExC_parse++;
17081                         }
17082                     }
17083
17084                     if (e == RExC_parse)
17085                         vFAIL2("Empty \\%c{}", c);
17086
17087                     n = e - RExC_parse;
17088                     while (isSPACE(*(RExC_parse + n - 1)))
17089                         n--;
17090
17091                 }   /* The \p isn't immediately followed by a '{' */
17092                 else if (! isALPHA(*RExC_parse)) {
17093                     RExC_parse += (UTF)
17094                                   ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17095                                   : 1;
17096                     vFAIL2("Character following \\%c must be '{' or a "
17097                            "single-character Unicode property name",
17098                            (U8) value);
17099                 }
17100                 else {
17101                     e = RExC_parse;
17102                     n = 1;
17103                 }
17104                 {
17105                     char* name = RExC_parse;
17106
17107                     /* Any message returned about expanding the definition */
17108                     SV* msg = newSVpvs_flags("", SVs_TEMP);
17109
17110                     /* If set TRUE, the property is user-defined as opposed to
17111                      * official Unicode */
17112                     bool user_defined = FALSE;
17113
17114                     SV * prop_definition = parse_uniprop_string(
17115                                             name, n, UTF, FOLD,
17116                                             FALSE, /* This is compile-time */
17117
17118                                             /* We can't defer this defn when
17119                                              * the full result is required in
17120                                              * this call */
17121                                             ! cBOOL(ret_invlist),
17122
17123                                             &user_defined,
17124                                             msg,
17125                                             0 /* Base level */
17126                                            );
17127                     if (SvCUR(msg)) {   /* Assumes any error causes a msg */
17128                         assert(prop_definition == NULL);
17129                         RExC_parse = e + 1;
17130                         if (SvUTF8(msg)) {  /* msg being UTF-8 makes the whole
17131                                                thing so, or else the display is
17132                                                mojibake */
17133                             RExC_utf8 = TRUE;
17134                         }
17135                         /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */
17136                         vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg),
17137                                     SvCUR(msg), SvPVX(msg)));
17138                     }
17139
17140                     if (! is_invlist(prop_definition)) {
17141
17142                         /* Here, the definition isn't known, so we have gotten
17143                          * returned a string that will be evaluated if and when
17144                          * encountered at runtime.  We add it to the list of
17145                          * such properties, along with whether it should be
17146                          * complemented or not */
17147                         if (value == 'P') {
17148                             sv_catpvs(listsv, "!");
17149                         }
17150                         else {
17151                             sv_catpvs(listsv, "+");
17152                         }
17153                         sv_catsv(listsv, prop_definition);
17154
17155                         has_runtime_dependency |= HAS_USER_DEFINED_PROPERTY;
17156
17157                         /* We don't know yet what this matches, so have to flag
17158                          * it */
17159                         anyof_flags |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17160                     }
17161                     else {
17162                         assert (prop_definition && is_invlist(prop_definition));
17163
17164                         /* Here we do have the complete property definition
17165                          *
17166                          * Temporary workaround for [perl #133136].  For this
17167                          * precise input that is in the .t that is failing,
17168                          * load utf8.pm, which is what the test wants, so that
17169                          * that .t passes */
17170                         if (     memEQs(RExC_start, e + 1 - RExC_start,
17171                                         "foo\\p{Alnum}")
17172                             && ! hv_common(GvHVn(PL_incgv),
17173                                            NULL,
17174                                            "utf8.pm", sizeof("utf8.pm") - 1,
17175                                            0, HV_FETCH_ISEXISTS, NULL, 0))
17176                         {
17177                             require_pv("utf8.pm");
17178                         }
17179
17180                         if (! user_defined &&
17181                             /* We warn on matching an above-Unicode code point
17182                              * if the match would return true, except don't
17183                              * warn for \p{All}, which has exactly one element
17184                              * = 0 */
17185                             (_invlist_contains_cp(prop_definition, 0x110000)
17186                                 && (! (_invlist_len(prop_definition) == 1
17187                                        && *invlist_array(prop_definition) == 0))))
17188                         {
17189                             warn_super = TRUE;
17190                         }
17191
17192                         /* Invert if asking for the complement */
17193                         if (value == 'P') {
17194                             _invlist_union_complement_2nd(properties,
17195                                                           prop_definition,
17196                                                           &properties);
17197                         }
17198                         else {
17199                             _invlist_union(properties, prop_definition, &properties);
17200                         }
17201                     }
17202                 }
17203
17204                 RExC_parse = e + 1;
17205                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
17206                                                 named */
17207                 }
17208                 break;
17209             case 'n':   value = '\n';                   break;
17210             case 'r':   value = '\r';                   break;
17211             case 't':   value = '\t';                   break;
17212             case 'f':   value = '\f';                   break;
17213             case 'b':   value = '\b';                   break;
17214             case 'e':   value = ESC_NATIVE;             break;
17215             case 'a':   value = '\a';                   break;
17216             case 'o':
17217                 RExC_parse--;   /* function expects to be pointed at the 'o' */
17218                 {
17219                     const char* error_msg;
17220                     bool valid = grok_bslash_o(&RExC_parse,
17221                                                RExC_end,
17222                                                &value,
17223                                                &error_msg,
17224                                                TO_OUTPUT_WARNINGS(RExC_parse),
17225                                                strict,
17226                                                silence_non_portable,
17227                                                UTF);
17228                     if (! valid) {
17229                         vFAIL(error_msg);
17230                     }
17231                     UPDATE_WARNINGS_LOC(RExC_parse - 1);
17232                 }
17233                 non_portable_endpoint++;
17234                 break;
17235             case 'x':
17236                 RExC_parse--;   /* function expects to be pointed at the 'x' */
17237                 {
17238                     const char* error_msg;
17239                     bool valid = grok_bslash_x(&RExC_parse,
17240                                                RExC_end,
17241                                                &value,
17242                                                &error_msg,
17243                                                TO_OUTPUT_WARNINGS(RExC_parse),
17244                                                strict,
17245                                                silence_non_portable,
17246                                                UTF);
17247                     if (! valid) {
17248                         vFAIL(error_msg);
17249                     }
17250                     UPDATE_WARNINGS_LOC(RExC_parse - 1);
17251                 }
17252                 non_portable_endpoint++;
17253                 break;
17254             case 'c':
17255                 value = grok_bslash_c(*RExC_parse, TO_OUTPUT_WARNINGS(RExC_parse));
17256                 UPDATE_WARNINGS_LOC(RExC_parse);
17257                 RExC_parse++;
17258                 non_portable_endpoint++;
17259                 break;
17260             case '0': case '1': case '2': case '3': case '4':
17261             case '5': case '6': case '7':
17262                 {
17263                     /* Take 1-3 octal digits */
17264                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
17265                     numlen = (strict) ? 4 : 3;
17266                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
17267                     RExC_parse += numlen;
17268                     if (numlen != 3) {
17269                         if (strict) {
17270                             RExC_parse += (UTF)
17271                                           ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
17272                                           : 1;
17273                             vFAIL("Need exactly 3 octal digits");
17274                         }
17275                         else if (   numlen < 3 /* like \08, \178 */
17276                                  && RExC_parse < RExC_end
17277                                  && isDIGIT(*RExC_parse)
17278                                  && ckWARN(WARN_REGEXP))
17279                         {
17280                             reg_warn_non_literal_string(
17281                                  RExC_parse + 1,
17282                                  form_short_octal_warning(RExC_parse, numlen));
17283                         }
17284                     }
17285                     non_portable_endpoint++;
17286                     break;
17287                 }
17288             default:
17289                 /* Allow \_ to not give an error */
17290                 if (isWORDCHAR(value) && value != '_') {
17291                     if (strict) {
17292                         vFAIL2("Unrecognized escape \\%c in character class",
17293                                (int)value);
17294                     }
17295                     else {
17296                         ckWARN2reg(RExC_parse,
17297                             "Unrecognized escape \\%c in character class passed through",
17298                             (int)value);
17299                     }
17300                 }
17301                 break;
17302             }   /* End of switch on char following backslash */
17303         } /* end of handling backslash escape sequences */
17304
17305         /* Here, we have the current token in 'value' */
17306
17307         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
17308             U8 classnum;
17309
17310             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
17311              * literal, as is the character that began the false range, i.e.
17312              * the 'a' in the examples */
17313             if (range) {
17314                 const int w = (RExC_parse >= rangebegin)
17315                                 ? RExC_parse - rangebegin
17316                                 : 0;
17317                 if (strict) {
17318                     vFAIL2utf8f(
17319                         "False [] range \"%" UTF8f "\"",
17320                         UTF8fARG(UTF, w, rangebegin));
17321                 }
17322                 else {
17323                     ckWARN2reg(RExC_parse,
17324                         "False [] range \"%" UTF8f "\"",
17325                         UTF8fARG(UTF, w, rangebegin));
17326                     cp_list = add_cp_to_invlist(cp_list, '-');
17327                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
17328                                                             prevvalue);
17329                 }
17330
17331                 range = 0; /* this was not a true range */
17332                 element_count += 2; /* So counts for three values */
17333             }
17334
17335             classnum = namedclass_to_classnum(namedclass);
17336
17337             if (LOC && namedclass < ANYOF_POSIXL_MAX
17338 #ifndef HAS_ISASCII
17339                 && classnum != _CC_ASCII
17340 #endif
17341             ) {
17342                 SV* scratch_list = NULL;
17343
17344                 /* What the Posix classes (like \w, [:space:]) match isn't
17345                  * generally knowable under locale until actual match time.  A
17346                  * special node is used for these which has extra space for a
17347                  * bitmap, with a bit reserved for each named class that is to
17348                  * be matched against.  (This isn't needed for \p{} and
17349                  * pseudo-classes, as they are not affected by locale, and
17350                  * hence are dealt with separately.)  However, if a named class
17351                  * and its complement are both present, then it matches
17352                  * everything, and there is no runtime dependency.  Odd numbers
17353                  * are the complements of the next lower number, so xor works.
17354                  * (Note that something like [\w\D] should match everything,
17355                  * because \d should be a proper subset of \w.  But rather than
17356                  * trust that the locale is well behaved, we leave this to
17357                  * runtime to sort out) */
17358                 if (POSIXL_TEST(posixl, namedclass ^ 1)) {
17359                     cp_list = _add_range_to_invlist(cp_list, 0, UV_MAX);
17360                     POSIXL_ZERO(posixl);
17361                     has_runtime_dependency &= ~HAS_L_RUNTIME_DEPENDENCY;
17362                     anyof_flags &= ~ANYOF_MATCHES_POSIXL;
17363                     continue;   /* We could ignore the rest of the class, but
17364                                    best to parse it for any errors */
17365                 }
17366                 else { /* Here, isn't the complement of any already parsed
17367                           class */
17368                     POSIXL_SET(posixl, namedclass);
17369                     has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
17370                     anyof_flags |= ANYOF_MATCHES_POSIXL;
17371
17372                     /* The above-Latin1 characters are not subject to locale
17373                      * rules.  Just add them to the unconditionally-matched
17374                      * list */
17375
17376                     /* Get the list of the above-Latin1 code points this
17377                      * matches */
17378                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
17379                                             PL_XPosix_ptrs[classnum],
17380
17381                                             /* Odd numbers are complements,
17382                                              * like NDIGIT, NASCII, ... */
17383                                             namedclass % 2 != 0,
17384                                             &scratch_list);
17385                     /* Checking if 'cp_list' is NULL first saves an extra
17386                      * clone.  Its reference count will be decremented at the
17387                      * next union, etc, or if this is the only instance, at the
17388                      * end of the routine */
17389                     if (! cp_list) {
17390                         cp_list = scratch_list;
17391                     }
17392                     else {
17393                         _invlist_union(cp_list, scratch_list, &cp_list);
17394                         SvREFCNT_dec_NN(scratch_list);
17395                     }
17396                     continue;   /* Go get next character */
17397                 }
17398             }
17399             else {
17400
17401                 /* Here, is not /l, or is a POSIX class for which /l doesn't
17402                  * matter (or is a Unicode property, which is skipped here). */
17403                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
17404                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
17405
17406                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
17407                          * nor /l make a difference in what these match,
17408                          * therefore we just add what they match to cp_list. */
17409                         if (classnum != _CC_VERTSPACE) {
17410                             assert(   namedclass == ANYOF_HORIZWS
17411                                    || namedclass == ANYOF_NHORIZWS);
17412
17413                             /* It turns out that \h is just a synonym for
17414                              * XPosixBlank */
17415                             classnum = _CC_BLANK;
17416                         }
17417
17418                         _invlist_union_maybe_complement_2nd(
17419                                 cp_list,
17420                                 PL_XPosix_ptrs[classnum],
17421                                 namedclass % 2 != 0,    /* Complement if odd
17422                                                           (NHORIZWS, NVERTWS)
17423                                                         */
17424                                 &cp_list);
17425                     }
17426                 }
17427                 else if (   AT_LEAST_UNI_SEMANTICS
17428                          || classnum == _CC_ASCII
17429                          || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
17430                                                    || classnum == _CC_XDIGIT)))
17431                 {
17432                     /* We usually have to worry about /d affecting what POSIX
17433                      * classes match, with special code needed because we won't
17434                      * know until runtime what all matches.  But there is no
17435                      * extra work needed under /u and /a; and [:ascii:] is
17436                      * unaffected by /d; and :digit: and :xdigit: don't have
17437                      * runtime differences under /d.  So we can special case
17438                      * these, and avoid some extra work below, and at runtime.
17439                      * */
17440                     _invlist_union_maybe_complement_2nd(
17441                                                      simple_posixes,
17442                                                       ((AT_LEAST_ASCII_RESTRICTED)
17443                                                        ? PL_Posix_ptrs[classnum]
17444                                                        : PL_XPosix_ptrs[classnum]),
17445                                                      namedclass % 2 != 0,
17446                                                      &simple_posixes);
17447                 }
17448                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
17449                            complement and use nposixes */
17450                     SV** posixes_ptr = namedclass % 2 == 0
17451                                        ? &posixes
17452                                        : &nposixes;
17453                     _invlist_union_maybe_complement_2nd(
17454                                                      *posixes_ptr,
17455                                                      PL_XPosix_ptrs[classnum],
17456                                                      namedclass % 2 != 0,
17457                                                      posixes_ptr);
17458                 }
17459             }
17460         } /* end of namedclass \blah */
17461
17462         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
17463
17464         /* If 'range' is set, 'value' is the ending of a range--check its
17465          * validity.  (If value isn't a single code point in the case of a
17466          * range, we should have figured that out above in the code that
17467          * catches false ranges).  Later, we will handle each individual code
17468          * point in the range.  If 'range' isn't set, this could be the
17469          * beginning of a range, so check for that by looking ahead to see if
17470          * the next real character to be processed is the range indicator--the
17471          * minus sign */
17472
17473         if (range) {
17474 #ifdef EBCDIC
17475             /* For unicode ranges, we have to test that the Unicode as opposed
17476              * to the native values are not decreasing.  (Above 255, there is
17477              * no difference between native and Unicode) */
17478             if (unicode_range && prevvalue < 255 && value < 255) {
17479                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
17480                     goto backwards_range;
17481                 }
17482             }
17483             else
17484 #endif
17485             if (prevvalue > value) /* b-a */ {
17486                 int w;
17487 #ifdef EBCDIC
17488               backwards_range:
17489 #endif
17490                 w = RExC_parse - rangebegin;
17491                 vFAIL2utf8f(
17492                     "Invalid [] range \"%" UTF8f "\"",
17493                     UTF8fARG(UTF, w, rangebegin));
17494                 NOT_REACHED; /* NOTREACHED */
17495             }
17496         }
17497         else {
17498             prevvalue = value; /* save the beginning of the potential range */
17499             if (! stop_at_1     /* Can't be a range if parsing just one thing */
17500                 && *RExC_parse == '-')
17501             {
17502                 char* next_char_ptr = RExC_parse + 1;
17503
17504                 /* Get the next real char after the '-' */
17505                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
17506
17507                 /* If the '-' is at the end of the class (just before the ']',
17508                  * it is a literal minus; otherwise it is a range */
17509                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
17510                     RExC_parse = next_char_ptr;
17511
17512                     /* a bad range like \w-, [:word:]- ? */
17513                     if (namedclass > OOB_NAMEDCLASS) {
17514                         if (strict || ckWARN(WARN_REGEXP)) {
17515                             const int w = RExC_parse >= rangebegin
17516                                           ?  RExC_parse - rangebegin
17517                                           : 0;
17518                             if (strict) {
17519                                 vFAIL4("False [] range \"%*.*s\"",
17520                                     w, w, rangebegin);
17521                             }
17522                             else {
17523                                 vWARN4(RExC_parse,
17524                                     "False [] range \"%*.*s\"",
17525                                     w, w, rangebegin);
17526                             }
17527                         }
17528                         cp_list = add_cp_to_invlist(cp_list, '-');
17529                         element_count++;
17530                     } else
17531                         range = 1;      /* yeah, it's a range! */
17532                     continue;   /* but do it the next time */
17533                 }
17534             }
17535         }
17536
17537         if (namedclass > OOB_NAMEDCLASS) {
17538             continue;
17539         }
17540
17541         /* Here, we have a single value this time through the loop, and
17542          * <prevvalue> is the beginning of the range, if any; or <value> if
17543          * not. */
17544
17545         /* non-Latin1 code point implies unicode semantics. */
17546         if (value > 255) {
17547             REQUIRE_UNI_RULES(flagp, 0);
17548         }
17549
17550         /* Ready to process either the single value, or the completed range.
17551          * For single-valued non-inverted ranges, we consider the possibility
17552          * of multi-char folds.  (We made a conscious decision to not do this
17553          * for the other cases because it can often lead to non-intuitive
17554          * results.  For example, you have the peculiar case that:
17555          *  "s s" =~ /^[^\xDF]+$/i => Y
17556          *  "ss"  =~ /^[^\xDF]+$/i => N
17557          *
17558          * See [perl #89750] */
17559         if (FOLD && allow_mutiple_chars && value == prevvalue) {
17560             if (    value == LATIN_SMALL_LETTER_SHARP_S
17561                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
17562                                                         value)))
17563             {
17564                 /* Here <value> is indeed a multi-char fold.  Get what it is */
17565
17566                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17567                 STRLEN foldlen;
17568
17569                 UV folded = _to_uni_fold_flags(
17570                                 value,
17571                                 foldbuf,
17572                                 &foldlen,
17573                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
17574                                                    ? FOLD_FLAGS_NOMIX_ASCII
17575                                                    : 0)
17576                                 );
17577
17578                 /* Here, <folded> should be the first character of the
17579                  * multi-char fold of <value>, with <foldbuf> containing the
17580                  * whole thing.  But, if this fold is not allowed (because of
17581                  * the flags), <fold> will be the same as <value>, and should
17582                  * be processed like any other character, so skip the special
17583                  * handling */
17584                 if (folded != value) {
17585
17586                     /* Skip if we are recursed, currently parsing the class
17587                      * again.  Otherwise add this character to the list of
17588                      * multi-char folds. */
17589                     if (! RExC_in_multi_char_class) {
17590                         STRLEN cp_count = utf8_length(foldbuf,
17591                                                       foldbuf + foldlen);
17592                         SV* multi_fold = sv_2mortal(newSVpvs(""));
17593
17594                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
17595
17596                         multi_char_matches
17597                                         = add_multi_match(multi_char_matches,
17598                                                           multi_fold,
17599                                                           cp_count);
17600
17601                     }
17602
17603                     /* This element should not be processed further in this
17604                      * class */
17605                     element_count--;
17606                     value = save_value;
17607                     prevvalue = save_prevvalue;
17608                     continue;
17609                 }
17610             }
17611         }
17612
17613         if (strict && ckWARN(WARN_REGEXP)) {
17614             if (range) {
17615
17616                 /* If the range starts above 255, everything is portable and
17617                  * likely to be so for any forseeable character set, so don't
17618                  * warn. */
17619                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
17620                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
17621                 }
17622                 else if (prevvalue != value) {
17623
17624                     /* Under strict, ranges that stop and/or end in an ASCII
17625                      * printable should have each end point be a portable value
17626                      * for it (preferably like 'A', but we don't warn if it is
17627                      * a (portable) Unicode name or code point), and the range
17628                      * must be be all digits or all letters of the same case.
17629                      * Otherwise, the range is non-portable and unclear as to
17630                      * what it contains */
17631                     if (             (isPRINT_A(prevvalue) || isPRINT_A(value))
17632                         && (          non_portable_endpoint
17633                             || ! (   (isDIGIT_A(prevvalue) && isDIGIT_A(value))
17634                                   || (isLOWER_A(prevvalue) && isLOWER_A(value))
17635                                   || (isUPPER_A(prevvalue) && isUPPER_A(value))
17636                     ))) {
17637                         vWARN(RExC_parse, "Ranges of ASCII printables should"
17638                                           " be some subset of \"0-9\","
17639                                           " \"A-Z\", or \"a-z\"");
17640                     }
17641                     else if (prevvalue >= FIRST_NON_ASCII_DECIMAL_DIGIT) {
17642                         SSize_t index_start;
17643                         SSize_t index_final;
17644
17645                         /* But the nature of Unicode and languages mean we
17646                          * can't do the same checks for above-ASCII ranges,
17647                          * except in the case of digit ones.  These should
17648                          * contain only digits from the same group of 10.  The
17649                          * ASCII case is handled just above.  Hence here, the
17650                          * range could be a range of digits.  First some
17651                          * unlikely special cases.  Grandfather in that a range
17652                          * ending in 19DA (NEW TAI LUE THAM DIGIT ONE) is bad
17653                          * if its starting value is one of the 10 digits prior
17654                          * to it.  This is because it is an alternate way of
17655                          * writing 19D1, and some people may expect it to be in
17656                          * that group.  But it is bad, because it won't give
17657                          * the expected results.  In Unicode 5.2 it was
17658                          * considered to be in that group (of 11, hence), but
17659                          * this was fixed in the next version */
17660
17661                         if (UNLIKELY(value == 0x19DA && prevvalue >= 0x19D0)) {
17662                             goto warn_bad_digit_range;
17663                         }
17664                         else if (UNLIKELY(   prevvalue >= 0x1D7CE
17665                                           &&     value <= 0x1D7FF))
17666                         {
17667                             /* This is the only other case currently in Unicode
17668                              * where the algorithm below fails.  The code
17669                              * points just above are the end points of a single
17670                              * range containing only decimal digits.  It is 5
17671                              * different series of 0-9.  All other ranges of
17672                              * digits currently in Unicode are just a single
17673                              * series.  (And mktables will notify us if a later
17674                              * Unicode version breaks this.)
17675                              *
17676                              * If the range being checked is at most 9 long,
17677                              * and the digit values represented are in
17678                              * numerical order, they are from the same series.
17679                              * */
17680                             if (         value - prevvalue > 9
17681                                 ||    (((    value - 0x1D7CE) % 10)
17682                                      <= (prevvalue - 0x1D7CE) % 10))
17683                             {
17684                                 goto warn_bad_digit_range;
17685                             }
17686                         }
17687                         else {
17688
17689                             /* For all other ranges of digits in Unicode, the
17690                              * algorithm is just to check if both end points
17691                              * are in the same series, which is the same range.
17692                              * */
17693                             index_start = _invlist_search(
17694                                                     PL_XPosix_ptrs[_CC_DIGIT],
17695                                                     prevvalue);
17696
17697                             /* Warn if the range starts and ends with a digit,
17698                              * and they are not in the same group of 10. */
17699                             if (   index_start >= 0
17700                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_start)
17701                                 && (index_final =
17702                                     _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
17703                                                     value)) != index_start
17704                                 && index_final >= 0
17705                                 && ELEMENT_RANGE_MATCHES_INVLIST(index_final))
17706                             {
17707                               warn_bad_digit_range:
17708                                 vWARN(RExC_parse, "Ranges of digits should be"
17709                                                   " from the same group of"
17710                                                   " 10");
17711                             }
17712                         }
17713                     }
17714                 }
17715             }
17716             if ((! range || prevvalue == value) && non_portable_endpoint) {
17717                 if (isPRINT_A(value)) {
17718                     char literal[3];
17719                     unsigned d = 0;
17720                     if (isBACKSLASHED_PUNCT(value)) {
17721                         literal[d++] = '\\';
17722                     }
17723                     literal[d++] = (char) value;
17724                     literal[d++] = '\0';
17725
17726                     vWARN4(RExC_parse,
17727                            "\"%.*s\" is more clearly written simply as \"%s\"",
17728                            (int) (RExC_parse - rangebegin),
17729                            rangebegin,
17730                            literal
17731                         );
17732                 }
17733                 else if (isMNEMONIC_CNTRL(value)) {
17734                     vWARN4(RExC_parse,
17735                            "\"%.*s\" is more clearly written simply as \"%s\"",
17736                            (int) (RExC_parse - rangebegin),
17737                            rangebegin,
17738                            cntrl_to_mnemonic((U8) value)
17739                         );
17740                 }
17741             }
17742         }
17743
17744         /* Deal with this element of the class */
17745
17746 #ifndef EBCDIC
17747         cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17748                                                     prevvalue, value);
17749 #else
17750         /* On non-ASCII platforms, for ranges that span all of 0..255, and ones
17751          * that don't require special handling, we can just add the range like
17752          * we do for ASCII platforms */
17753         if ((UNLIKELY(prevvalue == 0) && value >= 255)
17754             || ! (prevvalue < 256
17755                     && (unicode_range
17756                         || (! non_portable_endpoint
17757                             && ((isLOWER_A(prevvalue) && isLOWER_A(value))
17758                                 || (isUPPER_A(prevvalue)
17759                                     && isUPPER_A(value)))))))
17760         {
17761             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17762                                                         prevvalue, value);
17763         }
17764         else {
17765             /* Here, requires special handling.  This can be because it is a
17766              * range whose code points are considered to be Unicode, and so
17767              * must be individually translated into native, or because its a
17768              * subrange of 'A-Z' or 'a-z' which each aren't contiguous in
17769              * EBCDIC, but we have defined them to include only the "expected"
17770              * upper or lower case ASCII alphabetics.  Subranges above 255 are
17771              * the same in native and Unicode, so can be added as a range */
17772             U8 start = NATIVE_TO_LATIN1(prevvalue);
17773             unsigned j;
17774             U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
17775             for (j = start; j <= end; j++) {
17776                 cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
17777             }
17778             if (value > 255) {
17779                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
17780                                                             256, value);
17781             }
17782         }
17783 #endif
17784
17785         range = 0; /* this range (if it was one) is done now */
17786     } /* End of loop through all the text within the brackets */
17787
17788     if (   posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) {
17789         output_posix_warnings(pRExC_state, posix_warnings);
17790     }
17791
17792     /* If anything in the class expands to more than one character, we have to
17793      * deal with them by building up a substitute parse string, and recursively
17794      * calling reg() on it, instead of proceeding */
17795     if (multi_char_matches) {
17796         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
17797         I32 cp_count;
17798         STRLEN len;
17799         char *save_end = RExC_end;
17800         char *save_parse = RExC_parse;
17801         char *save_start = RExC_start;
17802         Size_t constructed_prefix_len = 0; /* This gives the length of the
17803                                               constructed portion of the
17804                                               substitute parse. */
17805         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
17806                                        a "|" */
17807         I32 reg_flags;
17808
17809         assert(! invert);
17810         /* Only one level of recursion allowed */
17811         assert(RExC_copy_start_in_constructed == RExC_precomp);
17812
17813 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
17814            because too confusing */
17815         if (invert) {
17816             sv_catpvs(substitute_parse, "(?:");
17817         }
17818 #endif
17819
17820         /* Look at the longest folds first */
17821         for (cp_count = av_tindex_skip_len_mg(multi_char_matches);
17822                         cp_count > 0;
17823                         cp_count--)
17824         {
17825
17826             if (av_exists(multi_char_matches, cp_count)) {
17827                 AV** this_array_ptr;
17828                 SV* this_sequence;
17829
17830                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
17831                                                  cp_count, FALSE);
17832                 while ((this_sequence = av_pop(*this_array_ptr)) !=
17833                                                                 &PL_sv_undef)
17834                 {
17835                     if (! first_time) {
17836                         sv_catpvs(substitute_parse, "|");
17837                     }
17838                     first_time = FALSE;
17839
17840                     sv_catpv(substitute_parse, SvPVX(this_sequence));
17841                 }
17842             }
17843         }
17844
17845         /* If the character class contains anything else besides these
17846          * multi-character folds, have to include it in recursive parsing */
17847         if (element_count) {
17848             sv_catpvs(substitute_parse, "|[");
17849             constructed_prefix_len = SvCUR(substitute_parse);
17850             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17851
17852             /* Put in a closing ']' only if not going off the end, as otherwise
17853              * we are adding something that really isn't there */
17854             if (RExC_parse < RExC_end) {
17855                 sv_catpvs(substitute_parse, "]");
17856             }
17857         }
17858
17859         sv_catpvs(substitute_parse, ")");
17860 #if 0
17861         if (invert) {
17862             /* This is a way to get the parse to skip forward a whole named
17863              * sequence instead of matching the 2nd character when it fails the
17864              * first */
17865             sv_catpvs(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17866         }
17867 #endif
17868
17869         /* Set up the data structure so that any errors will be properly
17870          * reported.  See the comments at the definition of
17871          * REPORT_LOCATION_ARGS for details */
17872         RExC_copy_start_in_input = (char *) orig_parse;
17873         RExC_start = RExC_parse = SvPV(substitute_parse, len);
17874         RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len;
17875         RExC_end = RExC_parse + len;
17876         RExC_in_multi_char_class = 1;
17877
17878         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17879
17880         *flagp |= reg_flags & (HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PARSE|NEED_UTF8);
17881
17882         /* And restore so can parse the rest of the pattern */
17883         RExC_parse = save_parse;
17884         RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start;
17885         RExC_end = save_end;
17886         RExC_in_multi_char_class = 0;
17887         SvREFCNT_dec_NN(multi_char_matches);
17888         return ret;
17889     }
17890
17891     /* If folding, we calculate all characters that could fold to or from the
17892      * ones already on the list */
17893     if (cp_foldable_list) {
17894         if (FOLD) {
17895             UV start, end;      /* End points of code point ranges */
17896
17897             SV* fold_intersection = NULL;
17898             SV** use_list;
17899
17900             /* Our calculated list will be for Unicode rules.  For locale
17901              * matching, we have to keep a separate list that is consulted at
17902              * runtime only when the locale indicates Unicode rules (and we
17903              * don't include potential matches in the ASCII/Latin1 range, as
17904              * any code point could fold to any other, based on the run-time
17905              * locale).   For non-locale, we just use the general list */
17906             if (LOC) {
17907                 use_list = &only_utf8_locale_list;
17908             }
17909             else {
17910                 use_list = &cp_list;
17911             }
17912
17913             /* Only the characters in this class that participate in folds need
17914              * be checked.  Get the intersection of this class and all the
17915              * possible characters that are foldable.  This can quickly narrow
17916              * down a large class */
17917             _invlist_intersection(PL_in_some_fold, cp_foldable_list,
17918                                   &fold_intersection);
17919
17920             /* Now look at the foldable characters in this class individually */
17921             invlist_iterinit(fold_intersection);
17922             while (invlist_iternext(fold_intersection, &start, &end)) {
17923                 UV j;
17924                 UV folded;
17925
17926                 /* Look at every character in the range */
17927                 for (j = start; j <= end; j++) {
17928                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17929                     STRLEN foldlen;
17930                     unsigned int k;
17931                     Size_t folds_count;
17932                     unsigned int first_fold;
17933                     const unsigned int * remaining_folds;
17934
17935                     if (j < 256) {
17936
17937                         /* Under /l, we don't know what code points below 256
17938                          * fold to, except we do know the MICRO SIGN folds to
17939                          * an above-255 character if the locale is UTF-8, so we
17940                          * add it to the special list (in *use_list)  Otherwise
17941                          * we know now what things can match, though some folds
17942                          * are valid under /d only if the target is UTF-8.
17943                          * Those go in a separate list */
17944                         if (      IS_IN_SOME_FOLD_L1(j)
17945                             && ! (LOC && j != MICRO_SIGN))
17946                         {
17947
17948                             /* ASCII is always matched; non-ASCII is matched
17949                              * only under Unicode rules (which could happen
17950                              * under /l if the locale is a UTF-8 one */
17951                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17952                                 *use_list = add_cp_to_invlist(*use_list,
17953                                                             PL_fold_latin1[j]);
17954                             }
17955                             else if (j != PL_fold_latin1[j]) {
17956                                 upper_latin1_only_utf8_matches
17957                                         = add_cp_to_invlist(
17958                                                 upper_latin1_only_utf8_matches,
17959                                                 PL_fold_latin1[j]);
17960                             }
17961                         }
17962
17963                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17964                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17965                         {
17966                             add_above_Latin1_folds(pRExC_state,
17967                                                    (U8) j,
17968                                                    use_list);
17969                         }
17970                         continue;
17971                     }
17972
17973                     /* Here is an above Latin1 character.  We don't have the
17974                      * rules hard-coded for it.  First, get its fold.  This is
17975                      * the simple fold, as the multi-character folds have been
17976                      * handled earlier and separated out */
17977                     folded = _to_uni_fold_flags(j, foldbuf, &foldlen,
17978                                                         (ASCII_FOLD_RESTRICTED)
17979                                                         ? FOLD_FLAGS_NOMIX_ASCII
17980                                                         : 0);
17981
17982                     /* Single character fold of above Latin1.  Add everything
17983                      * in its fold closure to the list that this node should
17984                      * match. */
17985                     folds_count = _inverse_folds(folded, &first_fold,
17986                                                     &remaining_folds);
17987                     for (k = 0; k <= folds_count; k++) {
17988                         UV c = (k == 0)     /* First time through use itself */
17989                                 ? folded
17990                                 : (k == 1)  /* 2nd time use, the first fold */
17991                                    ? first_fold
17992
17993                                      /* Then the remaining ones */
17994                                    : remaining_folds[k-2];
17995
17996                         /* /aa doesn't allow folds between ASCII and non- */
17997                         if ((   ASCII_FOLD_RESTRICTED
17998                             && (isASCII(c) != isASCII(j))))
17999                         {
18000                             continue;
18001                         }
18002
18003                         /* Folds under /l which cross the 255/256 boundary are
18004                          * added to a separate list.  (These are valid only
18005                          * when the locale is UTF-8.) */
18006                         if (c < 256 && LOC) {
18007                             *use_list = add_cp_to_invlist(*use_list, c);
18008                             continue;
18009                         }
18010
18011                         if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
18012                         {
18013                             cp_list = add_cp_to_invlist(cp_list, c);
18014                         }
18015                         else {
18016                             /* Similarly folds involving non-ascii Latin1
18017                              * characters under /d are added to their list */
18018                             upper_latin1_only_utf8_matches
18019                                     = add_cp_to_invlist(
18020                                                 upper_latin1_only_utf8_matches,
18021                                                 c);
18022                         }
18023                     }
18024                 }
18025             }
18026             SvREFCNT_dec_NN(fold_intersection);
18027         }
18028
18029         /* Now that we have finished adding all the folds, there is no reason
18030          * to keep the foldable list separate */
18031         _invlist_union(cp_list, cp_foldable_list, &cp_list);
18032         SvREFCNT_dec_NN(cp_foldable_list);
18033     }
18034
18035     /* And combine the result (if any) with any inversion lists from posix
18036      * classes.  The lists are kept separate up to now because we don't want to
18037      * fold the classes */
18038     if (simple_posixes) {   /* These are the classes known to be unaffected by
18039                                /a, /aa, and /d */
18040         if (cp_list) {
18041             _invlist_union(cp_list, simple_posixes, &cp_list);
18042             SvREFCNT_dec_NN(simple_posixes);
18043         }
18044         else {
18045             cp_list = simple_posixes;
18046         }
18047     }
18048     if (posixes || nposixes) {
18049         if (! DEPENDS_SEMANTICS) {
18050
18051             /* For everything but /d, we can just add the current 'posixes' and
18052              * 'nposixes' to the main list */
18053             if (posixes) {
18054                 if (cp_list) {
18055                     _invlist_union(cp_list, posixes, &cp_list);
18056                     SvREFCNT_dec_NN(posixes);
18057                 }
18058                 else {
18059                     cp_list = posixes;
18060                 }
18061             }
18062             if (nposixes) {
18063                 if (cp_list) {
18064                     _invlist_union(cp_list, nposixes, &cp_list);
18065                     SvREFCNT_dec_NN(nposixes);
18066                 }
18067                 else {
18068                     cp_list = nposixes;
18069                 }
18070             }
18071         }
18072         else {
18073             /* Under /d, things like \w match upper Latin1 characters only if
18074              * the target string is in UTF-8.  But things like \W match all the
18075              * upper Latin1 characters if the target string is not in UTF-8.
18076              *
18077              * Handle the case with something like \W separately */
18078             if (nposixes) {
18079                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1, NULL);
18080
18081                 /* A complemented posix class matches all upper Latin1
18082                  * characters if not in UTF-8.  And it matches just certain
18083                  * ones when in UTF-8.  That means those certain ones are
18084                  * matched regardless, so can just be added to the
18085                  * unconditional list */
18086                 if (cp_list) {
18087                     _invlist_union(cp_list, nposixes, &cp_list);
18088                     SvREFCNT_dec_NN(nposixes);
18089                     nposixes = NULL;
18090                 }
18091                 else {
18092                     cp_list = nposixes;
18093                 }
18094
18095                 /* Likewise for 'posixes' */
18096                 _invlist_union(posixes, cp_list, &cp_list);
18097
18098                 /* Likewise for anything else in the range that matched only
18099                  * under UTF-8 */
18100                 if (upper_latin1_only_utf8_matches) {
18101                     _invlist_union(cp_list,
18102                                    upper_latin1_only_utf8_matches,
18103                                    &cp_list);
18104                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18105                     upper_latin1_only_utf8_matches = NULL;
18106                 }
18107
18108                 /* If we don't match all the upper Latin1 characters regardless
18109                  * of UTF-8ness, we have to set a flag to match the rest when
18110                  * not in UTF-8 */
18111                 _invlist_subtract(only_non_utf8_list, cp_list,
18112                                   &only_non_utf8_list);
18113                 if (_invlist_len(only_non_utf8_list) != 0) {
18114                     anyof_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18115                 }
18116                 SvREFCNT_dec_NN(only_non_utf8_list);
18117             }
18118             else {
18119                 /* Here there were no complemented posix classes.  That means
18120                  * the upper Latin1 characters in 'posixes' match only when the
18121                  * target string is in UTF-8.  So we have to add them to the
18122                  * list of those types of code points, while adding the
18123                  * remainder to the unconditional list.
18124                  *
18125                  * First calculate what they are */
18126                 SV* nonascii_but_latin1_properties = NULL;
18127                 _invlist_intersection(posixes, PL_UpperLatin1,
18128                                       &nonascii_but_latin1_properties);
18129
18130                 /* And add them to the final list of such characters. */
18131                 _invlist_union(upper_latin1_only_utf8_matches,
18132                                nonascii_but_latin1_properties,
18133                                &upper_latin1_only_utf8_matches);
18134
18135                 /* Remove them from what now becomes the unconditional list */
18136                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
18137                                   &posixes);
18138
18139                 /* And add those unconditional ones to the final list */
18140                 if (cp_list) {
18141                     _invlist_union(cp_list, posixes, &cp_list);
18142                     SvREFCNT_dec_NN(posixes);
18143                     posixes = NULL;
18144                 }
18145                 else {
18146                     cp_list = posixes;
18147                 }
18148
18149                 SvREFCNT_dec(nonascii_but_latin1_properties);
18150
18151                 /* Get rid of any characters from the conditional list that we
18152                  * now know are matched unconditionally, which may make that
18153                  * list empty */
18154                 _invlist_subtract(upper_latin1_only_utf8_matches,
18155                                   cp_list,
18156                                   &upper_latin1_only_utf8_matches);
18157                 if (_invlist_len(upper_latin1_only_utf8_matches) == 0) {
18158                     SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
18159                     upper_latin1_only_utf8_matches = NULL;
18160                 }
18161             }
18162         }
18163     }
18164
18165     /* And combine the result (if any) with any inversion list from properties.
18166      * The lists are kept separate up to now so that we can distinguish the two
18167      * in regards to matching above-Unicode.  A run-time warning is generated
18168      * if a Unicode property is matched against a non-Unicode code point. But,
18169      * we allow user-defined properties to match anything, without any warning,
18170      * and we also suppress the warning if there is a portion of the character
18171      * class that isn't a Unicode property, and which matches above Unicode, \W
18172      * or [\x{110000}] for example.
18173      * (Note that in this case, unlike the Posix one above, there is no
18174      * <upper_latin1_only_utf8_matches>, because having a Unicode property
18175      * forces Unicode semantics */
18176     if (properties) {
18177         if (cp_list) {
18178
18179             /* If it matters to the final outcome, see if a non-property
18180              * component of the class matches above Unicode.  If so, the
18181              * warning gets suppressed.  This is true even if just a single
18182              * such code point is specified, as, though not strictly correct if
18183              * another such code point is matched against, the fact that they
18184              * are using above-Unicode code points indicates they should know
18185              * the issues involved */
18186             if (warn_super) {
18187                 warn_super = ! (invert
18188                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
18189             }
18190
18191             _invlist_union(properties, cp_list, &cp_list);
18192             SvREFCNT_dec_NN(properties);
18193         }
18194         else {
18195             cp_list = properties;
18196         }
18197
18198         if (warn_super) {
18199             anyof_flags
18200              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
18201
18202             /* Because an ANYOF node is the only one that warns, this node
18203              * can't be optimized into something else */
18204             optimizable = FALSE;
18205         }
18206     }
18207
18208     /* Here, we have calculated what code points should be in the character
18209      * class.
18210      *
18211      * Now we can see about various optimizations.  Fold calculation (which we
18212      * did above) needs to take place before inversion.  Otherwise /[^k]/i
18213      * would invert to include K, which under /i would match k, which it
18214      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
18215      * folded until runtime */
18216
18217     /* If we didn't do folding, it's because some information isn't available
18218      * until runtime; set the run-time fold flag for these  We know to set the
18219      * flag if we have a non-NULL list for UTF-8 locales, or the class matches
18220      * at least one 0-255 range code point */
18221     if (LOC && FOLD) {
18222
18223         /* Some things on the list might be unconditionally included because of
18224          * other components.  Remove them, and clean up the list if it goes to
18225          * 0 elements */
18226         if (only_utf8_locale_list && cp_list) {
18227             _invlist_subtract(only_utf8_locale_list, cp_list,
18228                               &only_utf8_locale_list);
18229
18230             if (_invlist_len(only_utf8_locale_list) == 0) {
18231                 SvREFCNT_dec_NN(only_utf8_locale_list);
18232                 only_utf8_locale_list = NULL;
18233             }
18234         }
18235         if (    only_utf8_locale_list
18236             || (cp_list && (   _invlist_contains_cp(cp_list, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE)
18237                             || _invlist_contains_cp(cp_list, LATIN_SMALL_LETTER_DOTLESS_I))))
18238         {
18239             has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18240             anyof_flags
18241                  |= ANYOFL_FOLD
18242                  |  ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
18243         }
18244         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
18245             UV start, end;
18246             invlist_iterinit(cp_list);
18247             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
18248                 anyof_flags |= ANYOFL_FOLD;
18249                 has_runtime_dependency |= HAS_L_RUNTIME_DEPENDENCY;
18250             }
18251             invlist_iterfinish(cp_list);
18252         }
18253     }
18254     else if (   DEPENDS_SEMANTICS
18255              && (    upper_latin1_only_utf8_matches
18256                  || (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
18257     {
18258         RExC_seen_d_op = TRUE;
18259         has_runtime_dependency |= HAS_D_RUNTIME_DEPENDENCY;
18260     }
18261
18262     /* Optimize inverted patterns (e.g. [^a-z]) when everything is known at
18263      * compile time. */
18264     if (     cp_list
18265         &&   invert
18266         && ! has_runtime_dependency)
18267     {
18268         _invlist_invert(cp_list);
18269
18270         /* Clear the invert flag since have just done it here */
18271         invert = FALSE;
18272     }
18273
18274     if (ret_invlist) {
18275         *ret_invlist = cp_list;
18276
18277         return RExC_emit;
18278     }
18279
18280     /* All possible optimizations below still have these characteristics.
18281      * (Multi-char folds aren't SIMPLE, but they don't get this far in this
18282      * routine) */
18283     *flagp |= HASWIDTH|SIMPLE;
18284
18285     if (anyof_flags & ANYOF_LOCALE_FLAGS) {
18286         RExC_contains_locale = 1;
18287     }
18288
18289     /* Some character classes are equivalent to other nodes.  Such nodes take
18290      * up less room, and some nodes require fewer operations to execute, than
18291      * ANYOF nodes.  EXACTish nodes may be joinable with adjacent nodes to
18292      * improve efficiency. */
18293
18294     if (optimizable) {
18295         PERL_UINT_FAST8_T i;
18296         Size_t partial_cp_count = 0;
18297         UV start[MAX_FOLD_FROMS+1] = { 0 }; /* +1 for the folded-to char */
18298         UV   end[MAX_FOLD_FROMS+1] = { 0 };
18299
18300         if (cp_list) { /* Count the code points in enough ranges that we would
18301                           see all the ones possible in any fold in this version
18302                           of Unicode */
18303
18304             invlist_iterinit(cp_list);
18305             for (i = 0; i <= MAX_FOLD_FROMS; i++) {
18306                 if (! invlist_iternext(cp_list, &start[i], &end[i])) {
18307                     break;
18308                 }
18309                 partial_cp_count += end[i] - start[i] + 1;
18310             }
18311
18312             invlist_iterfinish(cp_list);
18313         }
18314
18315         /* If we know at compile time that this matches every possible code
18316          * point, any run-time dependencies don't matter */
18317         if (start[0] == 0 && end[0] == UV_MAX) {
18318             if (invert) {
18319                 ret = reganode(pRExC_state, OPFAIL, 0);
18320             }
18321             else {
18322                 ret = reg_node(pRExC_state, SANY);
18323                 MARK_NAUGHTY(1);
18324             }
18325             goto not_anyof;
18326         }
18327
18328         /* Similarly, for /l posix classes, if both a class and its
18329          * complement match, any run-time dependencies don't matter */
18330         if (posixl) {
18331             for (namedclass = 0; namedclass < ANYOF_POSIXL_MAX;
18332                                                         namedclass += 2)
18333             {
18334                 if (   POSIXL_TEST(posixl, namedclass)      /* class */
18335                     && POSIXL_TEST(posixl, namedclass + 1)) /* its complement */
18336                 {
18337                     if (invert) {
18338                         ret = reganode(pRExC_state, OPFAIL, 0);
18339                     }
18340                     else {
18341                         ret = reg_node(pRExC_state, SANY);
18342                         MARK_NAUGHTY(1);
18343                     }
18344                     goto not_anyof;
18345                 }
18346             }
18347             /* For well-behaved locales, some classes are subsets of others,
18348              * so complementing the subset and including the non-complemented
18349              * superset should match everything, like [\D[:alnum:]], and
18350              * [[:^alpha:][:alnum:]], but some implementations of locales are
18351              * buggy, and khw thinks its a bad idea to have optimization change
18352              * behavior, even if it avoids an OS bug in a given case */
18353
18354 #define isSINGLE_BIT_SET(n) isPOWER_OF_2(n)
18355
18356             /* If is a single posix /l class, can optimize to just that op.
18357              * Such a node will not match anything in the Latin1 range, as that
18358              * is not determinable until runtime, but will match whatever the
18359              * class does outside that range.  (Note that some classes won't
18360              * match anything outside the range, like [:ascii:]) */
18361             if (    isSINGLE_BIT_SET(posixl)
18362                 && (partial_cp_count == 0 || start[0] > 255))
18363             {
18364                 U8 classnum;
18365                 SV * class_above_latin1 = NULL;
18366                 bool already_inverted;
18367                 bool are_equivalent;
18368
18369                 /* Compute which bit is set, which is the same thing as, e.g.,
18370                  * ANYOF_CNTRL.  From
18371                  * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLogDeBruijn
18372                  * */
18373                 static const int MultiplyDeBruijnBitPosition2[32] =
18374                     {
18375                     0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,
18376                     31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9
18377                     };
18378
18379                 namedclass = MultiplyDeBruijnBitPosition2[(posixl
18380                                                           * 0x077CB531U) >> 27];
18381                 classnum = namedclass_to_classnum(namedclass);
18382
18383                 /* The named classes are such that the inverted number is one
18384                  * larger than the non-inverted one */
18385                 already_inverted = namedclass
18386                                  - classnum_to_namedclass(classnum);
18387
18388                 /* Create an inversion list of the official property, inverted
18389                  * if the constructed node list is inverted, and restricted to
18390                  * only the above latin1 code points, which are the only ones
18391                  * known at compile time */
18392                 _invlist_intersection_maybe_complement_2nd(
18393                                                     PL_AboveLatin1,
18394                                                     PL_XPosix_ptrs[classnum],
18395                                                     already_inverted,
18396                                                     &class_above_latin1);
18397                 are_equivalent = _invlistEQ(class_above_latin1, cp_list,
18398                                                                         FALSE);
18399                 SvREFCNT_dec_NN(class_above_latin1);
18400
18401                 if (are_equivalent) {
18402
18403                     /* Resolve the run-time inversion flag with this possibly
18404                      * inverted class */
18405                     invert = invert ^ already_inverted;
18406
18407                     ret = reg_node(pRExC_state,
18408                                    POSIXL + invert * (NPOSIXL - POSIXL));
18409                     FLAGS(REGNODE_p(ret)) = classnum;
18410                     goto not_anyof;
18411                 }
18412             }
18413         }
18414
18415         /* khw can't think of any other possible transformation involving
18416          * these. */
18417         if (has_runtime_dependency & HAS_USER_DEFINED_PROPERTY) {
18418             goto is_anyof;
18419         }
18420
18421         if (! has_runtime_dependency) {
18422
18423             /* If the list is empty, nothing matches.  This happens, for
18424              * example, when a Unicode property that doesn't match anything is
18425              * the only element in the character class (perluniprops.pod notes
18426              * such properties). */
18427             if (partial_cp_count == 0) {
18428                 if (invert) {
18429                     ret = reg_node(pRExC_state, SANY);
18430                 }
18431                 else {
18432                     ret = reganode(pRExC_state, OPFAIL, 0);
18433                 }
18434
18435                 goto not_anyof;
18436             }
18437
18438             /* If matches everything but \n */
18439             if (   start[0] == 0 && end[0] == '\n' - 1
18440                 && start[1] == '\n' + 1 && end[1] == UV_MAX)
18441             {
18442                 assert (! invert);
18443                 ret = reg_node(pRExC_state, REG_ANY);
18444                 MARK_NAUGHTY(1);
18445                 goto not_anyof;
18446             }
18447         }
18448
18449         /* Next see if can optimize classes that contain just a few code points
18450          * into an EXACTish node.  The reason to do this is to let the
18451          * optimizer join this node with adjacent EXACTish ones.
18452          *
18453          * An EXACTFish node can be generated even if not under /i, and vice
18454          * versa.  But care must be taken.  An EXACTFish node has to be such
18455          * that it only matches precisely the code points in the class, but we
18456          * want to generate the least restrictive one that does that, to
18457          * increase the odds of being able to join with an adjacent node.  For
18458          * example, if the class contains [kK], we have to make it an EXACTFAA
18459          * node to prevent the KELVIN SIGN from matching.  Whether we are under
18460          * /i or not is irrelevant in this case.  Less obvious is the pattern
18461          * qr/[\x{02BC}]n/i.  U+02BC is MODIFIER LETTER APOSTROPHE. That is
18462          * supposed to match the single character U+0149 LATIN SMALL LETTER N
18463          * PRECEDED BY APOSTROPHE.  And so even though there is no simple fold
18464          * that includes \X{02BC}, there is a multi-char fold that does, and so
18465          * the node generated for it must be an EXACTFish one.  On the other
18466          * hand qr/:/i should generate a plain EXACT node since the colon
18467          * participates in no fold whatsoever, and having it EXACT tells the
18468          * optimizer the target string cannot match unless it has a colon in
18469          * it.
18470          *
18471          * We don't typically generate an EXACTish node if doing so would
18472          * require changing the pattern to UTF-8, as that affects /d and
18473          * otherwise is slower.  However, under /i, not changing to UTF-8 can
18474          * miss some potential multi-character folds.  We calculate the
18475          * EXACTish node, and then decide if something would be missed if we
18476          * don't upgrade */
18477         if (   ! posixl
18478             && ! invert
18479
18480                 /* Only try if there are no more code points in the class than
18481                  * in the max possible fold */
18482             &&   partial_cp_count > 0 && partial_cp_count <= MAX_FOLD_FROMS + 1
18483
18484             && (start[0] < 256 || UTF || FOLD))
18485         {
18486             if (partial_cp_count == 1 && ! upper_latin1_only_utf8_matches)
18487             {
18488                 /* We can always make a single code point class into an
18489                  * EXACTish node. */
18490
18491                 if (LOC) {
18492
18493                     /* Here is /l:  Use EXACTL, except /li indicates EXACTFL,
18494                      * as that means there is a fold not known until runtime so
18495                      * shows as only a single code point here. */
18496                     op = (FOLD) ? EXACTFL : EXACTL;
18497                 }
18498                 else if (! FOLD) { /* Not /l and not /i */
18499                     op = (start[0] < 256) ? EXACT : EXACT_ONLY8;
18500                 }
18501                 else if (start[0] < 256) { /* /i, not /l, and the code point is
18502                                               small */
18503
18504                     /* Under /i, it gets a little tricky.  A code point that
18505                      * doesn't participate in a fold should be an EXACT node.
18506                      * We know this one isn't the result of a simple fold, or
18507                      * there'd be more than one code point in the list, but it
18508                      * could be part of a multi- character fold.  In that case
18509                      * we better not create an EXACT node, as we would wrongly
18510                      * be telling the optimizer that this code point must be in
18511                      * the target string, and that is wrong.  This is because
18512                      * if the sequence around this code point forms a
18513                      * multi-char fold, what needs to be in the string could be
18514                      * the code point that folds to the sequence.
18515                      *
18516                      * This handles the case of below-255 code points, as we
18517                      * have an easy look up for those.  The next clause handles
18518                      * the above-256 one */
18519                     op = IS_IN_SOME_FOLD_L1(start[0])
18520                          ? EXACTFU
18521                          : EXACT;
18522                 }
18523                 else {  /* /i, larger code point.  Since we are under /i, and
18524                            have just this code point, we know that it can't
18525                            fold to something else, so PL_InMultiCharFold
18526                            applies to it */
18527                     op = _invlist_contains_cp(PL_InMultiCharFold,
18528                                               start[0])
18529                          ? EXACTFU_ONLY8
18530                          : EXACT_ONLY8;
18531                 }
18532
18533                 value = start[0];
18534             }
18535             else if (  ! (has_runtime_dependency & ~HAS_D_RUNTIME_DEPENDENCY)
18536                      && _invlist_contains_cp(PL_in_some_fold, start[0]))
18537             {
18538                 /* Here, the only runtime dependency, if any, is from /d, and
18539                  * the class matches more than one code point, and the lowest
18540                  * code point participates in some fold.  It might be that the
18541                  * other code points are /i equivalent to this one, and hence
18542                  * they would representable by an EXACTFish node.  Above, we
18543                  * eliminated classes that contain too many code points to be
18544                  * EXACTFish, with the test for MAX_FOLD_FROMS
18545                  *
18546                  * First, special case the ASCII fold pairs, like 'B' and 'b'.
18547                  * We do this because we have EXACTFAA at our disposal for the
18548                  * ASCII range */
18549                 if (partial_cp_count == 2 && isASCII(start[0])) {
18550
18551                     /* The only ASCII characters that participate in folds are
18552                      * alphabetics */
18553                     assert(isALPHA(start[0]));
18554                     if (   end[0] == start[0]   /* First range is a single
18555                                                    character, so 2nd exists */
18556                         && isALPHA_FOLD_EQ(start[0], start[1]))
18557                     {
18558
18559                         /* Here, is part of an ASCII fold pair */
18560
18561                         if (   ASCII_FOLD_RESTRICTED
18562                             || HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(start[0]))
18563                         {
18564                             /* If the second clause just above was true, it
18565                              * means we can't be under /i, or else the list
18566                              * would have included more than this fold pair.
18567                              * Therefore we have to exclude the possibility of
18568                              * whatever else it is that folds to these, by
18569                              * using EXACTFAA */
18570                             op = EXACTFAA;
18571                         }
18572                         else if (HAS_NONLATIN1_FOLD_CLOSURE(start[0])) {
18573
18574                             /* Here, there's no simple fold that start[0] is part
18575                              * of, but there is a multi-character one.  If we
18576                              * are not under /i, we want to exclude that
18577                              * possibility; if under /i, we want to include it
18578                              * */
18579                             op = (FOLD) ? EXACTFU : EXACTFAA;
18580                         }
18581                         else {
18582
18583                             /* Here, the only possible fold start[0] particpates in
18584                              * is with start[1].  /i or not isn't relevant */
18585                             op = EXACTFU;
18586                         }
18587
18588                         value = toFOLD(start[0]);
18589                     }
18590                 }
18591                 else if (  ! upper_latin1_only_utf8_matches
18592                          || (   _invlist_len(upper_latin1_only_utf8_matches)
18593                                                                           == 2
18594                              && PL_fold_latin1[
18595                                invlist_highest(upper_latin1_only_utf8_matches)]
18596                              == start[0]))
18597                 {
18598                     /* Here, the smallest character is non-ascii or there are
18599                      * more than 2 code points matched by this node.  Also, we
18600                      * either don't have /d UTF-8 dependent matches, or if we
18601                      * do, they look like they could be a single character that
18602                      * is the fold of the lowest one in the always-match list.
18603                      * This test quickly excludes most of the false positives
18604                      * when there are /d UTF-8 depdendent matches.  These are
18605                      * like LATIN CAPITAL LETTER A WITH GRAVE matching LATIN
18606                      * SMALL LETTER A WITH GRAVE iff the target string is
18607                      * UTF-8.  (We don't have to worry above about exceeding
18608                      * the array bounds of PL_fold_latin1[] because any code
18609                      * point in 'upper_latin1_only_utf8_matches' is below 256.)
18610                      *
18611                      * EXACTFAA would apply only to pairs (hence exactly 2 code
18612                      * points) in the ASCII range, so we can't use it here to
18613                      * artificially restrict the fold domain, so we check if
18614                      * the class does or does not match some EXACTFish node.
18615                      * Further, if we aren't under /i, and and the folded-to
18616                      * character is part of a multi-character fold, we can't do
18617                      * this optimization, as the sequence around it could be
18618                      * that multi-character fold, and we don't here know the
18619                      * context, so we have to assume it is that multi-char
18620                      * fold, to prevent potential bugs.
18621                      *
18622                      * To do the general case, we first find the fold of the
18623                      * lowest code point (which may be higher than the lowest
18624                      * one), then find everything that folds to it.  (The data
18625                      * structure we have only maps from the folded code points,
18626                      * so we have to do the earlier step.) */
18627
18628                     Size_t foldlen;
18629                     U8 foldbuf[UTF8_MAXBYTES_CASE];
18630                     UV folded = _to_uni_fold_flags(start[0],
18631                                                         foldbuf, &foldlen, 0);
18632                     unsigned int first_fold;
18633                     const unsigned int * remaining_folds;
18634                     Size_t folds_to_this_cp_count = _inverse_folds(
18635                                                             folded,
18636                                                             &first_fold,
18637                                                             &remaining_folds);
18638                     Size_t folds_count = folds_to_this_cp_count + 1;
18639                     SV * fold_list = _new_invlist(folds_count);
18640                     unsigned int i;
18641
18642                     /* If there are UTF-8 dependent matches, create a temporary
18643                      * list of what this node matches, including them. */
18644                     SV * all_cp_list = NULL;
18645                     SV ** use_this_list = &cp_list;
18646
18647                     if (upper_latin1_only_utf8_matches) {
18648                         all_cp_list = _new_invlist(0);
18649                         use_this_list = &all_cp_list;
18650                         _invlist_union(cp_list,
18651                                        upper_latin1_only_utf8_matches,
18652                                        use_this_list);
18653                     }
18654
18655                     /* Having gotten everything that participates in the fold
18656                      * containing the lowest code point, we turn that into an
18657                      * inversion list, making sure everything is included. */
18658                     fold_list = add_cp_to_invlist(fold_list, start[0]);
18659                     fold_list = add_cp_to_invlist(fold_list, folded);
18660                     if (folds_to_this_cp_count > 0) {
18661                         fold_list = add_cp_to_invlist(fold_list, first_fold);
18662                         for (i = 0; i + 1 < folds_to_this_cp_count; i++) {
18663                             fold_list = add_cp_to_invlist(fold_list,
18664                                                         remaining_folds[i]);
18665                         }
18666                     }
18667
18668                     /* If the fold list is identical to what's in this ANYOF
18669                      * node, the node can be represented by an EXACTFish one
18670                      * instead */
18671                     if (_invlistEQ(*use_this_list, fold_list,
18672                                    0 /* Don't complement */ )
18673                     ) {
18674
18675                         /* But, we have to be careful, as mentioned above.
18676                          * Just the right sequence of characters could match
18677                          * this if it is part of a multi-character fold.  That
18678                          * IS what we want if we are under /i.  But it ISN'T
18679                          * what we want if not under /i, as it could match when
18680                          * it shouldn't.  So, when we aren't under /i and this
18681                          * character participates in a multi-char fold, we
18682                          * don't optimize into an EXACTFish node.  So, for each
18683                          * case below we have to check if we are folding
18684                          * and if not, if it is not part of a multi-char fold.
18685                          * */
18686                         if (start[0] > 255) {    /* Highish code point */
18687                             if (FOLD || ! _invlist_contains_cp(
18688                                             PL_InMultiCharFold, folded))
18689                             {
18690                                 op = (LOC)
18691                                      ? EXACTFLU8
18692                                      : (ASCII_FOLD_RESTRICTED)
18693                                        ? EXACTFAA
18694                                        : EXACTFU_ONLY8;
18695                                 value = folded;
18696                             }
18697                         }   /* Below, the lowest code point < 256 */
18698                         else if (    FOLD
18699                                  &&  folded == 's'
18700                                  &&  DEPENDS_SEMANTICS)
18701                         {   /* An EXACTF node containing a single character
18702                                 's', can be an EXACTFU if it doesn't get
18703                                 joined with an adjacent 's' */
18704                             op = EXACTFU_S_EDGE;
18705                             value = folded;
18706                         }
18707                         else if (    FOLD
18708                                 || ! HAS_NONLATIN1_FOLD_CLOSURE(start[0]))
18709                         {
18710                             if (upper_latin1_only_utf8_matches) {
18711                                 op = EXACTF;
18712
18713                                 /* We can't use the fold, as that only matches
18714                                  * under UTF-8 */
18715                                 value = start[0];
18716                             }
18717                             else if (     UNLIKELY(start[0] == MICRO_SIGN)
18718                                      && ! UTF)
18719                             {   /* EXACTFUP is a special node for this
18720                                    character */
18721                                 op = (ASCII_FOLD_RESTRICTED)
18722                                      ? EXACTFAA
18723                                      : EXACTFUP;
18724                                 value = MICRO_SIGN;
18725                             }
18726                             else if (     ASCII_FOLD_RESTRICTED
18727                                      && ! isASCII(start[0]))
18728                             {   /* For ASCII under /iaa, we can use EXACTFU
18729                                    below */
18730                                 op = EXACTFAA;
18731                                 value = folded;
18732                             }
18733                             else {
18734                                 op = EXACTFU;
18735                                 value = folded;
18736                             }
18737                         }
18738                     }
18739
18740                     SvREFCNT_dec_NN(fold_list);
18741                     SvREFCNT_dec(all_cp_list);
18742                 }
18743             }
18744
18745             if (op != END) {
18746
18747                 /* Here, we have calculated what EXACTish node we would use.
18748                  * But we don't use it if it would require converting the
18749                  * pattern to UTF-8, unless not using it could cause us to miss
18750                  * some folds (hence be buggy) */
18751
18752                 if (! UTF && value > 255) {
18753                     SV * in_multis = NULL;
18754
18755                     assert(FOLD);
18756
18757                     /* If there is no code point that is part of a multi-char
18758                      * fold, then there aren't any matches, so we don't do this
18759                      * optimization.  Otherwise, it could match depending on
18760                      * the context around us, so we do upgrade */
18761                     _invlist_intersection(PL_InMultiCharFold, cp_list, &in_multis);
18762                     if (UNLIKELY(_invlist_len(in_multis) != 0)) {
18763                         REQUIRE_UTF8(flagp);
18764                     }
18765                     else {
18766                         op = END;
18767                     }
18768                 }
18769
18770                 if (op != END) {
18771                     U8 len = (UTF) ? UVCHR_SKIP(value) : 1;
18772
18773                     ret = regnode_guts(pRExC_state, op, len, "exact");
18774                     FILL_NODE(ret, op);
18775                     RExC_emit += 1 + STR_SZ(len);
18776                     STR_LEN(REGNODE_p(ret)) = len;
18777                     if (len == 1) {
18778                         *STRING(REGNODE_p(ret)) = (U8) value;
18779                     }
18780                     else {
18781                         uvchr_to_utf8((U8 *) STRING(REGNODE_p(ret)), value);
18782                     }
18783                     goto not_anyof;
18784                 }
18785             }
18786         }
18787
18788         if (! has_runtime_dependency) {
18789
18790             /* See if this can be turned into an ANYOFM node.  Think about the
18791              * bit patterns in two different bytes.  In some positions, the
18792              * bits in each will be 1; and in other positions both will be 0;
18793              * and in some positions the bit will be 1 in one byte, and 0 in
18794              * the other.  Let 'n' be the number of positions where the bits
18795              * differ.  We create a mask which has exactly 'n' 0 bits, each in
18796              * a position where the two bytes differ.  Now take the set of all
18797              * bytes that when ANDed with the mask yield the same result.  That
18798              * set has 2**n elements, and is representable by just two 8 bit
18799              * numbers: the result and the mask.  Importantly, matching the set
18800              * can be vectorized by creating a word full of the result bytes,
18801              * and a word full of the mask bytes, yielding a significant speed
18802              * up.  Here, see if this node matches such a set.  As a concrete
18803              * example consider [01], and the byte representing '0' which is
18804              * 0x30 on ASCII machines.  It has the bits 0011 0000.  Take the
18805              * mask 1111 1110.  If we AND 0x31 and 0x30 with that mask we get
18806              * 0x30.  Any other bytes ANDed yield something else.  So [01],
18807              * which is a common usage, is optimizable into ANYOFM, and can
18808              * benefit from the speed up.  We can only do this on UTF-8
18809              * invariant bytes, because they have the same bit patterns under
18810              * UTF-8 as not. */
18811             PERL_UINT_FAST8_T inverted = 0;
18812 #ifdef EBCDIC
18813             const PERL_UINT_FAST8_T max_permissible = 0xFF;
18814 #else
18815             const PERL_UINT_FAST8_T max_permissible = 0x7F;
18816 #endif
18817             /* If doesn't fit the criteria for ANYOFM, invert and try again.
18818              * If that works we will instead later generate an NANYOFM, and
18819              * invert back when through */
18820             if (invlist_highest(cp_list) > max_permissible) {
18821                 _invlist_invert(cp_list);
18822                 inverted = 1;
18823             }
18824
18825             if (invlist_highest(cp_list) <= max_permissible) {
18826                 UV this_start, this_end;
18827                 UV lowest_cp = UV_MAX;  /* inited to suppress compiler warn */
18828                 U8 bits_differing = 0;
18829                 Size_t full_cp_count = 0;
18830                 bool first_time = TRUE;
18831
18832                 /* Go through the bytes and find the bit positions that differ
18833                  * */
18834                 invlist_iterinit(cp_list);
18835                 while (invlist_iternext(cp_list, &this_start, &this_end)) {
18836                     unsigned int i = this_start;
18837
18838                     if (first_time) {
18839                         if (! UVCHR_IS_INVARIANT(i)) {
18840                             goto done_anyofm;
18841                         }
18842
18843                         first_time = FALSE;
18844                         lowest_cp = this_start;
18845
18846                         /* We have set up the code point to compare with.
18847                          * Don't compare it with itself */
18848                         i++;
18849                     }
18850
18851                     /* Find the bit positions that differ from the lowest code
18852                      * point in the node.  Keep track of all such positions by
18853                      * OR'ing */
18854                     for (; i <= this_end; i++) {
18855                         if (! UVCHR_IS_INVARIANT(i)) {
18856                             goto done_anyofm;
18857                         }
18858
18859                         bits_differing  |= i ^ lowest_cp;
18860                     }
18861
18862                     full_cp_count += this_end - this_start + 1;
18863                 }
18864                 invlist_iterfinish(cp_list);
18865
18866                 /* At the end of the loop, we count how many bits differ from
18867                  * the bits in lowest code point, call the count 'd'.  If the
18868                  * set we found contains 2**d elements, it is the closure of
18869                  * all code points that differ only in those bit positions.  To
18870                  * convince yourself of that, first note that the number in the
18871                  * closure must be a power of 2, which we test for.  The only
18872                  * way we could have that count and it be some differing set,
18873                  * is if we got some code points that don't differ from the
18874                  * lowest code point in any position, but do differ from each
18875                  * other in some other position.  That means one code point has
18876                  * a 1 in that position, and another has a 0.  But that would
18877                  * mean that one of them differs from the lowest code point in
18878                  * that position, which possibility we've already excluded.  */
18879                 if (  (inverted || full_cp_count > 1)
18880                     && full_cp_count == 1U << PL_bitcount[bits_differing])
18881                 {
18882                     U8 ANYOFM_mask;
18883
18884                     op = ANYOFM + inverted;;
18885
18886                     /* We need to make the bits that differ be 0's */
18887                     ANYOFM_mask = ~ bits_differing; /* This goes into FLAGS */
18888
18889                     /* The argument is the lowest code point */
18890                     ret = reganode(pRExC_state, op, lowest_cp);
18891                     FLAGS(REGNODE_p(ret)) = ANYOFM_mask;
18892                 }
18893             }
18894           done_anyofm:
18895
18896             if (inverted) {
18897                 _invlist_invert(cp_list);
18898             }
18899
18900             if (op != END) {
18901                 goto not_anyof;
18902             }
18903         }
18904
18905         if (! (anyof_flags & ANYOF_LOCALE_FLAGS)) {
18906             PERL_UINT_FAST8_T type;
18907             SV * intersection = NULL;
18908             SV* d_invlist = NULL;
18909
18910             /* See if this matches any of the POSIX classes.  The POSIXA and
18911              * POSIXD ones are about the same speed as ANYOF ops, but take less
18912              * room; the ones that have above-Latin1 code point matches are
18913              * somewhat faster than ANYOF.  */
18914
18915             for (type = POSIXA; type >= POSIXD; type--) {
18916                 int posix_class;
18917
18918                 if (type == POSIXL) {   /* But not /l posix classes */
18919                     continue;
18920                 }
18921
18922                 for (posix_class = 0;
18923                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
18924                      posix_class++)
18925                 {
18926                     SV** our_code_points = &cp_list;
18927                     SV** official_code_points;
18928                     int try_inverted;
18929
18930                     if (type == POSIXA) {
18931                         official_code_points = &PL_Posix_ptrs[posix_class];
18932                     }
18933                     else {
18934                         official_code_points = &PL_XPosix_ptrs[posix_class];
18935                     }
18936
18937                     /* Skip non-existent classes of this type.  e.g. \v only
18938                      * has an entry in PL_XPosix_ptrs */
18939                     if (! *official_code_points) {
18940                         continue;
18941                     }
18942
18943                     /* Try both the regular class, and its inversion */
18944                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
18945                         bool this_inverted = invert ^ try_inverted;
18946
18947                         if (type != POSIXD) {
18948
18949                             /* This class that isn't /d can't match if we have
18950                              * /d dependencies */
18951                             if (has_runtime_dependency
18952                                                     & HAS_D_RUNTIME_DEPENDENCY)
18953                             {
18954                                 continue;
18955                             }
18956                         }
18957                         else /* is /d */ if (! this_inverted) {
18958
18959                             /* /d classes don't match anything non-ASCII below
18960                              * 256 unconditionally (which cp_list contains) */
18961                             _invlist_intersection(cp_list, PL_UpperLatin1,
18962                                                            &intersection);
18963                             if (_invlist_len(intersection) != 0) {
18964                                 continue;
18965                             }
18966
18967                             SvREFCNT_dec(d_invlist);
18968                             d_invlist = invlist_clone(cp_list, NULL);
18969
18970                             /* But under UTF-8 it turns into using /u rules.
18971                              * Add the things it matches under these conditions
18972                              * so that we check below that these are identical
18973                              * to what the tested class should match */
18974                             if (upper_latin1_only_utf8_matches) {
18975                                 _invlist_union(
18976                                             d_invlist,
18977                                             upper_latin1_only_utf8_matches,
18978                                             &d_invlist);
18979                             }
18980                             our_code_points = &d_invlist;
18981                         }
18982                         else {  /* POSIXD, inverted.  If this doesn't have this
18983                                    flag set, it isn't /d. */
18984                             if (! (anyof_flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
18985                             {
18986                                 continue;
18987                             }
18988                             our_code_points = &cp_list;
18989                         }
18990
18991                         /* Here, have weeded out some things.  We want to see
18992                          * if the list of characters this node contains
18993                          * ('*our_code_points') precisely matches those of the
18994                          * class we are currently checking against
18995                          * ('*official_code_points'). */
18996                         if (_invlistEQ(*our_code_points,
18997                                        *official_code_points,
18998                                        try_inverted))
18999                         {
19000                             /* Here, they precisely match.  Optimize this ANYOF
19001                              * node into its equivalent POSIX one of the
19002                              * correct type, possibly inverted */
19003                             ret = reg_node(pRExC_state, (try_inverted)
19004                                                         ? type + NPOSIXA
19005                                                                 - POSIXA
19006                                                         : type);
19007                             FLAGS(REGNODE_p(ret)) = posix_class;
19008                             SvREFCNT_dec(d_invlist);
19009                             SvREFCNT_dec(intersection);
19010                             goto not_anyof;
19011                         }
19012                     }
19013                 }
19014             }
19015             SvREFCNT_dec(d_invlist);
19016             SvREFCNT_dec(intersection);
19017         }
19018
19019         /* If didn't find an optimization and there is no need for a
19020         * bitmap, optimize to indicate that */
19021         if (     start[0] >= NUM_ANYOF_CODE_POINTS
19022             && ! LOC
19023             && ! upper_latin1_only_utf8_matches
19024             &&   anyof_flags == 0)
19025         {
19026             UV highest_cp = invlist_highest(cp_list);
19027
19028             /* If the lowest and highest code point in the class have the same
19029              * UTF-8 first byte, then all do, and we can store that byte for
19030              * regexec.c to use so that it can more quickly scan the target
19031              * string for potential matches for this class.  We co-opt the the
19032              * flags field for this.  Zero means, they don't have the same
19033              * first byte.  We do accept here very large code points (for
19034              * future use), but don't bother with this optimization for them,
19035              * as it would cause other complications */
19036             if (highest_cp > IV_MAX) {
19037                 anyof_flags = 0;
19038             }
19039             else {
19040                 U8 low_utf8[UTF8_MAXBYTES+1];
19041                 U8 high_utf8[UTF8_MAXBYTES+1];
19042
19043                 (void) uvchr_to_utf8(low_utf8, start[0]);
19044                 (void) uvchr_to_utf8(high_utf8, invlist_highest(cp_list));
19045
19046                 anyof_flags = (low_utf8[0] == high_utf8[0])
19047                             ? low_utf8[0]
19048                             : 0;
19049             }
19050
19051             op = ANYOFH;
19052         }
19053     }   /* End of seeing if can optimize it into a different node */
19054
19055   is_anyof: /* It's going to be an ANYOF node. */
19056     if (op != ANYOFH) {
19057         op = (has_runtime_dependency & HAS_D_RUNTIME_DEPENDENCY)
19058              ? ANYOFD
19059              : ((posixl)
19060                 ? ANYOFPOSIXL
19061                 : ((LOC)
19062                    ? ANYOFL
19063                    : ANYOF));
19064     }
19065
19066     ret = regnode_guts(pRExC_state, op, regarglen[op], "anyof");
19067     FILL_NODE(ret, op);        /* We set the argument later */
19068     RExC_emit += 1 + regarglen[op];
19069     ANYOF_FLAGS(REGNODE_p(ret)) = anyof_flags;
19070
19071     /* Here, <cp_list> contains all the code points we can determine at
19072      * compile time that match under all conditions.  Go through it, and
19073      * for things that belong in the bitmap, put them there, and delete from
19074      * <cp_list>.  While we are at it, see if everything above 255 is in the
19075      * list, and if so, set a flag to speed up execution */
19076
19077     populate_ANYOF_from_invlist(REGNODE_p(ret), &cp_list);
19078
19079     if (posixl) {
19080         ANYOF_POSIXL_SET_TO_BITMAP(REGNODE_p(ret), posixl);
19081     }
19082
19083     if (invert) {
19084         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_INVERT;
19085     }
19086
19087     /* Here, the bitmap has been populated with all the Latin1 code points that
19088      * always match.  Can now add to the overall list those that match only
19089      * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>).
19090      * */
19091     if (upper_latin1_only_utf8_matches) {
19092         if (cp_list) {
19093             _invlist_union(cp_list,
19094                            upper_latin1_only_utf8_matches,
19095                            &cp_list);
19096             SvREFCNT_dec_NN(upper_latin1_only_utf8_matches);
19097         }
19098         else {
19099             cp_list = upper_latin1_only_utf8_matches;
19100         }
19101         ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
19102     }
19103
19104     set_ANYOF_arg(pRExC_state, REGNODE_p(ret), cp_list,
19105                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
19106                    ? listsv : NULL,
19107                   only_utf8_locale_list);
19108     return ret;
19109
19110   not_anyof:
19111
19112     /* Here, the node is getting optimized into something that's not an ANYOF
19113      * one.  Finish up. */
19114
19115     Set_Node_Offset_Length(REGNODE_p(ret), orig_parse - RExC_start,
19116                                            RExC_parse - orig_parse);;
19117     SvREFCNT_dec(cp_list);;
19118     return ret;
19119 }
19120
19121 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
19122
19123 STATIC void
19124 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
19125                 regnode* const node,
19126                 SV* const cp_list,
19127                 SV* const runtime_defns,
19128                 SV* const only_utf8_locale_list)
19129 {
19130     /* Sets the arg field of an ANYOF-type node 'node', using information about
19131      * the node passed-in.  If there is nothing outside the node's bitmap, the
19132      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
19133      * the count returned by add_data(), having allocated and stored an array,
19134      * av, as follows:
19135      *
19136      *  av[0] stores the inversion list defining this class as far as known at
19137      *        this time, or PL_sv_undef if nothing definite is now known.
19138      *  av[1] stores the inversion list of code points that match only if the
19139      *        current locale is UTF-8, or if none, PL_sv_undef if there is an
19140      *        av[2], or no entry otherwise.
19141      *  av[2] stores the list of user-defined properties whose subroutine
19142      *        definitions aren't known at this time, or no entry if none. */
19143
19144     UV n;
19145
19146     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
19147
19148     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
19149         assert(! (ANYOF_FLAGS(node)
19150                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
19151         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
19152     }
19153     else {
19154         AV * const av = newAV();
19155         SV *rv;
19156
19157         if (cp_list) {
19158             av_store(av, INVLIST_INDEX, cp_list);
19159         }
19160
19161         if (only_utf8_locale_list) {
19162             av_store(av, ONLY_LOCALE_MATCHES_INDEX, only_utf8_locale_list);
19163         }
19164
19165         if (runtime_defns) {
19166             av_store(av, DEFERRED_USER_DEFINED_INDEX, SvREFCNT_inc(runtime_defns));
19167         }
19168
19169         rv = newRV_noinc(MUTABLE_SV(av));
19170         n = add_data(pRExC_state, STR_WITH_LEN("s"));
19171         RExC_rxi->data->data[n] = (void*)rv;
19172         ARG_SET(node, n);
19173     }
19174 }
19175
19176 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
19177 SV *
19178 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
19179                                         const regnode* node,
19180                                         bool doinit,
19181                                         SV** listsvp,
19182                                         SV** only_utf8_locale_ptr,
19183                                         SV** output_invlist)
19184
19185 {
19186     /* For internal core use only.
19187      * Returns the inversion list for the input 'node' in the regex 'prog'.
19188      * If <doinit> is 'true', will attempt to create the inversion list if not
19189      *    already done.
19190      * If <listsvp> is non-null, will return the printable contents of the
19191      *    property definition.  This can be used to get debugging information
19192      *    even before the inversion list exists, by calling this function with
19193      *    'doinit' set to false, in which case the components that will be used
19194      *    to eventually create the inversion list are returned  (in a printable
19195      *    form).
19196      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
19197      *    store an inversion list of code points that should match only if the
19198      *    execution-time locale is a UTF-8 one.
19199      * If <output_invlist> is not NULL, it is where this routine is to store an
19200      *    inversion list of the code points that would be instead returned in
19201      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
19202      *    when this parameter is used, is just the non-code point data that
19203      *    will go into creating the inversion list.  This currently should be just
19204      *    user-defined properties whose definitions were not known at compile
19205      *    time.  Using this parameter allows for easier manipulation of the
19206      *    inversion list's data by the caller.  It is illegal to call this
19207      *    function with this parameter set, but not <listsvp>
19208      *
19209      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
19210      * that, in spite of this function's name, the inversion list it returns
19211      * may include the bitmap data as well */
19212
19213     SV *si  = NULL;         /* Input initialization string */
19214     SV* invlist = NULL;
19215
19216     RXi_GET_DECL(prog, progi);
19217     const struct reg_data * const data = prog ? progi->data : NULL;
19218
19219     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
19220     assert(! output_invlist || listsvp);
19221
19222     if (data && data->count) {
19223         const U32 n = ARG(node);
19224
19225         if (data->what[n] == 's') {
19226             SV * const rv = MUTABLE_SV(data->data[n]);
19227             AV * const av = MUTABLE_AV(SvRV(rv));
19228             SV **const ary = AvARRAY(av);
19229
19230             invlist = ary[INVLIST_INDEX];
19231
19232             if (av_tindex_skip_len_mg(av) >= ONLY_LOCALE_MATCHES_INDEX) {
19233                 *only_utf8_locale_ptr = ary[ONLY_LOCALE_MATCHES_INDEX];
19234             }
19235
19236             if (av_tindex_skip_len_mg(av) >= DEFERRED_USER_DEFINED_INDEX) {
19237                 si = ary[DEFERRED_USER_DEFINED_INDEX];
19238             }
19239
19240             if (doinit && (si || invlist)) {
19241                 if (si) {
19242                     bool user_defined;
19243                     SV * msg = newSVpvs_flags("", SVs_TEMP);
19244
19245                     SV * prop_definition = handle_user_defined_property(
19246                             "", 0, FALSE,   /* There is no \p{}, \P{} */
19247                             SvPVX_const(si)[1] - '0',   /* /i or not has been
19248                                                            stored here for just
19249                                                            this occasion */
19250                             TRUE,           /* run time */
19251                             FALSE,          /* This call must find the defn */
19252                             si,             /* The property definition  */
19253                             &user_defined,
19254                             msg,
19255                             0               /* base level call */
19256                            );
19257
19258                     if (SvCUR(msg)) {
19259                         assert(prop_definition == NULL);
19260
19261                         Perl_croak(aTHX_ "%" UTF8f,
19262                                 UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg)));
19263                     }
19264
19265                     if (invlist) {
19266                         _invlist_union(invlist, prop_definition, &invlist);
19267                         SvREFCNT_dec_NN(prop_definition);
19268                     }
19269                     else {
19270                         invlist = prop_definition;
19271                     }
19272
19273                     STATIC_ASSERT_STMT(ONLY_LOCALE_MATCHES_INDEX == 1 + INVLIST_INDEX);
19274                     STATIC_ASSERT_STMT(DEFERRED_USER_DEFINED_INDEX == 1 + ONLY_LOCALE_MATCHES_INDEX);
19275
19276                     av_store(av, INVLIST_INDEX, invlist);
19277                     av_fill(av, (ary[ONLY_LOCALE_MATCHES_INDEX])
19278                                  ? ONLY_LOCALE_MATCHES_INDEX:
19279                                  INVLIST_INDEX);
19280                     si = NULL;
19281                 }
19282             }
19283         }
19284     }
19285
19286     /* If requested, return a printable version of what this ANYOF node matches
19287      * */
19288     if (listsvp) {
19289         SV* matches_string = NULL;
19290
19291         /* This function can be called at compile-time, before everything gets
19292          * resolved, in which case we return the currently best available
19293          * information, which is the string that will eventually be used to do
19294          * that resolving, 'si' */
19295         if (si) {
19296             /* Here, we only have 'si' (and possibly some passed-in data in
19297              * 'invlist', which is handled below)  If the caller only wants
19298              * 'si', use that.  */
19299             if (! output_invlist) {
19300                 matches_string = newSVsv(si);
19301             }
19302             else {
19303                 /* But if the caller wants an inversion list of the node, we
19304                  * need to parse 'si' and place as much as possible in the
19305                  * desired output inversion list, making 'matches_string' only
19306                  * contain the currently unresolvable things */
19307                 const char *si_string = SvPVX(si);
19308                 STRLEN remaining = SvCUR(si);
19309                 UV prev_cp = 0;
19310                 U8 count = 0;
19311
19312                 /* Ignore everything before the first new-line */
19313                 while (*si_string != '\n' && remaining > 0) {
19314                     si_string++;
19315                     remaining--;
19316                 }
19317                 assert(remaining > 0);
19318
19319                 si_string++;
19320                 remaining--;
19321
19322                 while (remaining > 0) {
19323
19324                     /* The data consists of just strings defining user-defined
19325                      * property names, but in prior incarnations, and perhaps
19326                      * somehow from pluggable regex engines, it could still
19327                      * hold hex code point definitions.  Each component of a
19328                      * range would be separated by a tab, and each range by a
19329                      * new-line.  If these are found, instead add them to the
19330                      * inversion list */
19331                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
19332                                      |PERL_SCAN_SILENT_NON_PORTABLE;
19333                     STRLEN len = remaining;
19334                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
19335
19336                     /* If the hex decode routine found something, it should go
19337                      * up to the next \n */
19338                     if (   *(si_string + len) == '\n') {
19339                         if (count) {    /* 2nd code point on line */
19340                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
19341                         }
19342                         else {
19343                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
19344                         }
19345                         count = 0;
19346                         goto prepare_for_next_iteration;
19347                     }
19348
19349                     /* If the hex decode was instead for the lower range limit,
19350                      * save it, and go parse the upper range limit */
19351                     if (*(si_string + len) == '\t') {
19352                         assert(count == 0);
19353
19354                         prev_cp = cp;
19355                         count = 1;
19356                       prepare_for_next_iteration:
19357                         si_string += len + 1;
19358                         remaining -= len + 1;
19359                         continue;
19360                     }
19361
19362                     /* Here, didn't find a legal hex number.  Just add it from
19363                      * here to the next \n */
19364
19365                     remaining -= len;
19366                     while (*(si_string + len) != '\n' && remaining > 0) {
19367                         remaining--;
19368                         len++;
19369                     }
19370                     if (*(si_string + len) == '\n') {
19371                         len++;
19372                         remaining--;
19373                     }
19374                     if (matches_string) {
19375                         sv_catpvn(matches_string, si_string, len - 1);
19376                     }
19377                     else {
19378                         matches_string = newSVpvn(si_string, len - 1);
19379                     }
19380                     si_string += len;
19381                     sv_catpvs(matches_string, " ");
19382                 } /* end of loop through the text */
19383
19384                 assert(matches_string);
19385                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
19386                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
19387                 }
19388             } /* end of has an 'si' */
19389         }
19390
19391         /* Add the stuff that's already known */
19392         if (invlist) {
19393
19394             /* Again, if the caller doesn't want the output inversion list, put
19395              * everything in 'matches-string' */
19396             if (! output_invlist) {
19397                 if ( ! matches_string) {
19398                     matches_string = newSVpvs("\n");
19399                 }
19400                 sv_catsv(matches_string, invlist_contents(invlist,
19401                                                   TRUE /* traditional style */
19402                                                   ));
19403             }
19404             else if (! *output_invlist) {
19405                 *output_invlist = invlist_clone(invlist, NULL);
19406             }
19407             else {
19408                 _invlist_union(*output_invlist, invlist, output_invlist);
19409             }
19410         }
19411
19412         *listsvp = matches_string;
19413     }
19414
19415     return invlist;
19416 }
19417 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
19418
19419 /* reg_skipcomment()
19420
19421    Absorbs an /x style # comment from the input stream,
19422    returning a pointer to the first character beyond the comment, or if the
19423    comment terminates the pattern without anything following it, this returns
19424    one past the final character of the pattern (in other words, RExC_end) and
19425    sets the REG_RUN_ON_COMMENT_SEEN flag.
19426
19427    Note it's the callers responsibility to ensure that we are
19428    actually in /x mode
19429
19430 */
19431
19432 PERL_STATIC_INLINE char*
19433 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
19434 {
19435     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
19436
19437     assert(*p == '#');
19438
19439     while (p < RExC_end) {
19440         if (*(++p) == '\n') {
19441             return p+1;
19442         }
19443     }
19444
19445     /* we ran off the end of the pattern without ending the comment, so we have
19446      * to add an \n when wrapping */
19447     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
19448     return p;
19449 }
19450
19451 STATIC void
19452 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
19453                                 char ** p,
19454                                 const bool force_to_xmod
19455                          )
19456 {
19457     /* If the text at the current parse position '*p' is a '(?#...)' comment,
19458      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
19459      * is /x whitespace, advance '*p' so that on exit it points to the first
19460      * byte past all such white space and comments */
19461
19462     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
19463
19464     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
19465
19466     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
19467
19468     for (;;) {
19469         if (RExC_end - (*p) >= 3
19470             && *(*p)     == '('
19471             && *(*p + 1) == '?'
19472             && *(*p + 2) == '#')
19473         {
19474             while (*(*p) != ')') {
19475                 if ((*p) == RExC_end)
19476                     FAIL("Sequence (?#... not terminated");
19477                 (*p)++;
19478             }
19479             (*p)++;
19480             continue;
19481         }
19482
19483         if (use_xmod) {
19484             const char * save_p = *p;
19485             while ((*p) < RExC_end) {
19486                 STRLEN len;
19487                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
19488                     (*p) += len;
19489                 }
19490                 else if (*(*p) == '#') {
19491                     (*p) = reg_skipcomment(pRExC_state, (*p));
19492                 }
19493                 else {
19494                     break;
19495                 }
19496             }
19497             if (*p != save_p) {
19498                 continue;
19499             }
19500         }
19501
19502         break;
19503     }
19504
19505     return;
19506 }
19507
19508 /* nextchar()
19509
19510    Advances the parse position by one byte, unless that byte is the beginning
19511    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
19512    those two cases, the parse position is advanced beyond all such comments and
19513    white space.
19514
19515    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
19516 */
19517
19518 STATIC void
19519 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
19520 {
19521     PERL_ARGS_ASSERT_NEXTCHAR;
19522
19523     if (RExC_parse < RExC_end) {
19524         assert(   ! UTF
19525                || UTF8_IS_INVARIANT(*RExC_parse)
19526                || UTF8_IS_START(*RExC_parse));
19527
19528         RExC_parse += (UTF)
19529                       ? UTF8_SAFE_SKIP(RExC_parse, RExC_end)
19530                       : 1;
19531
19532         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
19533                                 FALSE /* Don't force /x */ );
19534     }
19535 }
19536
19537 STATIC void
19538 S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const Ptrdiff_t size)
19539 {
19540     /* 'size' is the delta to add or subtract from the current memory allocated
19541      * to the regex engine being constructed */
19542
19543     PERL_ARGS_ASSERT_CHANGE_ENGINE_SIZE;
19544
19545     RExC_size += size;
19546
19547     Renewc(RExC_rxi,
19548            sizeof(regexp_internal) + (RExC_size + 1) * sizeof(regnode),
19549                                                 /* +1 for REG_MAGIC */
19550            char,
19551            regexp_internal);
19552     if ( RExC_rxi == NULL )
19553         FAIL("Regexp out of space");
19554     RXi_SET(RExC_rx, RExC_rxi);
19555
19556     RExC_emit_start = RExC_rxi->program;
19557     if (size > 0) {
19558         Zero(REGNODE_p(RExC_emit), size, regnode);
19559     }
19560
19561 #ifdef RE_TRACK_PATTERN_OFFSETS
19562     Renew(RExC_offsets, 2*RExC_size+1, U32);
19563     if (size > 0) {
19564         Zero(RExC_offsets + 2*(RExC_size - size) + 1, 2 * size, U32);
19565     }
19566     RExC_offsets[0] = RExC_size;
19567 #endif
19568 }
19569
19570 STATIC regnode_offset
19571 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
19572 {
19573     /* Allocate a regnode for 'op', with 'extra_size' extra space.  It aligns
19574      * and increments RExC_size and RExC_emit
19575      *
19576      * It returns the regnode's offset into the regex engine program */
19577
19578     const regnode_offset ret = RExC_emit;
19579
19580     GET_RE_DEBUG_FLAGS_DECL;
19581
19582     PERL_ARGS_ASSERT_REGNODE_GUTS;
19583
19584     SIZE_ALIGN(RExC_size);
19585     change_engine_size(pRExC_state, (Ptrdiff_t) 1 + extra_size);
19586     NODE_ALIGN_FILL(REGNODE_p(ret));
19587 #ifndef RE_TRACK_PATTERN_OFFSETS
19588     PERL_UNUSED_ARG(name);
19589     PERL_UNUSED_ARG(op);
19590 #else
19591     assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF);
19592
19593     if (RExC_offsets) {         /* MJD */
19594         MJD_OFFSET_DEBUG(
19595               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
19596               name, __LINE__,
19597               PL_reg_name[op],
19598               (UV)(RExC_emit) > RExC_offsets[0]
19599                 ? "Overwriting end of array!\n" : "OK",
19600               (UV)(RExC_emit),
19601               (UV)(RExC_parse - RExC_start),
19602               (UV)RExC_offsets[0]));
19603         Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END));
19604     }
19605 #endif
19606     return(ret);
19607 }
19608
19609 /*
19610 - reg_node - emit a node
19611 */
19612 STATIC regnode_offset /* Location. */
19613 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
19614 {
19615     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
19616     regnode_offset ptr = ret;
19617
19618     PERL_ARGS_ASSERT_REG_NODE;
19619
19620     assert(regarglen[op] == 0);
19621
19622     FILL_ADVANCE_NODE(ptr, op);
19623     RExC_emit = ptr;
19624     return(ret);
19625 }
19626
19627 /*
19628 - reganode - emit a node with an argument
19629 */
19630 STATIC regnode_offset /* Location. */
19631 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
19632 {
19633     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
19634     regnode_offset ptr = ret;
19635
19636     PERL_ARGS_ASSERT_REGANODE;
19637
19638     /* ANYOF are special cased to allow non-length 1 args */
19639     assert(regarglen[op] == 1);
19640
19641     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
19642     RExC_emit = ptr;
19643     return(ret);
19644 }
19645
19646 STATIC regnode_offset
19647 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
19648 {
19649     /* emit a node with U32 and I32 arguments */
19650
19651     const regnode_offset ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
19652     regnode_offset ptr = ret;
19653
19654     PERL_ARGS_ASSERT_REG2LANODE;
19655
19656     assert(regarglen[op] == 2);
19657
19658     FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
19659     RExC_emit = ptr;
19660     return(ret);
19661 }
19662
19663 /*
19664 - reginsert - insert an operator in front of already-emitted operand
19665 *
19666 * That means that on exit 'operand' is the offset of the newly inserted
19667 * operator, and the original operand has been relocated.
19668 *
19669 * IMPORTANT NOTE - it is the *callers* responsibility to correctly
19670 * set up NEXT_OFF() of the inserted node if needed. Something like this:
19671 *
19672 *   reginsert(pRExC, OPFAIL, orig_emit, depth+1);
19673 *   NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE;
19674 *
19675 * ALSO NOTE - FLAGS(newly-inserted-operator) will be set to 0 as well.
19676 */
19677 STATIC void
19678 S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op,
19679                   const regnode_offset operand, const U32 depth)
19680 {
19681     regnode *src;
19682     regnode *dst;
19683     regnode *place;
19684     const int offset = regarglen[(U8)op];
19685     const int size = NODE_STEP_REGNODE + offset;
19686     GET_RE_DEBUG_FLAGS_DECL;
19687
19688     PERL_ARGS_ASSERT_REGINSERT;
19689     PERL_UNUSED_CONTEXT;
19690     PERL_UNUSED_ARG(depth);
19691 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
19692     DEBUG_PARSE_FMT("inst"," - %s", PL_reg_name[op]);
19693     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
19694                                     studying. If this is wrong then we need to adjust RExC_recurse
19695                                     below like we do with RExC_open_parens/RExC_close_parens. */
19696     change_engine_size(pRExC_state, (Ptrdiff_t) size);
19697     src = REGNODE_p(RExC_emit);
19698     RExC_emit += size;
19699     dst = REGNODE_p(RExC_emit);
19700
19701     /* If we are in a "count the parentheses" pass, the numbers are unreliable,
19702      * and [perl #133871] shows this can lead to problems, so skip this
19703      * realignment of parens until a later pass when they are reliable */
19704     if (! IN_PARENS_PASS && RExC_open_parens) {
19705         int paren;
19706         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
19707         /* remember that RExC_npar is rex->nparens + 1,
19708          * iow it is 1 more than the number of parens seen in
19709          * the pattern so far. */
19710         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
19711             /* note, RExC_open_parens[0] is the start of the
19712              * regex, it can't move. RExC_close_parens[0] is the end
19713              * of the regex, it *can* move. */
19714             if ( paren && RExC_open_parens[paren] >= operand ) {
19715                 /*DEBUG_PARSE_FMT("open"," - %d", size);*/
19716                 RExC_open_parens[paren] += size;
19717             } else {
19718                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
19719             }
19720             if ( RExC_close_parens[paren] >= operand ) {
19721                 /*DEBUG_PARSE_FMT("close"," - %d", size);*/
19722                 RExC_close_parens[paren] += size;
19723             } else {
19724                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
19725             }
19726         }
19727     }
19728     if (RExC_end_op)
19729         RExC_end_op += size;
19730
19731     while (src > REGNODE_p(operand)) {
19732         StructCopy(--src, --dst, regnode);
19733 #ifdef RE_TRACK_PATTERN_OFFSETS
19734         if (RExC_offsets) {     /* MJD 20010112 */
19735             MJD_OFFSET_DEBUG(
19736                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
19737                   "reginsert",
19738                   __LINE__,
19739                   PL_reg_name[op],
19740                   (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0]
19741                     ? "Overwriting end of array!\n" : "OK",
19742                   (UV)REGNODE_OFFSET(src),
19743                   (UV)REGNODE_OFFSET(dst),
19744                   (UV)RExC_offsets[0]));
19745             Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src));
19746             Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src));
19747         }
19748 #endif
19749     }
19750
19751     place = REGNODE_p(operand); /* Op node, where operand used to be. */
19752 #ifdef RE_TRACK_PATTERN_OFFSETS
19753     if (RExC_offsets) {         /* MJD */
19754         MJD_OFFSET_DEBUG(
19755               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
19756               "reginsert",
19757               __LINE__,
19758               PL_reg_name[op],
19759               (UV)REGNODE_OFFSET(place) > RExC_offsets[0]
19760               ? "Overwriting end of array!\n" : "OK",
19761               (UV)REGNODE_OFFSET(place),
19762               (UV)(RExC_parse - RExC_start),
19763               (UV)RExC_offsets[0]));
19764         Set_Node_Offset(place, RExC_parse);
19765         Set_Node_Length(place, 1);
19766     }
19767 #endif
19768     src = NEXTOPER(place);
19769     FLAGS(place) = 0;
19770     FILL_NODE(operand, op);
19771
19772     /* Zero out any arguments in the new node */
19773     Zero(src, offset, regnode);
19774 }
19775
19776 /*
19777 - regtail - set the next-pointer at the end of a node chain of p to val.  If
19778             that value won't fit in the space available, instead returns FALSE.
19779             (Except asserts if we can't fit in the largest space the regex
19780             engine is designed for.)
19781 - SEE ALSO: regtail_study
19782 */
19783 STATIC bool
19784 S_regtail(pTHX_ RExC_state_t * pRExC_state,
19785                 const regnode_offset p,
19786                 const regnode_offset val,
19787                 const U32 depth)
19788 {
19789     regnode_offset scan;
19790     GET_RE_DEBUG_FLAGS_DECL;
19791
19792     PERL_ARGS_ASSERT_REGTAIL;
19793 #ifndef DEBUGGING
19794     PERL_UNUSED_ARG(depth);
19795 #endif
19796
19797     /* Find last node. */
19798     scan = (regnode_offset) p;
19799     for (;;) {
19800         regnode * const temp = regnext(REGNODE_p(scan));
19801         DEBUG_PARSE_r({
19802             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
19803             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
19804             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
19805                 SvPV_nolen_const(RExC_mysv), scan,
19806                     (temp == NULL ? "->" : ""),
19807                     (temp == NULL ? PL_reg_name[OP(REGNODE_p(val))] : "")
19808             );
19809         });
19810         if (temp == NULL)
19811             break;
19812         scan = REGNODE_OFFSET(temp);
19813     }
19814
19815     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
19816         assert((UV) (val - scan) <= U32_MAX);
19817         ARG_SET(REGNODE_p(scan), val - scan);
19818     }
19819     else {
19820         if (val - scan > U16_MAX) {
19821             /* Since not all callers check the return value, populate this with
19822              * something that won't loop and will likely lead to a crash if
19823              * execution continues */
19824             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
19825             return FALSE;
19826         }
19827         NEXT_OFF(REGNODE_p(scan)) = val - scan;
19828     }
19829
19830     return TRUE;
19831 }
19832
19833 #ifdef DEBUGGING
19834 /*
19835 - regtail_study - set the next-pointer at the end of a node chain of p to val.
19836 - Look for optimizable sequences at the same time.
19837 - currently only looks for EXACT chains.
19838
19839 This is experimental code. The idea is to use this routine to perform
19840 in place optimizations on branches and groups as they are constructed,
19841 with the long term intention of removing optimization from study_chunk so
19842 that it is purely analytical.
19843
19844 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
19845 to control which is which.
19846
19847 This used to return a value that was ignored.  It was a problem that it is
19848 #ifdef'd to be another function that didn't return a value.  khw has changed it
19849 so both currently return a pass/fail return.
19850
19851 */
19852 /* TODO: All four parms should be const */
19853
19854 STATIC bool
19855 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p,
19856                       const regnode_offset val, U32 depth)
19857 {
19858     regnode_offset scan;
19859     U8 exact = PSEUDO;
19860 #ifdef EXPERIMENTAL_INPLACESCAN
19861     I32 min = 0;
19862 #endif
19863     GET_RE_DEBUG_FLAGS_DECL;
19864
19865     PERL_ARGS_ASSERT_REGTAIL_STUDY;
19866
19867
19868     /* Find last node. */
19869
19870     scan = p;
19871     for (;;) {
19872         regnode * const temp = regnext(REGNODE_p(scan));
19873 #ifdef EXPERIMENTAL_INPLACESCAN
19874         if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) {
19875             bool unfolded_multi_char;   /* Unexamined in this routine */
19876             if (join_exact(pRExC_state, scan, &min,
19877                            &unfolded_multi_char, 1, REGNODE_p(val), depth+1))
19878                 return TRUE; /* Was return EXACT */
19879         }
19880 #endif
19881         if ( exact ) {
19882             switch (OP(REGNODE_p(scan))) {
19883                 case EXACT:
19884                 case EXACT_ONLY8:
19885                 case EXACTL:
19886                 case EXACTF:
19887                 case EXACTFU_S_EDGE:
19888                 case EXACTFAA_NO_TRIE:
19889                 case EXACTFAA:
19890                 case EXACTFU:
19891                 case EXACTFU_ONLY8:
19892                 case EXACTFLU8:
19893                 case EXACTFUP:
19894                 case EXACTFL:
19895                         if( exact == PSEUDO )
19896                             exact= OP(REGNODE_p(scan));
19897                         else if ( exact != OP(REGNODE_p(scan)) )
19898                             exact= 0;
19899                 case NOTHING:
19900                     break;
19901                 default:
19902                     exact= 0;
19903             }
19904         }
19905         DEBUG_PARSE_r({
19906             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
19907             regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state);
19908             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
19909                 SvPV_nolen_const(RExC_mysv),
19910                 scan,
19911                 PL_reg_name[exact]);
19912         });
19913         if (temp == NULL)
19914             break;
19915         scan = REGNODE_OFFSET(temp);
19916     }
19917     DEBUG_PARSE_r({
19918         DEBUG_PARSE_MSG("");
19919         regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state);
19920         Perl_re_printf( aTHX_
19921                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
19922                       SvPV_nolen_const(RExC_mysv),
19923                       (IV)val,
19924                       (IV)(val - scan)
19925         );
19926     });
19927     if (reg_off_by_arg[OP(REGNODE_p(scan))]) {
19928         assert((UV) (val - scan) <= U32_MAX);
19929         ARG_SET(REGNODE_p(scan), val - scan);
19930     }
19931     else {
19932         if (val - scan > U16_MAX) {
19933             NEXT_OFF(REGNODE_p(scan)) = U16_MAX;
19934             return FALSE;
19935         }
19936         NEXT_OFF(REGNODE_p(scan)) = val - scan;
19937     }
19938
19939     return TRUE; /* Was 'return exact' */
19940 }
19941 #endif
19942
19943 STATIC SV*
19944 S_get_ANYOFM_contents(pTHX_ const regnode * n) {
19945
19946     /* Returns an inversion list of all the code points matched by the
19947      * ANYOFM/NANYOFM node 'n' */
19948
19949     SV * cp_list = _new_invlist(-1);
19950     const U8 lowest = (U8) ARG(n);
19951     unsigned int i;
19952     U8 count = 0;
19953     U8 needed = 1U << PL_bitcount[ (U8) ~ FLAGS(n)];
19954
19955     PERL_ARGS_ASSERT_GET_ANYOFM_CONTENTS;
19956
19957     /* Starting with the lowest code point, any code point that ANDed with the
19958      * mask yields the lowest code point is in the set */
19959     for (i = lowest; i <= 0xFF; i++) {
19960         if ((i & FLAGS(n)) == ARG(n)) {
19961             cp_list = add_cp_to_invlist(cp_list, i);
19962             count++;
19963
19964             /* We know how many code points (a power of two) that are in the
19965              * set.  No use looking once we've got that number */
19966             if (count >= needed) break;
19967         }
19968     }
19969
19970     if (OP(n) == NANYOFM) {
19971         _invlist_invert(cp_list);
19972     }
19973     return cp_list;
19974 }
19975
19976 /*
19977  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
19978  */
19979 #ifdef DEBUGGING
19980
19981 static void
19982 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
19983 {
19984     int bit;
19985     int set=0;
19986
19987     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
19988
19989     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
19990         if (flags & (1<<bit)) {
19991             if (!set++ && lead)
19992                 Perl_re_printf( aTHX_  "%s", lead);
19993             Perl_re_printf( aTHX_  "%s ", PL_reg_intflags_name[bit]);
19994         }
19995     }
19996     if (lead)  {
19997         if (set)
19998             Perl_re_printf( aTHX_  "\n");
19999         else
20000             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20001     }
20002 }
20003
20004 static void
20005 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
20006 {
20007     int bit;
20008     int set=0;
20009     regex_charset cs;
20010
20011     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
20012
20013     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
20014         if (flags & (1<<bit)) {
20015             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
20016                 continue;
20017             }
20018             if (!set++ && lead)
20019                 Perl_re_printf( aTHX_  "%s", lead);
20020             Perl_re_printf( aTHX_  "%s ", PL_reg_extflags_name[bit]);
20021         }
20022     }
20023     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
20024             if (!set++ && lead) {
20025                 Perl_re_printf( aTHX_  "%s", lead);
20026             }
20027             switch (cs) {
20028                 case REGEX_UNICODE_CHARSET:
20029                     Perl_re_printf( aTHX_  "UNICODE");
20030                     break;
20031                 case REGEX_LOCALE_CHARSET:
20032                     Perl_re_printf( aTHX_  "LOCALE");
20033                     break;
20034                 case REGEX_ASCII_RESTRICTED_CHARSET:
20035                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
20036                     break;
20037                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
20038                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
20039                     break;
20040                 default:
20041                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
20042                     break;
20043             }
20044     }
20045     if (lead)  {
20046         if (set)
20047             Perl_re_printf( aTHX_  "\n");
20048         else
20049             Perl_re_printf( aTHX_  "%s[none-set]\n", lead);
20050     }
20051 }
20052 #endif
20053
20054 void
20055 Perl_regdump(pTHX_ const regexp *r)
20056 {
20057 #ifdef DEBUGGING
20058     int i;
20059     SV * const sv = sv_newmortal();
20060     SV *dsv= sv_newmortal();
20061     RXi_GET_DECL(r, ri);
20062     GET_RE_DEBUG_FLAGS_DECL;
20063
20064     PERL_ARGS_ASSERT_REGDUMP;
20065
20066     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
20067
20068     /* Header fields of interest. */
20069     for (i = 0; i < 2; i++) {
20070         if (r->substrs->data[i].substr) {
20071             RE_PV_QUOTED_DECL(s, 0, dsv,
20072                             SvPVX_const(r->substrs->data[i].substr),
20073                             RE_SV_DUMPLEN(r->substrs->data[i].substr),
20074                             PL_dump_re_max_len);
20075             Perl_re_printf( aTHX_
20076                           "%s %s%s at %" IVdf "..%" UVuf " ",
20077                           i ? "floating" : "anchored",
20078                           s,
20079                           RE_SV_TAIL(r->substrs->data[i].substr),
20080                           (IV)r->substrs->data[i].min_offset,
20081                           (UV)r->substrs->data[i].max_offset);
20082         }
20083         else if (r->substrs->data[i].utf8_substr) {
20084             RE_PV_QUOTED_DECL(s, 1, dsv,
20085                             SvPVX_const(r->substrs->data[i].utf8_substr),
20086                             RE_SV_DUMPLEN(r->substrs->data[i].utf8_substr),
20087                             30);
20088             Perl_re_printf( aTHX_
20089                           "%s utf8 %s%s at %" IVdf "..%" UVuf " ",
20090                           i ? "floating" : "anchored",
20091                           s,
20092                           RE_SV_TAIL(r->substrs->data[i].utf8_substr),
20093                           (IV)r->substrs->data[i].min_offset,
20094                           (UV)r->substrs->data[i].max_offset);
20095         }
20096     }
20097
20098     if (r->check_substr || r->check_utf8)
20099         Perl_re_printf( aTHX_
20100                       (const char *)
20101                       (   r->check_substr == r->substrs->data[1].substr
20102                        && r->check_utf8   == r->substrs->data[1].utf8_substr
20103                        ? "(checking floating" : "(checking anchored"));
20104     if (r->intflags & PREGf_NOSCAN)
20105         Perl_re_printf( aTHX_  " noscan");
20106     if (r->extflags & RXf_CHECK_ALL)
20107         Perl_re_printf( aTHX_  " isall");
20108     if (r->check_substr || r->check_utf8)
20109         Perl_re_printf( aTHX_  ") ");
20110
20111     if (ri->regstclass) {
20112         regprop(r, sv, ri->regstclass, NULL, NULL);
20113         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
20114     }
20115     if (r->intflags & PREGf_ANCH) {
20116         Perl_re_printf( aTHX_  "anchored");
20117         if (r->intflags & PREGf_ANCH_MBOL)
20118             Perl_re_printf( aTHX_  "(MBOL)");
20119         if (r->intflags & PREGf_ANCH_SBOL)
20120             Perl_re_printf( aTHX_  "(SBOL)");
20121         if (r->intflags & PREGf_ANCH_GPOS)
20122             Perl_re_printf( aTHX_  "(GPOS)");
20123         Perl_re_printf( aTHX_ " ");
20124     }
20125     if (r->intflags & PREGf_GPOS_SEEN)
20126         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
20127     if (r->intflags & PREGf_SKIP)
20128         Perl_re_printf( aTHX_  "plus ");
20129     if (r->intflags & PREGf_IMPLICIT)
20130         Perl_re_printf( aTHX_  "implicit ");
20131     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
20132     if (r->extflags & RXf_EVAL_SEEN)
20133         Perl_re_printf( aTHX_  "with eval ");
20134     Perl_re_printf( aTHX_  "\n");
20135     DEBUG_FLAGS_r({
20136         regdump_extflags("r->extflags: ", r->extflags);
20137         regdump_intflags("r->intflags: ", r->intflags);
20138     });
20139 #else
20140     PERL_ARGS_ASSERT_REGDUMP;
20141     PERL_UNUSED_CONTEXT;
20142     PERL_UNUSED_ARG(r);
20143 #endif  /* DEBUGGING */
20144 }
20145
20146 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
20147 #ifdef DEBUGGING
20148
20149 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
20150      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
20151      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
20152      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
20153      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
20154      || _CC_VERTSPACE != 15
20155 #   error Need to adjust order of anyofs[]
20156 #  endif
20157 static const char * const anyofs[] = {
20158     "\\w",
20159     "\\W",
20160     "\\d",
20161     "\\D",
20162     "[:alpha:]",
20163     "[:^alpha:]",
20164     "[:lower:]",
20165     "[:^lower:]",
20166     "[:upper:]",
20167     "[:^upper:]",
20168     "[:punct:]",
20169     "[:^punct:]",
20170     "[:print:]",
20171     "[:^print:]",
20172     "[:alnum:]",
20173     "[:^alnum:]",
20174     "[:graph:]",
20175     "[:^graph:]",
20176     "[:cased:]",
20177     "[:^cased:]",
20178     "\\s",
20179     "\\S",
20180     "[:blank:]",
20181     "[:^blank:]",
20182     "[:xdigit:]",
20183     "[:^xdigit:]",
20184     "[:cntrl:]",
20185     "[:^cntrl:]",
20186     "[:ascii:]",
20187     "[:^ascii:]",
20188     "\\v",
20189     "\\V"
20190 };
20191 #endif
20192
20193 /*
20194 - regprop - printable representation of opcode, with run time support
20195 */
20196
20197 void
20198 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
20199 {
20200 #ifdef DEBUGGING
20201     dVAR;
20202     int k;
20203     RXi_GET_DECL(prog, progi);
20204     GET_RE_DEBUG_FLAGS_DECL;
20205
20206     PERL_ARGS_ASSERT_REGPROP;
20207
20208     SvPVCLEAR(sv);
20209
20210     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
20211         /* It would be nice to FAIL() here, but this may be called from
20212            regexec.c, and it would be hard to supply pRExC_state. */
20213         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
20214                                               (int)OP(o), (int)REGNODE_MAX);
20215     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
20216
20217     k = PL_regkind[OP(o)];
20218
20219     if (k == EXACT) {
20220         sv_catpvs(sv, " ");
20221         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
20222          * is a crude hack but it may be the best for now since
20223          * we have no flag "this EXACTish node was UTF-8"
20224          * --jhi */
20225         pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len,
20226                   PL_colors[0], PL_colors[1],
20227                   PERL_PV_ESCAPE_UNI_DETECT |
20228                   PERL_PV_ESCAPE_NONASCII   |
20229                   PERL_PV_PRETTY_ELLIPSES   |
20230                   PERL_PV_PRETTY_LTGT       |
20231                   PERL_PV_PRETTY_NOCLEAR
20232                   );
20233     } else if (k == TRIE) {
20234         /* print the details of the trie in dumpuntil instead, as
20235          * progi->data isn't available here */
20236         const char op = OP(o);
20237         const U32 n = ARG(o);
20238         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
20239                (reg_ac_data *)progi->data->data[n] :
20240                NULL;
20241         const reg_trie_data * const trie
20242             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
20243
20244         Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]);
20245         DEBUG_TRIE_COMPILE_r({
20246           if (trie->jump)
20247             sv_catpvs(sv, "(JUMP)");
20248           Perl_sv_catpvf(aTHX_ sv,
20249             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
20250             (UV)trie->startstate,
20251             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
20252             (UV)trie->wordcount,
20253             (UV)trie->minlen,
20254             (UV)trie->maxlen,
20255             (UV)TRIE_CHARCOUNT(trie),
20256             (UV)trie->uniquecharcount
20257           );
20258         });
20259         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
20260             sv_catpvs(sv, "[");
20261             (void) put_charclass_bitmap_innards(sv,
20262                                                 ((IS_ANYOF_TRIE(op))
20263                                                  ? ANYOF_BITMAP(o)
20264                                                  : TRIE_BITMAP(trie)),
20265                                                 NULL,
20266                                                 NULL,
20267                                                 NULL,
20268                                                 FALSE
20269                                                );
20270             sv_catpvs(sv, "]");
20271         }
20272     } else if (k == CURLY) {
20273         U32 lo = ARG1(o), hi = ARG2(o);
20274         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
20275             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
20276         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
20277         if (hi == REG_INFTY)
20278             sv_catpvs(sv, "INFTY");
20279         else
20280             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
20281         sv_catpvs(sv, "}");
20282     }
20283     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
20284         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
20285     else if (k == REF || k == OPEN || k == CLOSE
20286              || k == GROUPP || OP(o)==ACCEPT)
20287     {
20288         AV *name_list= NULL;
20289         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
20290         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
20291         if ( RXp_PAREN_NAMES(prog) ) {
20292             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
20293         } else if ( pRExC_state ) {
20294             name_list= RExC_paren_name_list;
20295         }
20296         if (name_list) {
20297             if ( k != REF || (OP(o) < REFN)) {
20298                 SV **name= av_fetch(name_list, parno, 0 );
20299                 if (name)
20300                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20301             }
20302             else {
20303                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
20304                 I32 *nums=(I32*)SvPVX(sv_dat);
20305                 SV **name= av_fetch(name_list, nums[0], 0 );
20306                 I32 n;
20307                 if (name) {
20308                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
20309                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
20310                                     (n ? "," : ""), (IV)nums[n]);
20311                     }
20312                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20313                 }
20314             }
20315         }
20316         if ( k == REF && reginfo) {
20317             U32 n = ARG(o);  /* which paren pair */
20318             I32 ln = prog->offs[n].start;
20319             if (prog->lastparen < n || ln == -1 || prog->offs[n].end == -1)
20320                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
20321             else if (ln == prog->offs[n].end)
20322                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
20323             else {
20324                 const char *s = reginfo->strbeg + ln;
20325                 Perl_sv_catpvf(aTHX_ sv, ": ");
20326                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
20327                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
20328             }
20329         }
20330     } else if (k == GOSUB) {
20331         AV *name_list= NULL;
20332         if ( RXp_PAREN_NAMES(prog) ) {
20333             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
20334         } else if ( pRExC_state ) {
20335             name_list= RExC_paren_name_list;
20336         }
20337
20338         /* Paren and offset */
20339         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
20340                 (int)((o + (int)ARG2L(o)) - progi->program) );
20341         if (name_list) {
20342             SV **name= av_fetch(name_list, ARG(o), 0 );
20343             if (name)
20344                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
20345         }
20346     }
20347     else if (k == LOGICAL)
20348         /* 2: embedded, otherwise 1 */
20349         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
20350     else if (k == ANYOF) {
20351         const U8 flags = (OP(o) == ANYOFH) ? 0 : ANYOF_FLAGS(o);
20352         bool do_sep = FALSE;    /* Do we need to separate various components of
20353                                    the output? */
20354         /* Set if there is still an unresolved user-defined property */
20355         SV *unresolved                = NULL;
20356
20357         /* Things that are ignored except when the runtime locale is UTF-8 */
20358         SV *only_utf8_locale_invlist = NULL;
20359
20360         /* Code points that don't fit in the bitmap */
20361         SV *nonbitmap_invlist = NULL;
20362
20363         /* And things that aren't in the bitmap, but are small enough to be */
20364         SV* bitmap_range_not_in_bitmap = NULL;
20365
20366         const bool inverted = flags & ANYOF_INVERT;
20367
20368         if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) {
20369             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
20370                 sv_catpvs(sv, "{utf8-locale-reqd}");
20371             }
20372             if (flags & ANYOFL_FOLD) {
20373                 sv_catpvs(sv, "{i}");
20374             }
20375         }
20376
20377         /* If there is stuff outside the bitmap, get it */
20378         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
20379             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
20380                                                 &unresolved,
20381                                                 &only_utf8_locale_invlist,
20382                                                 &nonbitmap_invlist);
20383             /* The non-bitmap data may contain stuff that could fit in the
20384              * bitmap.  This could come from a user-defined property being
20385              * finally resolved when this call was done; or much more likely
20386              * because there are matches that require UTF-8 to be valid, and so
20387              * aren't in the bitmap.  This is teased apart later */
20388             _invlist_intersection(nonbitmap_invlist,
20389                                   PL_InBitmap,
20390                                   &bitmap_range_not_in_bitmap);
20391             /* Leave just the things that don't fit into the bitmap */
20392             _invlist_subtract(nonbitmap_invlist,
20393                               PL_InBitmap,
20394                               &nonbitmap_invlist);
20395         }
20396
20397         /* Obey this flag to add all above-the-bitmap code points */
20398         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
20399             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
20400                                                       NUM_ANYOF_CODE_POINTS,
20401                                                       UV_MAX);
20402         }
20403
20404         /* Ready to start outputting.  First, the initial left bracket */
20405         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
20406
20407         if (OP(o) != ANYOFH) {
20408             /* Then all the things that could fit in the bitmap */
20409             do_sep = put_charclass_bitmap_innards(sv,
20410                                                   ANYOF_BITMAP(o),
20411                                                   bitmap_range_not_in_bitmap,
20412                                                   only_utf8_locale_invlist,
20413                                                   o,
20414
20415                                                   /* Can't try inverting for a
20416                                                    * better display if there
20417                                                    * are things that haven't
20418                                                    * been resolved */
20419                                                   unresolved != NULL);
20420             SvREFCNT_dec(bitmap_range_not_in_bitmap);
20421
20422             /* If there are user-defined properties which haven't been defined
20423              * yet, output them.  If the result is not to be inverted, it is
20424              * clearest to output them in a separate [] from the bitmap range
20425              * stuff.  If the result is to be complemented, we have to show
20426              * everything in one [], as the inversion applies to the whole
20427              * thing.  Use {braces} to separate them from anything in the
20428              * bitmap and anything above the bitmap. */
20429             if (unresolved) {
20430                 if (inverted) {
20431                     if (! do_sep) { /* If didn't output anything in the bitmap
20432                                      */
20433                         sv_catpvs(sv, "^");
20434                     }
20435                     sv_catpvs(sv, "{");
20436                 }
20437                 else if (do_sep) {
20438                     Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1],
20439                                                       PL_colors[0]);
20440                 }
20441                 sv_catsv(sv, unresolved);
20442                 if (inverted) {
20443                     sv_catpvs(sv, "}");
20444                 }
20445                 do_sep = ! inverted;
20446             }
20447         }
20448
20449         /* And, finally, add the above-the-bitmap stuff */
20450         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
20451             SV* contents;
20452
20453             /* See if truncation size is overridden */
20454             const STRLEN dump_len = (PL_dump_re_max_len > 256)
20455                                     ? PL_dump_re_max_len
20456                                     : 256;
20457
20458             /* This is output in a separate [] */
20459             if (do_sep) {
20460                 Perl_sv_catpvf(aTHX_ sv,"%s][%s", PL_colors[1], PL_colors[0]);
20461             }
20462
20463             /* And, for easy of understanding, it is shown in the
20464              * uncomplemented form if possible.  The one exception being if
20465              * there are unresolved items, where the inversion has to be
20466              * delayed until runtime */
20467             if (inverted && ! unresolved) {
20468                 _invlist_invert(nonbitmap_invlist);
20469                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
20470             }
20471
20472             contents = invlist_contents(nonbitmap_invlist,
20473                                         FALSE /* output suitable for catsv */
20474                                        );
20475
20476             /* If the output is shorter than the permissible maximum, just do it. */
20477             if (SvCUR(contents) <= dump_len) {
20478                 sv_catsv(sv, contents);
20479             }
20480             else {
20481                 const char * contents_string = SvPVX(contents);
20482                 STRLEN i = dump_len;
20483
20484                 /* Otherwise, start at the permissible max and work back to the
20485                  * first break possibility */
20486                 while (i > 0 && contents_string[i] != ' ') {
20487                     i--;
20488                 }
20489                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
20490                                        find a legal break */
20491                     i = dump_len;
20492                 }
20493
20494                 sv_catpvn(sv, contents_string, i);
20495                 sv_catpvs(sv, "...");
20496             }
20497
20498             SvREFCNT_dec_NN(contents);
20499             SvREFCNT_dec_NN(nonbitmap_invlist);
20500         }
20501
20502         /* And finally the matching, closing ']' */
20503         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
20504
20505         if (OP(o) == ANYOFH && FLAGS(o) != 0) {
20506             Perl_sv_catpvf(aTHX_ sv, " (First UTF-8 byte=\\x%02x)", FLAGS(o));
20507         }
20508
20509
20510         SvREFCNT_dec(unresolved);
20511     }
20512     else if (k == ANYOFM) {
20513         SV * cp_list = get_ANYOFM_contents(o);
20514
20515         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
20516         if (OP(o) == NANYOFM) {
20517             _invlist_invert(cp_list);
20518         }
20519
20520         put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, TRUE);
20521         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
20522
20523         SvREFCNT_dec(cp_list);
20524     }
20525     else if (k == POSIXD || k == NPOSIXD) {
20526         U8 index = FLAGS(o) * 2;
20527         if (index < C_ARRAY_LENGTH(anyofs)) {
20528             if (*anyofs[index] != '[')  {
20529                 sv_catpvs(sv, "[");
20530             }
20531             sv_catpv(sv, anyofs[index]);
20532             if (*anyofs[index] != '[')  {
20533                 sv_catpvs(sv, "]");
20534             }
20535         }
20536         else {
20537             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
20538         }
20539     }
20540     else if (k == BOUND || k == NBOUND) {
20541         /* Must be synced with order of 'bound_type' in regcomp.h */
20542         const char * const bounds[] = {
20543             "",      /* Traditional */
20544             "{gcb}",
20545             "{lb}",
20546             "{sb}",
20547             "{wb}"
20548         };
20549         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
20550         sv_catpv(sv, bounds[FLAGS(o)]);
20551     }
20552     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) {
20553         Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags));
20554         if (o->next_off) {
20555             Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off);
20556         }
20557         Perl_sv_catpvf(aTHX_ sv, "]");
20558     }
20559     else if (OP(o) == SBOL)
20560         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
20561
20562     /* add on the verb argument if there is one */
20563     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
20564         if ( ARG(o) )
20565             Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
20566                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
20567         else
20568             sv_catpvs(sv, ":NULL");
20569     }
20570 #else
20571     PERL_UNUSED_CONTEXT;
20572     PERL_UNUSED_ARG(sv);
20573     PERL_UNUSED_ARG(o);
20574     PERL_UNUSED_ARG(prog);
20575     PERL_UNUSED_ARG(reginfo);
20576     PERL_UNUSED_ARG(pRExC_state);
20577 #endif  /* DEBUGGING */
20578 }
20579
20580
20581
20582 SV *
20583 Perl_re_intuit_string(pTHX_ REGEXP * const r)
20584 {                               /* Assume that RE_INTUIT is set */
20585     struct regexp *const prog = ReANY(r);
20586     GET_RE_DEBUG_FLAGS_DECL;
20587
20588     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
20589     PERL_UNUSED_CONTEXT;
20590
20591     DEBUG_COMPILE_r(
20592         {
20593             const char * const s = SvPV_nolen_const(RX_UTF8(r)
20594                       ? prog->check_utf8 : prog->check_substr);
20595
20596             if (!PL_colorset) reginitcolors();
20597             Perl_re_printf( aTHX_
20598                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
20599                       PL_colors[4],
20600                       RX_UTF8(r) ? "utf8 " : "",
20601                       PL_colors[5], PL_colors[0],
20602                       s,
20603                       PL_colors[1],
20604                       (strlen(s) > PL_dump_re_max_len ? "..." : ""));
20605         } );
20606
20607     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
20608     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
20609 }
20610
20611 /*
20612    pregfree()
20613
20614    handles refcounting and freeing the perl core regexp structure. When
20615    it is necessary to actually free the structure the first thing it
20616    does is call the 'free' method of the regexp_engine associated to
20617    the regexp, allowing the handling of the void *pprivate; member
20618    first. (This routine is not overridable by extensions, which is why
20619    the extensions free is called first.)
20620
20621    See regdupe and regdupe_internal if you change anything here.
20622 */
20623 #ifndef PERL_IN_XSUB_RE
20624 void
20625 Perl_pregfree(pTHX_ REGEXP *r)
20626 {
20627     SvREFCNT_dec(r);
20628 }
20629
20630 void
20631 Perl_pregfree2(pTHX_ REGEXP *rx)
20632 {
20633     struct regexp *const r = ReANY(rx);
20634     GET_RE_DEBUG_FLAGS_DECL;
20635
20636     PERL_ARGS_ASSERT_PREGFREE2;
20637
20638     if (! r)
20639         return;
20640
20641     if (r->mother_re) {
20642         ReREFCNT_dec(r->mother_re);
20643     } else {
20644         CALLREGFREE_PVT(rx); /* free the private data */
20645         SvREFCNT_dec(RXp_PAREN_NAMES(r));
20646     }
20647     if (r->substrs) {
20648         int i;
20649         for (i = 0; i < 2; i++) {
20650             SvREFCNT_dec(r->substrs->data[i].substr);
20651             SvREFCNT_dec(r->substrs->data[i].utf8_substr);
20652         }
20653         Safefree(r->substrs);
20654     }
20655     RX_MATCH_COPY_FREE(rx);
20656 #ifdef PERL_ANY_COW
20657     SvREFCNT_dec(r->saved_copy);
20658 #endif
20659     Safefree(r->offs);
20660     SvREFCNT_dec(r->qr_anoncv);
20661     if (r->recurse_locinput)
20662         Safefree(r->recurse_locinput);
20663 }
20664
20665
20666 /*  reg_temp_copy()
20667
20668     Copy ssv to dsv, both of which should of type SVt_REGEXP or SVt_PVLV,
20669     except that dsv will be created if NULL.
20670
20671     This function is used in two main ways. First to implement
20672         $r = qr/....; $s = $$r;
20673
20674     Secondly, it is used as a hacky workaround to the structural issue of
20675     match results
20676     being stored in the regexp structure which is in turn stored in
20677     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
20678     could be PL_curpm in multiple contexts, and could require multiple
20679     result sets being associated with the pattern simultaneously, such
20680     as when doing a recursive match with (??{$qr})
20681
20682     The solution is to make a lightweight copy of the regexp structure
20683     when a qr// is returned from the code executed by (??{$qr}) this
20684     lightweight copy doesn't actually own any of its data except for
20685     the starp/end and the actual regexp structure itself.
20686
20687 */
20688
20689
20690 REGEXP *
20691 Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv)
20692 {
20693     struct regexp *drx;
20694     struct regexp *const srx = ReANY(ssv);
20695     const bool islv = dsv && SvTYPE(dsv) == SVt_PVLV;
20696
20697     PERL_ARGS_ASSERT_REG_TEMP_COPY;
20698
20699     if (!dsv)
20700         dsv = (REGEXP*) newSV_type(SVt_REGEXP);
20701     else {
20702         assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV));
20703
20704         /* our only valid caller, sv_setsv_flags(), should have done
20705          * a SV_CHECK_THINKFIRST_COW_DROP() by now */
20706         assert(!SvOOK(dsv));
20707         assert(!SvIsCOW(dsv));
20708         assert(!SvROK(dsv));
20709
20710         if (SvPVX_const(dsv)) {
20711             if (SvLEN(dsv))
20712                 Safefree(SvPVX(dsv));
20713             SvPVX(dsv) = NULL;
20714         }
20715         SvLEN_set(dsv, 0);
20716         SvCUR_set(dsv, 0);
20717         SvOK_off((SV *)dsv);
20718
20719         if (islv) {
20720             /* For PVLVs, the head (sv_any) points to an XPVLV, while
20721              * the LV's xpvlenu_rx will point to a regexp body, which
20722              * we allocate here */
20723             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
20724             assert(!SvPVX(dsv));
20725             ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any;
20726             temp->sv_any = NULL;
20727             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
20728             SvREFCNT_dec_NN(temp);
20729             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
20730                ing below will not set it. */
20731             SvCUR_set(dsv, SvCUR(ssv));
20732         }
20733     }
20734     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
20735        sv_force_normal(sv) is called.  */
20736     SvFAKE_on(dsv);
20737     drx = ReANY(dsv);
20738
20739     SvFLAGS(dsv) |= SvFLAGS(ssv) & (SVf_POK|SVp_POK|SVf_UTF8);
20740     SvPV_set(dsv, RX_WRAPPED(ssv));
20741     /* We share the same string buffer as the original regexp, on which we
20742        hold a reference count, incremented when mother_re is set below.
20743        The string pointer is copied here, being part of the regexp struct.
20744      */
20745     memcpy(&(drx->xpv_cur), &(srx->xpv_cur),
20746            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
20747     if (!islv)
20748         SvLEN_set(dsv, 0);
20749     if (srx->offs) {
20750         const I32 npar = srx->nparens+1;
20751         Newx(drx->offs, npar, regexp_paren_pair);
20752         Copy(srx->offs, drx->offs, npar, regexp_paren_pair);
20753     }
20754     if (srx->substrs) {
20755         int i;
20756         Newx(drx->substrs, 1, struct reg_substr_data);
20757         StructCopy(srx->substrs, drx->substrs, struct reg_substr_data);
20758
20759         for (i = 0; i < 2; i++) {
20760             SvREFCNT_inc_void(drx->substrs->data[i].substr);
20761             SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr);
20762         }
20763
20764         /* check_substr and check_utf8, if non-NULL, point to either their
20765            anchored or float namesakes, and don't hold a second reference.  */
20766     }
20767     RX_MATCH_COPIED_off(dsv);
20768 #ifdef PERL_ANY_COW
20769     drx->saved_copy = NULL;
20770 #endif
20771     drx->mother_re = ReREFCNT_inc(srx->mother_re ? srx->mother_re : ssv);
20772     SvREFCNT_inc_void(drx->qr_anoncv);
20773     if (srx->recurse_locinput)
20774         Newx(drx->recurse_locinput, srx->nparens + 1, char *);
20775
20776     return dsv;
20777 }
20778 #endif
20779
20780
20781 /* regfree_internal()
20782
20783    Free the private data in a regexp. This is overloadable by
20784    extensions. Perl takes care of the regexp structure in pregfree(),
20785    this covers the *pprivate pointer which technically perl doesn't
20786    know about, however of course we have to handle the
20787    regexp_internal structure when no extension is in use.
20788
20789    Note this is called before freeing anything in the regexp
20790    structure.
20791  */
20792
20793 void
20794 Perl_regfree_internal(pTHX_ REGEXP * const rx)
20795 {
20796     struct regexp *const r = ReANY(rx);
20797     RXi_GET_DECL(r, ri);
20798     GET_RE_DEBUG_FLAGS_DECL;
20799
20800     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
20801
20802     if (! ri) {
20803         return;
20804     }
20805
20806     DEBUG_COMPILE_r({
20807         if (!PL_colorset)
20808             reginitcolors();
20809         {
20810             SV *dsv= sv_newmortal();
20811             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
20812                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len);
20813             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
20814                 PL_colors[4], PL_colors[5], s);
20815         }
20816     });
20817
20818 #ifdef RE_TRACK_PATTERN_OFFSETS
20819     if (ri->u.offsets)
20820         Safefree(ri->u.offsets);             /* 20010421 MJD */
20821 #endif
20822     if (ri->code_blocks)
20823         S_free_codeblocks(aTHX_ ri->code_blocks);
20824
20825     if (ri->data) {
20826         int n = ri->data->count;
20827
20828         while (--n >= 0) {
20829           /* If you add a ->what type here, update the comment in regcomp.h */
20830             switch (ri->data->what[n]) {
20831             case 'a':
20832             case 'r':
20833             case 's':
20834             case 'S':
20835             case 'u':
20836                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
20837                 break;
20838             case 'f':
20839                 Safefree(ri->data->data[n]);
20840                 break;
20841             case 'l':
20842             case 'L':
20843                 break;
20844             case 'T':
20845                 { /* Aho Corasick add-on structure for a trie node.
20846                      Used in stclass optimization only */
20847                     U32 refcount;
20848                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
20849 #ifdef USE_ITHREADS
20850                     dVAR;
20851 #endif
20852                     OP_REFCNT_LOCK;
20853                     refcount = --aho->refcount;
20854                     OP_REFCNT_UNLOCK;
20855                     if ( !refcount ) {
20856                         PerlMemShared_free(aho->states);
20857                         PerlMemShared_free(aho->fail);
20858                          /* do this last!!!! */
20859                         PerlMemShared_free(ri->data->data[n]);
20860                         /* we should only ever get called once, so
20861                          * assert as much, and also guard the free
20862                          * which /might/ happen twice. At the least
20863                          * it will make code anlyzers happy and it
20864                          * doesn't cost much. - Yves */
20865                         assert(ri->regstclass);
20866                         if (ri->regstclass) {
20867                             PerlMemShared_free(ri->regstclass);
20868                             ri->regstclass = 0;
20869                         }
20870                     }
20871                 }
20872                 break;
20873             case 't':
20874                 {
20875                     /* trie structure. */
20876                     U32 refcount;
20877                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
20878 #ifdef USE_ITHREADS
20879                     dVAR;
20880 #endif
20881                     OP_REFCNT_LOCK;
20882                     refcount = --trie->refcount;
20883                     OP_REFCNT_UNLOCK;
20884                     if ( !refcount ) {
20885                         PerlMemShared_free(trie->charmap);
20886                         PerlMemShared_free(trie->states);
20887                         PerlMemShared_free(trie->trans);
20888                         if (trie->bitmap)
20889                             PerlMemShared_free(trie->bitmap);
20890                         if (trie->jump)
20891                             PerlMemShared_free(trie->jump);
20892                         PerlMemShared_free(trie->wordinfo);
20893                         /* do this last!!!! */
20894                         PerlMemShared_free(ri->data->data[n]);
20895                     }
20896                 }
20897                 break;
20898             default:
20899                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
20900                                                     ri->data->what[n]);
20901             }
20902         }
20903         Safefree(ri->data->what);
20904         Safefree(ri->data);
20905     }
20906
20907     Safefree(ri);
20908 }
20909
20910 #define av_dup_inc(s, t)        MUTABLE_AV(sv_dup_inc((const SV *)s, t))
20911 #define hv_dup_inc(s, t)        MUTABLE_HV(sv_dup_inc((const SV *)s, t))
20912 #define SAVEPVN(p, n)   ((p) ? savepvn(p, n) : NULL)
20913
20914 /*
20915    re_dup_guts - duplicate a regexp.
20916
20917    This routine is expected to clone a given regexp structure. It is only
20918    compiled under USE_ITHREADS.
20919
20920    After all of the core data stored in struct regexp is duplicated
20921    the regexp_engine.dupe method is used to copy any private data
20922    stored in the *pprivate pointer. This allows extensions to handle
20923    any duplication it needs to do.
20924
20925    See pregfree() and regfree_internal() if you change anything here.
20926 */
20927 #if defined(USE_ITHREADS)
20928 #ifndef PERL_IN_XSUB_RE
20929 void
20930 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
20931 {
20932     dVAR;
20933     I32 npar;
20934     const struct regexp *r = ReANY(sstr);
20935     struct regexp *ret = ReANY(dstr);
20936
20937     PERL_ARGS_ASSERT_RE_DUP_GUTS;
20938
20939     npar = r->nparens+1;
20940     Newx(ret->offs, npar, regexp_paren_pair);
20941     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
20942
20943     if (ret->substrs) {
20944         /* Do it this way to avoid reading from *r after the StructCopy().
20945            That way, if any of the sv_dup_inc()s dislodge *r from the L1
20946            cache, it doesn't matter.  */
20947         int i;
20948         const bool anchored = r->check_substr
20949             ? r->check_substr == r->substrs->data[0].substr
20950             : r->check_utf8   == r->substrs->data[0].utf8_substr;
20951         Newx(ret->substrs, 1, struct reg_substr_data);
20952         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
20953
20954         for (i = 0; i < 2; i++) {
20955             ret->substrs->data[i].substr =
20956                         sv_dup_inc(ret->substrs->data[i].substr, param);
20957             ret->substrs->data[i].utf8_substr =
20958                         sv_dup_inc(ret->substrs->data[i].utf8_substr, param);
20959         }
20960
20961         /* check_substr and check_utf8, if non-NULL, point to either their
20962            anchored or float namesakes, and don't hold a second reference.  */
20963
20964         if (ret->check_substr) {
20965             if (anchored) {
20966                 assert(r->check_utf8 == r->substrs->data[0].utf8_substr);
20967
20968                 ret->check_substr = ret->substrs->data[0].substr;
20969                 ret->check_utf8   = ret->substrs->data[0].utf8_substr;
20970             } else {
20971                 assert(r->check_substr == r->substrs->data[1].substr);
20972                 assert(r->check_utf8   == r->substrs->data[1].utf8_substr);
20973
20974                 ret->check_substr = ret->substrs->data[1].substr;
20975                 ret->check_utf8   = ret->substrs->data[1].utf8_substr;
20976             }
20977         } else if (ret->check_utf8) {
20978             if (anchored) {
20979                 ret->check_utf8 = ret->substrs->data[0].utf8_substr;
20980             } else {
20981                 ret->check_utf8 = ret->substrs->data[1].utf8_substr;
20982             }
20983         }
20984     }
20985
20986     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
20987     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
20988     if (r->recurse_locinput)
20989         Newx(ret->recurse_locinput, r->nparens + 1, char *);
20990
20991     if (ret->pprivate)
20992         RXi_SET(ret, CALLREGDUPE_PVT(dstr, param));
20993
20994     if (RX_MATCH_COPIED(dstr))
20995         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
20996     else
20997         ret->subbeg = NULL;
20998 #ifdef PERL_ANY_COW
20999     ret->saved_copy = NULL;
21000 #endif
21001
21002     /* Whether mother_re be set or no, we need to copy the string.  We
21003        cannot refrain from copying it when the storage points directly to
21004        our mother regexp, because that's
21005                1: a buffer in a different thread
21006                2: something we no longer hold a reference on
21007                so we need to copy it locally.  */
21008     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1);
21009     /* set malloced length to a non-zero value so it will be freed
21010      * (otherwise in combination with SVf_FAKE it looks like an alien
21011      * buffer). It doesn't have to be the actual malloced size, since it
21012      * should never be grown */
21013     SvLEN_set(dstr, SvCUR(sstr)+1);
21014     ret->mother_re   = NULL;
21015 }
21016 #endif /* PERL_IN_XSUB_RE */
21017
21018 /*
21019    regdupe_internal()
21020
21021    This is the internal complement to regdupe() which is used to copy
21022    the structure pointed to by the *pprivate pointer in the regexp.
21023    This is the core version of the extension overridable cloning hook.
21024    The regexp structure being duplicated will be copied by perl prior
21025    to this and will be provided as the regexp *r argument, however
21026    with the /old/ structures pprivate pointer value. Thus this routine
21027    may override any copying normally done by perl.
21028
21029    It returns a pointer to the new regexp_internal structure.
21030 */
21031
21032 void *
21033 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
21034 {
21035     dVAR;
21036     struct regexp *const r = ReANY(rx);
21037     regexp_internal *reti;
21038     int len;
21039     RXi_GET_DECL(r, ri);
21040
21041     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
21042
21043     len = ProgLen(ri);
21044
21045     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
21046           char, regexp_internal);
21047     Copy(ri->program, reti->program, len+1, regnode);
21048
21049
21050     if (ri->code_blocks) {
21051         int n;
21052         Newx(reti->code_blocks, 1, struct reg_code_blocks);
21053         Newx(reti->code_blocks->cb, ri->code_blocks->count,
21054                     struct reg_code_block);
21055         Copy(ri->code_blocks->cb, reti->code_blocks->cb,
21056              ri->code_blocks->count, struct reg_code_block);
21057         for (n = 0; n < ri->code_blocks->count; n++)
21058              reti->code_blocks->cb[n].src_regex = (REGEXP*)
21059                     sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param);
21060         reti->code_blocks->count = ri->code_blocks->count;
21061         reti->code_blocks->refcnt = 1;
21062     }
21063     else
21064         reti->code_blocks = NULL;
21065
21066     reti->regstclass = NULL;
21067
21068     if (ri->data) {
21069         struct reg_data *d;
21070         const int count = ri->data->count;
21071         int i;
21072
21073         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
21074                 char, struct reg_data);
21075         Newx(d->what, count, U8);
21076
21077         d->count = count;
21078         for (i = 0; i < count; i++) {
21079             d->what[i] = ri->data->what[i];
21080             switch (d->what[i]) {
21081                 /* see also regcomp.h and regfree_internal() */
21082             case 'a': /* actually an AV, but the dup function is identical.
21083                          values seem to be "plain sv's" generally. */
21084             case 'r': /* a compiled regex (but still just another SV) */
21085             case 's': /* an RV (currently only used for an RV to an AV by the ANYOF code)
21086                          this use case should go away, the code could have used
21087                          'a' instead - see S_set_ANYOF_arg() for array contents. */
21088             case 'S': /* actually an SV, but the dup function is identical.  */
21089             case 'u': /* actually an HV, but the dup function is identical.
21090                          values are "plain sv's" */
21091                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
21092                 break;
21093             case 'f':
21094                 /* Synthetic Start Class - "Fake" charclass we generate to optimize
21095                  * patterns which could start with several different things. Pre-TRIE
21096                  * this was more important than it is now, however this still helps
21097                  * in some places, for instance /x?a+/ might produce a SSC equivalent
21098                  * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass()
21099                  * in regexec.c
21100                  */
21101                 /* This is cheating. */
21102                 Newx(d->data[i], 1, regnode_ssc);
21103                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
21104                 reti->regstclass = (regnode*)d->data[i];
21105                 break;
21106             case 'T':
21107                 /* AHO-CORASICK fail table */
21108                 /* Trie stclasses are readonly and can thus be shared
21109                  * without duplication. We free the stclass in pregfree
21110                  * when the corresponding reg_ac_data struct is freed.
21111                  */
21112                 reti->regstclass= ri->regstclass;
21113                 /* FALLTHROUGH */
21114             case 't':
21115                 /* TRIE transition table */
21116                 OP_REFCNT_LOCK;
21117                 ((reg_trie_data*)ri->data->data[i])->refcount++;
21118                 OP_REFCNT_UNLOCK;
21119                 /* FALLTHROUGH */
21120             case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */
21121             case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code
21122                          is not from another regexp */
21123                 d->data[i] = ri->data->data[i];
21124                 break;
21125             default:
21126                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
21127                                                            ri->data->what[i]);
21128             }
21129         }
21130
21131         reti->data = d;
21132     }
21133     else
21134         reti->data = NULL;
21135
21136     reti->name_list_idx = ri->name_list_idx;
21137
21138 #ifdef RE_TRACK_PATTERN_OFFSETS
21139     if (ri->u.offsets) {
21140         Newx(reti->u.offsets, 2*len+1, U32);
21141         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
21142     }
21143 #else
21144     SetProgLen(reti, len);
21145 #endif
21146
21147     return (void*)reti;
21148 }
21149
21150 #endif    /* USE_ITHREADS */
21151
21152 #ifndef PERL_IN_XSUB_RE
21153
21154 /*
21155  - regnext - dig the "next" pointer out of a node
21156  */
21157 regnode *
21158 Perl_regnext(pTHX_ regnode *p)
21159 {
21160     I32 offset;
21161
21162     if (!p)
21163         return(NULL);
21164
21165     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
21166         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
21167                                                 (int)OP(p), (int)REGNODE_MAX);
21168     }
21169
21170     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
21171     if (offset == 0)
21172         return(NULL);
21173
21174     return(p+offset);
21175 }
21176
21177 #endif
21178
21179 STATIC void
21180 S_re_croak2(pTHX_ bool utf8, const char* pat1, const char* pat2,...)
21181 {
21182     va_list args;
21183     STRLEN l1 = strlen(pat1);
21184     STRLEN l2 = strlen(pat2);
21185     char buf[512];
21186     SV *msv;
21187     const char *message;
21188
21189     PERL_ARGS_ASSERT_RE_CROAK2;
21190
21191     if (l1 > 510)
21192         l1 = 510;
21193     if (l1 + l2 > 510)
21194         l2 = 510 - l1;
21195     Copy(pat1, buf, l1 , char);
21196     Copy(pat2, buf + l1, l2 , char);
21197     buf[l1 + l2] = '\n';
21198     buf[l1 + l2 + 1] = '\0';
21199     va_start(args, pat2);
21200     msv = vmess(buf, &args);
21201     va_end(args);
21202     message = SvPV_const(msv, l1);
21203     if (l1 > 512)
21204         l1 = 512;
21205     Copy(message, buf, l1 , char);
21206     /* l1-1 to avoid \n */
21207     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
21208 }
21209
21210 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
21211
21212 #ifndef PERL_IN_XSUB_RE
21213 void
21214 Perl_save_re_context(pTHX)
21215 {
21216     I32 nparens = -1;
21217     I32 i;
21218
21219     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
21220
21221     if (PL_curpm) {
21222         const REGEXP * const rx = PM_GETRE(PL_curpm);
21223         if (rx)
21224             nparens = RX_NPARENS(rx);
21225     }
21226
21227     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
21228      * that PL_curpm will be null, but that utf8.pm and the modules it
21229      * loads will only use $1..$3.
21230      * The t/porting/re_context.t test file checks this assumption.
21231      */
21232     if (nparens == -1)
21233         nparens = 3;
21234
21235     for (i = 1; i <= nparens; i++) {
21236         char digits[TYPE_CHARS(long)];
21237         const STRLEN len = my_snprintf(digits, sizeof(digits),
21238                                        "%lu", (long)i);
21239         GV *const *const gvp
21240             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
21241
21242         if (gvp) {
21243             GV * const gv = *gvp;
21244             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
21245                 save_scalar(gv);
21246         }
21247     }
21248 }
21249 #endif
21250
21251 #ifdef DEBUGGING
21252
21253 STATIC void
21254 S_put_code_point(pTHX_ SV *sv, UV c)
21255 {
21256     PERL_ARGS_ASSERT_PUT_CODE_POINT;
21257
21258     if (c > 255) {
21259         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
21260     }
21261     else if (isPRINT(c)) {
21262         const char string = (char) c;
21263
21264         /* We use {phrase} as metanotation in the class, so also escape literal
21265          * braces */
21266         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
21267             sv_catpvs(sv, "\\");
21268         sv_catpvn(sv, &string, 1);
21269     }
21270     else if (isMNEMONIC_CNTRL(c)) {
21271         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
21272     }
21273     else {
21274         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
21275     }
21276 }
21277
21278 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
21279
21280 STATIC void
21281 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
21282 {
21283     /* Appends to 'sv' a displayable version of the range of code points from
21284      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
21285      * that have them, when they occur at the beginning or end of the range.
21286      * It uses hex to output the remaining code points, unless 'allow_literals'
21287      * is true, in which case the printable ASCII ones are output as-is (though
21288      * some of these will be escaped by put_code_point()).
21289      *
21290      * NOTE:  This is designed only for printing ranges of code points that fit
21291      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
21292      */
21293
21294     const unsigned int min_range_count = 3;
21295
21296     assert(start <= end);
21297
21298     PERL_ARGS_ASSERT_PUT_RANGE;
21299
21300     while (start <= end) {
21301         UV this_end;
21302         const char * format;
21303
21304         if (end - start < min_range_count) {
21305
21306             /* Output chars individually when they occur in short ranges */
21307             for (; start <= end; start++) {
21308                 put_code_point(sv, start);
21309             }
21310             break;
21311         }
21312
21313         /* If permitted by the input options, and there is a possibility that
21314          * this range contains a printable literal, look to see if there is
21315          * one. */
21316         if (allow_literals && start <= MAX_PRINT_A) {
21317
21318             /* If the character at the beginning of the range isn't an ASCII
21319              * printable, effectively split the range into two parts:
21320              *  1) the portion before the first such printable,
21321              *  2) the rest
21322              * and output them separately. */
21323             if (! isPRINT_A(start)) {
21324                 UV temp_end = start + 1;
21325
21326                 /* There is no point looking beyond the final possible
21327                  * printable, in MAX_PRINT_A */
21328                 UV max = MIN(end, MAX_PRINT_A);
21329
21330                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
21331                     temp_end++;
21332                 }
21333
21334                 /* Here, temp_end points to one beyond the first printable if
21335                  * found, or to one beyond 'max' if not.  If none found, make
21336                  * sure that we use the entire range */
21337                 if (temp_end > MAX_PRINT_A) {
21338                     temp_end = end + 1;
21339                 }
21340
21341                 /* Output the first part of the split range: the part that
21342                  * doesn't have printables, with the parameter set to not look
21343                  * for literals (otherwise we would infinitely recurse) */
21344                 put_range(sv, start, temp_end - 1, FALSE);
21345
21346                 /* The 2nd part of the range (if any) starts here. */
21347                 start = temp_end;
21348
21349                 /* We do a continue, instead of dropping down, because even if
21350                  * the 2nd part is non-empty, it could be so short that we want
21351                  * to output it as individual characters, as tested for at the
21352                  * top of this loop.  */
21353                 continue;
21354             }
21355
21356             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
21357              * output a sub-range of just the digits or letters, then process
21358              * the remaining portion as usual. */
21359             if (isALPHANUMERIC_A(start)) {
21360                 UV mask = (isDIGIT_A(start))
21361                            ? _CC_DIGIT
21362                              : isUPPER_A(start)
21363                                ? _CC_UPPER
21364                                : _CC_LOWER;
21365                 UV temp_end = start + 1;
21366
21367                 /* Find the end of the sub-range that includes just the
21368                  * characters in the same class as the first character in it */
21369                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
21370                     temp_end++;
21371                 }
21372                 temp_end--;
21373
21374                 /* For short ranges, don't duplicate the code above to output
21375                  * them; just call recursively */
21376                 if (temp_end - start < min_range_count) {
21377                     put_range(sv, start, temp_end, FALSE);
21378                 }
21379                 else {  /* Output as a range */
21380                     put_code_point(sv, start);
21381                     sv_catpvs(sv, "-");
21382                     put_code_point(sv, temp_end);
21383                 }
21384                 start = temp_end + 1;
21385                 continue;
21386             }
21387
21388             /* We output any other printables as individual characters */
21389             if (isPUNCT_A(start) || isSPACE_A(start)) {
21390                 while (start <= end && (isPUNCT_A(start)
21391                                         || isSPACE_A(start)))
21392                 {
21393                     put_code_point(sv, start);
21394                     start++;
21395                 }
21396                 continue;
21397             }
21398         } /* End of looking for literals */
21399
21400         /* Here is not to output as a literal.  Some control characters have
21401          * mnemonic names.  Split off any of those at the beginning and end of
21402          * the range to print mnemonically.  It isn't possible for many of
21403          * these to be in a row, so this won't overwhelm with output */
21404         if (   start <= end
21405             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
21406         {
21407             while (isMNEMONIC_CNTRL(start) && start <= end) {
21408                 put_code_point(sv, start);
21409                 start++;
21410             }
21411
21412             /* If this didn't take care of the whole range ... */
21413             if (start <= end) {
21414
21415                 /* Look backwards from the end to find the final non-mnemonic
21416                  * */
21417                 UV temp_end = end;
21418                 while (isMNEMONIC_CNTRL(temp_end)) {
21419                     temp_end--;
21420                 }
21421
21422                 /* And separately output the interior range that doesn't start
21423                  * or end with mnemonics */
21424                 put_range(sv, start, temp_end, FALSE);
21425
21426                 /* Then output the mnemonic trailing controls */
21427                 start = temp_end + 1;
21428                 while (start <= end) {
21429                     put_code_point(sv, start);
21430                     start++;
21431                 }
21432                 break;
21433             }
21434         }
21435
21436         /* As a final resort, output the range or subrange as hex. */
21437
21438         this_end = (end < NUM_ANYOF_CODE_POINTS)
21439                     ? end
21440                     : NUM_ANYOF_CODE_POINTS - 1;
21441 #if NUM_ANYOF_CODE_POINTS > 256
21442         format = (this_end < 256)
21443                  ? "\\x%02" UVXf "-\\x%02" UVXf
21444                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
21445 #else
21446         format = "\\x%02" UVXf "-\\x%02" UVXf;
21447 #endif
21448         GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
21449         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
21450         GCC_DIAG_RESTORE_STMT;
21451         break;
21452     }
21453 }
21454
21455 STATIC void
21456 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
21457 {
21458     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
21459      * 'invlist' */
21460
21461     UV start, end;
21462     bool allow_literals = TRUE;
21463
21464     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
21465
21466     /* Generally, it is more readable if printable characters are output as
21467      * literals, but if a range (nearly) spans all of them, it's best to output
21468      * it as a single range.  This code will use a single range if all but 2
21469      * ASCII printables are in it */
21470     invlist_iterinit(invlist);
21471     while (invlist_iternext(invlist, &start, &end)) {
21472
21473         /* If the range starts beyond the final printable, it doesn't have any
21474          * in it */
21475         if (start > MAX_PRINT_A) {
21476             break;
21477         }
21478
21479         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
21480          * all but two, the range must start and end no later than 2 from
21481          * either end */
21482         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
21483             if (end > MAX_PRINT_A) {
21484                 end = MAX_PRINT_A;
21485             }
21486             if (start < ' ') {
21487                 start = ' ';
21488             }
21489             if (end - start >= MAX_PRINT_A - ' ' - 2) {
21490                 allow_literals = FALSE;
21491             }
21492             break;
21493         }
21494     }
21495     invlist_iterfinish(invlist);
21496
21497     /* Here we have figured things out.  Output each range */
21498     invlist_iterinit(invlist);
21499     while (invlist_iternext(invlist, &start, &end)) {
21500         if (start >= NUM_ANYOF_CODE_POINTS) {
21501             break;
21502         }
21503         put_range(sv, start, end, allow_literals);
21504     }
21505     invlist_iterfinish(invlist);
21506
21507     return;
21508 }
21509
21510 STATIC SV*
21511 S_put_charclass_bitmap_innards_common(pTHX_
21512         SV* invlist,            /* The bitmap */
21513         SV* posixes,            /* Under /l, things like [:word:], \S */
21514         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
21515         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
21516         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
21517         const bool invert       /* Is the result to be inverted? */
21518 )
21519 {
21520     /* Create and return an SV containing a displayable version of the bitmap
21521      * and associated information determined by the input parameters.  If the
21522      * output would have been only the inversion indicator '^', NULL is instead
21523      * returned. */
21524
21525     dVAR;
21526     SV * output;
21527
21528     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
21529
21530     if (invert) {
21531         output = newSVpvs("^");
21532     }
21533     else {
21534         output = newSVpvs("");
21535     }
21536
21537     /* First, the code points in the bitmap that are unconditionally there */
21538     put_charclass_bitmap_innards_invlist(output, invlist);
21539
21540     /* Traditionally, these have been placed after the main code points */
21541     if (posixes) {
21542         sv_catsv(output, posixes);
21543     }
21544
21545     if (only_utf8 && _invlist_len(only_utf8)) {
21546         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
21547         put_charclass_bitmap_innards_invlist(output, only_utf8);
21548     }
21549
21550     if (not_utf8 && _invlist_len(not_utf8)) {
21551         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
21552         put_charclass_bitmap_innards_invlist(output, not_utf8);
21553     }
21554
21555     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
21556         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
21557         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
21558
21559         /* This is the only list in this routine that can legally contain code
21560          * points outside the bitmap range.  The call just above to
21561          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
21562          * output them here.  There's about a half-dozen possible, and none in
21563          * contiguous ranges longer than 2 */
21564         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21565             UV start, end;
21566             SV* above_bitmap = NULL;
21567
21568             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
21569
21570             invlist_iterinit(above_bitmap);
21571             while (invlist_iternext(above_bitmap, &start, &end)) {
21572                 UV i;
21573
21574                 for (i = start; i <= end; i++) {
21575                     put_code_point(output, i);
21576                 }
21577             }
21578             invlist_iterfinish(above_bitmap);
21579             SvREFCNT_dec_NN(above_bitmap);
21580         }
21581     }
21582
21583     if (invert && SvCUR(output) == 1) {
21584         return NULL;
21585     }
21586
21587     return output;
21588 }
21589
21590 STATIC bool
21591 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
21592                                      char *bitmap,
21593                                      SV *nonbitmap_invlist,
21594                                      SV *only_utf8_locale_invlist,
21595                                      const regnode * const node,
21596                                      const bool force_as_is_display)
21597 {
21598     /* Appends to 'sv' a displayable version of the innards of the bracketed
21599      * character class defined by the other arguments:
21600      *  'bitmap' points to the bitmap, or NULL if to ignore that.
21601      *  'nonbitmap_invlist' is an inversion list of the code points that are in
21602      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
21603      *      none.  The reasons for this could be that they require some
21604      *      condition such as the target string being or not being in UTF-8
21605      *      (under /d), or because they came from a user-defined property that
21606      *      was not resolved at the time of the regex compilation (under /u)
21607      *  'only_utf8_locale_invlist' is an inversion list of the code points that
21608      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
21609      *  'node' is the regex pattern ANYOF node.  It is needed only when the
21610      *      above two parameters are not null, and is passed so that this
21611      *      routine can tease apart the various reasons for them.
21612      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
21613      *      to invert things to see if that leads to a cleaner display.  If
21614      *      FALSE, this routine is free to use its judgment about doing this.
21615      *
21616      * It returns TRUE if there was actually something output.  (It may be that
21617      * the bitmap, etc is empty.)
21618      *
21619      * When called for outputting the bitmap of a non-ANYOF node, just pass the
21620      * bitmap, with the succeeding parameters set to NULL, and the final one to
21621      * FALSE.
21622      */
21623
21624     /* In general, it tries to display the 'cleanest' representation of the
21625      * innards, choosing whether to display them inverted or not, regardless of
21626      * whether the class itself is to be inverted.  However,  there are some
21627      * cases where it can't try inverting, as what actually matches isn't known
21628      * until runtime, and hence the inversion isn't either. */
21629
21630     dVAR;
21631     bool inverting_allowed = ! force_as_is_display;
21632
21633     int i;
21634     STRLEN orig_sv_cur = SvCUR(sv);
21635
21636     SV* invlist;            /* Inversion list we accumulate of code points that
21637                                are unconditionally matched */
21638     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
21639                                UTF-8 */
21640     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
21641                              */
21642     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
21643     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
21644                                        is UTF-8 */
21645
21646     SV* as_is_display;      /* The output string when we take the inputs
21647                                literally */
21648     SV* inverted_display;   /* The output string when we invert the inputs */
21649
21650     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
21651
21652     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
21653                                                    to match? */
21654     /* We are biased in favor of displaying things without them being inverted,
21655      * as that is generally easier to understand */
21656     const int bias = 5;
21657
21658     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
21659
21660     /* Start off with whatever code points are passed in.  (We clone, so we
21661      * don't change the caller's list) */
21662     if (nonbitmap_invlist) {
21663         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
21664         invlist = invlist_clone(nonbitmap_invlist, NULL);
21665     }
21666     else {  /* Worst case size is every other code point is matched */
21667         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
21668     }
21669
21670     if (flags) {
21671         if (OP(node) == ANYOFD) {
21672
21673             /* This flag indicates that the code points below 0x100 in the
21674              * nonbitmap list are precisely the ones that match only when the
21675              * target is UTF-8 (they should all be non-ASCII). */
21676             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
21677             {
21678                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
21679                 _invlist_subtract(invlist, only_utf8, &invlist);
21680             }
21681
21682             /* And this flag for matching all non-ASCII 0xFF and below */
21683             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
21684             {
21685                 not_utf8 = invlist_clone(PL_UpperLatin1, NULL);
21686             }
21687         }
21688         else if (OP(node) == ANYOFL || OP(node) == ANYOFPOSIXL) {
21689
21690             /* If either of these flags are set, what matches isn't
21691              * determinable except during execution, so don't know enough here
21692              * to invert */
21693             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
21694                 inverting_allowed = FALSE;
21695             }
21696
21697             /* What the posix classes match also varies at runtime, so these
21698              * will be output symbolically. */
21699             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
21700                 int i;
21701
21702                 posixes = newSVpvs("");
21703                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
21704                     if (ANYOF_POSIXL_TEST(node, i)) {
21705                         sv_catpv(posixes, anyofs[i]);
21706                     }
21707                 }
21708             }
21709         }
21710     }
21711
21712     /* Accumulate the bit map into the unconditional match list */
21713     if (bitmap) {
21714         for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
21715             if (BITMAP_TEST(bitmap, i)) {
21716                 int start = i++;
21717                 for (;
21718                      i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i);
21719                      i++)
21720                 { /* empty */ }
21721                 invlist = _add_range_to_invlist(invlist, start, i-1);
21722             }
21723         }
21724     }
21725
21726     /* Make sure that the conditional match lists don't have anything in them
21727      * that match unconditionally; otherwise the output is quite confusing.
21728      * This could happen if the code that populates these misses some
21729      * duplication. */
21730     if (only_utf8) {
21731         _invlist_subtract(only_utf8, invlist, &only_utf8);
21732     }
21733     if (not_utf8) {
21734         _invlist_subtract(not_utf8, invlist, &not_utf8);
21735     }
21736
21737     if (only_utf8_locale_invlist) {
21738
21739         /* Since this list is passed in, we have to make a copy before
21740          * modifying it */
21741         only_utf8_locale = invlist_clone(only_utf8_locale_invlist, NULL);
21742
21743         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
21744
21745         /* And, it can get really weird for us to try outputting an inverted
21746          * form of this list when it has things above the bitmap, so don't even
21747          * try */
21748         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
21749             inverting_allowed = FALSE;
21750         }
21751     }
21752
21753     /* Calculate what the output would be if we take the input as-is */
21754     as_is_display = put_charclass_bitmap_innards_common(invlist,
21755                                                     posixes,
21756                                                     only_utf8,
21757                                                     not_utf8,
21758                                                     only_utf8_locale,
21759                                                     invert);
21760
21761     /* If have to take the output as-is, just do that */
21762     if (! inverting_allowed) {
21763         if (as_is_display) {
21764             sv_catsv(sv, as_is_display);
21765             SvREFCNT_dec_NN(as_is_display);
21766         }
21767     }
21768     else { /* But otherwise, create the output again on the inverted input, and
21769               use whichever version is shorter */
21770
21771         int inverted_bias, as_is_bias;
21772
21773         /* We will apply our bias to whichever of the the results doesn't have
21774          * the '^' */
21775         if (invert) {
21776             invert = FALSE;
21777             as_is_bias = bias;
21778             inverted_bias = 0;
21779         }
21780         else {
21781             invert = TRUE;
21782             as_is_bias = 0;
21783             inverted_bias = bias;
21784         }
21785
21786         /* Now invert each of the lists that contribute to the output,
21787          * excluding from the result things outside the possible range */
21788
21789         /* For the unconditional inversion list, we have to add in all the
21790          * conditional code points, so that when inverted, they will be gone
21791          * from it */
21792         _invlist_union(only_utf8, invlist, &invlist);
21793         _invlist_union(not_utf8, invlist, &invlist);
21794         _invlist_union(only_utf8_locale, invlist, &invlist);
21795         _invlist_invert(invlist);
21796         _invlist_intersection(invlist, PL_InBitmap, &invlist);
21797
21798         if (only_utf8) {
21799             _invlist_invert(only_utf8);
21800             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
21801         }
21802         else if (not_utf8) {
21803
21804             /* If a code point matches iff the target string is not in UTF-8,
21805              * then complementing the result has it not match iff not in UTF-8,
21806              * which is the same thing as matching iff it is UTF-8. */
21807             only_utf8 = not_utf8;
21808             not_utf8 = NULL;
21809         }
21810
21811         if (only_utf8_locale) {
21812             _invlist_invert(only_utf8_locale);
21813             _invlist_intersection(only_utf8_locale,
21814                                   PL_InBitmap,
21815                                   &only_utf8_locale);
21816         }
21817
21818         inverted_display = put_charclass_bitmap_innards_common(
21819                                             invlist,
21820                                             posixes,
21821                                             only_utf8,
21822                                             not_utf8,
21823                                             only_utf8_locale, invert);
21824
21825         /* Use the shortest representation, taking into account our bias
21826          * against showing it inverted */
21827         if (   inverted_display
21828             && (   ! as_is_display
21829                 || (  SvCUR(inverted_display) + inverted_bias
21830                     < SvCUR(as_is_display)    + as_is_bias)))
21831         {
21832             sv_catsv(sv, inverted_display);
21833         }
21834         else if (as_is_display) {
21835             sv_catsv(sv, as_is_display);
21836         }
21837
21838         SvREFCNT_dec(as_is_display);
21839         SvREFCNT_dec(inverted_display);
21840     }
21841
21842     SvREFCNT_dec_NN(invlist);
21843     SvREFCNT_dec(only_utf8);
21844     SvREFCNT_dec(not_utf8);
21845     SvREFCNT_dec(posixes);
21846     SvREFCNT_dec(only_utf8_locale);
21847
21848     return SvCUR(sv) > orig_sv_cur;
21849 }
21850
21851 #define CLEAR_OPTSTART                                                       \
21852     if (optstart) STMT_START {                                               \
21853         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
21854                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
21855         optstart=NULL;                                                       \
21856     } STMT_END
21857
21858 #define DUMPUNTIL(b,e)                                                       \
21859                     CLEAR_OPTSTART;                                          \
21860                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
21861
21862 STATIC const regnode *
21863 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
21864             const regnode *last, const regnode *plast,
21865             SV* sv, I32 indent, U32 depth)
21866 {
21867     U8 op = PSEUDO;     /* Arbitrary non-END op. */
21868     const regnode *next;
21869     const regnode *optstart= NULL;
21870
21871     RXi_GET_DECL(r, ri);
21872     GET_RE_DEBUG_FLAGS_DECL;
21873
21874     PERL_ARGS_ASSERT_DUMPUNTIL;
21875
21876 #ifdef DEBUG_DUMPUNTIL
21877     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n", indent, node-start,
21878         last ? last-start : 0, plast ? plast-start : 0);
21879 #endif
21880
21881     if (plast && plast < last)
21882         last= plast;
21883
21884     while (PL_regkind[op] != END && (!last || node < last)) {
21885         assert(node);
21886         /* While that wasn't END last time... */
21887         NODE_ALIGN(node);
21888         op = OP(node);
21889         if (op == CLOSE || op == SRCLOSE || op == WHILEM)
21890             indent--;
21891         next = regnext((regnode *)node);
21892
21893         /* Where, what. */
21894         if (OP(node) == OPTIMIZED) {
21895             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
21896                 optstart = node;
21897             else
21898                 goto after_print;
21899         } else
21900             CLEAR_OPTSTART;
21901
21902         regprop(r, sv, node, NULL, NULL);
21903         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
21904                       (int)(2*indent + 1), "", SvPVX_const(sv));
21905
21906         if (OP(node) != OPTIMIZED) {
21907             if (next == NULL)           /* Next ptr. */
21908                 Perl_re_printf( aTHX_  " (0)");
21909             else if (PL_regkind[(U8)op] == BRANCH
21910                      && PL_regkind[OP(next)] != BRANCH )
21911                 Perl_re_printf( aTHX_  " (FAIL)");
21912             else
21913                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
21914             Perl_re_printf( aTHX_ "\n");
21915         }
21916
21917       after_print:
21918         if (PL_regkind[(U8)op] == BRANCHJ) {
21919             assert(next);
21920             {
21921                 const regnode *nnode = (OP(next) == LONGJMP
21922                                        ? regnext((regnode *)next)
21923                                        : next);
21924                 if (last && nnode > last)
21925                     nnode = last;
21926                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
21927             }
21928         }
21929         else if (PL_regkind[(U8)op] == BRANCH) {
21930             assert(next);
21931             DUMPUNTIL(NEXTOPER(node), next);
21932         }
21933         else if ( PL_regkind[(U8)op]  == TRIE ) {
21934             const regnode *this_trie = node;
21935             const char op = OP(node);
21936             const U32 n = ARG(node);
21937             const reg_ac_data * const ac = op>=AHOCORASICK ?
21938                (reg_ac_data *)ri->data->data[n] :
21939                NULL;
21940             const reg_trie_data * const trie =
21941                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
21942 #ifdef DEBUGGING
21943             AV *const trie_words
21944                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
21945 #endif
21946             const regnode *nextbranch= NULL;
21947             I32 word_idx;
21948             SvPVCLEAR(sv);
21949             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
21950                 SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0);
21951
21952                 Perl_re_indentf( aTHX_  "%s ",
21953                     indent+3,
21954                     elem_ptr
21955                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
21956                                 SvCUR(*elem_ptr), PL_dump_re_max_len,
21957                                 PL_colors[0], PL_colors[1],
21958                                 (SvUTF8(*elem_ptr)
21959                                  ? PERL_PV_ESCAPE_UNI
21960                                  : 0)
21961                                 | PERL_PV_PRETTY_ELLIPSES
21962                                 | PERL_PV_PRETTY_LTGT
21963                             )
21964                     : "???"
21965                 );
21966                 if (trie->jump) {
21967                     U16 dist= trie->jump[word_idx+1];
21968                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
21969                                (UV)((dist ? this_trie + dist : next) - start));
21970                     if (dist) {
21971                         if (!nextbranch)
21972                             nextbranch= this_trie + trie->jump[0];
21973                         DUMPUNTIL(this_trie + dist, nextbranch);
21974                     }
21975                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
21976                         nextbranch= regnext((regnode *)nextbranch);
21977                 } else {
21978                     Perl_re_printf( aTHX_  "\n");
21979                 }
21980             }
21981             if (last && next > last)
21982                 node= last;
21983             else
21984                 node= next;
21985         }
21986         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
21987             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
21988                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
21989         }
21990         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
21991             assert(next);
21992             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
21993         }
21994         else if ( op == PLUS || op == STAR) {
21995             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
21996         }
21997         else if (PL_regkind[(U8)op] == EXACT) {
21998             /* Literal string, where present. */
21999             node += NODE_SZ_STR(node) - 1;
22000             node = NEXTOPER(node);
22001         }
22002         else {
22003             node = NEXTOPER(node);
22004             node += regarglen[(U8)op];
22005         }
22006         if (op == CURLYX || op == OPEN || op == SROPEN)
22007             indent++;
22008     }
22009     CLEAR_OPTSTART;
22010 #ifdef DEBUG_DUMPUNTIL
22011     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
22012 #endif
22013     return node;
22014 }
22015
22016 #endif  /* DEBUGGING */
22017
22018 #ifndef PERL_IN_XSUB_RE
22019
22020 #include "uni_keywords.h"
22021
22022 void
22023 Perl_init_uniprops(pTHX)
22024 {
22025     dVAR;
22026
22027     PL_user_def_props = newHV();
22028
22029 #ifdef USE_ITHREADS
22030
22031     HvSHAREKEYS_off(PL_user_def_props);
22032     PL_user_def_props_aTHX = aTHX;
22033
22034 #endif
22035
22036     /* Set up the inversion list global variables */
22037
22038     PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
22039     PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALNUM]);
22040     PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXALPHA]);
22041     PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXBLANK]);
22042     PL_XPosix_ptrs[_CC_CASED] =  _new_invlist_C_array(uni_prop_ptrs[UNI_CASED]);
22043     PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXCNTRL]);
22044     PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXDIGIT]);
22045     PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXGRAPH]);
22046     PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXLOWER]);
22047     PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPRINT]);
22048     PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXPUNCT]);
22049     PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXSPACE]);
22050     PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXUPPER]);
22051     PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_VERTSPACE]);
22052     PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXWORD]);
22053     PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_XPOSIXXDIGIT]);
22054
22055     PL_Posix_ptrs[_CC_ASCII] = _new_invlist_C_array(uni_prop_ptrs[UNI_ASCII]);
22056     PL_Posix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALNUM]);
22057     PL_Posix_ptrs[_CC_ALPHA] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXALPHA]);
22058     PL_Posix_ptrs[_CC_BLANK] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXBLANK]);
22059     PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
22060     PL_Posix_ptrs[_CC_CNTRL] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXCNTRL]);
22061     PL_Posix_ptrs[_CC_DIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXDIGIT]);
22062     PL_Posix_ptrs[_CC_GRAPH] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXGRAPH]);
22063     PL_Posix_ptrs[_CC_LOWER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXLOWER]);
22064     PL_Posix_ptrs[_CC_PRINT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPRINT]);
22065     PL_Posix_ptrs[_CC_PUNCT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXPUNCT]);
22066     PL_Posix_ptrs[_CC_SPACE] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXSPACE]);
22067     PL_Posix_ptrs[_CC_UPPER] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXUPPER]);
22068     PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
22069     PL_Posix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXWORD]);
22070     PL_Posix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(uni_prop_ptrs[UNI_POSIXXDIGIT]);
22071
22072     PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist);
22073     PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist);
22074     PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist);
22075     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
22076     PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
22077
22078     PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
22079     PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
22080     PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
22081
22082     PL_Assigned_invlist = _new_invlist_C_array(uni_prop_ptrs[UNI_ASSIGNED]);
22083
22084     PL_utf8_perl_idstart = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDSTART]);
22085     PL_utf8_perl_idcont = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_IDCONT]);
22086
22087     PL_utf8_charname_begin = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_BEGIN]);
22088     PL_utf8_charname_continue = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_CHARNAME_CONTINUE]);
22089
22090     PL_in_some_fold = _new_invlist_C_array(uni_prop_ptrs[UNI__PERL_ANY_FOLDS]);
22091     PL_HasMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
22092                                             UNI__PERL_FOLDS_TO_MULTI_CHAR]);
22093     PL_InMultiCharFold = _new_invlist_C_array(uni_prop_ptrs[
22094                                             UNI__PERL_IS_IN_MULTI_CHAR_FOLD]);
22095     PL_NonFinalFold = _new_invlist_C_array(uni_prop_ptrs[
22096                                             UNI__PERL_NON_FINAL_FOLDS]);
22097
22098     PL_utf8_toupper = _new_invlist_C_array(Uppercase_Mapping_invlist);
22099     PL_utf8_tolower = _new_invlist_C_array(Lowercase_Mapping_invlist);
22100     PL_utf8_totitle = _new_invlist_C_array(Titlecase_Mapping_invlist);
22101     PL_utf8_tofold = _new_invlist_C_array(Case_Folding_invlist);
22102     PL_utf8_tosimplefold = _new_invlist_C_array(Simple_Case_Folding_invlist);
22103     PL_utf8_foldclosures = _new_invlist_C_array(_Perl_IVCF_invlist);
22104     PL_utf8_mark = _new_invlist_C_array(uni_prop_ptrs[UNI_M]);
22105     PL_CCC_non0_non230 = _new_invlist_C_array(_Perl_CCC_non0_non230_invlist);
22106     PL_Private_Use = _new_invlist_C_array(uni_prop_ptrs[UNI_CO]);
22107
22108 #ifdef UNI_XIDC
22109     /* The below are used only by deprecated functions.  They could be removed */
22110     PL_utf8_xidcont  = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDC]);
22111     PL_utf8_idcont   = _new_invlist_C_array(uni_prop_ptrs[UNI_IDC]);
22112     PL_utf8_xidstart = _new_invlist_C_array(uni_prop_ptrs[UNI_XIDS]);
22113 #endif
22114 }
22115
22116 #if 0
22117
22118 This code was mainly added for backcompat to give a warning for non-portable
22119 code points in user-defined properties.  But experiments showed that the
22120 warning in earlier perls were only omitted on overflow, which should be an
22121 error, so there really isnt a backcompat issue, and actually adding the
22122 warning when none was present before might cause breakage, for little gain.  So
22123 khw left this code in, but not enabled.  Tests were never added.
22124
22125 embed.fnc entry:
22126 Ei      |const char *|get_extended_utf8_msg|const UV cp
22127
22128 PERL_STATIC_INLINE const char *
22129 S_get_extended_utf8_msg(pTHX_ const UV cp)
22130 {
22131     U8 dummy[UTF8_MAXBYTES + 1];
22132     HV *msgs;
22133     SV **msg;
22134
22135     uvchr_to_utf8_flags_msgs(dummy, cp, UNICODE_WARN_PERL_EXTENDED,
22136                              &msgs);
22137
22138     msg = hv_fetchs(msgs, "text", 0);
22139     assert(msg);
22140
22141     (void) sv_2mortal((SV *) msgs);
22142
22143     return SvPVX(*msg);
22144 }
22145
22146 #endif
22147
22148 SV *
22149 Perl_handle_user_defined_property(pTHX_
22150
22151     /* Parses the contents of a user-defined property definition; returning the
22152      * expanded definition if possible.  If so, the return is an inversion
22153      * list.
22154      *
22155      * If there are subroutines that are part of the expansion and which aren't
22156      * known at the time of the call to this function, this returns what
22157      * parse_uniprop_string() returned for the first one encountered.
22158      *
22159      * If an error was found, NULL is returned, and 'msg' gets a suitable
22160      * message appended to it.  (Appending allows the back trace of how we got
22161      * to the faulty definition to be displayed through nested calls of
22162      * user-defined subs.)
22163      *
22164      * The caller IS responsible for freeing any returned SV.
22165      *
22166      * The syntax of the contents is pretty much described in perlunicode.pod,
22167      * but we also allow comments on each line */
22168
22169     const char * name,          /* Name of property */
22170     const STRLEN name_len,      /* The name's length in bytes */
22171     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22172     const bool to_fold,         /* ? Is this under /i */
22173     const bool runtime,         /* ? Are we in compile- or run-time */
22174     const bool deferrable,      /* Is it ok for this property's full definition
22175                                    to be deferred until later? */
22176     SV* contents,               /* The property's definition */
22177     bool *user_defined_ptr,     /* This will be set TRUE as we wouldn't be
22178                                    getting called unless this is thought to be
22179                                    a user-defined property */
22180     SV * msg,                   /* Any error or warning msg(s) are appended to
22181                                    this */
22182     const STRLEN level)         /* Recursion level of this call */
22183 {
22184     STRLEN len;
22185     const char * string         = SvPV_const(contents, len);
22186     const char * const e        = string + len;
22187     const bool is_contents_utf8 = cBOOL(SvUTF8(contents));
22188     const STRLEN msgs_length_on_entry = SvCUR(msg);
22189
22190     const char * s0 = string;   /* Points to first byte in the current line
22191                                    being parsed in 'string' */
22192     const char overflow_msg[] = "Code point too large in \"";
22193     SV* running_definition = NULL;
22194
22195     PERL_ARGS_ASSERT_HANDLE_USER_DEFINED_PROPERTY;
22196
22197     *user_defined_ptr = TRUE;
22198
22199     /* Look at each line */
22200     while (s0 < e) {
22201         const char * s;     /* Current byte */
22202         char op = '+';      /* Default operation is 'union' */
22203         IV   min = 0;       /* range begin code point */
22204         IV   max = -1;      /* and range end */
22205         SV* this_definition;
22206
22207         /* Skip comment lines */
22208         if (*s0 == '#') {
22209             s0 = strchr(s0, '\n');
22210             if (s0 == NULL) {
22211                 break;
22212             }
22213             s0++;
22214             continue;
22215         }
22216
22217         /* For backcompat, allow an empty first line */
22218         if (*s0 == '\n') {
22219             s0++;
22220             continue;
22221         }
22222
22223         /* First character in the line may optionally be the operation */
22224         if (   *s0 == '+'
22225             || *s0 == '!'
22226             || *s0 == '-'
22227             || *s0 == '&')
22228         {
22229             op = *s0++;
22230         }
22231
22232         /* If the line is one or two hex digits separated by blank space, its
22233          * a range; otherwise it is either another user-defined property or an
22234          * error */
22235
22236         s = s0;
22237
22238         if (! isXDIGIT(*s)) {
22239             goto check_if_property;
22240         }
22241
22242         do { /* Each new hex digit will add 4 bits. */
22243             if (min > ( (IV) MAX_LEGAL_CP >> 4)) {
22244                 s = strchr(s, '\n');
22245                 if (s == NULL) {
22246                     s = e;
22247                 }
22248                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22249                 sv_catpv(msg, overflow_msg);
22250                 Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22251                                      UTF8fARG(is_contents_utf8, s - s0, s0));
22252                 sv_catpvs(msg, "\"");
22253                 goto return_failure;
22254             }
22255
22256             /* Accumulate this digit into the value */
22257             min = (min << 4) + READ_XDIGIT(s);
22258         } while (isXDIGIT(*s));
22259
22260         while (isBLANK(*s)) { s++; }
22261
22262         /* We allow comments at the end of the line */
22263         if (*s == '#') {
22264             s = strchr(s, '\n');
22265             if (s == NULL) {
22266                 s = e;
22267             }
22268             s++;
22269         }
22270         else if (s < e && *s != '\n') {
22271             if (! isXDIGIT(*s)) {
22272                 goto check_if_property;
22273             }
22274
22275             /* Look for the high point of the range */
22276             max = 0;
22277             do {
22278                 if (max > ( (IV) MAX_LEGAL_CP >> 4)) {
22279                     s = strchr(s, '\n');
22280                     if (s == NULL) {
22281                         s = e;
22282                     }
22283                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22284                     sv_catpv(msg, overflow_msg);
22285                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22286                                       UTF8fARG(is_contents_utf8, s - s0, s0));
22287                     sv_catpvs(msg, "\"");
22288                     goto return_failure;
22289                 }
22290
22291                 max = (max << 4) + READ_XDIGIT(s);
22292             } while (isXDIGIT(*s));
22293
22294             while (isBLANK(*s)) { s++; }
22295
22296             if (*s == '#') {
22297                 s = strchr(s, '\n');
22298                 if (s == NULL) {
22299                     s = e;
22300                 }
22301             }
22302             else if (s < e && *s != '\n') {
22303                 goto check_if_property;
22304             }
22305         }
22306
22307         if (max == -1) {    /* The line only had one entry */
22308             max = min;
22309         }
22310         else if (max < min) {
22311             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22312             sv_catpvs(msg, "Illegal range in \"");
22313             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22314                                 UTF8fARG(is_contents_utf8, s - s0, s0));
22315             sv_catpvs(msg, "\"");
22316             goto return_failure;
22317         }
22318
22319 #if 0   /* See explanation at definition above of get_extended_utf8_msg() */
22320
22321         if (   UNICODE_IS_PERL_EXTENDED(min)
22322             || UNICODE_IS_PERL_EXTENDED(max))
22323         {
22324             if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
22325
22326             /* If both code points are non-portable, warn only on the lower
22327              * one. */
22328             sv_catpv(msg, get_extended_utf8_msg(
22329                                             (UNICODE_IS_PERL_EXTENDED(min))
22330                                             ? min : max));
22331             sv_catpvs(msg, " in \"");
22332             Perl_sv_catpvf(aTHX_ msg, "%" UTF8f,
22333                                  UTF8fARG(is_contents_utf8, s - s0, s0));
22334             sv_catpvs(msg, "\"");
22335         }
22336
22337 #endif
22338
22339         /* Here, this line contains a legal range */
22340         this_definition = sv_2mortal(_new_invlist(2));
22341         this_definition = _add_range_to_invlist(this_definition, min, max);
22342         goto calculate;
22343
22344       check_if_property:
22345
22346         /* Here it isn't a legal range line.  See if it is a legal property
22347          * line.  First find the end of the meat of the line */
22348         s = strpbrk(s, "#\n");
22349         if (s == NULL) {
22350             s = e;
22351         }
22352
22353         /* Ignore trailing blanks in keeping with the requirements of
22354          * parse_uniprop_string() */
22355         s--;
22356         while (s > s0 && isBLANK_A(*s)) {
22357             s--;
22358         }
22359         s++;
22360
22361         this_definition = parse_uniprop_string(s0, s - s0,
22362                                                is_utf8, to_fold, runtime,
22363                                                deferrable,
22364                                                user_defined_ptr, msg,
22365                                                (name_len == 0)
22366                                                 ? level /* Don't increase level
22367                                                            if input is empty */
22368                                                 : level + 1
22369                                               );
22370         if (this_definition == NULL) {
22371             goto return_failure;    /* 'msg' should have had the reason
22372                                        appended to it by the above call */
22373         }
22374
22375         if (! is_invlist(this_definition)) {    /* Unknown at this time */
22376             return newSVsv(this_definition);
22377         }
22378
22379         if (*s != '\n') {
22380             s = strchr(s, '\n');
22381             if (s == NULL) {
22382                 s = e;
22383             }
22384         }
22385
22386       calculate:
22387
22388         switch (op) {
22389             case '+':
22390                 _invlist_union(running_definition, this_definition,
22391                                                         &running_definition);
22392                 break;
22393             case '-':
22394                 _invlist_subtract(running_definition, this_definition,
22395                                                         &running_definition);
22396                 break;
22397             case '&':
22398                 _invlist_intersection(running_definition, this_definition,
22399                                                         &running_definition);
22400                 break;
22401             case '!':
22402                 _invlist_union_complement_2nd(running_definition,
22403                                         this_definition, &running_definition);
22404                 break;
22405             default:
22406                 Perl_croak(aTHX_ "panic: %s: %d: Unexpected operation %d",
22407                                  __FILE__, __LINE__, op);
22408                 break;
22409         }
22410
22411         /* Position past the '\n' */
22412         s0 = s + 1;
22413     }   /* End of loop through the lines of 'contents' */
22414
22415     /* Here, we processed all the lines in 'contents' without error.  If we
22416      * didn't add any warnings, simply return success */
22417     if (msgs_length_on_entry == SvCUR(msg)) {
22418
22419         /* If the expansion was empty, the answer isn't nothing: its an empty
22420          * inversion list */
22421         if (running_definition == NULL) {
22422             running_definition = _new_invlist(1);
22423         }
22424
22425         return running_definition;
22426     }
22427
22428     /* Otherwise, add some explanatory text, but we will return success */
22429     goto return_msg;
22430
22431   return_failure:
22432     running_definition = NULL;
22433
22434   return_msg:
22435
22436     if (name_len > 0) {
22437         sv_catpvs(msg, " in expansion of ");
22438         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
22439     }
22440
22441     return running_definition;
22442 }
22443
22444 /* As explained below, certain operations need to take place in the first
22445  * thread created.  These macros switch contexts */
22446 #ifdef USE_ITHREADS
22447 #  define DECLARATION_FOR_GLOBAL_CONTEXT                                    \
22448                                         PerlInterpreter * save_aTHX = aTHX;
22449 #  define SWITCH_TO_GLOBAL_CONTEXT                                          \
22450                            PERL_SET_CONTEXT((aTHX = PL_user_def_props_aTHX))
22451 #  define RESTORE_CONTEXT  PERL_SET_CONTEXT((aTHX = save_aTHX));
22452 #  define CUR_CONTEXT      aTHX
22453 #  define ORIGINAL_CONTEXT save_aTHX
22454 #else
22455 #  define DECLARATION_FOR_GLOBAL_CONTEXT
22456 #  define SWITCH_TO_GLOBAL_CONTEXT          NOOP
22457 #  define RESTORE_CONTEXT                   NOOP
22458 #  define CUR_CONTEXT                       NULL
22459 #  define ORIGINAL_CONTEXT                  NULL
22460 #endif
22461
22462 STATIC void
22463 S_delete_recursion_entry(pTHX_ void *key)
22464 {
22465     /* Deletes the entry used to detect recursion when expanding user-defined
22466      * properties.  This is a function so it can be set up to be called even if
22467      * the program unexpectedly quits */
22468
22469     dVAR;
22470     SV ** current_entry;
22471     const STRLEN key_len = strlen((const char *) key);
22472     DECLARATION_FOR_GLOBAL_CONTEXT;
22473
22474     SWITCH_TO_GLOBAL_CONTEXT;
22475
22476     /* If the entry is one of these types, it is a permanent entry, and not the
22477      * one used to detect recursions.  This function should delete only the
22478      * recursion entry */
22479     current_entry = hv_fetch(PL_user_def_props, (const char *) key, key_len, 0);
22480     if (     current_entry
22481         && ! is_invlist(*current_entry)
22482         && ! SvPOK(*current_entry))
22483     {
22484         (void) hv_delete(PL_user_def_props, (const char *) key, key_len,
22485                                                                     G_DISCARD);
22486     }
22487
22488     RESTORE_CONTEXT;
22489 }
22490
22491 STATIC SV *
22492 S_get_fq_name(pTHX_
22493               const char * const name,    /* The first non-blank in the \p{}, \P{} */
22494               const Size_t name_len,      /* Its length in bytes, not including any trailing space */
22495               const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22496               const bool has_colon_colon
22497              )
22498 {
22499     /* Returns a mortal SV containing the fully qualified version of the input
22500      * name */
22501
22502     SV * fq_name;
22503
22504     fq_name = newSVpvs_flags("", SVs_TEMP);
22505
22506     /* Use the current package if it wasn't included in our input */
22507     if (! has_colon_colon) {
22508         const HV * pkg = (IN_PERL_COMPILETIME)
22509                          ? PL_curstash
22510                          : CopSTASH(PL_curcop);
22511         const char* pkgname = HvNAME(pkg);
22512
22513         Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
22514                       UTF8fARG(is_utf8, strlen(pkgname), pkgname));
22515         sv_catpvs(fq_name, "::");
22516     }
22517
22518     Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
22519                          UTF8fARG(is_utf8, name_len, name));
22520     return fq_name;
22521 }
22522
22523 SV *
22524 Perl_parse_uniprop_string(pTHX_
22525
22526     /* Parse the interior of a \p{}, \P{}.  Returns its definition if knowable
22527      * now.  If so, the return is an inversion list.
22528      *
22529      * If the property is user-defined, it is a subroutine, which in turn
22530      * may call other subroutines.  This function will call the whole nest of
22531      * them to get the definition they return; if some aren't known at the time
22532      * of the call to this function, the fully qualified name of the highest
22533      * level sub is returned.  It is an error to call this function at runtime
22534      * without every sub defined.
22535      *
22536      * If an error was found, NULL is returned, and 'msg' gets a suitable
22537      * message appended to it.  (Appending allows the back trace of how we got
22538      * to the faulty definition to be displayed through nested calls of
22539      * user-defined subs.)
22540      *
22541      * The caller should NOT try to free any returned inversion list.
22542      *
22543      * Other parameters will be set on return as described below */
22544
22545     const char * const name,    /* The first non-blank in the \p{}, \P{} */
22546     const Size_t name_len,      /* Its length in bytes, not including any
22547                                    trailing space */
22548     const bool is_utf8,         /* ? Is 'name' encoded in UTF-8 */
22549     const bool to_fold,         /* ? Is this under /i */
22550     const bool runtime,         /* TRUE if this is being called at run time */
22551     const bool deferrable,      /* TRUE if it's ok for the definition to not be
22552                                    known at this call */
22553     bool *user_defined_ptr,     /* Upon return from this function it will be
22554                                    set to TRUE if any component is a
22555                                    user-defined property */
22556     SV * msg,                   /* Any error or warning msg(s) are appended to
22557                                    this */
22558    const STRLEN level)          /* Recursion level of this call */
22559 {
22560     dVAR;
22561     char* lookup_name;          /* normalized name for lookup in our tables */
22562     unsigned lookup_len;        /* Its length */
22563     bool stricter = FALSE;      /* Some properties have stricter name
22564                                    normalization rules, which we decide upon
22565                                    based on parsing */
22566
22567     /* nv= or numeric_value=, or possibly one of the cjk numeric properties
22568      * (though it requires extra effort to download them from Unicode and
22569      * compile perl to know about them) */
22570     bool is_nv_type = FALSE;
22571
22572     unsigned int i, j = 0;
22573     int equals_pos = -1;    /* Where the '=' is found, or negative if none */
22574     int slash_pos  = -1;    /* Where the '/' is found, or negative if none */
22575     int table_index = 0;    /* The entry number for this property in the table
22576                                of all Unicode property names */
22577     bool starts_with_In_or_Is = FALSE;  /* ? Does the name start with 'In' or
22578                                              'Is' */
22579     Size_t lookup_offset = 0;   /* Used to ignore the first few characters of
22580                                    the normalized name in certain situations */
22581     Size_t non_pkg_begin = 0;   /* Offset of first byte in 'name' that isn't
22582                                    part of a package name */
22583     bool could_be_user_defined = TRUE;  /* ? Could this be a user-defined
22584                                              property rather than a Unicode
22585                                              one. */
22586     SV * prop_definition = NULL;  /* The returned definition of 'name' or NULL
22587                                      if an error.  If it is an inversion list,
22588                                      it is the definition.  Otherwise it is a
22589                                      string containing the fully qualified sub
22590                                      name of 'name' */
22591     SV * fq_name = NULL;        /* For user-defined properties, the fully
22592                                    qualified name */
22593     bool invert_return = FALSE; /* ? Do we need to complement the result before
22594                                      returning it */
22595
22596     PERL_ARGS_ASSERT_PARSE_UNIPROP_STRING;
22597
22598     /* The input will be normalized into 'lookup_name' */
22599     Newx(lookup_name, name_len, char);
22600     SAVEFREEPV(lookup_name);
22601
22602     /* Parse the input. */
22603     for (i = 0; i < name_len; i++) {
22604         char cur = name[i];
22605
22606         /* Most of the characters in the input will be of this ilk, being parts
22607          * of a name */
22608         if (isIDCONT_A(cur)) {
22609
22610             /* Case differences are ignored.  Our lookup routine assumes
22611              * everything is lowercase, so normalize to that */
22612             if (isUPPER_A(cur)) {
22613                 lookup_name[j++] = toLOWER_A(cur);
22614                 continue;
22615             }
22616
22617             if (cur == '_') { /* Don't include these in the normalized name */
22618                 continue;
22619             }
22620
22621             lookup_name[j++] = cur;
22622
22623             /* The first character in a user-defined name must be of this type.
22624              * */
22625             if (i - non_pkg_begin == 0 && ! isIDFIRST_A(cur)) {
22626                 could_be_user_defined = FALSE;
22627             }
22628
22629             continue;
22630         }
22631
22632         /* Here, the character is not something typically in a name,  But these
22633          * two types of characters (and the '_' above) can be freely ignored in
22634          * most situations.  Later it may turn out we shouldn't have ignored
22635          * them, and we have to reparse, but we don't have enough information
22636          * yet to make that decision */
22637         if (cur == '-' || isSPACE_A(cur)) {
22638             could_be_user_defined = FALSE;
22639             continue;
22640         }
22641
22642         /* An equals sign or single colon mark the end of the first part of
22643          * the property name */
22644         if (    cur == '='
22645             || (cur == ':' && (i >= name_len - 1 || name[i+1] != ':')))
22646         {
22647             lookup_name[j++] = '='; /* Treat the colon as an '=' */
22648             equals_pos = j; /* Note where it occurred in the input */
22649             could_be_user_defined = FALSE;
22650             break;
22651         }
22652
22653         /* Otherwise, this character is part of the name. */
22654         lookup_name[j++] = cur;
22655
22656         /* Here it isn't a single colon, so if it is a colon, it must be a
22657          * double colon */
22658         if (cur == ':') {
22659
22660             /* A double colon should be a package qualifier.  We note its
22661              * position and continue.  Note that one could have
22662              *      pkg1::pkg2::...::foo
22663              * so that the position at the end of the loop will be just after
22664              * the final qualifier */
22665
22666             i++;
22667             non_pkg_begin = i + 1;
22668             lookup_name[j++] = ':';
22669         }
22670         else { /* Only word chars (and '::') can be in a user-defined name */
22671             could_be_user_defined = FALSE;
22672         }
22673     } /* End of parsing through the lhs of the property name (or all of it if
22674          no rhs) */
22675
22676 #define STRLENs(s)  (sizeof("" s "") - 1)
22677
22678     /* If there is a single package name 'utf8::', it is ambiguous.  It could
22679      * be for a user-defined property, or it could be a Unicode property, as
22680      * all of them are considered to be for that package.  For the purposes of
22681      * parsing the rest of the property, strip it off */
22682     if (non_pkg_begin == STRLENs("utf8::") && memBEGINPs(name, name_len, "utf8::")) {
22683         lookup_name +=  STRLENs("utf8::");
22684         j -=  STRLENs("utf8::");
22685         equals_pos -=  STRLENs("utf8::");
22686     }
22687
22688     /* Here, we are either done with the whole property name, if it was simple;
22689      * or are positioned just after the '=' if it is compound. */
22690
22691     if (equals_pos >= 0) {
22692         assert(! stricter); /* We shouldn't have set this yet */
22693
22694         /* Space immediately after the '=' is ignored */
22695         i++;
22696         for (; i < name_len; i++) {
22697             if (! isSPACE_A(name[i])) {
22698                 break;
22699             }
22700         }
22701
22702         /* Most punctuation after the equals indicates a subpattern, like
22703          * \p{foo=/bar/} */
22704         if (   isPUNCT_A(name[i])
22705             && name[i] != '-'
22706             && name[i] != '+'
22707             && name[i] != '_'
22708             && name[i] != '{')
22709         {
22710             /* Find the property.  The table includes the equals sign, so we
22711              * use 'j' as-is */
22712             table_index = match_uniprop((U8 *) lookup_name, j);
22713             if (table_index) {
22714                 const char * const * prop_values
22715                                             = UNI_prop_value_ptrs[table_index];
22716                 SV * subpattern;
22717                 Size_t subpattern_len;
22718                 REGEXP * subpattern_re;
22719                 char open = name[i++];
22720                 char close;
22721                 const char * pos_in_brackets;
22722                 bool escaped = 0;
22723
22724                 /* A backslash means the real delimitter is the next character.
22725                  * */
22726                 if (open == '\\') {
22727                     open = name[i++];
22728                     escaped = 1;
22729                 }
22730
22731                 /* This data structure is constructed so that the matching
22732                  * closing bracket is 3 past its matching opening.  The second
22733                  * set of closing is so that if the opening is something like
22734                  * ']', the closing will be that as well.  Something similar is
22735                  * done in toke.c */
22736                 pos_in_brackets = strchr("([<)]>)]>", open);
22737                 close = (pos_in_brackets) ? pos_in_brackets[3] : open;
22738
22739                 if (    i >= name_len
22740                     ||  name[name_len-1] != close
22741                     || (escaped && name[name_len-2] != '\\'))
22742                 {
22743                     sv_catpvs(msg, "Unicode property wildcard not terminated");
22744                     goto append_name_to_msg;
22745                 }
22746
22747                 Perl_ck_warner_d(aTHX_
22748                     packWARN(WARN_EXPERIMENTAL__UNIPROP_WILDCARDS),
22749                     "The Unicode property wildcards feature is experimental");
22750
22751                 /* Now create and compile the wildcard subpattern.  Use /iaa
22752                  * because nothing outside of ASCII will match, and it the
22753                  * property values should all match /i.  Note that when the
22754                  * pattern fails to compile, our added text to the user's
22755                  * pattern will be displayed to the user, which is not so
22756                  * desirable. */
22757                 subpattern_len = name_len - i - 1 - escaped;
22758                 subpattern = Perl_newSVpvf(aTHX_ "(?iaa:%.*s)",
22759                                               (unsigned) subpattern_len,
22760                                               name + i);
22761                 subpattern = sv_2mortal(subpattern);
22762                 subpattern_re = re_compile(subpattern, 0);
22763                 assert(subpattern_re);  /* Should have died if didn't compile
22764                                          successfully */
22765
22766                 /* For each legal property value, see if the supplied pattern
22767                  * matches it. */
22768                 while (*prop_values) {
22769                     const char * const entry = *prop_values;
22770                     const Size_t len = strlen(entry);
22771                     SV* entry_sv = newSVpvn_flags(entry, len, SVs_TEMP);
22772
22773                     if (pregexec(subpattern_re,
22774                                  (char *) entry,
22775                                  (char *) entry + len,
22776                                  (char *) entry, 0,
22777                                  entry_sv,
22778                                  0))
22779                     { /* Here, matched.  Add to the returned list */
22780                         Size_t total_len = j + len;
22781                         SV * sub_invlist = NULL;
22782                         char * this_string;
22783
22784                         /* We know this is a legal \p{property=value}.  Call
22785                          * the function to return the list of code points that
22786                          * match it */
22787                         Newxz(this_string, total_len + 1, char);
22788                         Copy(lookup_name, this_string, j, char);
22789                         my_strlcat(this_string, entry, total_len + 1);
22790                         SAVEFREEPV(this_string);
22791                         sub_invlist = parse_uniprop_string(this_string,
22792                                                            total_len,
22793                                                            is_utf8,
22794                                                            to_fold,
22795                                                            runtime,
22796                                                            deferrable,
22797                                                            user_defined_ptr,
22798                                                            msg,
22799                                                            level + 1);
22800                         _invlist_union(prop_definition, sub_invlist,
22801                                        &prop_definition);
22802                     }
22803
22804                     prop_values++;  /* Next iteration, look at next propvalue */
22805                 } /* End of looking through property values; (the data
22806                      structure is terminated by a NULL ptr) */
22807
22808                 SvREFCNT_dec_NN(subpattern_re);
22809
22810                 if (prop_definition) {
22811                     return prop_definition;
22812                 }
22813
22814                 sv_catpvs(msg, "No Unicode property value wildcard matches:");
22815                 goto append_name_to_msg;
22816             }
22817
22818             /* Here's how khw thinks we should proceed to handle the properties
22819              * not yet done:    Bidi Mirroring Glyph
22820                                 Bidi Paired Bracket
22821                                 Case Folding  (both full and simple)
22822                                 Decomposition Mapping
22823                                 Equivalent Unified Ideograph
22824                                 Name
22825                                 Name Alias
22826                                 Lowercase Mapping  (both full and simple)
22827                                 NFKC Case Fold
22828                                 Titlecase Mapping  (both full and simple)
22829                                 Uppercase Mapping  (both full and simple)
22830              * Move the part that looks at the property values into a perl
22831              * script, like utf8_heavy.pl is done.  This makes things somewhat
22832              * easier, but most importantly, it avoids always adding all these
22833              * strings to the memory usage when the feature is little-used.
22834              *
22835              * The property values would all be concatenated into a single
22836              * string per property with each value on a separate line, and the
22837              * code point it's for on alternating lines.  Then we match the
22838              * user's input pattern m//mg, without having to worry about their
22839              * uses of '^' and '$'.  Only the values that aren't the default
22840              * would be in the strings.  Code points would be in UTF-8.  The
22841              * search pattern that we would construct would look like
22842              * (?: \n (code-point_re) \n (?aam: user-re ) \n )
22843              * And so $1 would contain the code point that matched the user-re.
22844              * For properties where the default is the code point itself, such
22845              * as any of the case changing mappings, the string would otherwise
22846              * consist of all Unicode code points in UTF-8 strung together.
22847              * This would be impractical.  So instead, examine their compiled
22848              * pattern, looking at the ssc.  If none, reject the pattern as an
22849              * error.  Otherwise run the pattern against every code point in
22850              * the ssc.  The ssc is kind of like tr18's 3.9 Possible Match Sets
22851              * And it might be good to create an API to return the ssc.
22852              *
22853              * For the name properties, a new function could be created in
22854              * charnames which essentially does the same thing as above,
22855              * sharing Name.pl with the other charname functions.  Don't know
22856              * about loose name matching, or algorithmically determined names.
22857              * Decomposition.pl similarly.
22858              *
22859              * It might be that a new pattern modifier would have to be
22860              * created, like /t for resTricTed, which changed the behavior of
22861              * some constructs in their subpattern, like \A. */
22862         } /* End of is a wildcard subppattern */
22863
22864
22865         /* Certain properties whose values are numeric need special handling.
22866          * They may optionally be prefixed by 'is'.  Ignore that prefix for the
22867          * purposes of checking if this is one of those properties */
22868         if (memBEGINPs(lookup_name, name_len, "is")) {
22869             lookup_offset = 2;
22870         }
22871
22872         /* Then check if it is one of these specially-handled properties.  The
22873          * possibilities are hard-coded because easier this way, and the list
22874          * is unlikely to change.
22875          *
22876          * All numeric value type properties are of this ilk, and are also
22877          * special in a different way later on.  So find those first.  There
22878          * are several numeric value type properties in the Unihan DB (which is
22879          * unlikely to be compiled with perl, but we handle it here in case it
22880          * does get compiled).  They all end with 'numeric'.  The interiors
22881          * aren't checked for the precise property.  This would stop working if
22882          * a cjk property were to be created that ended with 'numeric' and
22883          * wasn't a numeric type */
22884         is_nv_type = memEQs(lookup_name + lookup_offset,
22885                        j - 1 - lookup_offset, "numericvalue")
22886                   || memEQs(lookup_name + lookup_offset,
22887                       j - 1 - lookup_offset, "nv")
22888                   || (   memENDPs(lookup_name + lookup_offset,
22889                             j - 1 - lookup_offset, "numeric")
22890                       && (   memBEGINPs(lookup_name + lookup_offset,
22891                                       j - 1 - lookup_offset, "cjk")
22892                           || memBEGINPs(lookup_name + lookup_offset,
22893                                       j - 1 - lookup_offset, "k")));
22894         if (   is_nv_type
22895             || memEQs(lookup_name + lookup_offset,
22896                       j - 1 - lookup_offset, "canonicalcombiningclass")
22897             || memEQs(lookup_name + lookup_offset,
22898                       j - 1 - lookup_offset, "ccc")
22899             || memEQs(lookup_name + lookup_offset,
22900                       j - 1 - lookup_offset, "age")
22901             || memEQs(lookup_name + lookup_offset,
22902                       j - 1 - lookup_offset, "in")
22903             || memEQs(lookup_name + lookup_offset,
22904                       j - 1 - lookup_offset, "presentin"))
22905         {
22906             unsigned int k;
22907
22908             /* Since the stuff after the '=' is a number, we can't throw away
22909              * '-' willy-nilly, as those could be a minus sign.  Other stricter
22910              * rules also apply.  However, these properties all can have the
22911              * rhs not be a number, in which case they contain at least one
22912              * alphabetic.  In those cases, the stricter rules don't apply.
22913              * But the numeric type properties can have the alphas [Ee] to
22914              * signify an exponent, and it is still a number with stricter
22915              * rules.  So look for an alpha that signifies not-strict */
22916             stricter = TRUE;
22917             for (k = i; k < name_len; k++) {
22918                 if (   isALPHA_A(name[k])
22919                     && (! is_nv_type || ! isALPHA_FOLD_EQ(name[k], 'E')))
22920                 {
22921                     stricter = FALSE;
22922                     break;
22923                 }
22924             }
22925         }
22926
22927         if (stricter) {
22928
22929             /* A number may have a leading '+' or '-'.  The latter is retained
22930              * */
22931             if (name[i] == '+') {
22932                 i++;
22933             }
22934             else if (name[i] == '-') {
22935                 lookup_name[j++] = '-';
22936                 i++;
22937             }
22938
22939             /* Skip leading zeros including single underscores separating the
22940              * zeros, or between the final leading zero and the first other
22941              * digit */
22942             for (; i < name_len - 1; i++) {
22943                 if (    name[i] != '0'
22944                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
22945                 {
22946                     break;
22947                 }
22948             }
22949         }
22950     }
22951     else {  /* No '=' */
22952
22953        /* Only a few properties without an '=' should be parsed with stricter
22954         * rules.  The list is unlikely to change. */
22955         if (   memBEGINPs(lookup_name, j, "perl")
22956             && memNEs(lookup_name + 4, j - 4, "space")
22957             && memNEs(lookup_name + 4, j - 4, "word"))
22958         {
22959             stricter = TRUE;
22960
22961             /* We set the inputs back to 0 and the code below will reparse,
22962              * using strict */
22963             i = j = 0;
22964         }
22965     }
22966
22967     /* Here, we have either finished the property, or are positioned to parse
22968      * the remainder, and we know if stricter rules apply.  Finish out, if not
22969      * already done */
22970     for (; i < name_len; i++) {
22971         char cur = name[i];
22972
22973         /* In all instances, case differences are ignored, and we normalize to
22974          * lowercase */
22975         if (isUPPER_A(cur)) {
22976             lookup_name[j++] = toLOWER(cur);
22977             continue;
22978         }
22979
22980         /* An underscore is skipped, but not under strict rules unless it
22981          * separates two digits */
22982         if (cur == '_') {
22983             if (    stricter
22984                 && (     i == 0 || (int) i == equals_pos || i == name_len- 1
22985                     || ! isDIGIT_A(name[i-1]) || ! isDIGIT_A(name[i+1])))
22986             {
22987                 lookup_name[j++] = '_';
22988             }
22989             continue;
22990         }
22991
22992         /* Hyphens are skipped except under strict */
22993         if (cur == '-' && ! stricter) {
22994             continue;
22995         }
22996
22997         /* XXX Bug in documentation.  It says white space skipped adjacent to
22998          * non-word char.  Maybe we should, but shouldn't skip it next to a dot
22999          * in a number */
23000         if (isSPACE_A(cur) && ! stricter) {
23001             continue;
23002         }
23003
23004         lookup_name[j++] = cur;
23005
23006         /* Unless this is a non-trailing slash, we are done with it */
23007         if (i >= name_len - 1 || cur != '/') {
23008             continue;
23009         }
23010
23011         slash_pos = j;
23012
23013         /* A slash in the 'numeric value' property indicates that what follows
23014          * is a denominator.  It can have a leading '+' and '0's that should be
23015          * skipped.  But we have never allowed a negative denominator, so treat
23016          * a minus like every other character.  (No need to rule out a second
23017          * '/', as that won't match anything anyway */
23018         if (is_nv_type) {
23019             i++;
23020             if (i < name_len && name[i] == '+') {
23021                 i++;
23022             }
23023
23024             /* Skip leading zeros including underscores separating digits */
23025             for (; i < name_len - 1; i++) {
23026                 if (   name[i] != '0'
23027                     && (name[i] != '_' || ! isDIGIT_A(name[i+1])))
23028                 {
23029                     break;
23030                 }
23031             }
23032
23033             /* Store the first real character in the denominator */
23034             lookup_name[j++] = name[i];
23035         }
23036     }
23037
23038     /* Here are completely done parsing the input 'name', and 'lookup_name'
23039      * contains a copy, normalized.
23040      *
23041      * This special case is grandfathered in: 'L_' and 'GC=L_' are accepted and
23042      * different from without the underscores.  */
23043     if (  (   UNLIKELY(memEQs(lookup_name, j, "l"))
23044            || UNLIKELY(memEQs(lookup_name, j, "gc=l")))
23045         && UNLIKELY(name[name_len-1] == '_'))
23046     {
23047         lookup_name[j++] = '&';
23048     }
23049
23050     /* If the original input began with 'In' or 'Is', it could be a subroutine
23051      * call to a user-defined property instead of a Unicode property name. */
23052     if (    non_pkg_begin + name_len > 2
23053         &&  name[non_pkg_begin+0] == 'I'
23054         && (name[non_pkg_begin+1] == 'n' || name[non_pkg_begin+1] == 's'))
23055     {
23056         starts_with_In_or_Is = TRUE;
23057     }
23058     else {
23059         could_be_user_defined = FALSE;
23060     }
23061
23062     if (could_be_user_defined) {
23063         CV* user_sub;
23064
23065         /* If the user defined property returns the empty string, it could
23066          * easily be because the pattern is being compiled before the data it
23067          * actually needs to compile is available.  This could be argued to be
23068          * a bug in the perl code, but this is a change of behavior for Perl,
23069          * so we handle it.  This means that intentionally returning nothing
23070          * will not be resolved until runtime */
23071         bool empty_return = FALSE;
23072
23073         /* Here, the name could be for a user defined property, which are
23074          * implemented as subs. */
23075         user_sub = get_cvn_flags(name, name_len, 0);
23076         if (user_sub) {
23077             const char insecure[] = "Insecure user-defined property";
23078
23079             /* Here, there is a sub by the correct name.  Normally we call it
23080              * to get the property definition */
23081             dSP;
23082             SV * user_sub_sv = MUTABLE_SV(user_sub);
23083             SV * error;     /* Any error returned by calling 'user_sub' */
23084             SV * key;       /* The key into the hash of user defined sub names
23085                              */
23086             SV * placeholder;
23087             SV ** saved_user_prop_ptr;      /* Hash entry for this property */
23088
23089             /* How many times to retry when another thread is in the middle of
23090              * expanding the same definition we want */
23091             PERL_INT_FAST8_T retry_countdown = 10;
23092
23093             DECLARATION_FOR_GLOBAL_CONTEXT;
23094
23095             /* If we get here, we know this property is user-defined */
23096             *user_defined_ptr = TRUE;
23097
23098             /* We refuse to call a potentially tainted subroutine; returning an
23099              * error instead */
23100             if (TAINT_get) {
23101                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23102                 sv_catpvn(msg, insecure, sizeof(insecure) - 1);
23103                 goto append_name_to_msg;
23104             }
23105
23106             /* In principal, we only call each subroutine property definition
23107              * once during the life of the program.  This guarantees that the
23108              * property definition never changes.  The results of the single
23109              * sub call are stored in a hash, which is used instead for future
23110              * references to this property.  The property definition is thus
23111              * immutable.  But, to allow the user to have a /i-dependent
23112              * definition, we call the sub once for non-/i, and once for /i,
23113              * should the need arise, passing the /i status as a parameter.
23114              *
23115              * We start by constructing the hash key name, consisting of the
23116              * fully qualified subroutine name, preceded by the /i status, so
23117              * that there is a key for /i and a different key for non-/i */
23118             key = newSVpvn(((to_fold) ? "1" : "0"), 1);
23119             fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
23120                                           non_pkg_begin != 0);
23121             sv_catsv(key, fq_name);
23122             sv_2mortal(key);
23123
23124             /* We only call the sub once throughout the life of the program
23125              * (with the /i, non-/i exception noted above).  That means the
23126              * hash must be global and accessible to all threads.  It is
23127              * created at program start-up, before any threads are created, so
23128              * is accessible to all children.  But this creates some
23129              * complications.
23130              *
23131              * 1) The keys can't be shared, or else problems arise; sharing is
23132              *    turned off at hash creation time
23133              * 2) All SVs in it are there for the remainder of the life of the
23134              *    program, and must be created in the same interpreter context
23135              *    as the hash, or else they will be freed from the wrong pool
23136              *    at global destruction time.  This is handled by switching to
23137              *    the hash's context to create each SV going into it, and then
23138              *    immediately switching back
23139              * 3) All accesses to the hash must be controlled by a mutex, to
23140              *    prevent two threads from getting an unstable state should
23141              *    they simultaneously be accessing it.  The code below is
23142              *    crafted so that the mutex is locked whenever there is an
23143              *    access and unlocked only when the next stable state is
23144              *    achieved.
23145              *
23146              * The hash stores either the definition of the property if it was
23147              * valid, or, if invalid, the error message that was raised.  We
23148              * use the type of SV to distinguish.
23149              *
23150              * There's also the need to guard against the definition expansion
23151              * from infinitely recursing.  This is handled by storing the aTHX
23152              * of the expanding thread during the expansion.  Again the SV type
23153              * is used to distinguish this from the other two cases.  If we
23154              * come to here and the hash entry for this property is our aTHX,
23155              * it means we have recursed, and the code assumes that we would
23156              * infinitely recurse, so instead stops and raises an error.
23157              * (Any recursion has always been treated as infinite recursion in
23158              * this feature.)
23159              *
23160              * If instead, the entry is for a different aTHX, it means that
23161              * that thread has gotten here first, and hasn't finished expanding
23162              * the definition yet.  We just have to wait until it is done.  We
23163              * sleep and retry a few times, returning an error if the other
23164              * thread doesn't complete. */
23165
23166           re_fetch:
23167             USER_PROP_MUTEX_LOCK;
23168
23169             /* If we have an entry for this key, the subroutine has already
23170              * been called once with this /i status. */
23171             saved_user_prop_ptr = hv_fetch(PL_user_def_props,
23172                                                    SvPVX(key), SvCUR(key), 0);
23173             if (saved_user_prop_ptr) {
23174
23175                 /* If the saved result is an inversion list, it is the valid
23176                  * definition of this property */
23177                 if (is_invlist(*saved_user_prop_ptr)) {
23178                     prop_definition = *saved_user_prop_ptr;
23179
23180                     /* The SV in the hash won't be removed until global
23181                      * destruction, so it is stable and we can unlock */
23182                     USER_PROP_MUTEX_UNLOCK;
23183
23184                     /* The caller shouldn't try to free this SV */
23185                     return prop_definition;
23186                 }
23187
23188                 /* Otherwise, if it is a string, it is the error message
23189                  * that was returned when we first tried to evaluate this
23190                  * property.  Fail, and append the message */
23191                 if (SvPOK(*saved_user_prop_ptr)) {
23192                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23193                     sv_catsv(msg, *saved_user_prop_ptr);
23194
23195                     /* The SV in the hash won't be removed until global
23196                      * destruction, so it is stable and we can unlock */
23197                     USER_PROP_MUTEX_UNLOCK;
23198
23199                     return NULL;
23200                 }
23201
23202                 assert(SvIOK(*saved_user_prop_ptr));
23203
23204                 /* Here, we have an unstable entry in the hash.  Either another
23205                  * thread is in the middle of expanding the property's
23206                  * definition, or we are ourselves recursing.  We use the aTHX
23207                  * in it to distinguish */
23208                 if (SvIV(*saved_user_prop_ptr) != PTR2IV(CUR_CONTEXT)) {
23209
23210                     /* Here, it's another thread doing the expanding.  We've
23211                      * looked as much as we are going to at the contents of the
23212                      * hash entry.  It's safe to unlock. */
23213                     USER_PROP_MUTEX_UNLOCK;
23214
23215                     /* Retry a few times */
23216                     if (retry_countdown-- > 0) {
23217                         PerlProc_sleep(1);
23218                         goto re_fetch;
23219                     }
23220
23221                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23222                     sv_catpvs(msg, "Timeout waiting for another thread to "
23223                                    "define");
23224                     goto append_name_to_msg;
23225                 }
23226
23227                 /* Here, we are recursing; don't dig any deeper */
23228                 USER_PROP_MUTEX_UNLOCK;
23229
23230                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23231                 sv_catpvs(msg,
23232                           "Infinite recursion in user-defined property");
23233                 goto append_name_to_msg;
23234             }
23235
23236             /* Here, this thread has exclusive control, and there is no entry
23237              * for this property in the hash.  So we have the go ahead to
23238              * expand the definition ourselves. */
23239
23240             PUSHSTACKi(PERLSI_MAGIC);
23241             ENTER;
23242
23243             /* Create a temporary placeholder in the hash to detect recursion
23244              * */
23245             SWITCH_TO_GLOBAL_CONTEXT;
23246             placeholder= newSVuv(PTR2IV(ORIGINAL_CONTEXT));
23247             (void) hv_store_ent(PL_user_def_props, key, placeholder, 0);
23248             RESTORE_CONTEXT;
23249
23250             /* Now that we have a placeholder, we can let other threads
23251              * continue */
23252             USER_PROP_MUTEX_UNLOCK;
23253
23254             /* Make sure the placeholder always gets destroyed */
23255             SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(key));
23256
23257             PUSHMARK(SP);
23258             SAVETMPS;
23259
23260             /* Call the user's function, with the /i status as a parameter.
23261              * Note that we have gone to a lot of trouble to keep this call
23262              * from being within the locked mutex region. */
23263             XPUSHs(boolSV(to_fold));
23264             PUTBACK;
23265
23266             /* The following block was taken from swash_init().  Presumably
23267              * they apply to here as well, though we no longer use a swash --
23268              * khw */
23269             SAVEHINTS();
23270             save_re_context();
23271             /* We might get here via a subroutine signature which uses a utf8
23272              * parameter name, at which point PL_subname will have been set
23273              * but not yet used. */
23274             save_item(PL_subname);
23275
23276             (void) call_sv(user_sub_sv, G_EVAL|G_SCALAR);
23277
23278             SPAGAIN;
23279
23280             error = ERRSV;
23281             if (TAINT_get || SvTRUE(error)) {
23282                 if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23283                 if (SvTRUE(error)) {
23284                     sv_catpvs(msg, "Error \"");
23285                     sv_catsv(msg, error);
23286                     sv_catpvs(msg, "\"");
23287                 }
23288                 if (TAINT_get) {
23289                     if (SvTRUE(error)) sv_catpvs(msg, "; ");
23290                     sv_catpvn(msg, insecure, sizeof(insecure) - 1);
23291                 }
23292
23293                 if (name_len > 0) {
23294                     sv_catpvs(msg, " in expansion of ");
23295                     Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8,
23296                                                                   name_len,
23297                                                                   name));
23298                 }
23299
23300                 (void) POPs;
23301                 prop_definition = NULL;
23302             }
23303             else {  /* G_SCALAR guarantees a single return value */
23304                 SV * contents = POPs;
23305
23306                 /* The contents is supposed to be the expansion of the property
23307                  * definition.  If the definition is deferrable, and we got an
23308                  * empty string back, set a flag to later defer it (after clean
23309                  * up below). */
23310                 if (      deferrable
23311                     && (! SvPOK(contents) || SvCUR(contents) == 0))
23312                 {
23313                         empty_return = TRUE;
23314                 }
23315                 else { /* Otherwise, call a function to check for valid syntax,
23316                           and handle it */
23317
23318                     prop_definition = handle_user_defined_property(
23319                                                     name, name_len,
23320                                                     is_utf8, to_fold, runtime,
23321                                                     deferrable,
23322                                                     contents, user_defined_ptr,
23323                                                     msg,
23324                                                     level);
23325                 }
23326             }
23327
23328             /* Here, we have the results of the expansion.  Delete the
23329              * placeholder, and if the definition is now known, replace it with
23330              * that definition.  We need exclusive access to the hash, and we
23331              * can't let anyone else in, between when we delete the placeholder
23332              * and add the permanent entry */
23333             USER_PROP_MUTEX_LOCK;
23334
23335             S_delete_recursion_entry(aTHX_ SvPVX(key));
23336
23337             if (    ! empty_return
23338                 && (! prop_definition || is_invlist(prop_definition)))
23339             {
23340                 /* If we got success we use the inversion list defining the
23341                  * property; otherwise use the error message */
23342                 SWITCH_TO_GLOBAL_CONTEXT;
23343                 (void) hv_store_ent(PL_user_def_props,
23344                                     key,
23345                                     ((prop_definition)
23346                                      ? newSVsv(prop_definition)
23347                                      : newSVsv(msg)),
23348                                     0);
23349                 RESTORE_CONTEXT;
23350             }
23351
23352             /* All done, and the hash now has a permanent entry for this
23353              * property.  Give up exclusive control */
23354             USER_PROP_MUTEX_UNLOCK;
23355
23356             FREETMPS;
23357             LEAVE;
23358             POPSTACK;
23359
23360             if (empty_return) {
23361                 goto definition_deferred;
23362             }
23363
23364             if (prop_definition) {
23365
23366                 /* If the definition is for something not known at this time,
23367                  * we toss it, and go return the main property name, as that's
23368                  * the one the user will be aware of */
23369                 if (! is_invlist(prop_definition)) {
23370                     SvREFCNT_dec_NN(prop_definition);
23371                     goto definition_deferred;
23372                 }
23373
23374                 sv_2mortal(prop_definition);
23375             }
23376
23377             /* And return */
23378             return prop_definition;
23379
23380         }   /* End of calling the subroutine for the user-defined property */
23381     }       /* End of it could be a user-defined property */
23382
23383     /* Here it wasn't a user-defined property that is known at this time.  See
23384      * if it is a Unicode property */
23385
23386     lookup_len = j;     /* This is a more mnemonic name than 'j' */
23387
23388     /* Get the index into our pointer table of the inversion list corresponding
23389      * to the property */
23390     table_index = match_uniprop((U8 *) lookup_name, lookup_len);
23391
23392     /* If it didn't find the property ... */
23393     if (table_index == 0) {
23394
23395         /* Try again stripping off any initial 'In' or 'Is' */
23396         if (starts_with_In_or_Is) {
23397             lookup_name += 2;
23398             lookup_len -= 2;
23399             equals_pos -= 2;
23400             slash_pos -= 2;
23401
23402             table_index = match_uniprop((U8 *) lookup_name, lookup_len);
23403         }
23404
23405         if (table_index == 0) {
23406             char * canonical;
23407
23408             /* Here, we didn't find it.  If not a numeric type property, and
23409              * can't be a user-defined one, it isn't a legal property */
23410             if (! is_nv_type) {
23411                 if (! could_be_user_defined) {
23412                     goto failed;
23413                 }
23414
23415                 /* Here, the property name is legal as a user-defined one.   At
23416                  * compile time, it might just be that the subroutine for that
23417                  * property hasn't been encountered yet, but at runtime, it's
23418                  * an error to try to use an undefined one */
23419                 if (! deferrable) {
23420                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23421                     sv_catpvs(msg, "Unknown user-defined property name");
23422                     goto append_name_to_msg;
23423                 }
23424
23425                 goto definition_deferred;
23426             } /* End of isn't a numeric type property */
23427
23428             /* The numeric type properties need more work to decide.  What we
23429              * do is make sure we have the number in canonical form and look
23430              * that up. */
23431
23432             if (slash_pos < 0) {    /* No slash */
23433
23434                 /* When it isn't a rational, take the input, convert it to a
23435                  * NV, then create a canonical string representation of that
23436                  * NV. */
23437
23438                 NV value;
23439                 SSize_t value_len = lookup_len - equals_pos;
23440
23441                 /* Get the value */
23442                 if (   value_len <= 0
23443                     || my_atof3(lookup_name + equals_pos, &value,
23444                                 value_len)
23445                           != lookup_name + lookup_len)
23446                 {
23447                     goto failed;
23448                 }
23449
23450                 /* If the value is an integer, the canonical value is integral
23451                  * */
23452                 if (Perl_ceil(value) == value) {
23453                     canonical = Perl_form(aTHX_ "%.*s%.0" NVff,
23454                                             equals_pos, lookup_name, value);
23455                 }
23456                 else {  /* Otherwise, it is %e with a known precision */
23457                     char * exp_ptr;
23458
23459                     canonical = Perl_form(aTHX_ "%.*s%.*" NVef,
23460                                                 equals_pos, lookup_name,
23461                                                 PL_E_FORMAT_PRECISION, value);
23462
23463                     /* The exponent generated is expecting two digits, whereas
23464                      * %e on some systems will generate three.  Remove leading
23465                      * zeros in excess of 2 from the exponent.  We start
23466                      * looking for them after the '=' */
23467                     exp_ptr = strchr(canonical + equals_pos, 'e');
23468                     if (exp_ptr) {
23469                         char * cur_ptr = exp_ptr + 2; /* past the 'e[+-]' */
23470                         SSize_t excess_exponent_len = strlen(cur_ptr) - 2;
23471
23472                         assert(*(cur_ptr - 1) == '-' || *(cur_ptr - 1) == '+');
23473
23474                         if (excess_exponent_len > 0) {
23475                             SSize_t leading_zeros = strspn(cur_ptr, "0");
23476                             SSize_t excess_leading_zeros
23477                                     = MIN(leading_zeros, excess_exponent_len);
23478                             if (excess_leading_zeros > 0) {
23479                                 Move(cur_ptr + excess_leading_zeros,
23480                                      cur_ptr,
23481                                      strlen(cur_ptr) - excess_leading_zeros
23482                                        + 1,  /* Copy the NUL as well */
23483                                      char);
23484                             }
23485                         }
23486                     }
23487                 }
23488             }
23489             else {  /* Has a slash.  Create a rational in canonical form  */
23490                 UV numerator, denominator, gcd, trial;
23491                 const char * end_ptr;
23492                 const char * sign = "";
23493
23494                 /* We can't just find the numerator, denominator, and do the
23495                  * division, then use the method above, because that is
23496                  * inexact.  And the input could be a rational that is within
23497                  * epsilon (given our precision) of a valid rational, and would
23498                  * then incorrectly compare valid.
23499                  *
23500                  * We're only interested in the part after the '=' */
23501                 const char * this_lookup_name = lookup_name + equals_pos;
23502                 lookup_len -= equals_pos;
23503                 slash_pos -= equals_pos;
23504
23505                 /* Handle any leading minus */
23506                 if (this_lookup_name[0] == '-') {
23507                     sign = "-";
23508                     this_lookup_name++;
23509                     lookup_len--;
23510                     slash_pos--;
23511                 }
23512
23513                 /* Convert the numerator to numeric */
23514                 end_ptr = this_lookup_name + slash_pos;
23515                 if (! grok_atoUV(this_lookup_name, &numerator, &end_ptr)) {
23516                     goto failed;
23517                 }
23518
23519                 /* It better have included all characters before the slash */
23520                 if (*end_ptr != '/') {
23521                     goto failed;
23522                 }
23523
23524                 /* Set to look at just the denominator */
23525                 this_lookup_name += slash_pos;
23526                 lookup_len -= slash_pos;
23527                 end_ptr = this_lookup_name + lookup_len;
23528
23529                 /* Convert the denominator to numeric */
23530                 if (! grok_atoUV(this_lookup_name, &denominator, &end_ptr)) {
23531                     goto failed;
23532                 }
23533
23534                 /* It better be the rest of the characters, and don't divide by
23535                  * 0 */
23536                 if (   end_ptr != this_lookup_name + lookup_len
23537                     || denominator == 0)
23538                 {
23539                     goto failed;
23540                 }
23541
23542                 /* Get the greatest common denominator using
23543                    http://en.wikipedia.org/wiki/Euclidean_algorithm */
23544                 gcd = numerator;
23545                 trial = denominator;
23546                 while (trial != 0) {
23547                     UV temp = trial;
23548                     trial = gcd % trial;
23549                     gcd = temp;
23550                 }
23551
23552                 /* If already in lowest possible terms, we have already tried
23553                  * looking this up */
23554                 if (gcd == 1) {
23555                     goto failed;
23556                 }
23557
23558                 /* Reduce the rational, which should put it in canonical form
23559                  * */
23560                 numerator /= gcd;
23561                 denominator /= gcd;
23562
23563                 canonical = Perl_form(aTHX_ "%.*s%s%" UVuf "/%" UVuf,
23564                         equals_pos, lookup_name, sign, numerator, denominator);
23565             }
23566
23567             /* Here, we have the number in canonical form.  Try that */
23568             table_index = match_uniprop((U8 *) canonical, strlen(canonical));
23569             if (table_index == 0) {
23570                 goto failed;
23571             }
23572         }   /* End of still didn't find the property in our table */
23573     }       /* End of       didn't find the property in our table */
23574
23575     /* Here, we have a non-zero return, which is an index into a table of ptrs.
23576      * A negative return signifies that the real index is the absolute value,
23577      * but the result needs to be inverted */
23578     if (table_index < 0) {
23579         invert_return = TRUE;
23580         table_index = -table_index;
23581     }
23582
23583     /* Out-of band indices indicate a deprecated property.  The proper index is
23584      * modulo it with the table size.  And dividing by the table size yields
23585      * an offset into a table constructed by regen/mk_invlists.pl to contain
23586      * the corresponding warning message */
23587     if (table_index > MAX_UNI_KEYWORD_INDEX) {
23588         Size_t warning_offset = table_index / MAX_UNI_KEYWORD_INDEX;
23589         table_index %= MAX_UNI_KEYWORD_INDEX;
23590         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
23591                 "Use of '%.*s' in \\p{} or \\P{} is deprecated because: %s",
23592                 (int) name_len, name, deprecated_property_msgs[warning_offset]);
23593     }
23594
23595     /* In a few properties, a different property is used under /i.  These are
23596      * unlikely to change, so are hard-coded here. */
23597     if (to_fold) {
23598         if (   table_index == UNI_XPOSIXUPPER
23599             || table_index == UNI_XPOSIXLOWER
23600             || table_index == UNI_TITLE)
23601         {
23602             table_index = UNI_CASED;
23603         }
23604         else if (   table_index == UNI_UPPERCASELETTER
23605                  || table_index == UNI_LOWERCASELETTER
23606 #  ifdef UNI_TITLECASELETTER   /* Missing from early Unicodes */
23607                  || table_index == UNI_TITLECASELETTER
23608 #  endif
23609         ) {
23610             table_index = UNI_CASEDLETTER;
23611         }
23612         else if (  table_index == UNI_POSIXUPPER
23613                 || table_index == UNI_POSIXLOWER)
23614         {
23615             table_index = UNI_POSIXALPHA;
23616         }
23617     }
23618
23619     /* Create and return the inversion list */
23620     prop_definition =_new_invlist_C_array(uni_prop_ptrs[table_index]);
23621     sv_2mortal(prop_definition);
23622
23623
23624     /* See if there is a private use override to add to this definition */
23625     {
23626         COPHH * hinthash = (IN_PERL_COMPILETIME)
23627                            ? CopHINTHASH_get(&PL_compiling)
23628                            : CopHINTHASH_get(PL_curcop);
23629         SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0);
23630
23631         if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) {
23632
23633             /* See if there is an element in the hints hash for this table */
23634             SV * pu_lookup = Perl_newSVpvf(aTHX_ "%d=", table_index);
23635             const char * pos = strstr(SvPVX(pu_overrides), SvPVX(pu_lookup));
23636
23637             if (pos) {
23638                 bool dummy;
23639                 SV * pu_definition;
23640                 SV * pu_invlist;
23641                 SV * expanded_prop_definition =
23642                             sv_2mortal(invlist_clone(prop_definition, NULL));
23643
23644                 /* If so, it's definition is the string from here to the next
23645                  * \a character.  And its format is the same as a user-defined
23646                  * property */
23647                 pos += SvCUR(pu_lookup);
23648                 pu_definition = newSVpvn(pos, strchr(pos, '\a') - pos);
23649                 pu_invlist = handle_user_defined_property(lookup_name,
23650                                                           lookup_len,
23651                                                           0, /* Not UTF-8 */
23652                                                           0, /* Not folded */
23653                                                           runtime,
23654                                                           deferrable,
23655                                                           pu_definition,
23656                                                           &dummy,
23657                                                           msg,
23658                                                           level);
23659                 if (TAINT_get) {
23660                     if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23661                     sv_catpvs(msg, "Insecure private-use override");
23662                     goto append_name_to_msg;
23663                 }
23664
23665                 /* For now, as a safety measure, make sure that it doesn't
23666                  * override non-private use code points */
23667                 _invlist_intersection(pu_invlist, PL_Private_Use, &pu_invlist);
23668
23669                 /* Add it to the list to be returned */
23670                 _invlist_union(prop_definition, pu_invlist,
23671                                &expanded_prop_definition);
23672                 prop_definition = expanded_prop_definition;
23673                 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__PRIVATE_USE), "The private_use feature is experimental");
23674             }
23675         }
23676     }
23677
23678     if (invert_return) {
23679         _invlist_invert(prop_definition);
23680     }
23681     return prop_definition;
23682
23683
23684   failed:
23685     if (non_pkg_begin != 0) {
23686         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23687         sv_catpvs(msg, "Illegal user-defined property name");
23688     }
23689     else {
23690         if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
23691         sv_catpvs(msg, "Can't find Unicode property definition");
23692     }
23693     /* FALLTHROUGH */
23694
23695   append_name_to_msg:
23696     {
23697         const char * prefix = (runtime && level == 0) ?  " \\p{" : " \"";
23698         const char * suffix = (runtime && level == 0) ?  "}" : "\"";
23699
23700         sv_catpv(msg, prefix);
23701         Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8, name_len, name));
23702         sv_catpv(msg, suffix);
23703     }
23704
23705     return NULL;
23706
23707   definition_deferred:
23708
23709     /* Here it could yet to be defined, so defer evaluation of this
23710      * until its needed at runtime.  We need the fully qualified property name
23711      * to avoid ambiguity, and a trailing newline */
23712     if (! fq_name) {
23713         fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
23714                                       non_pkg_begin != 0 /* If has "::" */
23715                                );
23716     }
23717     sv_catpvs(fq_name, "\n");
23718
23719     *user_defined_ptr = TRUE;
23720     return fq_name;
23721 }
23722
23723 #endif
23724
23725 /*
23726  * ex: set ts=8 sts=4 sw=4 et:
23727  */