This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d2322757c7f216931a24b9ccce6df94d28742935
[perl5.git] / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #  include "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 EXTERN_C const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_inline.h"
90 #include "invlist_inline.h"
91 #include "unicode_constants.h"
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
94  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
96  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
97 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
98 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99
100 #ifndef STATIC
101 #define STATIC  static
102 #endif
103
104 /* this is a chain of data about sub patterns we are processing that
105    need to be handled separately/specially in study_chunk. Its so
106    we can simulate recursion without losing state.  */
107 struct scan_frame;
108 typedef struct scan_frame {
109     regnode *last_regnode;      /* last node to process in this frame */
110     regnode *next_regnode;      /* next node to process when last is reached */
111     U32 prev_recursed_depth;
112     I32 stopparen;              /* what stopparen do we use */
113     U32 is_top_frame;           /* what flags do we use? */
114
115     struct scan_frame *this_prev_frame; /* this previous frame */
116     struct scan_frame *prev_frame;      /* previous frame */
117     struct scan_frame *next_frame;      /* next frame */
118 } scan_frame;
119
120 /* Certain characters are output as a sequence with the first being a
121  * backslash. */
122 #define isBACKSLASHED_PUNCT(c)                                              \
123                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
124
125
126 struct RExC_state_t {
127     U32         flags;                  /* RXf_* are we folding, multilining? */
128     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
129     char        *precomp;               /* uncompiled string. */
130     char        *precomp_end;           /* pointer to end of uncompiled string. */
131     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
132     regexp      *rx;                    /* perl core regexp structure */
133     regexp_internal     *rxi;           /* internal data for regexp object
134                                            pprivate field */
135     char        *start;                 /* Start of input for compile */
136     char        *end;                   /* End of input for compile */
137     char        *parse;                 /* Input-scan pointer. */
138     char        *adjusted_start;        /* 'start', adjusted.  See code use */
139     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
140     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
141     regnode     *emit_start;            /* Start of emitted-code area */
142     regnode     *emit_bound;            /* First regnode outside of the
143                                            allocated space */
144     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
145                                            implies compiling, so don't emit */
146     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
147                                            large enough for the largest
148                                            non-EXACTish node, so can use it as
149                                            scratch in pass1 */
150     I32         naughty;                /* How bad is this pattern? */
151     I32         sawback;                /* Did we see \1, ...? */
152     U32         seen;
153     SSize_t     size;                   /* Code size. */
154     I32                npar;            /* Capture buffer count, (OPEN) plus
155                                            one. ("par" 0 is the whole
156                                            pattern)*/
157     I32         nestroot;               /* root parens we are in - used by
158                                            accept */
159     I32         extralen;
160     I32         seen_zerolen;
161     regnode     **open_parens;          /* pointers to open parens */
162     regnode     **close_parens;         /* pointers to close parens */
163     regnode     *end_op;                /* END node in program */
164     I32         utf8;           /* whether the pattern is utf8 or not */
165     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
166                                 /* XXX use this for future optimisation of case
167                                  * where pattern must be upgraded to utf8. */
168     I32         uni_semantics;  /* If a d charset modifier should use unicode
169                                    rules, even if the pattern is not in
170                                    utf8 */
171     HV          *paren_names;           /* Paren names */
172
173     regnode     **recurse;              /* Recurse regops */
174     I32                recurse_count;                /* Number of recurse regops we have generated */
175     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
176                                            through */
177     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
178     I32         in_lookbehind;
179     I32         contains_locale;
180     I32         contains_i;
181     I32         override_recoding;
182 #ifdef EBCDIC
183     I32         recode_x_to_native;
184 #endif
185     I32         in_multi_char_class;
186     struct reg_code_block *code_blocks; /* positions of literal (?{})
187                                             within pattern */
188     int         num_code_blocks;        /* size of code_blocks[] */
189     int         code_index;             /* next code_blocks[] slot */
190     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
191     scan_frame *frame_head;
192     scan_frame *frame_last;
193     U32         frame_count;
194     AV         *warn_text;
195 #ifdef ADD_TO_REGEXEC
196     char        *starttry;              /* -Dr: where regtry was called. */
197 #define RExC_starttry   (pRExC_state->starttry)
198 #endif
199     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
200 #ifdef DEBUGGING
201     const char  *lastparse;
202     I32         lastnum;
203     AV          *paren_name_list;       /* idx -> name */
204     U32         study_chunk_recursed_count;
205     SV          *mysv1;
206     SV          *mysv2;
207 #define RExC_lastparse  (pRExC_state->lastparse)
208 #define RExC_lastnum    (pRExC_state->lastnum)
209 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
210 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
211 #define RExC_mysv       (pRExC_state->mysv1)
212 #define RExC_mysv1      (pRExC_state->mysv1)
213 #define RExC_mysv2      (pRExC_state->mysv2)
214
215 #endif
216     bool        seen_unfolded_sharp_s;
217     bool        strict;
218     bool        study_started;
219 };
220
221 #define RExC_flags      (pRExC_state->flags)
222 #define RExC_pm_flags   (pRExC_state->pm_flags)
223 #define RExC_precomp    (pRExC_state->precomp)
224 #define RExC_precomp_adj (pRExC_state->precomp_adj)
225 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
226 #define RExC_precomp_end (pRExC_state->precomp_end)
227 #define RExC_rx_sv      (pRExC_state->rx_sv)
228 #define RExC_rx         (pRExC_state->rx)
229 #define RExC_rxi        (pRExC_state->rxi)
230 #define RExC_start      (pRExC_state->start)
231 #define RExC_end        (pRExC_state->end)
232 #define RExC_parse      (pRExC_state->parse)
233 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
234
235 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
236  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
237  * something forces the pattern into using /ui rules, the sharp s should be
238  * folded into the sequence 'ss', which takes up more space than previously
239  * calculated.  This means that the sizing pass needs to be restarted.  (The
240  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
241  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
242  * so there is no need to resize [perl #125990]. */
243 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
244
245 #ifdef RE_TRACK_PATTERN_OFFSETS
246 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
247                                                          others */
248 #endif
249 #define RExC_emit       (pRExC_state->emit)
250 #define RExC_emit_dummy (pRExC_state->emit_dummy)
251 #define RExC_emit_start (pRExC_state->emit_start)
252 #define RExC_emit_bound (pRExC_state->emit_bound)
253 #define RExC_sawback    (pRExC_state->sawback)
254 #define RExC_seen       (pRExC_state->seen)
255 #define RExC_size       (pRExC_state->size)
256 #define RExC_maxlen        (pRExC_state->maxlen)
257 #define RExC_npar       (pRExC_state->npar)
258 #define RExC_nestroot   (pRExC_state->nestroot)
259 #define RExC_extralen   (pRExC_state->extralen)
260 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
261 #define RExC_utf8       (pRExC_state->utf8)
262 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
263 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
264 #define RExC_open_parens        (pRExC_state->open_parens)
265 #define RExC_close_parens       (pRExC_state->close_parens)
266 #define RExC_end_op     (pRExC_state->end_op)
267 #define RExC_paren_names        (pRExC_state->paren_names)
268 #define RExC_recurse    (pRExC_state->recurse)
269 #define RExC_recurse_count      (pRExC_state->recurse_count)
270 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
271 #define RExC_study_chunk_recursed_bytes  \
272                                    (pRExC_state->study_chunk_recursed_bytes)
273 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
274 #define RExC_contains_locale    (pRExC_state->contains_locale)
275 #define RExC_contains_i (pRExC_state->contains_i)
276 #define RExC_override_recoding (pRExC_state->override_recoding)
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
288 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
289  * a flag to disable back-off on the fixed/floating substrings - if it's
290  * a high complexity pattern we assume the benefit of avoiding a full match
291  * is worth the cost of checking for the substrings even if they rarely help.
292  */
293 #define RExC_naughty    (pRExC_state->naughty)
294 #define TOO_NAUGHTY (10)
295 #define MARK_NAUGHTY(add) \
296     if (RExC_naughty < TOO_NAUGHTY) \
297         RExC_naughty += (add)
298 #define MARK_NAUGHTY_EXP(exp, add) \
299     if (RExC_naughty < TOO_NAUGHTY) \
300         RExC_naughty += RExC_naughty / (exp) + (add)
301
302 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
303 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
304         ((*s) == '{' && regcurly(s)))
305
306 /*
307  * Flags to be passed up and down.
308  */
309 #define WORST           0       /* Worst case. */
310 #define HASWIDTH        0x01    /* Known to match non-null strings. */
311
312 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
313  * character.  (There needs to be a case: in the switch statement in regexec.c
314  * for any node marked SIMPLE.)  Note that this is not the same thing as
315  * REGNODE_SIMPLE */
316 #define SIMPLE          0x02
317 #define SPSTART         0x04    /* Starts with * or + */
318 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
319 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
320 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
321 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
322                                    calcuate sizes as UTF-8 */
323
324 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
325
326 /* whether trie related optimizations are enabled */
327 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
328 #define TRIE_STUDY_OPT
329 #define FULL_TRIE_STUDY
330 #define TRIE_STCLASS
331 #endif
332
333
334
335 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
336 #define PBITVAL(paren) (1 << ((paren) & 7))
337 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
338 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
339 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
340
341 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
342                                      if (!UTF) {                           \
343                                          assert(PASS1);                    \
344                                          *flagp = RESTART_PASS1|NEED_UTF8; \
345                                          return NULL;                      \
346                                      }                                     \
347                              } STMT_END
348
349 /* Change from /d into /u rules, and restart the parse if we've already seen
350  * something whose size would increase as a result, by setting *flagp and
351  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
352  * we've change to /u during the parse.  */
353 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
354     STMT_START {                                                            \
355             if (DEPENDS_SEMANTICS) {                                        \
356                 assert(PASS1);                                              \
357                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
358                 RExC_uni_semantics = 1;                                     \
359                 if (RExC_seen_unfolded_sharp_s) {                           \
360                     *flagp |= RESTART_PASS1;                                \
361                     return restart_retval;                                  \
362                 }                                                           \
363             }                                                               \
364     } STMT_END
365
366 /* This converts the named class defined in regcomp.h to its equivalent class
367  * number defined in handy.h. */
368 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
369 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
370
371 #define _invlist_union_complement_2nd(a, b, output) \
372                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
373 #define _invlist_intersection_complement_2nd(a, b, output) \
374                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
375
376 /* About scan_data_t.
377
378   During optimisation we recurse through the regexp program performing
379   various inplace (keyhole style) optimisations. In addition study_chunk
380   and scan_commit populate this data structure with information about
381   what strings MUST appear in the pattern. We look for the longest
382   string that must appear at a fixed location, and we look for the
383   longest string that may appear at a floating location. So for instance
384   in the pattern:
385
386     /FOO[xX]A.*B[xX]BAR/
387
388   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
389   strings (because they follow a .* construct). study_chunk will identify
390   both FOO and BAR as being the longest fixed and floating strings respectively.
391
392   The strings can be composites, for instance
393
394      /(f)(o)(o)/
395
396   will result in a composite fixed substring 'foo'.
397
398   For each string some basic information is maintained:
399
400   - offset or min_offset
401     This is the position the string must appear at, or not before.
402     It also implicitly (when combined with minlenp) tells us how many
403     characters must match before the string we are searching for.
404     Likewise when combined with minlenp and the length of the string it
405     tells us how many characters must appear after the string we have
406     found.
407
408   - max_offset
409     Only used for floating strings. This is the rightmost point that
410     the string can appear at. If set to SSize_t_MAX it indicates that the
411     string can occur infinitely far to the right.
412
413   - minlenp
414     A pointer to the minimum number of characters of the pattern that the
415     string was found inside. This is important as in the case of positive
416     lookahead or positive lookbehind we can have multiple patterns
417     involved. Consider
418
419     /(?=FOO).*F/
420
421     The minimum length of the pattern overall is 3, the minimum length
422     of the lookahead part is 3, but the minimum length of the part that
423     will actually match is 1. So 'FOO's minimum length is 3, but the
424     minimum length for the F is 1. This is important as the minimum length
425     is used to determine offsets in front of and behind the string being
426     looked for.  Since strings can be composites this is the length of the
427     pattern at the time it was committed with a scan_commit. Note that
428     the length is calculated by study_chunk, so that the minimum lengths
429     are not known until the full pattern has been compiled, thus the
430     pointer to the value.
431
432   - lookbehind
433
434     In the case of lookbehind the string being searched for can be
435     offset past the start point of the final matching string.
436     If this value was just blithely removed from the min_offset it would
437     invalidate some of the calculations for how many chars must match
438     before or after (as they are derived from min_offset and minlen and
439     the length of the string being searched for).
440     When the final pattern is compiled and the data is moved from the
441     scan_data_t structure into the regexp structure the information
442     about lookbehind is factored in, with the information that would
443     have been lost precalculated in the end_shift field for the
444     associated string.
445
446   The fields pos_min and pos_delta are used to store the minimum offset
447   and the delta to the maximum offset at the current point in the pattern.
448
449 */
450
451 typedef struct scan_data_t {
452     /*I32 len_min;      unused */
453     /*I32 len_delta;    unused */
454     SSize_t pos_min;
455     SSize_t pos_delta;
456     SV *last_found;
457     SSize_t last_end;       /* min value, <0 unless valid. */
458     SSize_t last_start_min;
459     SSize_t last_start_max;
460     SV **longest;           /* Either &l_fixed, or &l_float. */
461     SV *longest_fixed;      /* longest fixed string found in pattern */
462     SSize_t offset_fixed;   /* offset where it starts */
463     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
464     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
465     SV *longest_float;      /* longest floating string found in pattern */
466     SSize_t offset_float_min; /* earliest point in string it can appear */
467     SSize_t offset_float_max; /* latest point in string it can appear */
468     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
469     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
470     I32 flags;
471     I32 whilem_c;
472     SSize_t *last_closep;
473     regnode_ssc *start_class;
474 } scan_data_t;
475
476 /*
477  * Forward declarations for pregcomp()'s friends.
478  */
479
480 static const scan_data_t zero_scan_data =
481   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
482
483 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
484 #define SF_BEFORE_SEOL          0x0001
485 #define SF_BEFORE_MEOL          0x0002
486 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
487 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
488
489 #define SF_FIX_SHIFT_EOL        (+2)
490 #define SF_FL_SHIFT_EOL         (+4)
491
492 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
493 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
494
495 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
496 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
497 #define SF_IS_INF               0x0040
498 #define SF_HAS_PAR              0x0080
499 #define SF_IN_PAR               0x0100
500 #define SF_HAS_EVAL             0x0200
501
502
503 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
504  * longest substring in the pattern. When it is not set the optimiser keeps
505  * track of position, but does not keep track of the actual strings seen,
506  *
507  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
508  * /foo/i will not.
509  *
510  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
511  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
512  * turned off because of the alternation (BRANCH). */
513 #define SCF_DO_SUBSTR           0x0400
514
515 #define SCF_DO_STCLASS_AND      0x0800
516 #define SCF_DO_STCLASS_OR       0x1000
517 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
518 #define SCF_WHILEM_VISITED_POS  0x2000
519
520 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
521 #define SCF_SEEN_ACCEPT         0x8000
522 #define SCF_TRIE_DOING_RESTUDY 0x10000
523 #define SCF_IN_DEFINE          0x20000
524
525
526
527
528 #define UTF cBOOL(RExC_utf8)
529
530 /* The enums for all these are ordered so things work out correctly */
531 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
532 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
533                                                      == REGEX_DEPENDS_CHARSET)
534 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
535 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
536                                                      >= REGEX_UNICODE_CHARSET)
537 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
538                                             == REGEX_ASCII_RESTRICTED_CHARSET)
539 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
540                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
541 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
542                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
543
544 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
545
546 /* For programs that want to be strictly Unicode compatible by dying if any
547  * attempt is made to match a non-Unicode code point against a Unicode
548  * property.  */
549 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
550
551 #define OOB_NAMEDCLASS          -1
552
553 /* There is no code point that is out-of-bounds, so this is problematic.  But
554  * its only current use is to initialize a variable that is always set before
555  * looked at. */
556 #define OOB_UNICODE             0xDEADBEEF
557
558 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
559 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
560
561
562 /* length of regex to show in messages that don't mark a position within */
563 #define RegexLengthToShowInErrorMessages 127
564
565 /*
566  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
567  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
568  * op/pragma/warn/regcomp.
569  */
570 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
571 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
572
573 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
574                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
575
576 /* The code in this file in places uses one level of recursion with parsing
577  * rebased to an alternate string constructed by us in memory.  This can take
578  * the form of something that is completely different from the input, or
579  * something that uses the input as part of the alternate.  In the first case,
580  * there should be no possibility of an error, as we are in complete control of
581  * the alternate string.  But in the second case we don't control the input
582  * portion, so there may be errors in that.  Here's an example:
583  *      /[abc\x{DF}def]/ui
584  * is handled specially because \x{df} folds to a sequence of more than one
585  * character, 'ss'.  What is done is to create and parse an alternate string,
586  * which looks like this:
587  *      /(?:\x{DF}|[abc\x{DF}def])/ui
588  * where it uses the input unchanged in the middle of something it constructs,
589  * which is a branch for the DF outside the character class, and clustering
590  * parens around the whole thing. (It knows enough to skip the DF inside the
591  * class while in this substitute parse.) 'abc' and 'def' may have errors that
592  * need to be reported.  The general situation looks like this:
593  *
594  *              sI                       tI               xI       eI
595  * Input:       ----------------------------------------------------
596  * Constructed:         ---------------------------------------------------
597  *                      sC               tC               xC       eC     EC
598  *
599  * The input string sI..eI is the input pattern.  The string sC..EC is the
600  * constructed substitute parse string.  The portions sC..tC and eC..EC are
601  * constructed by us.  The portion tC..eC is an exact duplicate of the input
602  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
603  * while parsing, we find an error at xC.  We want to display a message showing
604  * the real input string.  Thus we need to find the point xI in it which
605  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
606  * been constructed by us, and so shouldn't have errors.  We get:
607  *
608  *      xI = sI + (tI - sI) + (xC - tC)
609  *
610  * and, the offset into sI is:
611  *
612  *      (xI - sI) = (tI - sI) + (xC - tC)
613  *
614  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
615  * and we save tC as RExC_adjusted_start.
616  *
617  * During normal processing of the input pattern, everything points to that,
618  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
619  */
620
621 #define tI_sI           RExC_precomp_adj
622 #define tC              RExC_adjusted_start
623 #define sC              RExC_precomp
624 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
625 #define xI(xC)          (sC + xI_offset(xC))
626 #define eC              RExC_precomp_end
627
628 #define REPORT_LOCATION_ARGS(xC)                                            \
629     UTF8fARG(UTF,                                                           \
630              (xI(xC) > eC) /* Don't run off end */                          \
631               ? eC - sC   /* Length before the <--HERE */                   \
632               : xI_offset(xC),                                              \
633              sC),         /* The input pattern printed up to the <--HERE */ \
634     UTF8fARG(UTF,                                                           \
635              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
636              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
637
638 /* Used to point after bad bytes for an error message, but avoid skipping
639  * past a nul byte. */
640 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
641
642 /*
643  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
644  * arg. Show regex, up to a maximum length. If it's too long, chop and add
645  * "...".
646  */
647 #define _FAIL(code) STMT_START {                                        \
648     const char *ellipses = "";                                          \
649     IV len = RExC_precomp_end - RExC_precomp;                                   \
650                                                                         \
651     if (!SIZE_ONLY)                                                     \
652         SAVEFREESV(RExC_rx_sv);                                         \
653     if (len > RegexLengthToShowInErrorMessages) {                       \
654         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
655         len = RegexLengthToShowInErrorMessages - 10;                    \
656         ellipses = "...";                                               \
657     }                                                                   \
658     code;                                                               \
659 } STMT_END
660
661 #define FAIL(msg) _FAIL(                            \
662     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
663             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
664
665 #define FAIL2(msg,arg) _FAIL(                       \
666     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
667             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
668
669 /*
670  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
671  */
672 #define Simple_vFAIL(m) STMT_START {                                    \
673     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
674             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
675 } STMT_END
676
677 /*
678  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
679  */
680 #define vFAIL(m) STMT_START {                           \
681     if (!SIZE_ONLY)                                     \
682         SAVEFREESV(RExC_rx_sv);                         \
683     Simple_vFAIL(m);                                    \
684 } STMT_END
685
686 /*
687  * Like Simple_vFAIL(), but accepts two arguments.
688  */
689 #define Simple_vFAIL2(m,a1) STMT_START {                        \
690     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
691                       REPORT_LOCATION_ARGS(RExC_parse));        \
692 } STMT_END
693
694 /*
695  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
696  */
697 #define vFAIL2(m,a1) STMT_START {                       \
698     if (!SIZE_ONLY)                                     \
699         SAVEFREESV(RExC_rx_sv);                         \
700     Simple_vFAIL2(m, a1);                               \
701 } STMT_END
702
703
704 /*
705  * Like Simple_vFAIL(), but accepts three arguments.
706  */
707 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
708     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
709             REPORT_LOCATION_ARGS(RExC_parse));                  \
710 } STMT_END
711
712 /*
713  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
714  */
715 #define vFAIL3(m,a1,a2) STMT_START {                    \
716     if (!SIZE_ONLY)                                     \
717         SAVEFREESV(RExC_rx_sv);                         \
718     Simple_vFAIL3(m, a1, a2);                           \
719 } STMT_END
720
721 /*
722  * Like Simple_vFAIL(), but accepts four arguments.
723  */
724 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
725     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
726             REPORT_LOCATION_ARGS(RExC_parse));                  \
727 } STMT_END
728
729 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
730     if (!SIZE_ONLY)                                     \
731         SAVEFREESV(RExC_rx_sv);                         \
732     Simple_vFAIL4(m, a1, a2, a3);                       \
733 } STMT_END
734
735 /* A specialized version of vFAIL2 that works with UTF8f */
736 #define vFAIL2utf8f(m, a1) STMT_START {             \
737     if (!SIZE_ONLY)                                 \
738         SAVEFREESV(RExC_rx_sv);                     \
739     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
740             REPORT_LOCATION_ARGS(RExC_parse));      \
741 } STMT_END
742
743 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
744     if (!SIZE_ONLY)                                     \
745         SAVEFREESV(RExC_rx_sv);                         \
746     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
747             REPORT_LOCATION_ARGS(RExC_parse));          \
748 } STMT_END
749
750 /* These have asserts in them because of [perl #122671] Many warnings in
751  * regcomp.c can occur twice.  If they get output in pass1 and later in that
752  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
753  * would get output again.  So they should be output in pass2, and these
754  * asserts make sure new warnings follow that paradigm. */
755
756 /* m is not necessarily a "literal string", in this macro */
757 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
758     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
759                                        "%s" REPORT_LOCATION,            \
760                                   m, REPORT_LOCATION_ARGS(loc));        \
761 } STMT_END
762
763 #define ckWARNreg(loc,m) STMT_START {                                   \
764     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
765                                           m REPORT_LOCATION,            \
766                                           REPORT_LOCATION_ARGS(loc));   \
767 } STMT_END
768
769 #define vWARN(loc, m) STMT_START {                                      \
770     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
771                                        m REPORT_LOCATION,               \
772                                        REPORT_LOCATION_ARGS(loc));      \
773 } STMT_END
774
775 #define vWARN_dep(loc, m) STMT_START {                                  \
776     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
777                                        m REPORT_LOCATION,               \
778                                        REPORT_LOCATION_ARGS(loc));      \
779 } STMT_END
780
781 #define ckWARNdep(loc,m) STMT_START {                                   \
782     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
783                                             m REPORT_LOCATION,          \
784                                             REPORT_LOCATION_ARGS(loc)); \
785 } STMT_END
786
787 #define ckWARNregdep(loc,m) STMT_START {                                    \
788     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
789                                                       WARN_REGEXP),         \
790                                              m REPORT_LOCATION,             \
791                                              REPORT_LOCATION_ARGS(loc));    \
792 } STMT_END
793
794 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
795     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
796                                             m REPORT_LOCATION,              \
797                                             a1, REPORT_LOCATION_ARGS(loc)); \
798 } STMT_END
799
800 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
801     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
802                                           m REPORT_LOCATION,                \
803                                           a1, REPORT_LOCATION_ARGS(loc));   \
804 } STMT_END
805
806 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
807     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
808                                        m REPORT_LOCATION,                   \
809                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
810 } STMT_END
811
812 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
813     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
814                                           m REPORT_LOCATION,                \
815                                           a1, a2,                           \
816                                           REPORT_LOCATION_ARGS(loc));       \
817 } STMT_END
818
819 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
820     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
821                                        m REPORT_LOCATION,               \
822                                        a1, a2, a3,                      \
823                                        REPORT_LOCATION_ARGS(loc));      \
824 } STMT_END
825
826 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
827     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
828                                           m REPORT_LOCATION,            \
829                                           a1, a2, a3,                   \
830                                           REPORT_LOCATION_ARGS(loc));   \
831 } STMT_END
832
833 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
834     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
835                                        m REPORT_LOCATION,               \
836                                        a1, a2, a3, a4,                  \
837                                        REPORT_LOCATION_ARGS(loc));      \
838 } STMT_END
839
840 /* Macros for recording node offsets.   20001227 mjd@plover.com
841  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
842  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
843  * Element 0 holds the number n.
844  * Position is 1 indexed.
845  */
846 #ifndef RE_TRACK_PATTERN_OFFSETS
847 #define Set_Node_Offset_To_R(node,byte)
848 #define Set_Node_Offset(node,byte)
849 #define Set_Cur_Node_Offset
850 #define Set_Node_Length_To_R(node,len)
851 #define Set_Node_Length(node,len)
852 #define Set_Node_Cur_Length(node,start)
853 #define Node_Offset(n)
854 #define Node_Length(n)
855 #define Set_Node_Offset_Length(node,offset,len)
856 #define ProgLen(ri) ri->u.proglen
857 #define SetProgLen(ri,x) ri->u.proglen = x
858 #else
859 #define ProgLen(ri) ri->u.offsets[0]
860 #define SetProgLen(ri,x) ri->u.offsets[0] = x
861 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
862     if (! SIZE_ONLY) {                                                  \
863         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
864                     __LINE__, (int)(node), (int)(byte)));               \
865         if((node) < 0) {                                                \
866             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
867                                          (int)(node));                  \
868         } else {                                                        \
869             RExC_offsets[2*(node)-1] = (byte);                          \
870         }                                                               \
871     }                                                                   \
872 } STMT_END
873
874 #define Set_Node_Offset(node,byte) \
875     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
876 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
877
878 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
879     if (! SIZE_ONLY) {                                                  \
880         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
881                 __LINE__, (int)(node), (int)(len)));                    \
882         if((node) < 0) {                                                \
883             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
884                                          (int)(node));                  \
885         } else {                                                        \
886             RExC_offsets[2*(node)] = (len);                             \
887         }                                                               \
888     }                                                                   \
889 } STMT_END
890
891 #define Set_Node_Length(node,len) \
892     Set_Node_Length_To_R((node)-RExC_emit_start, len)
893 #define Set_Node_Cur_Length(node, start)                \
894     Set_Node_Length(node, RExC_parse - start)
895
896 /* Get offsets and lengths */
897 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
898 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
899
900 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
901     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
902     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
903 } STMT_END
904 #endif
905
906 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
907 #define EXPERIMENTAL_INPLACESCAN
908 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
909
910 #ifdef DEBUGGING
911 int
912 Perl_re_printf(pTHX_ const char *fmt, ...)
913 {
914     va_list ap;
915     int result;
916     PerlIO *f= Perl_debug_log;
917     PERL_ARGS_ASSERT_RE_PRINTF;
918     va_start(ap, fmt);
919     result = PerlIO_vprintf(f, fmt, ap);
920     va_end(ap);
921     return result;
922 }
923
924 int
925 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
926 {
927     va_list ap;
928     int result;
929     PerlIO *f= Perl_debug_log;
930     PERL_ARGS_ASSERT_RE_INDENTF;
931     va_start(ap, depth);
932     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
933     result = PerlIO_vprintf(f, fmt, ap);
934     va_end(ap);
935     return result;
936 }
937 #endif /* DEBUGGING */
938
939 #define DEBUG_RExC_seen()                                                   \
940         DEBUG_OPTIMISE_MORE_r({                                             \
941             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
942                                                                             \
943             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
944                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
945                                                                             \
946             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
947                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
948                                                                             \
949             if (RExC_seen & REG_GPOS_SEEN)                                  \
950                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
951                                                                             \
952             if (RExC_seen & REG_RECURSE_SEEN)                               \
953                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
954                                                                             \
955             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
956                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
957                                                                             \
958             if (RExC_seen & REG_VERBARG_SEEN)                               \
959                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
960                                                                             \
961             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
962                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
963                                                                             \
964             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
965                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
966                                                                             \
967             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
968                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
969                                                                             \
970             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
971                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
972                                                                             \
973             Perl_re_printf( aTHX_ "\n");                                                \
974         });
975
976 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
977   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
978
979 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
980     if ( ( flags ) ) {                                                      \
981         Perl_re_printf( aTHX_  "%s", open_str);                                         \
982         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
983         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
984         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
985         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
986         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
987         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
988         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
989         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
990         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
991         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
992         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
993         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
994         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
995         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
996         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
997         Perl_re_printf( aTHX_  "%s", close_str);                                        \
998     }
999
1000
1001 #define DEBUG_STUDYDATA(str,data,depth)                              \
1002 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
1003     Perl_re_indentf( aTHX_  "" str "Pos:%" IVdf "/%" IVdf            \
1004         " Flags: 0x%" UVXf,                                          \
1005         depth,                                                       \
1006         (IV)((data)->pos_min),                                       \
1007         (IV)((data)->pos_delta),                                     \
1008         (UV)((data)->flags)                                          \
1009     );                                                               \
1010     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1011     Perl_re_printf( aTHX_                                            \
1012         " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",                    \
1013         (IV)((data)->whilem_c),                                      \
1014         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1015         is_inf ? "INF " : ""                                         \
1016     );                                                               \
1017     if ((data)->last_found)                                          \
1018         Perl_re_printf( aTHX_                                        \
1019             "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf                   \
1020             " %sFixed:'%s' @ %" IVdf                                 \
1021             " %sFloat: '%s' @ %" IVdf "/%" IVdf,                     \
1022             SvPVX_const((data)->last_found),                         \
1023             (IV)((data)->last_end),                                  \
1024             (IV)((data)->last_start_min),                            \
1025             (IV)((data)->last_start_max),                            \
1026             ((data)->longest &&                                      \
1027              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1028             SvPVX_const((data)->longest_fixed),                      \
1029             (IV)((data)->offset_fixed),                              \
1030             ((data)->longest &&                                      \
1031              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1032             SvPVX_const((data)->longest_float),                      \
1033             (IV)((data)->offset_float_min),                          \
1034             (IV)((data)->offset_float_max)                           \
1035         );                                                           \
1036     Perl_re_printf( aTHX_ "\n");                                                 \
1037 });
1038
1039
1040 /* =========================================================
1041  * BEGIN edit_distance stuff.
1042  *
1043  * This calculates how many single character changes of any type are needed to
1044  * transform a string into another one.  It is taken from version 3.1 of
1045  *
1046  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1047  */
1048
1049 /* Our unsorted dictionary linked list.   */
1050 /* Note we use UVs, not chars. */
1051
1052 struct dictionary{
1053   UV key;
1054   UV value;
1055   struct dictionary* next;
1056 };
1057 typedef struct dictionary item;
1058
1059
1060 PERL_STATIC_INLINE item*
1061 push(UV key,item* curr)
1062 {
1063     item* head;
1064     Newxz(head, 1, item);
1065     head->key = key;
1066     head->value = 0;
1067     head->next = curr;
1068     return head;
1069 }
1070
1071
1072 PERL_STATIC_INLINE item*
1073 find(item* head, UV key)
1074 {
1075     item* iterator = head;
1076     while (iterator){
1077         if (iterator->key == key){
1078             return iterator;
1079         }
1080         iterator = iterator->next;
1081     }
1082
1083     return NULL;
1084 }
1085
1086 PERL_STATIC_INLINE item*
1087 uniquePush(item* head,UV key)
1088 {
1089     item* iterator = head;
1090
1091     while (iterator){
1092         if (iterator->key == key) {
1093             return head;
1094         }
1095         iterator = iterator->next;
1096     }
1097
1098     return push(key,head);
1099 }
1100
1101 PERL_STATIC_INLINE void
1102 dict_free(item* head)
1103 {
1104     item* iterator = head;
1105
1106     while (iterator) {
1107         item* temp = iterator;
1108         iterator = iterator->next;
1109         Safefree(temp);
1110     }
1111
1112     head = NULL;
1113 }
1114
1115 /* End of Dictionary Stuff */
1116
1117 /* All calculations/work are done here */
1118 STATIC int
1119 S_edit_distance(const UV* src,
1120                 const UV* tgt,
1121                 const STRLEN x,             /* length of src[] */
1122                 const STRLEN y,             /* length of tgt[] */
1123                 const SSize_t maxDistance
1124 )
1125 {
1126     item *head = NULL;
1127     UV swapCount,swapScore,targetCharCount,i,j;
1128     UV *scores;
1129     UV score_ceil = x + y;
1130
1131     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1132
1133     /* intialize matrix start values */
1134     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1135     scores[0] = score_ceil;
1136     scores[1 * (y + 2) + 0] = score_ceil;
1137     scores[0 * (y + 2) + 1] = score_ceil;
1138     scores[1 * (y + 2) + 1] = 0;
1139     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1140
1141     /* work loops    */
1142     /* i = src index */
1143     /* j = tgt index */
1144     for (i=1;i<=x;i++) {
1145         if (i < x)
1146             head = uniquePush(head,src[i]);
1147         scores[(i+1) * (y + 2) + 1] = i;
1148         scores[(i+1) * (y + 2) + 0] = score_ceil;
1149         swapCount = 0;
1150
1151         for (j=1;j<=y;j++) {
1152             if (i == 1) {
1153                 if(j < y)
1154                 head = uniquePush(head,tgt[j]);
1155                 scores[1 * (y + 2) + (j + 1)] = j;
1156                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1157             }
1158
1159             targetCharCount = find(head,tgt[j-1])->value;
1160             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1161
1162             if (src[i-1] != tgt[j-1]){
1163                 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));
1164             }
1165             else {
1166                 swapCount = j;
1167                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1168             }
1169         }
1170
1171         find(head,src[i-1])->value = i;
1172     }
1173
1174     {
1175         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1176         dict_free(head);
1177         Safefree(scores);
1178         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1179     }
1180 }
1181
1182 /* END of edit_distance() stuff
1183  * ========================================================= */
1184
1185 /* is c a control character for which we have a mnemonic? */
1186 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1187
1188 STATIC const char *
1189 S_cntrl_to_mnemonic(const U8 c)
1190 {
1191     /* Returns the mnemonic string that represents character 'c', if one
1192      * exists; NULL otherwise.  The only ones that exist for the purposes of
1193      * this routine are a few control characters */
1194
1195     switch (c) {
1196         case '\a':       return "\\a";
1197         case '\b':       return "\\b";
1198         case ESC_NATIVE: return "\\e";
1199         case '\f':       return "\\f";
1200         case '\n':       return "\\n";
1201         case '\r':       return "\\r";
1202         case '\t':       return "\\t";
1203     }
1204
1205     return NULL;
1206 }
1207
1208 /* Mark that we cannot extend a found fixed substring at this point.
1209    Update the longest found anchored substring and the longest found
1210    floating substrings if needed. */
1211
1212 STATIC void
1213 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1214                     SSize_t *minlenp, int is_inf)
1215 {
1216     const STRLEN l = CHR_SVLEN(data->last_found);
1217     const STRLEN old_l = CHR_SVLEN(*data->longest);
1218     GET_RE_DEBUG_FLAGS_DECL;
1219
1220     PERL_ARGS_ASSERT_SCAN_COMMIT;
1221
1222     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1223         SvSetMagicSV(*data->longest, data->last_found);
1224         if (*data->longest == data->longest_fixed) {
1225             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1226             if (data->flags & SF_BEFORE_EOL)
1227                 data->flags
1228                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1229             else
1230                 data->flags &= ~SF_FIX_BEFORE_EOL;
1231             data->minlen_fixed=minlenp;
1232             data->lookbehind_fixed=0;
1233         }
1234         else { /* *data->longest == data->longest_float */
1235             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1236             data->offset_float_max = (l
1237                           ? data->last_start_max
1238                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1239                                          ? SSize_t_MAX
1240                                          : data->pos_min + data->pos_delta));
1241             if (is_inf
1242                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1243                 data->offset_float_max = SSize_t_MAX;
1244             if (data->flags & SF_BEFORE_EOL)
1245                 data->flags
1246                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1247             else
1248                 data->flags &= ~SF_FL_BEFORE_EOL;
1249             data->minlen_float=minlenp;
1250             data->lookbehind_float=0;
1251         }
1252     }
1253     SvCUR_set(data->last_found, 0);
1254     {
1255         SV * const sv = data->last_found;
1256         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1257             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1258             if (mg)
1259                 mg->mg_len = 0;
1260         }
1261     }
1262     data->last_end = -1;
1263     data->flags &= ~SF_BEFORE_EOL;
1264     DEBUG_STUDYDATA("commit: ",data,0);
1265 }
1266
1267 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1268  * list that describes which code points it matches */
1269
1270 STATIC void
1271 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1272 {
1273     /* Set the SSC 'ssc' to match an empty string or any code point */
1274
1275     PERL_ARGS_ASSERT_SSC_ANYTHING;
1276
1277     assert(is_ANYOF_SYNTHETIC(ssc));
1278
1279     /* mortalize so won't leak */
1280     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1281     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1282 }
1283
1284 STATIC int
1285 S_ssc_is_anything(const regnode_ssc *ssc)
1286 {
1287     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1288      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1289      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1290      * in any way, so there's no point in using it */
1291
1292     UV start, end;
1293     bool ret;
1294
1295     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1296
1297     assert(is_ANYOF_SYNTHETIC(ssc));
1298
1299     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1300         return FALSE;
1301     }
1302
1303     /* See if the list consists solely of the range 0 - Infinity */
1304     invlist_iterinit(ssc->invlist);
1305     ret = invlist_iternext(ssc->invlist, &start, &end)
1306           && start == 0
1307           && end == UV_MAX;
1308
1309     invlist_iterfinish(ssc->invlist);
1310
1311     if (ret) {
1312         return TRUE;
1313     }
1314
1315     /* If e.g., both \w and \W are set, matches everything */
1316     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1317         int i;
1318         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1319             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1320                 return TRUE;
1321             }
1322         }
1323     }
1324
1325     return FALSE;
1326 }
1327
1328 STATIC void
1329 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1330 {
1331     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1332      * string, any code point, or any posix class under locale */
1333
1334     PERL_ARGS_ASSERT_SSC_INIT;
1335
1336     Zero(ssc, 1, regnode_ssc);
1337     set_ANYOF_SYNTHETIC(ssc);
1338     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1339     ssc_anything(ssc);
1340
1341     /* If any portion of the regex is to operate under locale rules that aren't
1342      * fully known at compile time, initialization includes it.  The reason
1343      * this isn't done for all regexes is that the optimizer was written under
1344      * the assumption that locale was all-or-nothing.  Given the complexity and
1345      * lack of documentation in the optimizer, and that there are inadequate
1346      * test cases for locale, many parts of it may not work properly, it is
1347      * safest to avoid locale unless necessary. */
1348     if (RExC_contains_locale) {
1349         ANYOF_POSIXL_SETALL(ssc);
1350     }
1351     else {
1352         ANYOF_POSIXL_ZERO(ssc);
1353     }
1354 }
1355
1356 STATIC int
1357 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1358                         const regnode_ssc *ssc)
1359 {
1360     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1361      * to the list of code points matched, and locale posix classes; hence does
1362      * not check its flags) */
1363
1364     UV start, end;
1365     bool ret;
1366
1367     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1368
1369     assert(is_ANYOF_SYNTHETIC(ssc));
1370
1371     invlist_iterinit(ssc->invlist);
1372     ret = invlist_iternext(ssc->invlist, &start, &end)
1373           && start == 0
1374           && end == UV_MAX;
1375
1376     invlist_iterfinish(ssc->invlist);
1377
1378     if (! ret) {
1379         return FALSE;
1380     }
1381
1382     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1383         return FALSE;
1384     }
1385
1386     return TRUE;
1387 }
1388
1389 STATIC SV*
1390 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1391                                const regnode_charclass* const node)
1392 {
1393     /* Returns a mortal inversion list defining which code points are matched
1394      * by 'node', which is of type ANYOF.  Handles complementing the result if
1395      * appropriate.  If some code points aren't knowable at this time, the
1396      * returned list must, and will, contain every code point that is a
1397      * possibility. */
1398
1399     SV* invlist = NULL;
1400     SV* only_utf8_locale_invlist = NULL;
1401     unsigned int i;
1402     const U32 n = ARG(node);
1403     bool new_node_has_latin1 = FALSE;
1404
1405     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1406
1407     /* Look at the data structure created by S_set_ANYOF_arg() */
1408     if (n != ANYOF_ONLY_HAS_BITMAP) {
1409         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1410         AV * const av = MUTABLE_AV(SvRV(rv));
1411         SV **const ary = AvARRAY(av);
1412         assert(RExC_rxi->data->what[n] == 's');
1413
1414         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1415             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1416         }
1417         else if (ary[0] && ary[0] != &PL_sv_undef) {
1418
1419             /* Here, no compile-time swash, and there are things that won't be
1420              * known until runtime -- we have to assume it could be anything */
1421             invlist = sv_2mortal(_new_invlist(1));
1422             return _add_range_to_invlist(invlist, 0, UV_MAX);
1423         }
1424         else if (ary[3] && ary[3] != &PL_sv_undef) {
1425
1426             /* Here no compile-time swash, and no run-time only data.  Use the
1427              * node's inversion list */
1428             invlist = sv_2mortal(invlist_clone(ary[3]));
1429         }
1430
1431         /* Get the code points valid only under UTF-8 locales */
1432         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1433             && ary[2] && ary[2] != &PL_sv_undef)
1434         {
1435             only_utf8_locale_invlist = ary[2];
1436         }
1437     }
1438
1439     if (! invlist) {
1440         invlist = sv_2mortal(_new_invlist(0));
1441     }
1442
1443     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1444      * code points, and an inversion list for the others, but if there are code
1445      * points that should match only conditionally on the target string being
1446      * UTF-8, those are placed in the inversion list, and not the bitmap.
1447      * Since there are circumstances under which they could match, they are
1448      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1449      * to exclude them here, so that when we invert below, the end result
1450      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1451      * have to do this here before we add the unconditionally matched code
1452      * points */
1453     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1454         _invlist_intersection_complement_2nd(invlist,
1455                                              PL_UpperLatin1,
1456                                              &invlist);
1457     }
1458
1459     /* Add in the points from the bit map */
1460     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1461         if (ANYOF_BITMAP_TEST(node, i)) {
1462             unsigned int start = i++;
1463
1464             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1465                 /* empty */
1466             }
1467             invlist = _add_range_to_invlist(invlist, start, i-1);
1468             new_node_has_latin1 = TRUE;
1469         }
1470     }
1471
1472     /* If this can match all upper Latin1 code points, have to add them
1473      * as well.  But don't add them if inverting, as when that gets done below,
1474      * it would exclude all these characters, including the ones it shouldn't
1475      * that were added just above */
1476     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1477         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1478     {
1479         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1480     }
1481
1482     /* Similarly for these */
1483     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1484         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1485     }
1486
1487     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1488         _invlist_invert(invlist);
1489     }
1490     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1491
1492         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1493          * locale.  We can skip this if there are no 0-255 at all. */
1494         _invlist_union(invlist, PL_Latin1, &invlist);
1495     }
1496
1497     /* Similarly add the UTF-8 locale possible matches.  These have to be
1498      * deferred until after the non-UTF-8 locale ones are taken care of just
1499      * above, or it leads to wrong results under ANYOF_INVERT */
1500     if (only_utf8_locale_invlist) {
1501         _invlist_union_maybe_complement_2nd(invlist,
1502                                             only_utf8_locale_invlist,
1503                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1504                                             &invlist);
1505     }
1506
1507     return invlist;
1508 }
1509
1510 /* These two functions currently do the exact same thing */
1511 #define ssc_init_zero           ssc_init
1512
1513 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1514 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1515
1516 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1517  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1518  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1519
1520 STATIC void
1521 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1522                 const regnode_charclass *and_with)
1523 {
1524     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1525      * another SSC or a regular ANYOF class.  Can create false positives. */
1526
1527     SV* anded_cp_list;
1528     U8  anded_flags;
1529
1530     PERL_ARGS_ASSERT_SSC_AND;
1531
1532     assert(is_ANYOF_SYNTHETIC(ssc));
1533
1534     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1535      * the code point inversion list and just the relevant flags */
1536     if (is_ANYOF_SYNTHETIC(and_with)) {
1537         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1538         anded_flags = ANYOF_FLAGS(and_with);
1539
1540         /* XXX This is a kludge around what appears to be deficiencies in the
1541          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1542          * there are paths through the optimizer where it doesn't get weeded
1543          * out when it should.  And if we don't make some extra provision for
1544          * it like the code just below, it doesn't get added when it should.
1545          * This solution is to add it only when AND'ing, which is here, and
1546          * only when what is being AND'ed is the pristine, original node
1547          * matching anything.  Thus it is like adding it to ssc_anything() but
1548          * only when the result is to be AND'ed.  Probably the same solution
1549          * could be adopted for the same problem we have with /l matching,
1550          * which is solved differently in S_ssc_init(), and that would lead to
1551          * fewer false positives than that solution has.  But if this solution
1552          * creates bugs, the consequences are only that a warning isn't raised
1553          * that should be; while the consequences for having /l bugs is
1554          * incorrect matches */
1555         if (ssc_is_anything((regnode_ssc *)and_with)) {
1556             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1557         }
1558     }
1559     else {
1560         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1561         if (OP(and_with) == ANYOFD) {
1562             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1563         }
1564         else {
1565             anded_flags = ANYOF_FLAGS(and_with)
1566             &( ANYOF_COMMON_FLAGS
1567               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1568               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1569             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1570                 anded_flags &=
1571                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1572             }
1573         }
1574     }
1575
1576     ANYOF_FLAGS(ssc) &= anded_flags;
1577
1578     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1579      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1580      * 'and_with' may be inverted.  When not inverted, we have the situation of
1581      * computing:
1582      *  (C1 | P1) & (C2 | P2)
1583      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1584      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1585      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1586      *                    <=  ((C1 & C2) | P1 | P2)
1587      * Alternatively, the last few steps could be:
1588      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1589      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1590      *                    <=  (C1 | C2 | (P1 & P2))
1591      * We favor the second approach if either P1 or P2 is non-empty.  This is
1592      * because these components are a barrier to doing optimizations, as what
1593      * they match cannot be known until the moment of matching as they are
1594      * dependent on the current locale, 'AND"ing them likely will reduce or
1595      * eliminate them.
1596      * But we can do better if we know that C1,P1 are in their initial state (a
1597      * frequent occurrence), each matching everything:
1598      *  (<everything>) & (C2 | P2) =  C2 | P2
1599      * Similarly, if C2,P2 are in their initial state (again a frequent
1600      * occurrence), the result is a no-op
1601      *  (C1 | P1) & (<everything>) =  C1 | P1
1602      *
1603      * Inverted, we have
1604      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1605      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1606      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1607      * */
1608
1609     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1610         && ! is_ANYOF_SYNTHETIC(and_with))
1611     {
1612         unsigned int i;
1613
1614         ssc_intersection(ssc,
1615                          anded_cp_list,
1616                          FALSE /* Has already been inverted */
1617                          );
1618
1619         /* If either P1 or P2 is empty, the intersection will be also; can skip
1620          * the loop */
1621         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1622             ANYOF_POSIXL_ZERO(ssc);
1623         }
1624         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1625
1626             /* Note that the Posix class component P from 'and_with' actually
1627              * looks like:
1628              *      P = Pa | Pb | ... | Pn
1629              * where each component is one posix class, such as in [\w\s].
1630              * Thus
1631              *      ~P = ~(Pa | Pb | ... | Pn)
1632              *         = ~Pa & ~Pb & ... & ~Pn
1633              *        <= ~Pa | ~Pb | ... | ~Pn
1634              * The last is something we can easily calculate, but unfortunately
1635              * is likely to have many false positives.  We could do better
1636              * in some (but certainly not all) instances if two classes in
1637              * P have known relationships.  For example
1638              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1639              * So
1640              *      :lower: & :print: = :lower:
1641              * And similarly for classes that must be disjoint.  For example,
1642              * since \s and \w can have no elements in common based on rules in
1643              * the POSIX standard,
1644              *      \w & ^\S = nothing
1645              * Unfortunately, some vendor locales do not meet the Posix
1646              * standard, in particular almost everything by Microsoft.
1647              * The loop below just changes e.g., \w into \W and vice versa */
1648
1649             regnode_charclass_posixl temp;
1650             int add = 1;    /* To calculate the index of the complement */
1651
1652             ANYOF_POSIXL_ZERO(&temp);
1653             for (i = 0; i < ANYOF_MAX; i++) {
1654                 assert(i % 2 != 0
1655                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1656                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1657
1658                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1659                     ANYOF_POSIXL_SET(&temp, i + add);
1660                 }
1661                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1662             }
1663             ANYOF_POSIXL_AND(&temp, ssc);
1664
1665         } /* else ssc already has no posixes */
1666     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1667          in its initial state */
1668     else if (! is_ANYOF_SYNTHETIC(and_with)
1669              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1670     {
1671         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1672          * copy it over 'ssc' */
1673         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1674             if (is_ANYOF_SYNTHETIC(and_with)) {
1675                 StructCopy(and_with, ssc, regnode_ssc);
1676             }
1677             else {
1678                 ssc->invlist = anded_cp_list;
1679                 ANYOF_POSIXL_ZERO(ssc);
1680                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1681                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1682                 }
1683             }
1684         }
1685         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1686                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1687         {
1688             /* One or the other of P1, P2 is non-empty. */
1689             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1690                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1691             }
1692             ssc_union(ssc, anded_cp_list, FALSE);
1693         }
1694         else { /* P1 = P2 = empty */
1695             ssc_intersection(ssc, anded_cp_list, FALSE);
1696         }
1697     }
1698 }
1699
1700 STATIC void
1701 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1702                const regnode_charclass *or_with)
1703 {
1704     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1705      * another SSC or a regular ANYOF class.  Can create false positives if
1706      * 'or_with' is to be inverted. */
1707
1708     SV* ored_cp_list;
1709     U8 ored_flags;
1710
1711     PERL_ARGS_ASSERT_SSC_OR;
1712
1713     assert(is_ANYOF_SYNTHETIC(ssc));
1714
1715     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1716      * the code point inversion list and just the relevant flags */
1717     if (is_ANYOF_SYNTHETIC(or_with)) {
1718         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1719         ored_flags = ANYOF_FLAGS(or_with);
1720     }
1721     else {
1722         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1723         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1724         if (OP(or_with) != ANYOFD) {
1725             ored_flags
1726             |= ANYOF_FLAGS(or_with)
1727              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1728                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1729             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1730                 ored_flags |=
1731                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1732             }
1733         }
1734     }
1735
1736     ANYOF_FLAGS(ssc) |= ored_flags;
1737
1738     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1739      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1740      * 'or_with' may be inverted.  When not inverted, we have the simple
1741      * situation of computing:
1742      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1743      * If P1|P2 yields a situation with both a class and its complement are
1744      * set, like having both \w and \W, this matches all code points, and we
1745      * can delete these from the P component of the ssc going forward.  XXX We
1746      * might be able to delete all the P components, but I (khw) am not certain
1747      * about this, and it is better to be safe.
1748      *
1749      * Inverted, we have
1750      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1751      *                         <=  (C1 | P1) | ~C2
1752      *                         <=  (C1 | ~C2) | P1
1753      * (which results in actually simpler code than the non-inverted case)
1754      * */
1755
1756     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1757         && ! is_ANYOF_SYNTHETIC(or_with))
1758     {
1759         /* We ignore P2, leaving P1 going forward */
1760     }   /* else  Not inverted */
1761     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1762         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1763         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1764             unsigned int i;
1765             for (i = 0; i < ANYOF_MAX; i += 2) {
1766                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1767                 {
1768                     ssc_match_all_cp(ssc);
1769                     ANYOF_POSIXL_CLEAR(ssc, i);
1770                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1771                 }
1772             }
1773         }
1774     }
1775
1776     ssc_union(ssc,
1777               ored_cp_list,
1778               FALSE /* Already has been inverted */
1779               );
1780 }
1781
1782 PERL_STATIC_INLINE void
1783 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1784 {
1785     PERL_ARGS_ASSERT_SSC_UNION;
1786
1787     assert(is_ANYOF_SYNTHETIC(ssc));
1788
1789     _invlist_union_maybe_complement_2nd(ssc->invlist,
1790                                         invlist,
1791                                         invert2nd,
1792                                         &ssc->invlist);
1793 }
1794
1795 PERL_STATIC_INLINE void
1796 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1797                          SV* const invlist,
1798                          const bool invert2nd)
1799 {
1800     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1801
1802     assert(is_ANYOF_SYNTHETIC(ssc));
1803
1804     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1805                                                invlist,
1806                                                invert2nd,
1807                                                &ssc->invlist);
1808 }
1809
1810 PERL_STATIC_INLINE void
1811 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1812 {
1813     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1814
1815     assert(is_ANYOF_SYNTHETIC(ssc));
1816
1817     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1818 }
1819
1820 PERL_STATIC_INLINE void
1821 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1822 {
1823     /* AND just the single code point 'cp' into the SSC 'ssc' */
1824
1825     SV* cp_list = _new_invlist(2);
1826
1827     PERL_ARGS_ASSERT_SSC_CP_AND;
1828
1829     assert(is_ANYOF_SYNTHETIC(ssc));
1830
1831     cp_list = add_cp_to_invlist(cp_list, cp);
1832     ssc_intersection(ssc, cp_list,
1833                      FALSE /* Not inverted */
1834                      );
1835     SvREFCNT_dec_NN(cp_list);
1836 }
1837
1838 PERL_STATIC_INLINE void
1839 S_ssc_clear_locale(regnode_ssc *ssc)
1840 {
1841     /* Set the SSC 'ssc' to not match any locale things */
1842     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1843
1844     assert(is_ANYOF_SYNTHETIC(ssc));
1845
1846     ANYOF_POSIXL_ZERO(ssc);
1847     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1848 }
1849
1850 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1851
1852 STATIC bool
1853 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1854 {
1855     /* The synthetic start class is used to hopefully quickly winnow down
1856      * places where a pattern could start a match in the target string.  If it
1857      * doesn't really narrow things down that much, there isn't much point to
1858      * having the overhead of using it.  This function uses some very crude
1859      * heuristics to decide if to use the ssc or not.
1860      *
1861      * It returns TRUE if 'ssc' rules out more than half what it considers to
1862      * be the "likely" possible matches, but of course it doesn't know what the
1863      * actual things being matched are going to be; these are only guesses
1864      *
1865      * For /l matches, it assumes that the only likely matches are going to be
1866      *      in the 0-255 range, uniformly distributed, so half of that is 127
1867      * For /a and /d matches, it assumes that the likely matches will be just
1868      *      the ASCII range, so half of that is 63
1869      * For /u and there isn't anything matching above the Latin1 range, it
1870      *      assumes that that is the only range likely to be matched, and uses
1871      *      half that as the cut-off: 127.  If anything matches above Latin1,
1872      *      it assumes that all of Unicode could match (uniformly), except for
1873      *      non-Unicode code points and things in the General Category "Other"
1874      *      (unassigned, private use, surrogates, controls and formats).  This
1875      *      is a much large number. */
1876
1877     U32 count = 0;      /* Running total of number of code points matched by
1878                            'ssc' */
1879     UV start, end;      /* Start and end points of current range in inversion
1880                            list */
1881     const U32 max_code_points = (LOC)
1882                                 ?  256
1883                                 : ((   ! UNI_SEMANTICS
1884                                      || invlist_highest(ssc->invlist) < 256)
1885                                   ? 128
1886                                   : NON_OTHER_COUNT);
1887     const U32 max_match = max_code_points / 2;
1888
1889     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1890
1891     invlist_iterinit(ssc->invlist);
1892     while (invlist_iternext(ssc->invlist, &start, &end)) {
1893         if (start >= max_code_points) {
1894             break;
1895         }
1896         end = MIN(end, max_code_points - 1);
1897         count += end - start + 1;
1898         if (count >= max_match) {
1899             invlist_iterfinish(ssc->invlist);
1900             return FALSE;
1901         }
1902     }
1903
1904     return TRUE;
1905 }
1906
1907
1908 STATIC void
1909 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1910 {
1911     /* The inversion list in the SSC is marked mortal; now we need a more
1912      * permanent copy, which is stored the same way that is done in a regular
1913      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1914      * map */
1915
1916     SV* invlist = invlist_clone(ssc->invlist);
1917
1918     PERL_ARGS_ASSERT_SSC_FINALIZE;
1919
1920     assert(is_ANYOF_SYNTHETIC(ssc));
1921
1922     /* The code in this file assumes that all but these flags aren't relevant
1923      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1924      * by the time we reach here */
1925     assert(! (ANYOF_FLAGS(ssc)
1926         & ~( ANYOF_COMMON_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
1930     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1931
1932     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1933                                 NULL, NULL, NULL, FALSE);
1934
1935     /* Make sure is clone-safe */
1936     ssc->invlist = NULL;
1937
1938     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1939         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1940     }
1941
1942     if (RExC_contains_locale) {
1943         OP(ssc) = ANYOFL;
1944     }
1945
1946     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1947 }
1948
1949 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1950 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1951 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1952 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1953                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1954                                : 0 )
1955
1956
1957 #ifdef DEBUGGING
1958 /*
1959    dump_trie(trie,widecharmap,revcharmap)
1960    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1961    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1962
1963    These routines dump out a trie in a somewhat readable format.
1964    The _interim_ variants are used for debugging the interim
1965    tables that are used to generate the final compressed
1966    representation which is what dump_trie expects.
1967
1968    Part of the reason for their existence is to provide a form
1969    of documentation as to how the different representations function.
1970
1971 */
1972
1973 /*
1974   Dumps the final compressed table form of the trie to Perl_debug_log.
1975   Used for debugging make_trie().
1976 */
1977
1978 STATIC void
1979 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1980             AV *revcharmap, U32 depth)
1981 {
1982     U32 state;
1983     SV *sv=sv_newmortal();
1984     int colwidth= widecharmap ? 6 : 4;
1985     U16 word;
1986     GET_RE_DEBUG_FLAGS_DECL;
1987
1988     PERL_ARGS_ASSERT_DUMP_TRIE;
1989
1990     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1991         depth+1, "Match","Base","Ofs" );
1992
1993     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1994         SV ** const tmp = av_fetch( revcharmap, state, 0);
1995         if ( tmp ) {
1996             Perl_re_printf( aTHX_  "%*s",
1997                 colwidth,
1998                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1999                             PL_colors[0], PL_colors[1],
2000                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2001                             PERL_PV_ESCAPE_FIRSTCHAR
2002                 )
2003             );
2004         }
2005     }
2006     Perl_re_printf( aTHX_  "\n");
2007     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2008
2009     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2010         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2011     Perl_re_printf( aTHX_  "\n");
2012
2013     for( state = 1 ; state < trie->statecount ; state++ ) {
2014         const U32 base = trie->states[ state ].trans.base;
2015
2016         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2017
2018         if ( trie->states[ state ].wordnum ) {
2019             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2020         } else {
2021             Perl_re_printf( aTHX_  "%6s", "" );
2022         }
2023
2024         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2025
2026         if ( base ) {
2027             U32 ofs = 0;
2028
2029             while( ( base + ofs  < trie->uniquecharcount ) ||
2030                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2031                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2032                                                                     != state))
2033                     ofs++;
2034
2035             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2036
2037             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2038                 if ( ( base + ofs >= trie->uniquecharcount )
2039                         && ( base + ofs - trie->uniquecharcount
2040                                                         < trie->lasttrans )
2041                         && trie->trans[ base + ofs
2042                                     - trie->uniquecharcount ].check == state )
2043                 {
2044                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2045                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2046                    );
2047                 } else {
2048                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2049                 }
2050             }
2051
2052             Perl_re_printf( aTHX_  "]");
2053
2054         }
2055         Perl_re_printf( aTHX_  "\n" );
2056     }
2057     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2058                                 depth);
2059     for (word=1; word <= trie->wordcount; word++) {
2060         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2061             (int)word, (int)(trie->wordinfo[word].prev),
2062             (int)(trie->wordinfo[word].len));
2063     }
2064     Perl_re_printf( aTHX_  "\n" );
2065 }
2066 /*
2067   Dumps a fully constructed but uncompressed trie in list form.
2068   List tries normally only are used for construction when the number of
2069   possible chars (trie->uniquecharcount) is very high.
2070   Used for debugging make_trie().
2071 */
2072 STATIC void
2073 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2074                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2075                          U32 depth)
2076 {
2077     U32 state;
2078     SV *sv=sv_newmortal();
2079     int colwidth= widecharmap ? 6 : 4;
2080     GET_RE_DEBUG_FLAGS_DECL;
2081
2082     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2083
2084     /* print out the table precompression.  */
2085     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2086             depth+1 );
2087     Perl_re_indentf( aTHX_  "%s",
2088             depth+1, "------:-----+-----------------\n" );
2089
2090     for( state=1 ; state < next_alloc ; state ++ ) {
2091         U16 charid;
2092
2093         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2094             depth+1, (UV)state  );
2095         if ( ! trie->states[ state ].wordnum ) {
2096             Perl_re_printf( aTHX_  "%5s| ","");
2097         } else {
2098             Perl_re_printf( aTHX_  "W%4x| ",
2099                 trie->states[ state ].wordnum
2100             );
2101         }
2102         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2103             SV ** const tmp = av_fetch( revcharmap,
2104                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2105             if ( tmp ) {
2106                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2107                     colwidth,
2108                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2109                               colwidth,
2110                               PL_colors[0], PL_colors[1],
2111                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2112                               | PERL_PV_ESCAPE_FIRSTCHAR
2113                     ) ,
2114                     TRIE_LIST_ITEM(state,charid).forid,
2115                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2116                 );
2117                 if (!(charid % 10))
2118                     Perl_re_printf( aTHX_  "\n%*s| ",
2119                         (int)((depth * 2) + 14), "");
2120             }
2121         }
2122         Perl_re_printf( aTHX_  "\n");
2123     }
2124 }
2125
2126 /*
2127   Dumps a fully constructed but uncompressed trie in table form.
2128   This is the normal DFA style state transition table, with a few
2129   twists to facilitate compression later.
2130   Used for debugging make_trie().
2131 */
2132 STATIC void
2133 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2134                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2135                           U32 depth)
2136 {
2137     U32 state;
2138     U16 charid;
2139     SV *sv=sv_newmortal();
2140     int colwidth= widecharmap ? 6 : 4;
2141     GET_RE_DEBUG_FLAGS_DECL;
2142
2143     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2144
2145     /*
2146        print out the table precompression so that we can do a visual check
2147        that they are identical.
2148      */
2149
2150     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2151
2152     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2153         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2154         if ( tmp ) {
2155             Perl_re_printf( aTHX_  "%*s",
2156                 colwidth,
2157                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2158                             PL_colors[0], PL_colors[1],
2159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2160                             PERL_PV_ESCAPE_FIRSTCHAR
2161                 )
2162             );
2163         }
2164     }
2165
2166     Perl_re_printf( aTHX_ "\n");
2167     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2168
2169     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2170         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2171     }
2172
2173     Perl_re_printf( aTHX_  "\n" );
2174
2175     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2176
2177         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2178             depth+1,
2179             (UV)TRIE_NODENUM( state ) );
2180
2181         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2182             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2183             if (v)
2184                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2185             else
2186                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2187         }
2188         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2189             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2190                                             (UV)trie->trans[ state ].check );
2191         } else {
2192             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2193                                             (UV)trie->trans[ state ].check,
2194             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2195         }
2196     }
2197 }
2198
2199 #endif
2200
2201
2202 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2203   startbranch: the first branch in the whole branch sequence
2204   first      : start branch of sequence of branch-exact nodes.
2205                May be the same as startbranch
2206   last       : Thing following the last branch.
2207                May be the same as tail.
2208   tail       : item following the branch sequence
2209   count      : words in the sequence
2210   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2211   depth      : indent depth
2212
2213 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2214
2215 A trie is an N'ary tree where the branches are determined by digital
2216 decomposition of the key. IE, at the root node you look up the 1st character and
2217 follow that branch repeat until you find the end of the branches. Nodes can be
2218 marked as "accepting" meaning they represent a complete word. Eg:
2219
2220   /he|she|his|hers/
2221
2222 would convert into the following structure. Numbers represent states, letters
2223 following numbers represent valid transitions on the letter from that state, if
2224 the number is in square brackets it represents an accepting state, otherwise it
2225 will be in parenthesis.
2226
2227       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2228       |    |
2229       |   (2)
2230       |    |
2231      (1)   +-i->(6)-+-s->[7]
2232       |
2233       +-s->(3)-+-h->(4)-+-e->[5]
2234
2235       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2236
2237 This shows that when matching against the string 'hers' we will begin at state 1
2238 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2239 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2240 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2241 single traverse. We store a mapping from accepting to state to which word was
2242 matched, and then when we have multiple possibilities we try to complete the
2243 rest of the regex in the order in which they occurred in the alternation.
2244
2245 The only prior NFA like behaviour that would be changed by the TRIE support is
2246 the silent ignoring of duplicate alternations which are of the form:
2247
2248  / (DUPE|DUPE) X? (?{ ... }) Y /x
2249
2250 Thus EVAL blocks following a trie may be called a different number of times with
2251 and without the optimisation. With the optimisations dupes will be silently
2252 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2253 the following demonstrates:
2254
2255  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2256
2257 which prints out 'word' three times, but
2258
2259  'words'=~/(word|word|word)(?{ print $1 })S/
2260
2261 which doesnt print it out at all. This is due to other optimisations kicking in.
2262
2263 Example of what happens on a structural level:
2264
2265 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2266
2267    1: CURLYM[1] {1,32767}(18)
2268    5:   BRANCH(8)
2269    6:     EXACT <ac>(16)
2270    8:   BRANCH(11)
2271    9:     EXACT <ad>(16)
2272   11:   BRANCH(14)
2273   12:     EXACT <ab>(16)
2274   16:   SUCCEED(0)
2275   17:   NOTHING(18)
2276   18: END(0)
2277
2278 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2279 and should turn into:
2280
2281    1: CURLYM[1] {1,32767}(18)
2282    5:   TRIE(16)
2283         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2284           <ac>
2285           <ad>
2286           <ab>
2287   16:   SUCCEED(0)
2288   17:   NOTHING(18)
2289   18: END(0)
2290
2291 Cases where tail != last would be like /(?foo|bar)baz/:
2292
2293    1: BRANCH(4)
2294    2:   EXACT <foo>(8)
2295    4: BRANCH(7)
2296    5:   EXACT <bar>(8)
2297    7: TAIL(8)
2298    8: EXACT <baz>(10)
2299   10: END(0)
2300
2301 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2302 and would end up looking like:
2303
2304     1: TRIE(8)
2305       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2306         <foo>
2307         <bar>
2308    7: TAIL(8)
2309    8: EXACT <baz>(10)
2310   10: END(0)
2311
2312     d = uvchr_to_utf8_flags(d, uv, 0);
2313
2314 is the recommended Unicode-aware way of saying
2315
2316     *(d++) = uv;
2317 */
2318
2319 #define TRIE_STORE_REVCHAR(val)                                            \
2320     STMT_START {                                                           \
2321         if (UTF) {                                                         \
2322             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2323             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2324             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2325             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2326             SvPOK_on(zlopp);                                               \
2327             SvUTF8_on(zlopp);                                              \
2328             av_push(revcharmap, zlopp);                                    \
2329         } else {                                                           \
2330             char ooooff = (char)val;                                           \
2331             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2332         }                                                                  \
2333         } STMT_END
2334
2335 /* This gets the next character from the input, folding it if not already
2336  * folded. */
2337 #define TRIE_READ_CHAR STMT_START {                                           \
2338     wordlen++;                                                                \
2339     if ( UTF ) {                                                              \
2340         /* if it is UTF then it is either already folded, or does not need    \
2341          * folding */                                                         \
2342         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2343     }                                                                         \
2344     else if (folder == PL_fold_latin1) {                                      \
2345         /* This folder implies Unicode rules, which in the range expressible  \
2346          *  by not UTF is the lower case, with the two exceptions, one of     \
2347          *  which should have been taken care of before calling this */       \
2348         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2349         uvc = toLOWER_L1(*uc);                                                \
2350         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2351         len = 1;                                                              \
2352     } else {                                                                  \
2353         /* raw data, will be folded later if needed */                        \
2354         uvc = (U32)*uc;                                                       \
2355         len = 1;                                                              \
2356     }                                                                         \
2357 } STMT_END
2358
2359
2360
2361 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2362     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2363         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2364         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2365     }                                                           \
2366     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2367     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2368     TRIE_LIST_CUR( state )++;                                   \
2369 } STMT_END
2370
2371 #define TRIE_LIST_NEW(state) STMT_START {                       \
2372     Newxz( trie->states[ state ].trans.list,               \
2373         4, reg_trie_trans_le );                                 \
2374      TRIE_LIST_CUR( state ) = 1;                                \
2375      TRIE_LIST_LEN( state ) = 4;                                \
2376 } STMT_END
2377
2378 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2379     U16 dupe= trie->states[ state ].wordnum;                    \
2380     regnode * const noper_next = regnext( noper );              \
2381                                                                 \
2382     DEBUG_r({                                                   \
2383         /* store the word for dumping */                        \
2384         SV* tmp;                                                \
2385         if (OP(noper) != NOTHING)                               \
2386             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2387         else                                                    \
2388             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2389         av_push( trie_words, tmp );                             \
2390     });                                                         \
2391                                                                 \
2392     curword++;                                                  \
2393     trie->wordinfo[curword].prev   = 0;                         \
2394     trie->wordinfo[curword].len    = wordlen;                   \
2395     trie->wordinfo[curword].accept = state;                     \
2396                                                                 \
2397     if ( noper_next < tail ) {                                  \
2398         if (!trie->jump)                                        \
2399             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2400                                                  sizeof(U16) ); \
2401         trie->jump[curword] = (U16)(noper_next - convert);      \
2402         if (!jumper)                                            \
2403             jumper = noper_next;                                \
2404         if (!nextbranch)                                        \
2405             nextbranch= regnext(cur);                           \
2406     }                                                           \
2407                                                                 \
2408     if ( dupe ) {                                               \
2409         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2410         /* chain, so that when the bits of chain are later    */\
2411         /* linked together, the dups appear in the chain      */\
2412         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2413         trie->wordinfo[dupe].prev = curword;                    \
2414     } else {                                                    \
2415         /* we haven't inserted this word yet.                */ \
2416         trie->states[ state ].wordnum = curword;                \
2417     }                                                           \
2418 } STMT_END
2419
2420
2421 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2422      ( ( base + charid >=  ucharcount                                   \
2423          && base + charid < ubound                                      \
2424          && state == trie->trans[ base - ucharcount + charid ].check    \
2425          && trie->trans[ base - ucharcount + charid ].next )            \
2426            ? trie->trans[ base - ucharcount + charid ].next             \
2427            : ( state==1 ? special : 0 )                                 \
2428       )
2429
2430 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2431 STMT_START {                                                \
2432     TRIE_BITMAP_SET(trie, uvc);                             \
2433     /* store the folded codepoint */                        \
2434     if ( folder )                                           \
2435         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2436                                                             \
2437     if ( !UTF ) {                                           \
2438         /* store first byte of utf8 representation of */    \
2439         /* variant codepoints */                            \
2440         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2441             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2442         }                                                   \
2443     }                                                       \
2444 } STMT_END
2445 #define MADE_TRIE       1
2446 #define MADE_JUMP_TRIE  2
2447 #define MADE_EXACT_TRIE 4
2448
2449 STATIC I32
2450 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2451                   regnode *first, regnode *last, regnode *tail,
2452                   U32 word_count, U32 flags, U32 depth)
2453 {
2454     /* first pass, loop through and scan words */
2455     reg_trie_data *trie;
2456     HV *widecharmap = NULL;
2457     AV *revcharmap = newAV();
2458     regnode *cur;
2459     STRLEN len = 0;
2460     UV uvc = 0;
2461     U16 curword = 0;
2462     U32 next_alloc = 0;
2463     regnode *jumper = NULL;
2464     regnode *nextbranch = NULL;
2465     regnode *convert = NULL;
2466     U32 *prev_states; /* temp array mapping each state to previous one */
2467     /* we just use folder as a flag in utf8 */
2468     const U8 * folder = NULL;
2469
2470 #ifdef DEBUGGING
2471     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2472     AV *trie_words = NULL;
2473     /* along with revcharmap, this only used during construction but both are
2474      * useful during debugging so we store them in the struct when debugging.
2475      */
2476 #else
2477     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2478     STRLEN trie_charcount=0;
2479 #endif
2480     SV *re_trie_maxbuff;
2481     GET_RE_DEBUG_FLAGS_DECL;
2482
2483     PERL_ARGS_ASSERT_MAKE_TRIE;
2484 #ifndef DEBUGGING
2485     PERL_UNUSED_ARG(depth);
2486 #endif
2487
2488     switch (flags) {
2489         case EXACT: case EXACTL: break;
2490         case EXACTFA:
2491         case EXACTFU_SS:
2492         case EXACTFU:
2493         case EXACTFLU8: folder = PL_fold_latin1; break;
2494         case EXACTF:  folder = PL_fold; break;
2495         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2496     }
2497
2498     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2499     trie->refcount = 1;
2500     trie->startstate = 1;
2501     trie->wordcount = word_count;
2502     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2503     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2504     if (flags == EXACT || flags == EXACTL)
2505         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2506     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2507                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2508
2509     DEBUG_r({
2510         trie_words = newAV();
2511     });
2512
2513     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2514     assert(re_trie_maxbuff);
2515     if (!SvIOK(re_trie_maxbuff)) {
2516         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2517     }
2518     DEBUG_TRIE_COMPILE_r({
2519         Perl_re_indentf( aTHX_
2520           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2521           depth+1,
2522           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2523           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2524     });
2525
2526    /* Find the node we are going to overwrite */
2527     if ( first == startbranch && OP( last ) != BRANCH ) {
2528         /* whole branch chain */
2529         convert = first;
2530     } else {
2531         /* branch sub-chain */
2532         convert = NEXTOPER( first );
2533     }
2534
2535     /*  -- First loop and Setup --
2536
2537        We first traverse the branches and scan each word to determine if it
2538        contains widechars, and how many unique chars there are, this is
2539        important as we have to build a table with at least as many columns as we
2540        have unique chars.
2541
2542        We use an array of integers to represent the character codes 0..255
2543        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2544        the native representation of the character value as the key and IV's for
2545        the coded index.
2546
2547        *TODO* If we keep track of how many times each character is used we can
2548        remap the columns so that the table compression later on is more
2549        efficient in terms of memory by ensuring the most common value is in the
2550        middle and the least common are on the outside.  IMO this would be better
2551        than a most to least common mapping as theres a decent chance the most
2552        common letter will share a node with the least common, meaning the node
2553        will not be compressible. With a middle is most common approach the worst
2554        case is when we have the least common nodes twice.
2555
2556      */
2557
2558     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2559         regnode *noper = NEXTOPER( cur );
2560         const U8 *uc;
2561         const U8 *e;
2562         int foldlen = 0;
2563         U32 wordlen      = 0;         /* required init */
2564         STRLEN minchars = 0;
2565         STRLEN maxchars = 0;
2566         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2567                                                bitmap?*/
2568
2569         if (OP(noper) == NOTHING) {
2570             /* skip past a NOTHING at the start of an alternation
2571              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2572              */
2573             regnode *noper_next= regnext(noper);
2574             if (noper_next < tail)
2575                 noper= noper_next;
2576         }
2577
2578         if ( noper < tail &&
2579                 (
2580                     OP(noper) == flags ||
2581                     (
2582                         flags == EXACTFU &&
2583                         OP(noper) == EXACTFU_SS
2584                     )
2585                 )
2586         ) {
2587             uc= (U8*)STRING(noper);
2588             e= uc + STR_LEN(noper);
2589         } else {
2590             trie->minlen= 0;
2591             continue;
2592         }
2593
2594
2595         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2596             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2597                                           regardless of encoding */
2598             if (OP( noper ) == EXACTFU_SS) {
2599                 /* false positives are ok, so just set this */
2600                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2601             }
2602         }
2603
2604         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2605                                            branch */
2606             TRIE_CHARCOUNT(trie)++;
2607             TRIE_READ_CHAR;
2608
2609             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2610              * is in effect.  Under /i, this character can match itself, or
2611              * anything that folds to it.  If not under /i, it can match just
2612              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2613              * all fold to k, and all are single characters.   But some folds
2614              * expand to more than one character, so for example LATIN SMALL
2615              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2616              * the string beginning at 'uc' is 'ffi', it could be matched by
2617              * three characters, or just by the one ligature character. (It
2618              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2619              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2620              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2621              * match.)  The trie needs to know the minimum and maximum number
2622              * of characters that could match so that it can use size alone to
2623              * quickly reject many match attempts.  The max is simple: it is
2624              * the number of folded characters in this branch (since a fold is
2625              * never shorter than what folds to it. */
2626
2627             maxchars++;
2628
2629             /* And the min is equal to the max if not under /i (indicated by
2630              * 'folder' being NULL), or there are no multi-character folds.  If
2631              * there is a multi-character fold, the min is incremented just
2632              * once, for the character that folds to the sequence.  Each
2633              * character in the sequence needs to be added to the list below of
2634              * characters in the trie, but we count only the first towards the
2635              * min number of characters needed.  This is done through the
2636              * variable 'foldlen', which is returned by the macros that look
2637              * for these sequences as the number of bytes the sequence
2638              * occupies.  Each time through the loop, we decrement 'foldlen' by
2639              * how many bytes the current char occupies.  Only when it reaches
2640              * 0 do we increment 'minchars' or look for another multi-character
2641              * sequence. */
2642             if (folder == NULL) {
2643                 minchars++;
2644             }
2645             else if (foldlen > 0) {
2646                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2647             }
2648             else {
2649                 minchars++;
2650
2651                 /* See if *uc is the beginning of a multi-character fold.  If
2652                  * so, we decrement the length remaining to look at, to account
2653                  * for the current character this iteration.  (We can use 'uc'
2654                  * instead of the fold returned by TRIE_READ_CHAR because for
2655                  * non-UTF, the latin1_safe macro is smart enough to account
2656                  * for all the unfolded characters, and because for UTF, the
2657                  * string will already have been folded earlier in the
2658                  * compilation process */
2659                 if (UTF) {
2660                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2661                         foldlen -= UTF8SKIP(uc);
2662                     }
2663                 }
2664                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2665                     foldlen--;
2666                 }
2667             }
2668
2669             /* The current character (and any potential folds) should be added
2670              * to the possible matching characters for this position in this
2671              * branch */
2672             if ( uvc < 256 ) {
2673                 if ( folder ) {
2674                     U8 folded= folder[ (U8) uvc ];
2675                     if ( !trie->charmap[ folded ] ) {
2676                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2677                         TRIE_STORE_REVCHAR( folded );
2678                     }
2679                 }
2680                 if ( !trie->charmap[ uvc ] ) {
2681                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2682                     TRIE_STORE_REVCHAR( uvc );
2683                 }
2684                 if ( set_bit ) {
2685                     /* store the codepoint in the bitmap, and its folded
2686                      * equivalent. */
2687                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2688                     set_bit = 0; /* We've done our bit :-) */
2689                 }
2690             } else {
2691
2692                 /* XXX We could come up with the list of code points that fold
2693                  * to this using PL_utf8_foldclosures, except not for
2694                  * multi-char folds, as there may be multiple combinations
2695                  * there that could work, which needs to wait until runtime to
2696                  * resolve (The comment about LIGATURE FFI above is such an
2697                  * example */
2698
2699                 SV** svpp;
2700                 if ( !widecharmap )
2701                     widecharmap = newHV();
2702
2703                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2704
2705                 if ( !svpp )
2706                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2707
2708                 if ( !SvTRUE( *svpp ) ) {
2709                     sv_setiv( *svpp, ++trie->uniquecharcount );
2710                     TRIE_STORE_REVCHAR(uvc);
2711                 }
2712             }
2713         } /* end loop through characters in this branch of the trie */
2714
2715         /* We take the min and max for this branch and combine to find the min
2716          * and max for all branches processed so far */
2717         if( cur == first ) {
2718             trie->minlen = minchars;
2719             trie->maxlen = maxchars;
2720         } else if (minchars < trie->minlen) {
2721             trie->minlen = minchars;
2722         } else if (maxchars > trie->maxlen) {
2723             trie->maxlen = maxchars;
2724         }
2725     } /* end first pass */
2726     DEBUG_TRIE_COMPILE_r(
2727         Perl_re_indentf( aTHX_
2728                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2729                 depth+1,
2730                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2731                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2732                 (int)trie->minlen, (int)trie->maxlen )
2733     );
2734
2735     /*
2736         We now know what we are dealing with in terms of unique chars and
2737         string sizes so we can calculate how much memory a naive
2738         representation using a flat table  will take. If it's over a reasonable
2739         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2740         conservative but potentially much slower representation using an array
2741         of lists.
2742
2743         At the end we convert both representations into the same compressed
2744         form that will be used in regexec.c for matching with. The latter
2745         is a form that cannot be used to construct with but has memory
2746         properties similar to the list form and access properties similar
2747         to the table form making it both suitable for fast searches and
2748         small enough that its feasable to store for the duration of a program.
2749
2750         See the comment in the code where the compressed table is produced
2751         inplace from the flat tabe representation for an explanation of how
2752         the compression works.
2753
2754     */
2755
2756
2757     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2758     prev_states[1] = 0;
2759
2760     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2761                                                     > SvIV(re_trie_maxbuff) )
2762     {
2763         /*
2764             Second Pass -- Array Of Lists Representation
2765
2766             Each state will be represented by a list of charid:state records
2767             (reg_trie_trans_le) the first such element holds the CUR and LEN
2768             points of the allocated array. (See defines above).
2769
2770             We build the initial structure using the lists, and then convert
2771             it into the compressed table form which allows faster lookups
2772             (but cant be modified once converted).
2773         */
2774
2775         STRLEN transcount = 1;
2776
2777         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2778             depth+1));
2779
2780         trie->states = (reg_trie_state *)
2781             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2782                                   sizeof(reg_trie_state) );
2783         TRIE_LIST_NEW(1);
2784         next_alloc = 2;
2785
2786         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2787
2788             regnode *noper   = NEXTOPER( cur );
2789             U32 state        = 1;         /* required init */
2790             U16 charid       = 0;         /* sanity init */
2791             U32 wordlen      = 0;         /* required init */
2792
2793             if (OP(noper) == NOTHING) {
2794                 regnode *noper_next= regnext(noper);
2795                 if (noper_next < tail)
2796                     noper= noper_next;
2797             }
2798
2799             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2800                 const U8 *uc= (U8*)STRING(noper);
2801                 const U8 *e= uc + STR_LEN(noper);
2802
2803                 for ( ; uc < e ; uc += len ) {
2804
2805                     TRIE_READ_CHAR;
2806
2807                     if ( uvc < 256 ) {
2808                         charid = trie->charmap[ uvc ];
2809                     } else {
2810                         SV** const svpp = hv_fetch( widecharmap,
2811                                                     (char*)&uvc,
2812                                                     sizeof( UV ),
2813                                                     0);
2814                         if ( !svpp ) {
2815                             charid = 0;
2816                         } else {
2817                             charid=(U16)SvIV( *svpp );
2818                         }
2819                     }
2820                     /* charid is now 0 if we dont know the char read, or
2821                      * nonzero if we do */
2822                     if ( charid ) {
2823
2824                         U16 check;
2825                         U32 newstate = 0;
2826
2827                         charid--;
2828                         if ( !trie->states[ state ].trans.list ) {
2829                             TRIE_LIST_NEW( state );
2830                         }
2831                         for ( check = 1;
2832                               check <= TRIE_LIST_USED( state );
2833                               check++ )
2834                         {
2835                             if ( TRIE_LIST_ITEM( state, check ).forid
2836                                                                     == charid )
2837                             {
2838                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2839                                 break;
2840                             }
2841                         }
2842                         if ( ! newstate ) {
2843                             newstate = next_alloc++;
2844                             prev_states[newstate] = state;
2845                             TRIE_LIST_PUSH( state, charid, newstate );
2846                             transcount++;
2847                         }
2848                         state = newstate;
2849                     } else {
2850                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2851                     }
2852                 }
2853             }
2854             TRIE_HANDLE_WORD(state);
2855
2856         } /* end second pass */
2857
2858         /* next alloc is the NEXT state to be allocated */
2859         trie->statecount = next_alloc;
2860         trie->states = (reg_trie_state *)
2861             PerlMemShared_realloc( trie->states,
2862                                    next_alloc
2863                                    * sizeof(reg_trie_state) );
2864
2865         /* and now dump it out before we compress it */
2866         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2867                                                          revcharmap, next_alloc,
2868                                                          depth+1)
2869         );
2870
2871         trie->trans = (reg_trie_trans *)
2872             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2873         {
2874             U32 state;
2875             U32 tp = 0;
2876             U32 zp = 0;
2877
2878
2879             for( state=1 ; state < next_alloc ; state ++ ) {
2880                 U32 base=0;
2881
2882                 /*
2883                 DEBUG_TRIE_COMPILE_MORE_r(
2884                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2885                 );
2886                 */
2887
2888                 if (trie->states[state].trans.list) {
2889                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2890                     U16 maxid=minid;
2891                     U16 idx;
2892
2893                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2894                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2895                         if ( forid < minid ) {
2896                             minid=forid;
2897                         } else if ( forid > maxid ) {
2898                             maxid=forid;
2899                         }
2900                     }
2901                     if ( transcount < tp + maxid - minid + 1) {
2902                         transcount *= 2;
2903                         trie->trans = (reg_trie_trans *)
2904                             PerlMemShared_realloc( trie->trans,
2905                                                      transcount
2906                                                      * sizeof(reg_trie_trans) );
2907                         Zero( trie->trans + (transcount / 2),
2908                               transcount / 2,
2909                               reg_trie_trans );
2910                     }
2911                     base = trie->uniquecharcount + tp - minid;
2912                     if ( maxid == minid ) {
2913                         U32 set = 0;
2914                         for ( ; zp < tp ; zp++ ) {
2915                             if ( ! trie->trans[ zp ].next ) {
2916                                 base = trie->uniquecharcount + zp - minid;
2917                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2918                                                                    1).newstate;
2919                                 trie->trans[ zp ].check = state;
2920                                 set = 1;
2921                                 break;
2922                             }
2923                         }
2924                         if ( !set ) {
2925                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2926                                                                    1).newstate;
2927                             trie->trans[ tp ].check = state;
2928                             tp++;
2929                             zp = tp;
2930                         }
2931                     } else {
2932                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2933                             const U32 tid = base
2934                                            - trie->uniquecharcount
2935                                            + TRIE_LIST_ITEM( state, idx ).forid;
2936                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2937                                                                 idx ).newstate;
2938                             trie->trans[ tid ].check = state;
2939                         }
2940                         tp += ( maxid - minid + 1 );
2941                     }
2942                     Safefree(trie->states[ state ].trans.list);
2943                 }
2944                 /*
2945                 DEBUG_TRIE_COMPILE_MORE_r(
2946                     Perl_re_printf( aTHX_  " base: %d\n",base);
2947                 );
2948                 */
2949                 trie->states[ state ].trans.base=base;
2950             }
2951             trie->lasttrans = tp + 1;
2952         }
2953     } else {
2954         /*
2955            Second Pass -- Flat Table Representation.
2956
2957            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2958            each.  We know that we will need Charcount+1 trans at most to store
2959            the data (one row per char at worst case) So we preallocate both
2960            structures assuming worst case.
2961
2962            We then construct the trie using only the .next slots of the entry
2963            structs.
2964
2965            We use the .check field of the first entry of the node temporarily
2966            to make compression both faster and easier by keeping track of how
2967            many non zero fields are in the node.
2968
2969            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2970            transition.
2971
2972            There are two terms at use here: state as a TRIE_NODEIDX() which is
2973            a number representing the first entry of the node, and state as a
2974            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2975            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2976            if there are 2 entrys per node. eg:
2977
2978              A B       A B
2979           1. 2 4    1. 3 7
2980           2. 0 3    3. 0 5
2981           3. 0 0    5. 0 0
2982           4. 0 0    7. 0 0
2983
2984            The table is internally in the right hand, idx form. However as we
2985            also have to deal with the states array which is indexed by nodenum
2986            we have to use TRIE_NODENUM() to convert.
2987
2988         */
2989         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2990             depth+1));
2991
2992         trie->trans = (reg_trie_trans *)
2993             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2994                                   * trie->uniquecharcount + 1,
2995                                   sizeof(reg_trie_trans) );
2996         trie->states = (reg_trie_state *)
2997             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2998                                   sizeof(reg_trie_state) );
2999         next_alloc = trie->uniquecharcount + 1;
3000
3001
3002         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3003
3004             regnode *noper   = NEXTOPER( cur );
3005
3006             U32 state        = 1;         /* required init */
3007
3008             U16 charid       = 0;         /* sanity init */
3009             U32 accept_state = 0;         /* sanity init */
3010
3011             U32 wordlen      = 0;         /* required init */
3012
3013             if (OP(noper) == NOTHING) {
3014                 regnode *noper_next= regnext(noper);
3015                 if (noper_next < tail)
3016                     noper= noper_next;
3017             }
3018
3019             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3020                 const U8 *uc= (U8*)STRING(noper);
3021                 const U8 *e= uc + STR_LEN(noper);
3022
3023                 for ( ; uc < e ; uc += len ) {
3024
3025                     TRIE_READ_CHAR;
3026
3027                     if ( uvc < 256 ) {
3028                         charid = trie->charmap[ uvc ];
3029                     } else {
3030                         SV* const * const svpp = hv_fetch( widecharmap,
3031                                                            (char*)&uvc,
3032                                                            sizeof( UV ),
3033                                                            0);
3034                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3035                     }
3036                     if ( charid ) {
3037                         charid--;
3038                         if ( !trie->trans[ state + charid ].next ) {
3039                             trie->trans[ state + charid ].next = next_alloc;
3040                             trie->trans[ state ].check++;
3041                             prev_states[TRIE_NODENUM(next_alloc)]
3042                                     = TRIE_NODENUM(state);
3043                             next_alloc += trie->uniquecharcount;
3044                         }
3045                         state = trie->trans[ state + charid ].next;
3046                     } else {
3047                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3048                     }
3049                     /* charid is now 0 if we dont know the char read, or
3050                      * nonzero if we do */
3051                 }
3052             }
3053             accept_state = TRIE_NODENUM( state );
3054             TRIE_HANDLE_WORD(accept_state);
3055
3056         } /* end second pass */
3057
3058         /* and now dump it out before we compress it */
3059         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3060                                                           revcharmap,
3061                                                           next_alloc, depth+1));
3062
3063         {
3064         /*
3065            * Inplace compress the table.*
3066
3067            For sparse data sets the table constructed by the trie algorithm will
3068            be mostly 0/FAIL transitions or to put it another way mostly empty.
3069            (Note that leaf nodes will not contain any transitions.)
3070
3071            This algorithm compresses the tables by eliminating most such
3072            transitions, at the cost of a modest bit of extra work during lookup:
3073
3074            - Each states[] entry contains a .base field which indicates the
3075            index in the state[] array wheres its transition data is stored.
3076
3077            - If .base is 0 there are no valid transitions from that node.
3078
3079            - If .base is nonzero then charid is added to it to find an entry in
3080            the trans array.
3081
3082            -If trans[states[state].base+charid].check!=state then the
3083            transition is taken to be a 0/Fail transition. Thus if there are fail
3084            transitions at the front of the node then the .base offset will point
3085            somewhere inside the previous nodes data (or maybe even into a node
3086            even earlier), but the .check field determines if the transition is
3087            valid.
3088
3089            XXX - wrong maybe?
3090            The following process inplace converts the table to the compressed
3091            table: We first do not compress the root node 1,and mark all its
3092            .check pointers as 1 and set its .base pointer as 1 as well. This
3093            allows us to do a DFA construction from the compressed table later,
3094            and ensures that any .base pointers we calculate later are greater
3095            than 0.
3096
3097            - We set 'pos' to indicate the first entry of the second node.
3098
3099            - We then iterate over the columns of the node, finding the first and
3100            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3101            and set the .check pointers accordingly, and advance pos
3102            appropriately and repreat for the next node. Note that when we copy
3103            the next pointers we have to convert them from the original
3104            NODEIDX form to NODENUM form as the former is not valid post
3105            compression.
3106
3107            - If a node has no transitions used we mark its base as 0 and do not
3108            advance the pos pointer.
3109
3110            - If a node only has one transition we use a second pointer into the
3111            structure to fill in allocated fail transitions from other states.
3112            This pointer is independent of the main pointer and scans forward
3113            looking for null transitions that are allocated to a state. When it
3114            finds one it writes the single transition into the "hole".  If the
3115            pointer doesnt find one the single transition is appended as normal.
3116
3117            - Once compressed we can Renew/realloc the structures to release the
3118            excess space.
3119
3120            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3121            specifically Fig 3.47 and the associated pseudocode.
3122
3123            demq
3124         */
3125         const U32 laststate = TRIE_NODENUM( next_alloc );
3126         U32 state, charid;
3127         U32 pos = 0, zp=0;
3128         trie->statecount = laststate;
3129
3130         for ( state = 1 ; state < laststate ; state++ ) {
3131             U8 flag = 0;
3132             const U32 stateidx = TRIE_NODEIDX( state );
3133             const U32 o_used = trie->trans[ stateidx ].check;
3134             U32 used = trie->trans[ stateidx ].check;
3135             trie->trans[ stateidx ].check = 0;
3136
3137             for ( charid = 0;
3138                   used && charid < trie->uniquecharcount;
3139                   charid++ )
3140             {
3141                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3142                     if ( trie->trans[ stateidx + charid ].next ) {
3143                         if (o_used == 1) {
3144                             for ( ; zp < pos ; zp++ ) {
3145                                 if ( ! trie->trans[ zp ].next ) {
3146                                     break;
3147                                 }
3148                             }
3149                             trie->states[ state ].trans.base
3150                                                     = zp
3151                                                       + trie->uniquecharcount
3152                                                       - charid ;
3153                             trie->trans[ zp ].next
3154                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3155                                                              + charid ].next );
3156                             trie->trans[ zp ].check = state;
3157                             if ( ++zp > pos ) pos = zp;
3158                             break;
3159                         }
3160                         used--;
3161                     }
3162                     if ( !flag ) {
3163                         flag = 1;
3164                         trie->states[ state ].trans.base
3165                                        = pos + trie->uniquecharcount - charid ;
3166                     }
3167                     trie->trans[ pos ].next
3168                         = SAFE_TRIE_NODENUM(
3169                                        trie->trans[ stateidx + charid ].next );
3170                     trie->trans[ pos ].check = state;
3171                     pos++;
3172                 }
3173             }
3174         }
3175         trie->lasttrans = pos + 1;
3176         trie->states = (reg_trie_state *)
3177             PerlMemShared_realloc( trie->states, laststate
3178                                    * sizeof(reg_trie_state) );
3179         DEBUG_TRIE_COMPILE_MORE_r(
3180             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3181                 depth+1,
3182                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3183                        + 1 ),
3184                 (IV)next_alloc,
3185                 (IV)pos,
3186                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3187             );
3188
3189         } /* end table compress */
3190     }
3191     DEBUG_TRIE_COMPILE_MORE_r(
3192             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3193                 depth+1,
3194                 (UV)trie->statecount,
3195                 (UV)trie->lasttrans)
3196     );
3197     /* resize the trans array to remove unused space */
3198     trie->trans = (reg_trie_trans *)
3199         PerlMemShared_realloc( trie->trans, trie->lasttrans
3200                                * sizeof(reg_trie_trans) );
3201
3202     {   /* Modify the program and insert the new TRIE node */
3203         U8 nodetype =(U8)(flags & 0xFF);
3204         char *str=NULL;
3205
3206 #ifdef DEBUGGING
3207         regnode *optimize = NULL;
3208 #ifdef RE_TRACK_PATTERN_OFFSETS
3209
3210         U32 mjd_offset = 0;
3211         U32 mjd_nodelen = 0;
3212 #endif /* RE_TRACK_PATTERN_OFFSETS */
3213 #endif /* DEBUGGING */
3214         /*
3215            This means we convert either the first branch or the first Exact,
3216            depending on whether the thing following (in 'last') is a branch
3217            or not and whther first is the startbranch (ie is it a sub part of
3218            the alternation or is it the whole thing.)
3219            Assuming its a sub part we convert the EXACT otherwise we convert
3220            the whole branch sequence, including the first.
3221          */
3222         /* Find the node we are going to overwrite */
3223         if ( first != startbranch || OP( last ) == BRANCH ) {
3224             /* branch sub-chain */
3225             NEXT_OFF( first ) = (U16)(last - first);
3226 #ifdef RE_TRACK_PATTERN_OFFSETS
3227             DEBUG_r({
3228                 mjd_offset= Node_Offset((convert));
3229                 mjd_nodelen= Node_Length((convert));
3230             });
3231 #endif
3232             /* whole branch chain */
3233         }
3234 #ifdef RE_TRACK_PATTERN_OFFSETS
3235         else {
3236             DEBUG_r({
3237                 const  regnode *nop = NEXTOPER( convert );
3238                 mjd_offset= Node_Offset((nop));
3239                 mjd_nodelen= Node_Length((nop));
3240             });
3241         }
3242         DEBUG_OPTIMISE_r(
3243             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3244                 depth+1,
3245                 (UV)mjd_offset, (UV)mjd_nodelen)
3246         );
3247 #endif
3248         /* But first we check to see if there is a common prefix we can
3249            split out as an EXACT and put in front of the TRIE node.  */
3250         trie->startstate= 1;
3251         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3252             /* we want to find the first state that has more than
3253              * one transition, if that state is not the first state
3254              * then we have a common prefix which we can remove.
3255              */
3256             U32 state;
3257             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3258                 U32 ofs = 0;
3259                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3260                                        transition, -1 means none */
3261                 U32 count = 0;
3262                 const U32 base = trie->states[ state ].trans.base;
3263
3264                 /* does this state terminate an alternation? */
3265                 if ( trie->states[state].wordnum )
3266                         count = 1;
3267
3268                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3269                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3270                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3271                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3272                     {
3273                         if ( ++count > 1 ) {
3274                             /* we have more than one transition */
3275                             SV **tmp;
3276                             U8 *ch;
3277                             /* if this is the first state there is no common prefix
3278                              * to extract, so we can exit */
3279                             if ( state == 1 ) break;
3280                             tmp = av_fetch( revcharmap, ofs, 0);
3281                             ch = (U8*)SvPV_nolen_const( *tmp );
3282
3283                             /* if we are on count 2 then we need to initialize the
3284                              * bitmap, and store the previous char if there was one
3285                              * in it*/
3286                             if ( count == 2 ) {
3287                                 /* clear the bitmap */
3288                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3289                                 DEBUG_OPTIMISE_r(
3290                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3291                                         depth+1,
3292                                         (UV)state));
3293                                 if (first_ofs >= 0) {
3294                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3295                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3296
3297                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3298                                     DEBUG_OPTIMISE_r(
3299                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3300                                     );
3301                                 }
3302                             }
3303                             /* store the current firstchar in the bitmap */
3304                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3305                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3306                         }
3307                         first_ofs = ofs;
3308                     }
3309                 }
3310                 if ( count == 1 ) {
3311                     /* This state has only one transition, its transition is part
3312                      * of a common prefix - we need to concatenate the char it
3313                      * represents to what we have so far. */
3314                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3315                     STRLEN len;
3316                     char *ch = SvPV( *tmp, len );
3317                     DEBUG_OPTIMISE_r({
3318                         SV *sv=sv_newmortal();
3319                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3320                             depth+1,
3321                             (UV)state, (UV)first_ofs,
3322                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3323                                 PL_colors[0], PL_colors[1],
3324                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3325                                 PERL_PV_ESCAPE_FIRSTCHAR
3326                             )
3327                         );
3328                     });
3329                     if ( state==1 ) {
3330                         OP( convert ) = nodetype;
3331                         str=STRING(convert);
3332                         STR_LEN(convert)=0;
3333                     }
3334                     STR_LEN(convert) += len;
3335                     while (len--)
3336                         *str++ = *ch++;
3337                 } else {
3338 #ifdef DEBUGGING
3339                     if (state>1)
3340                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3341 #endif
3342                     break;
3343                 }
3344             }
3345             trie->prefixlen = (state-1);
3346             if (str) {
3347                 regnode *n = convert+NODE_SZ_STR(convert);
3348                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3349                 trie->startstate = state;
3350                 trie->minlen -= (state - 1);
3351                 trie->maxlen -= (state - 1);
3352 #ifdef DEBUGGING
3353                /* At least the UNICOS C compiler choked on this
3354                 * being argument to DEBUG_r(), so let's just have
3355                 * it right here. */
3356                if (
3357 #ifdef PERL_EXT_RE_BUILD
3358                    1
3359 #else
3360                    DEBUG_r_TEST
3361 #endif
3362                    ) {
3363                    regnode *fix = convert;
3364                    U32 word = trie->wordcount;
3365                    mjd_nodelen++;
3366                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3367                    while( ++fix < n ) {
3368                        Set_Node_Offset_Length(fix, 0, 0);
3369                    }
3370                    while (word--) {
3371                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3372                        if (tmp) {
3373                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3374                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3375                            else
3376                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3377                        }
3378                    }
3379                }
3380 #endif
3381                 if (trie->maxlen) {
3382                     convert = n;
3383                 } else {
3384                     NEXT_OFF(convert) = (U16)(tail - convert);
3385                     DEBUG_r(optimize= n);
3386                 }
3387             }
3388         }
3389         if (!jumper)
3390             jumper = last;
3391         if ( trie->maxlen ) {
3392             NEXT_OFF( convert ) = (U16)(tail - convert);
3393             ARG_SET( convert, data_slot );
3394             /* Store the offset to the first unabsorbed branch in
3395                jump[0], which is otherwise unused by the jump logic.
3396                We use this when dumping a trie and during optimisation. */
3397             if (trie->jump)
3398                 trie->jump[0] = (U16)(nextbranch - convert);
3399
3400             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3401              *   and there is a bitmap
3402              *   and the first "jump target" node we found leaves enough room
3403              * then convert the TRIE node into a TRIEC node, with the bitmap
3404              * embedded inline in the opcode - this is hypothetically faster.
3405              */
3406             if ( !trie->states[trie->startstate].wordnum
3407                  && trie->bitmap
3408                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3409             {
3410                 OP( convert ) = TRIEC;
3411                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3412                 PerlMemShared_free(trie->bitmap);
3413                 trie->bitmap= NULL;
3414             } else
3415                 OP( convert ) = TRIE;
3416
3417             /* store the type in the flags */
3418             convert->flags = nodetype;
3419             DEBUG_r({
3420             optimize = convert
3421                       + NODE_STEP_REGNODE
3422                       + regarglen[ OP( convert ) ];
3423             });
3424             /* XXX We really should free up the resource in trie now,
3425                    as we won't use them - (which resources?) dmq */
3426         }
3427         /* needed for dumping*/
3428         DEBUG_r(if (optimize) {
3429             regnode *opt = convert;
3430
3431             while ( ++opt < optimize) {
3432                 Set_Node_Offset_Length(opt,0,0);
3433             }
3434             /*
3435                 Try to clean up some of the debris left after the
3436                 optimisation.
3437              */
3438             while( optimize < jumper ) {
3439                 mjd_nodelen += Node_Length((optimize));
3440                 OP( optimize ) = OPTIMIZED;
3441                 Set_Node_Offset_Length(optimize,0,0);
3442                 optimize++;
3443             }
3444             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3445         });
3446     } /* end node insert */
3447
3448     /*  Finish populating the prev field of the wordinfo array.  Walk back
3449      *  from each accept state until we find another accept state, and if
3450      *  so, point the first word's .prev field at the second word. If the
3451      *  second already has a .prev field set, stop now. This will be the
3452      *  case either if we've already processed that word's accept state,
3453      *  or that state had multiple words, and the overspill words were
3454      *  already linked up earlier.
3455      */
3456     {
3457         U16 word;
3458         U32 state;
3459         U16 prev;
3460
3461         for (word=1; word <= trie->wordcount; word++) {
3462             prev = 0;
3463             if (trie->wordinfo[word].prev)
3464                 continue;
3465             state = trie->wordinfo[word].accept;
3466             while (state) {
3467                 state = prev_states[state];
3468                 if (!state)
3469                     break;
3470                 prev = trie->states[state].wordnum;
3471                 if (prev)
3472                     break;
3473             }
3474             trie->wordinfo[word].prev = prev;
3475         }
3476         Safefree(prev_states);
3477     }
3478
3479
3480     /* and now dump out the compressed format */
3481     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3482
3483     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3484 #ifdef DEBUGGING
3485     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3486     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3487 #else
3488     SvREFCNT_dec_NN(revcharmap);
3489 #endif
3490     return trie->jump
3491            ? MADE_JUMP_TRIE
3492            : trie->startstate>1
3493              ? MADE_EXACT_TRIE
3494              : MADE_TRIE;
3495 }
3496
3497 STATIC regnode *
3498 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3499 {
3500 /* The Trie is constructed and compressed now so we can build a fail array if
3501  * it's needed
3502
3503    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3504    3.32 in the
3505    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3506    Ullman 1985/88
3507    ISBN 0-201-10088-6
3508
3509    We find the fail state for each state in the trie, this state is the longest
3510    proper suffix of the current state's 'word' that is also a proper prefix of
3511    another word in our trie. State 1 represents the word '' and is thus the
3512    default fail state. This allows the DFA not to have to restart after its
3513    tried and failed a word at a given point, it simply continues as though it
3514    had been matching the other word in the first place.
3515    Consider
3516       'abcdgu'=~/abcdefg|cdgu/
3517    When we get to 'd' we are still matching the first word, we would encounter
3518    'g' which would fail, which would bring us to the state representing 'd' in
3519    the second word where we would try 'g' and succeed, proceeding to match
3520    'cdgu'.
3521  */
3522  /* add a fail transition */
3523     const U32 trie_offset = ARG(source);
3524     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3525     U32 *q;
3526     const U32 ucharcount = trie->uniquecharcount;
3527     const U32 numstates = trie->statecount;
3528     const U32 ubound = trie->lasttrans + ucharcount;
3529     U32 q_read = 0;
3530     U32 q_write = 0;
3531     U32 charid;
3532     U32 base = trie->states[ 1 ].trans.base;
3533     U32 *fail;
3534     reg_ac_data *aho;
3535     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3536     regnode *stclass;
3537     GET_RE_DEBUG_FLAGS_DECL;
3538
3539     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3540     PERL_UNUSED_CONTEXT;
3541 #ifndef DEBUGGING
3542     PERL_UNUSED_ARG(depth);
3543 #endif
3544
3545     if ( OP(source) == TRIE ) {
3546         struct regnode_1 *op = (struct regnode_1 *)
3547             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3548         StructCopy(source,op,struct regnode_1);
3549         stclass = (regnode *)op;
3550     } else {
3551         struct regnode_charclass *op = (struct regnode_charclass *)
3552             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3553         StructCopy(source,op,struct regnode_charclass);
3554         stclass = (regnode *)op;
3555     }
3556     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3557
3558     ARG_SET( stclass, data_slot );
3559     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3560     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3561     aho->trie=trie_offset;
3562     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3563     Copy( trie->states, aho->states, numstates, reg_trie_state );
3564     Newxz( q, numstates, U32);
3565     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3566     aho->refcount = 1;
3567     fail = aho->fail;
3568     /* initialize fail[0..1] to be 1 so that we always have
3569        a valid final fail state */
3570     fail[ 0 ] = fail[ 1 ] = 1;
3571
3572     for ( charid = 0; charid < ucharcount ; charid++ ) {
3573         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3574         if ( newstate ) {
3575             q[ q_write ] = newstate;
3576             /* set to point at the root */
3577             fail[ q[ q_write++ ] ]=1;
3578         }
3579     }
3580     while ( q_read < q_write) {
3581         const U32 cur = q[ q_read++ % numstates ];
3582         base = trie->states[ cur ].trans.base;
3583
3584         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3585             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3586             if (ch_state) {
3587                 U32 fail_state = cur;
3588                 U32 fail_base;
3589                 do {
3590                     fail_state = fail[ fail_state ];
3591                     fail_base = aho->states[ fail_state ].trans.base;
3592                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3593
3594                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3595                 fail[ ch_state ] = fail_state;
3596                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3597                 {
3598                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3599                 }
3600                 q[ q_write++ % numstates] = ch_state;
3601             }
3602         }
3603     }
3604     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3605        when we fail in state 1, this allows us to use the
3606        charclass scan to find a valid start char. This is based on the principle
3607        that theres a good chance the string being searched contains lots of stuff
3608        that cant be a start char.
3609      */
3610     fail[ 0 ] = fail[ 1 ] = 0;
3611     DEBUG_TRIE_COMPILE_r({
3612         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3613                       depth, (UV)numstates
3614         );
3615         for( q_read=1; q_read<numstates; q_read++ ) {
3616             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3617         }
3618         Perl_re_printf( aTHX_  "\n");
3619     });
3620     Safefree(q);
3621     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3622     return stclass;
3623 }
3624
3625
3626 #define DEBUG_PEEP(str,scan,depth)         \
3627     DEBUG_OPTIMISE_r({if (scan){           \
3628        regnode *Next = regnext(scan);      \
3629        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3630        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3631            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3632            Next ? (REG_NODE_NUM(Next)) : 0 );\
3633        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3634        Perl_re_printf( aTHX_  "\n");                   \
3635    }});
3636
3637 /* The below joins as many adjacent EXACTish nodes as possible into a single
3638  * one.  The regop may be changed if the node(s) contain certain sequences that
3639  * require special handling.  The joining is only done if:
3640  * 1) there is room in the current conglomerated node to entirely contain the
3641  *    next one.
3642  * 2) they are the exact same node type
3643  *
3644  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3645  * these get optimized out
3646  *
3647  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3648  * as possible, even if that means splitting an existing node so that its first
3649  * part is moved to the preceeding node.  This would maximise the efficiency of
3650  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3651  * EXACTFish nodes into portions that don't change under folding vs those that
3652  * do.  Those portions that don't change may be the only things in the pattern that
3653  * could be used to find fixed and floating strings.
3654  *
3655  * If a node is to match under /i (folded), the number of characters it matches
3656  * can be different than its character length if it contains a multi-character
3657  * fold.  *min_subtract is set to the total delta number of characters of the
3658  * input nodes.
3659  *
3660  * And *unfolded_multi_char is set to indicate whether or not the node contains
3661  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3662  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3663  * SMALL LETTER SHARP S, as only if the target string being matched against
3664  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3665  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3666  * whose components are all above the Latin1 range are not run-time locale
3667  * dependent, and have already been folded by the time this function is
3668  * called.)
3669  *
3670  * This is as good a place as any to discuss the design of handling these
3671  * multi-character fold sequences.  It's been wrong in Perl for a very long
3672  * time.  There are three code points in Unicode whose multi-character folds
3673  * were long ago discovered to mess things up.  The previous designs for
3674  * dealing with these involved assigning a special node for them.  This
3675  * approach doesn't always work, as evidenced by this example:
3676  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3677  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3678  * would match just the \xDF, it won't be able to handle the case where a
3679  * successful match would have to cross the node's boundary.  The new approach
3680  * that hopefully generally solves the problem generates an EXACTFU_SS node
3681  * that is "sss" in this case.
3682  *
3683  * It turns out that there are problems with all multi-character folds, and not
3684  * just these three.  Now the code is general, for all such cases.  The
3685  * approach taken is:
3686  * 1)   This routine examines each EXACTFish node that could contain multi-
3687  *      character folded sequences.  Since a single character can fold into
3688  *      such a sequence, the minimum match length for this node is less than
3689  *      the number of characters in the node.  This routine returns in
3690  *      *min_subtract how many characters to subtract from the the actual
3691  *      length of the string to get a real minimum match length; it is 0 if
3692  *      there are no multi-char foldeds.  This delta is used by the caller to
3693  *      adjust the min length of the match, and the delta between min and max,
3694  *      so that the optimizer doesn't reject these possibilities based on size
3695  *      constraints.
3696  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3697  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3698  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3699  *      there is a possible fold length change.  That means that a regular
3700  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3701  *      with length changes, and so can be processed faster.  regexec.c takes
3702  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3703  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3704  *      known until runtime).  This saves effort in regex matching.  However,
3705  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3706  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3707  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3708  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3709  *      possibilities for the non-UTF8 patterns are quite simple, except for
3710  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3711  *      members of a fold-pair, and arrays are set up for all of them so that
3712  *      the other member of the pair can be found quickly.  Code elsewhere in
3713  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3714  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3715  *      described in the next item.
3716  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3717  *      validity of the fold won't be known until runtime, and so must remain
3718  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3719  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3720  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3721  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3722  *      The reason this is a problem is that the optimizer part of regexec.c
3723  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3724  *      that a character in the pattern corresponds to at most a single
3725  *      character in the target string.  (And I do mean character, and not byte
3726  *      here, unlike other parts of the documentation that have never been
3727  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3728  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3729  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3730  *      nodes, violate the assumption, and they are the only instances where it
3731  *      is violated.  I'm reluctant to try to change the assumption, as the
3732  *      code involved is impenetrable to me (khw), so instead the code here
3733  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3734  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3735  *      boolean indicating whether or not the node contains such a fold.  When
3736  *      it is true, the caller sets a flag that later causes the optimizer in
3737  *      this file to not set values for the floating and fixed string lengths,
3738  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3739  *      assumption.  Thus, there is no optimization based on string lengths for
3740  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3741  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3742  *      assumption is wrong only in these cases is that all other non-UTF-8
3743  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3744  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3745  *      EXACTF nodes because we don't know at compile time if it actually
3746  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3747  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3748  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3749  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3750  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3751  *      string would require the pattern to be forced into UTF-8, the overhead
3752  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3753  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3754  *      locale.)
3755  *
3756  *      Similarly, the code that generates tries doesn't currently handle
3757  *      not-already-folded multi-char folds, and it looks like a pain to change
3758  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3759  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3760  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3761  *      using /iaa matching will be doing so almost entirely with ASCII
3762  *      strings, so this should rarely be encountered in practice */
3763
3764 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3765     if (PL_regkind[OP(scan)] == EXACT) \
3766         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3767
3768 STATIC U32
3769 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3770                    UV *min_subtract, bool *unfolded_multi_char,
3771                    U32 flags,regnode *val, U32 depth)
3772 {
3773     /* Merge several consecutive EXACTish nodes into one. */
3774     regnode *n = regnext(scan);
3775     U32 stringok = 1;
3776     regnode *next = scan + NODE_SZ_STR(scan);
3777     U32 merged = 0;
3778     U32 stopnow = 0;
3779 #ifdef DEBUGGING
3780     regnode *stop = scan;
3781     GET_RE_DEBUG_FLAGS_DECL;
3782 #else
3783     PERL_UNUSED_ARG(depth);
3784 #endif
3785
3786     PERL_ARGS_ASSERT_JOIN_EXACT;
3787 #ifndef EXPERIMENTAL_INPLACESCAN
3788     PERL_UNUSED_ARG(flags);
3789     PERL_UNUSED_ARG(val);
3790 #endif
3791     DEBUG_PEEP("join",scan,depth);
3792
3793     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3794      * EXACT ones that are mergeable to the current one. */
3795     while (n
3796            && (PL_regkind[OP(n)] == NOTHING
3797                || (stringok && OP(n) == OP(scan)))
3798            && NEXT_OFF(n)
3799            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3800     {
3801
3802         if (OP(n) == TAIL || n > next)
3803             stringok = 0;
3804         if (PL_regkind[OP(n)] == NOTHING) {
3805             DEBUG_PEEP("skip:",n,depth);
3806             NEXT_OFF(scan) += NEXT_OFF(n);
3807             next = n + NODE_STEP_REGNODE;
3808 #ifdef DEBUGGING
3809             if (stringok)
3810                 stop = n;
3811 #endif
3812             n = regnext(n);
3813         }
3814         else if (stringok) {
3815             const unsigned int oldl = STR_LEN(scan);
3816             regnode * const nnext = regnext(n);
3817
3818             /* XXX I (khw) kind of doubt that this works on platforms (should
3819              * Perl ever run on one) where U8_MAX is above 255 because of lots
3820              * of other assumptions */
3821             /* Don't join if the sum can't fit into a single node */
3822             if (oldl + STR_LEN(n) > U8_MAX)
3823                 break;
3824
3825             DEBUG_PEEP("merg",n,depth);
3826             merged++;
3827
3828             NEXT_OFF(scan) += NEXT_OFF(n);
3829             STR_LEN(scan) += STR_LEN(n);
3830             next = n + NODE_SZ_STR(n);
3831             /* Now we can overwrite *n : */
3832             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3833 #ifdef DEBUGGING
3834             stop = next - 1;
3835 #endif
3836             n = nnext;
3837             if (stopnow) break;
3838         }
3839
3840 #ifdef EXPERIMENTAL_INPLACESCAN
3841         if (flags && !NEXT_OFF(n)) {
3842             DEBUG_PEEP("atch", val, depth);
3843             if (reg_off_by_arg[OP(n)]) {
3844                 ARG_SET(n, val - n);
3845             }
3846             else {
3847                 NEXT_OFF(n) = val - n;
3848             }
3849             stopnow = 1;
3850         }
3851 #endif
3852     }
3853
3854     *min_subtract = 0;
3855     *unfolded_multi_char = FALSE;
3856
3857     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3858      * can now analyze for sequences of problematic code points.  (Prior to
3859      * this final joining, sequences could have been split over boundaries, and
3860      * hence missed).  The sequences only happen in folding, hence for any
3861      * non-EXACT EXACTish node */
3862     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3863         U8* s0 = (U8*) STRING(scan);
3864         U8* s = s0;
3865         U8* s_end = s0 + STR_LEN(scan);
3866
3867         int total_count_delta = 0;  /* Total delta number of characters that
3868                                        multi-char folds expand to */
3869
3870         /* One pass is made over the node's string looking for all the
3871          * possibilities.  To avoid some tests in the loop, there are two main
3872          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3873          * non-UTF-8 */
3874         if (UTF) {
3875             U8* folded = NULL;
3876
3877             if (OP(scan) == EXACTFL) {
3878                 U8 *d;
3879
3880                 /* An EXACTFL node would already have been changed to another
3881                  * node type unless there is at least one character in it that
3882                  * is problematic; likely a character whose fold definition
3883                  * won't be known until runtime, and so has yet to be folded.
3884                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3885                  * to handle the UTF-8 case, we need to create a temporary
3886                  * folded copy using UTF-8 locale rules in order to analyze it.
3887                  * This is because our macros that look to see if a sequence is
3888                  * a multi-char fold assume everything is folded (otherwise the
3889                  * tests in those macros would be too complicated and slow).
3890                  * Note that here, the non-problematic folds will have already
3891                  * been done, so we can just copy such characters.  We actually
3892                  * don't completely fold the EXACTFL string.  We skip the
3893                  * unfolded multi-char folds, as that would just create work
3894                  * below to figure out the size they already are */
3895
3896                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3897                 d = folded;
3898                 while (s < s_end) {
3899                     STRLEN s_len = UTF8SKIP(s);
3900                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3901                         Copy(s, d, s_len, U8);
3902                         d += s_len;
3903                     }
3904                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3905                         *unfolded_multi_char = TRUE;
3906                         Copy(s, d, s_len, U8);
3907                         d += s_len;
3908                     }
3909                     else if (isASCII(*s)) {
3910                         *(d++) = toFOLD(*s);
3911                     }
3912                     else {
3913                         STRLEN len;
3914                         _toFOLD_utf8_flags(s, d, &len, FOLD_FLAGS_FULL);
3915                         d += len;
3916                     }
3917                     s += s_len;
3918                 }
3919
3920                 /* Point the remainder of the routine to look at our temporary
3921                  * folded copy */
3922                 s = folded;
3923                 s_end = d;
3924             } /* End of creating folded copy of EXACTFL string */
3925
3926             /* Examine the string for a multi-character fold sequence.  UTF-8
3927              * patterns have all characters pre-folded by the time this code is
3928              * executed */
3929             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3930                                      length sequence we are looking for is 2 */
3931             {
3932                 int count = 0;  /* How many characters in a multi-char fold */
3933                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3934                 if (! len) {    /* Not a multi-char fold: get next char */
3935                     s += UTF8SKIP(s);
3936                     continue;
3937                 }
3938
3939                 /* Nodes with 'ss' require special handling, except for
3940                  * EXACTFA-ish for which there is no multi-char fold to this */
3941                 if (len == 2 && *s == 's' && *(s+1) == 's'
3942                     && OP(scan) != EXACTFA
3943                     && OP(scan) != EXACTFA_NO_TRIE)
3944                 {
3945                     count = 2;
3946                     if (OP(scan) != EXACTFL) {
3947                         OP(scan) = EXACTFU_SS;
3948                     }
3949                     s += 2;
3950                 }
3951                 else { /* Here is a generic multi-char fold. */
3952                     U8* multi_end  = s + len;
3953
3954                     /* Count how many characters are in it.  In the case of
3955                      * /aa, no folds which contain ASCII code points are
3956                      * allowed, so check for those, and skip if found. */
3957                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3958                         count = utf8_length(s, multi_end);
3959                         s = multi_end;
3960                     }
3961                     else {
3962                         while (s < multi_end) {
3963                             if (isASCII(*s)) {
3964                                 s++;
3965                                 goto next_iteration;
3966                             }
3967                             else {
3968                                 s += UTF8SKIP(s);
3969                             }
3970                             count++;
3971                         }
3972                     }
3973                 }
3974
3975                 /* The delta is how long the sequence is minus 1 (1 is how long
3976                  * the character that folds to the sequence is) */
3977                 total_count_delta += count - 1;
3978               next_iteration: ;
3979             }
3980
3981             /* We created a temporary folded copy of the string in EXACTFL
3982              * nodes.  Therefore we need to be sure it doesn't go below zero,
3983              * as the real string could be shorter */
3984             if (OP(scan) == EXACTFL) {
3985                 int total_chars = utf8_length((U8*) STRING(scan),
3986                                            (U8*) STRING(scan) + STR_LEN(scan));
3987                 if (total_count_delta > total_chars) {
3988                     total_count_delta = total_chars;
3989                 }
3990             }
3991
3992             *min_subtract += total_count_delta;
3993             Safefree(folded);
3994         }
3995         else if (OP(scan) == EXACTFA) {
3996
3997             /* Non-UTF-8 pattern, EXACTFA node.  There can't be a multi-char
3998              * fold to the ASCII range (and there are no existing ones in the
3999              * upper latin1 range).  But, as outlined in the comments preceding
4000              * this function, we need to flag any occurrences of the sharp s.
4001              * This character forbids trie formation (because of added
4002              * complexity) */
4003 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
4004    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
4005                                       || UNICODE_DOT_DOT_VERSION > 0)
4006             while (s < s_end) {
4007                 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4008                     OP(scan) = EXACTFA_NO_TRIE;
4009                     *unfolded_multi_char = TRUE;
4010                     break;
4011                 }
4012                 s++;
4013             }
4014         }
4015         else {
4016
4017             /* Non-UTF-8 pattern, not EXACTFA node.  Look for the multi-char
4018              * folds that are all Latin1.  As explained in the comments
4019              * preceding this function, we look also for the sharp s in EXACTF
4020              * and EXACTFL nodes; it can be in the final position.  Otherwise
4021              * we can stop looking 1 byte earlier because have to find at least
4022              * two characters for a multi-fold */
4023             const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL)
4024                               ? s_end
4025                               : s_end -1;
4026
4027             while (s < upper) {
4028                 int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end);
4029                 if (! len) {    /* Not a multi-char fold. */
4030                     if (*s == LATIN_SMALL_LETTER_SHARP_S
4031                         && (OP(scan) == EXACTF || OP(scan) == EXACTFL))
4032                     {
4033                         *unfolded_multi_char = TRUE;
4034                     }
4035                     s++;
4036                     continue;
4037                 }
4038
4039                 if (len == 2
4040                     && isALPHA_FOLD_EQ(*s, 's')
4041                     && isALPHA_FOLD_EQ(*(s+1), 's'))
4042                 {
4043
4044                     /* EXACTF nodes need to know that the minimum length
4045                      * changed so that a sharp s in the string can match this
4046                      * ss in the pattern, but they remain EXACTF nodes, as they
4047                      * won't match this unless the target string is is UTF-8,
4048                      * which we don't know until runtime.  EXACTFL nodes can't
4049                      * transform into EXACTFU nodes */
4050                     if (OP(scan) != EXACTF && OP(scan) != EXACTFL) {
4051                         OP(scan) = EXACTFU_SS;
4052                     }
4053                 }
4054
4055                 *min_subtract += len - 1;
4056                 s += len;
4057             }
4058 #endif
4059         }
4060     }
4061
4062 #ifdef DEBUGGING
4063     /* Allow dumping but overwriting the collection of skipped
4064      * ops and/or strings with fake optimized ops */
4065     n = scan + NODE_SZ_STR(scan);
4066     while (n <= stop) {
4067         OP(n) = OPTIMIZED;
4068         FLAGS(n) = 0;
4069         NEXT_OFF(n) = 0;
4070         n++;
4071     }
4072 #endif
4073     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
4074     return stopnow;
4075 }
4076
4077 /* REx optimizer.  Converts nodes into quicker variants "in place".
4078    Finds fixed substrings.  */
4079
4080 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
4081    to the position after last scanned or to NULL. */
4082
4083 #define INIT_AND_WITHP \
4084     assert(!and_withp); \
4085     Newx(and_withp,1, regnode_ssc); \
4086     SAVEFREEPV(and_withp)
4087
4088
4089 static void
4090 S_unwind_scan_frames(pTHX_ const void *p)
4091 {
4092     scan_frame *f= (scan_frame *)p;
4093     do {
4094         scan_frame *n= f->next_frame;
4095         Safefree(f);
4096         f= n;
4097     } while (f);
4098 }
4099
4100
4101 STATIC SSize_t
4102 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
4103                         SSize_t *minlenp, SSize_t *deltap,
4104                         regnode *last,
4105                         scan_data_t *data,
4106                         I32 stopparen,
4107                         U32 recursed_depth,
4108                         regnode_ssc *and_withp,
4109                         U32 flags, U32 depth)
4110                         /* scanp: Start here (read-write). */
4111                         /* deltap: Write maxlen-minlen here. */
4112                         /* last: Stop before this one. */
4113                         /* data: string data about the pattern */
4114                         /* stopparen: treat close N as END */
4115                         /* recursed: which subroutines have we recursed into */
4116                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
4117 {
4118     /* There must be at least this number of characters to match */
4119     SSize_t min = 0;
4120     I32 pars = 0, code;
4121     regnode *scan = *scanp, *next;
4122     SSize_t delta = 0;
4123     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
4124     int is_inf_internal = 0;            /* The studied chunk is infinite */
4125     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
4126     scan_data_t data_fake;
4127     SV *re_trie_maxbuff = NULL;
4128     regnode *first_non_open = scan;
4129     SSize_t stopmin = SSize_t_MAX;
4130     scan_frame *frame = NULL;
4131     GET_RE_DEBUG_FLAGS_DECL;
4132
4133     PERL_ARGS_ASSERT_STUDY_CHUNK;
4134     RExC_study_started= 1;
4135
4136
4137     if ( depth == 0 ) {
4138         while (first_non_open && OP(first_non_open) == OPEN)
4139             first_non_open=regnext(first_non_open);
4140     }
4141
4142
4143   fake_study_recurse:
4144     DEBUG_r(
4145         RExC_study_chunk_recursed_count++;
4146     );
4147     DEBUG_OPTIMISE_MORE_r(
4148     {
4149         Perl_re_indentf( aTHX_  "study_chunk stopparen=%ld recursed_count=%lu depth=%lu recursed_depth=%lu scan=%p last=%p",
4150             depth, (long)stopparen,
4151             (unsigned long)RExC_study_chunk_recursed_count,
4152             (unsigned long)depth, (unsigned long)recursed_depth,
4153             scan,
4154             last);
4155         if (recursed_depth) {
4156             U32 i;
4157             U32 j;
4158             for ( j = 0 ; j < recursed_depth ; j++ ) {
4159                 for ( i = 0 ; i < (U32)RExC_npar ; i++ ) {
4160                     if (
4161                         PAREN_TEST(RExC_study_chunk_recursed +
4162                                    ( j * RExC_study_chunk_recursed_bytes), i )
4163                         && (
4164                             !j ||
4165                             !PAREN_TEST(RExC_study_chunk_recursed +
4166                                    (( j - 1 ) * RExC_study_chunk_recursed_bytes), i)
4167                         )
4168                     ) {
4169                         Perl_re_printf( aTHX_ " %d",(int)i);
4170                         break;
4171                     }
4172                 }
4173                 if ( j + 1 < recursed_depth ) {
4174                     Perl_re_printf( aTHX_  ",");
4175                 }
4176             }
4177         }
4178         Perl_re_printf( aTHX_ "\n");
4179     }
4180     );
4181     while ( scan && OP(scan) != END && scan < last ){
4182         UV min_subtract = 0;    /* How mmany chars to subtract from the minimum
4183                                    node length to get a real minimum (because
4184                                    the folded version may be shorter) */
4185         bool unfolded_multi_char = FALSE;
4186         /* Peephole optimizer: */
4187         DEBUG_STUDYDATA("Peep:", data, depth);
4188         DEBUG_PEEP("Peep", scan, depth);
4189
4190
4191         /* The reason we do this here is that we need to deal with things like
4192          * /(?:f)(?:o)(?:o)/ which cant be dealt with by the normal EXACT
4193          * parsing code, as each (?:..) is handled by a different invocation of
4194          * reg() -- Yves
4195          */
4196         JOIN_EXACT(scan,&min_subtract, &unfolded_multi_char, 0);
4197
4198         /* Follow the next-chain of the current node and optimize
4199            away all the NOTHINGs from it.  */
4200         if (OP(scan) != CURLYX) {
4201             const int max = (reg_off_by_arg[OP(scan)]
4202                        ? I32_MAX
4203                        /* I32 may be smaller than U16 on CRAYs! */
4204                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
4205             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
4206             int noff;
4207             regnode *n = scan;
4208
4209             /* Skip NOTHING and LONGJMP. */
4210             while ((n = regnext(n))
4211                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
4212                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
4213                    && off + noff < max)
4214                 off += noff;
4215             if (reg_off_by_arg[OP(scan)])
4216                 ARG(scan) = off;
4217             else
4218                 NEXT_OFF(scan) = off;
4219         }
4220
4221         /* The principal pseudo-switch.  Cannot be a switch, since we
4222            look into several different things.  */
4223         if ( OP(scan) == DEFINEP ) {
4224             SSize_t minlen = 0;
4225             SSize_t deltanext = 0;
4226             SSize_t fake_last_close = 0;
4227             I32 f = SCF_IN_DEFINE;
4228
4229             StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4230             scan = regnext(scan);
4231             assert( OP(scan) == IFTHEN );
4232             DEBUG_PEEP("expect IFTHEN", scan, depth);
4233
4234             data_fake.last_closep= &fake_last_close;
4235             minlen = *minlenp;
4236             next = regnext(scan);
4237             scan = NEXTOPER(NEXTOPER(scan));
4238             DEBUG_PEEP("scan", scan, depth);
4239             DEBUG_PEEP("next", next, depth);
4240
4241             /* we suppose the run is continuous, last=next...
4242              * NOTE we dont use the return here! */
4243             (void)study_chunk(pRExC_state, &scan, &minlen,
4244                               &deltanext, next, &data_fake, stopparen,
4245                               recursed_depth, NULL, f, depth+1);
4246
4247             scan = next;
4248         } else
4249         if (
4250             OP(scan) == BRANCH  ||
4251             OP(scan) == BRANCHJ ||
4252             OP(scan) == IFTHEN
4253         ) {
4254             next = regnext(scan);
4255             code = OP(scan);
4256
4257             /* The op(next)==code check below is to see if we
4258              * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN"
4259              * IFTHEN is special as it might not appear in pairs.
4260              * Not sure whether BRANCH-BRANCHJ is possible, regardless
4261              * we dont handle it cleanly. */
4262             if (OP(next) == code || code == IFTHEN) {
4263                 /* NOTE - There is similar code to this block below for
4264                  * handling TRIE nodes on a re-study.  If you change stuff here
4265                  * check there too. */
4266                 SSize_t max1 = 0, min1 = SSize_t_MAX, num = 0;
4267                 regnode_ssc accum;
4268                 regnode * const startbranch=scan;
4269
4270                 if (flags & SCF_DO_SUBSTR) {
4271                     /* Cannot merge strings after this. */
4272                     scan_commit(pRExC_state, data, minlenp, is_inf);
4273                 }
4274
4275                 if (flags & SCF_DO_STCLASS)
4276                     ssc_init_zero(pRExC_state, &accum);
4277
4278                 while (OP(scan) == code) {
4279                     SSize_t deltanext, minnext, fake;
4280                     I32 f = 0;
4281                     regnode_ssc this_class;
4282
4283                     DEBUG_PEEP("Branch", scan, depth);
4284
4285                     num++;
4286                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
4287                     if (data) {
4288                         data_fake.whilem_c = data->whilem_c;
4289                         data_fake.last_closep = data->last_closep;
4290                     }
4291                     else
4292                         data_fake.last_closep = &fake;
4293
4294                     data_fake.pos_delta = delta;
4295                     next = regnext(scan);
4296
4297                     scan = NEXTOPER(scan); /* everything */
4298                     if (code != BRANCH)    /* everything but BRANCH */
4299                         scan = NEXTOPER(scan);
4300
4301                     if (flags & SCF_DO_STCLASS) {
4302                         ssc_init(pRExC_state, &this_class);
4303                         data_fake.start_class = &this_class;
4304                         f = SCF_DO_STCLASS_AND;
4305                     }
4306                     if (flags & SCF_WHILEM_VISITED_POS)
4307                         f |= SCF_WHILEM_VISITED_POS;
4308
4309                     /* we suppose the run is continuous, last=next...*/
4310                     minnext = study_chunk(pRExC_state, &scan, minlenp,
4311                                       &deltanext, next, &data_fake, stopparen,
4312                                       recursed_depth, NULL, f,depth+1);
4313
4314                     if (min1 > minnext)
4315                         min1 = minnext;
4316                     if (deltanext == SSize_t_MAX) {
4317                         is_inf = is_inf_internal = 1;
4318                         max1 = SSize_t_MAX;
4319                     } else if (max1 < minnext + deltanext)
4320                         max1 = minnext + deltanext;
4321                     scan = next;
4322                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4323                         pars++;
4324                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4325                         if ( stopmin > minnext)
4326                             stopmin = min + min1;
4327                         flags &= ~SCF_DO_SUBSTR;
4328                         if (data)
4329                             data->flags |= SCF_SEEN_ACCEPT;
4330                     }
4331                     if (data) {
4332                         if (data_fake.flags & SF_HAS_EVAL)
4333                             data->flags |= SF_HAS_EVAL;
4334                         data->whilem_c = data_fake.whilem_c;
4335                     }
4336                     if (flags & SCF_DO_STCLASS)
4337                         ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class);
4338                 }
4339                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
4340                     min1 = 0;
4341                 if (flags & SCF_DO_SUBSTR) {
4342                     data->pos_min += min1;
4343                     if (data->pos_delta >= SSize_t_MAX - (max1 - min1))
4344                         data->pos_delta = SSize_t_MAX;
4345                     else
4346                         data->pos_delta += max1 - min1;
4347                     if (max1 != min1 || is_inf)
4348                         data->longest = &(data->longest_float);
4349                 }
4350                 min += min1;
4351                 if (delta == SSize_t_MAX
4352                  || SSize_t_MAX - delta - (max1 - min1) < 0)
4353                     delta = SSize_t_MAX;
4354                 else
4355                     delta += max1 - min1;
4356                 if (flags & SCF_DO_STCLASS_OR) {
4357                     ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum);
4358                     if (min1) {
4359                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4360                         flags &= ~SCF_DO_STCLASS;
4361                     }
4362                 }
4363                 else if (flags & SCF_DO_STCLASS_AND) {
4364                     if (min1) {
4365                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
4366                         flags &= ~SCF_DO_STCLASS;
4367                     }
4368                     else {
4369                         /* Switch to OR mode: cache the old value of
4370                          * data->start_class */
4371                         INIT_AND_WITHP;
4372                         StructCopy(data->start_class, and_withp, regnode_ssc);
4373                         flags &= ~SCF_DO_STCLASS_AND;
4374                         StructCopy(&accum, data->start_class, regnode_ssc);
4375                         flags |= SCF_DO_STCLASS_OR;
4376                     }
4377                 }
4378
4379                 if (PERL_ENABLE_TRIE_OPTIMISATION &&
4380                         OP( startbranch ) == BRANCH )
4381                 {
4382                 /* demq.
4383
4384                    Assuming this was/is a branch we are dealing with: 'scan'
4385                    now points at the item that follows the branch sequence,
4386                    whatever it is. We now start at the beginning of the
4387                    sequence and look for subsequences of
4388
4389                    BRANCH->EXACT=>x1
4390                    BRANCH->EXACT=>x2
4391                    tail
4392
4393                    which would be constructed from a pattern like
4394                    /A|LIST|OF|WORDS/
4395
4396                    If we can find such a subsequence we need to turn the first
4397                    element into a trie and then add the subsequent branch exact
4398                    strings to the trie.
4399
4400                    We have two cases
4401
4402                      1. patterns where the whole set of branches can be
4403                         converted.
4404
4405                      2. patterns where only a subset can be converted.
4406
4407                    In case 1 we can replace the whole set with a single regop
4408                    for the trie. In case 2 we need to keep the start and end
4409                    branches so
4410
4411                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
4412                      becomes BRANCH TRIE; BRANCH X;
4413
4414                   There is an additional case, that being where there is a
4415                   common prefix, which gets split out into an EXACT like node
4416                   preceding the TRIE node.
4417
4418                   If x(1..n)==tail then we can do a simple trie, if not we make
4419                   a "jump" trie, such that when we match the appropriate word
4420                   we "jump" to the appropriate tail node. Essentially we turn
4421                   a nested if into a case structure of sorts.
4422
4423                 */
4424
4425                     int made=0;
4426                     if (!re_trie_maxbuff) {
4427                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
4428                         if (!SvIOK(re_trie_maxbuff))
4429                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
4430                     }
4431                     if ( SvIV(re_trie_maxbuff)>=0  ) {
4432                         regnode *cur;
4433                         regnode *first = (regnode *)NULL;
4434                         regnode *last = (regnode *)NULL;
4435                         regnode *tail = scan;
4436                         U8 trietype = 0;
4437                         U32 count=0;
4438
4439                         /* var tail is used because there may be a TAIL
4440                            regop in the way. Ie, the exacts will point to the
4441                            thing following the TAIL, but the last branch will
4442                            point at the TAIL. So we advance tail. If we
4443                            have nested (?:) we may have to move through several
4444                            tails.
4445                          */
4446
4447                         while ( OP( tail ) == TAIL ) {
4448                             /* this is the TAIL generated by (?:) */
4449                             tail = regnext( tail );
4450                         }
4451
4452
4453                         DEBUG_TRIE_COMPILE_r({
4454                             regprop(RExC_rx, RExC_mysv, tail, NULL, pRExC_state);
4455                             Perl_re_indentf( aTHX_  "%s %" UVuf ":%s\n",
4456                               depth+1,
4457                               "Looking for TRIE'able sequences. Tail node is ",
4458                               (UV)(tail - RExC_emit_start),
4459                               SvPV_nolen_const( RExC_mysv )
4460                             );
4461                         });
4462
4463                         /*
4464
4465                             Step through the branches
4466                                 cur represents each branch,
4467                                 noper is the first thing to be matched as part
4468                                       of that branch
4469                                 noper_next is the regnext() of that node.
4470
4471                             We normally handle a case like this
4472                             /FOO[xyz]|BAR[pqr]/ via a "jump trie" but we also
4473                             support building with NOJUMPTRIE, which restricts
4474                             the trie logic to structures like /FOO|BAR/.
4475
4476                             If noper is a trieable nodetype then the branch is
4477                             a possible optimization target. If we are building
4478                             under NOJUMPTRIE then we require that noper_next is
4479                             the same as scan (our current position in the regex
4480                             program).
4481
4482                             Once we have two or more consecutive such branches
4483                             we can create a trie of the EXACT's contents and
4484                             stitch it in place into the program.
4485
4486                             If the sequence represents all of the branches in
4487                             the alternation we replace the entire thing with a
4488                             single TRIE node.
4489
4490                             Otherwise when it is a subsequence we need to
4491                             stitch it in place and replace only the relevant
4492                             branches. This means the first branch has to remain
4493                             as it is used by the alternation logic, and its
4494                             next pointer, and needs to be repointed at the item
4495                             on the branch chain following the last branch we
4496                             have optimized away.
4497
4498                             This could be either a BRANCH, in which case the
4499                             subsequence is internal, or it could be the item
4500                             following the branch sequence in which case the
4501                             subsequence is at the end (which does not
4502                             necessarily mean the first node is the start of the
4503                             alternation).
4504
4505                             TRIE_TYPE(X) is a define which maps the optype to a
4506                             trietype.
4507
4508                                 optype          |  trietype
4509                                 ----------------+-----------
4510                                 NOTHING         | NOTHING
4511                                 EXACT           | EXACT
4512                                 EXACTFU         | EXACTFU
4513                                 EXACTFU_SS      | EXACTFU
4514                                 EXACTFA         | EXACTFA
4515                                 EXACTL          | EXACTL
4516                                 EXACTFLU8       | EXACTFLU8
4517
4518
4519                         */
4520 #define TRIE_TYPE(X) ( ( NOTHING == (X) )                                   \
4521                        ? NOTHING                                            \
4522                        : ( EXACT == (X) )                                   \
4523                          ? EXACT                                            \
4524                          : ( EXACTFU == (X) || EXACTFU_SS == (X) )          \
4525                            ? EXACTFU                                        \
4526                            : ( EXACTFA == (X) )                             \
4527                              ? EXACTFA                                      \
4528                              : ( EXACTL == (X) )                            \
4529                                ? EXACTL                                     \
4530                                : ( EXACTFLU8 == (X) )                        \
4531                                  ? EXACTFLU8                                 \
4532                                  : 0 )
4533
4534                         /* dont use tail as the end marker for this traverse */
4535                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
4536                             regnode * const noper = NEXTOPER( cur );
4537                             U8 noper_type = OP( noper );
4538                             U8 noper_trietype = TRIE_TYPE( noper_type );
4539 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
4540                             regnode * const noper_next = regnext( noper );
4541                             U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4542                             U8 noper_next_trietype = (noper_next && noper_next < tail) ? TRIE_TYPE( noper_next_type ) :0;
4543 #endif
4544
4545                             DEBUG_TRIE_COMPILE_r({
4546                                 regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4547                                 Perl_re_indentf( aTHX_  "- %d:%s (%d)",
4548                                    depth+1,
4549                                    REG_NODE_NUM(cur), SvPV_nolen_const( RExC_mysv ), REG_NODE_NUM(cur) );
4550
4551                                 regprop(RExC_rx, RExC_mysv, noper, NULL, pRExC_state);
4552                                 Perl_re_printf( aTHX_  " -> %d:%s",
4553                                     REG_NODE_NUM(noper), SvPV_nolen_const(RExC_mysv));
4554
4555                                 if ( noper_next ) {
4556                                   regprop(RExC_rx, RExC_mysv, noper_next, NULL, pRExC_state);
4557                                   Perl_re_printf( aTHX_ "\t=> %d:%s\t",
4558                                     REG_NODE_NUM(noper_next), SvPV_nolen_const(RExC_mysv));
4559                                 }
4560                                 Perl_re_printf( aTHX_  "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n",
4561                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4562                                    PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
4563                                 );
4564                             });
4565
4566                             /* Is noper a trieable nodetype that can be merged
4567                              * with the current trie (if there is one)? */
4568                             if ( noper_trietype
4569                                   &&
4570                                   (
4571                                         ( noper_trietype == NOTHING )
4572                                         || ( trietype == NOTHING )
4573                                         || ( trietype == noper_trietype )
4574                                   )
4575 #ifdef NOJUMPTRIE
4576                                   && noper_next >= tail
4577 #endif
4578                                   && count < U16_MAX)
4579                             {
4580                                 /* Handle mergable triable node Either we are
4581                                  * the first node in a new trieable sequence,
4582                                  * in which case we do some bookkeeping,
4583                                  * otherwise we update the end pointer. */
4584                                 if ( !first ) {
4585                                     first = cur;
4586                                     if ( noper_trietype == NOTHING ) {
4587 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
4588                                         regnode * const noper_next = regnext( noper );
4589                                         U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0;
4590                                         U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
4591 #endif
4592
4593                                         if ( noper_next_trietype ) {
4594                                             trietype = noper_next_trietype;
4595                                         } else if (noper_next_type)  {
4596                                             /* a NOTHING regop is 1 regop wide.
4597                                              * We need at least two for a trie
4598                                              * so we can't merge this in */
4599                                             first = NULL;
4600                                         }
4601                                     } else {
4602                                         trietype = noper_trietype;
4603                                     }
4604                                 } else {
4605                                     if ( trietype == NOTHING )
4606                                         trietype = noper_trietype;
4607                                     last = cur;
4608                                 }
4609                                 if (first)
4610                                     count++;
4611                             } /* end handle mergable triable node */
4612                             else {
4613                                 /* handle unmergable node -
4614                                  * noper may either be a triable node which can
4615                                  * not be tried together with the current trie,
4616                                  * or a non triable node */
4617                                 if ( last ) {
4618                                     /* If last is set and trietype is not
4619                                      * NOTHING then we have found at least two
4620                                      * triable branch sequences in a row of a
4621                                      * similar trietype so we can turn them
4622                                      * into a trie. If/when we allow NOTHING to
4623                                      * start a trie sequence this condition
4624                                      * will be required, and it isn't expensive
4625                                      * so we leave it in for now. */
4626                                     if ( trietype && trietype != NOTHING )
4627                                         make_trie( pRExC_state,
4628                                                 startbranch, first, cur, tail,
4629                                                 count, trietype, depth+1 );
4630                                     last = NULL; /* note: we clear/update
4631                                                     first, trietype etc below,
4632                                                     so we dont do it here */
4633                                 }
4634                                 if ( noper_trietype
4635 #ifdef NOJUMPTRIE
4636                                      && noper_next >= tail
4637 #endif
4638                                 ){
4639                                     /* noper is triable, so we can start a new
4640                                      * trie sequence */
4641                                     count = 1;
4642                                     first = cur;
4643                                     trietype = noper_trietype;
4644                                 } else if (first) {
4645                                     /* if we already saw a first but the
4646                                      * current node is not triable then we have
4647                                      * to reset the first information. */
4648                                     count = 0;
4649                                     first = NULL;
4650                                     trietype = 0;
4651                                 }
4652                             } /* end handle unmergable node */
4653                         } /* loop over branches */
4654                         DEBUG_TRIE_COMPILE_r({
4655                             regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4656                             Perl_re_indentf( aTHX_  "- %s (%d) <SCAN FINISHED> ",
4657                               depth+1, SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4658                             Perl_re_printf( aTHX_  "(First==%d, Last==%d, Cur==%d, tt==%s)\n",
4659                                REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
4660                                PL_reg_name[trietype]
4661                             );
4662
4663                         });
4664                         if ( last && trietype ) {
4665                             if ( trietype != NOTHING ) {
4666                                 /* the last branch of the sequence was part of
4667                                  * a trie, so we have to construct it here
4668                                  * outside of the loop */
4669                                 made= make_trie( pRExC_state, startbranch,
4670                                                  first, scan, tail, count,
4671                                                  trietype, depth+1 );
4672 #ifdef TRIE_STUDY_OPT
4673                                 if ( ((made == MADE_EXACT_TRIE &&
4674                                      startbranch == first)
4675                                      || ( first_non_open == first )) &&
4676                                      depth==0 ) {
4677                                     flags |= SCF_TRIE_RESTUDY;
4678                                     if ( startbranch == first
4679                                          && scan >= tail )
4680                                     {
4681                                         RExC_seen &=~REG_TOP_LEVEL_BRANCHES_SEEN;
4682                                     }
4683                                 }
4684 #endif
4685                             } else {
4686                                 /* at this point we know whatever we have is a
4687                                  * NOTHING sequence/branch AND if 'startbranch'
4688                                  * is 'first' then we can turn the whole thing
4689                                  * into a NOTHING
4690                                  */
4691                                 if ( startbranch == first ) {
4692                                     regnode *opt;
4693                                     /* the entire thing is a NOTHING sequence,
4694                                      * something like this: (?:|) So we can
4695                                      * turn it into a plain NOTHING op. */
4696                                     DEBUG_TRIE_COMPILE_r({
4697                                         regprop(RExC_rx, RExC_mysv, cur, NULL, pRExC_state);
4698                                         Perl_re_indentf( aTHX_  "- %s (%d) <NOTHING BRANCH SEQUENCE>\n",
4699                                           depth+1,
4700                                           SvPV_nolen_const( RExC_mysv ),REG_NODE_NUM(cur));
4701
4702                                     });
4703                                     OP(startbranch)= NOTHING;
4704                                     NEXT_OFF(startbranch)= tail - startbranch;
4705                                     for ( opt= startbranch + 1; opt < tail ; opt++ )
4706                                         OP(opt)= OPTIMIZED;
4707                                 }
4708                             }
4709                         } /* end if ( last) */
4710                     } /* TRIE_MAXBUF is non zero */
4711
4712                 } /* do trie */
4713
4714             }
4715             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
4716                 scan = NEXTOPER(NEXTOPER(scan));
4717             } else                      /* single branch is optimized. */
4718                 scan = NEXTOPER(scan);
4719             continue;
4720         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) {
4721             I32 paren = 0;
4722             regnode *start = NULL;
4723             regnode *end = NULL;
4724             U32 my_recursed_depth= recursed_depth;
4725
4726             if (OP(scan) != SUSPEND) { /* GOSUB */
4727                 /* Do setup, note this code has side effects beyond
4728                  * the rest of this block. Specifically setting
4729                  * RExC_recurse[] must happen at least once during
4730                  * study_chunk(). */
4731                 paren = ARG(scan);
4732                 RExC_recurse[ARG2L(scan)] = scan;
4733                 start = RExC_open_parens[paren];
4734                 end   = RExC_close_parens[paren];
4735
4736                 /* NOTE we MUST always execute the above code, even
4737                  * if we do nothing with a GOSUB */
4738                 if (
4739                     ( flags & SCF_IN_DEFINE )
4740                     ||
4741                     (
4742                         (is_inf_internal || is_inf || (data && data->flags & SF_IS_INF))
4743                         &&
4744                         ( (flags & (SCF_DO_STCLASS | SCF_DO_SUBSTR)) == 0 )
4745                     )
4746                 ) {
4747                     /* no need to do anything here if we are in a define. */
4748                     /* or we are after some kind of infinite construct
4749                      * so we can skip recursing into this item.
4750                      * Since it is infinite we will not change the maxlen
4751                      * or delta, and if we miss something that might raise
4752                      * the minlen it will merely pessimise a little.
4753                      *
4754                      * Iow /(?(DEFINE)(?<foo>foo|food))a+(?&foo)/
4755                      * might result in a minlen of 1 and not of 4,
4756                      * but this doesn't make us mismatch, just try a bit
4757                      * harder than we should.
4758                      * */
4759                     scan= regnext(scan);
4760                     continue;
4761                 }
4762
4763                 if (
4764                     !recursed_depth
4765                     ||
4766                     !PAREN_TEST(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes), paren)
4767                 ) {
4768                     /* it is quite possible that there are more efficient ways
4769                      * to do this. We maintain a bitmap per level of recursion
4770                      * of which patterns we have entered so we can detect if a
4771                      * pattern creates a possible infinite loop. When we
4772                      * recurse down a level we copy the previous levels bitmap
4773                      * down. When we are at recursion level 0 we zero the top
4774                      * level bitmap. It would be nice to implement a different
4775                      * more efficient way of doing this. In particular the top
4776                      * level bitmap may be unnecessary.
4777                      */
4778                     if (!recursed_depth) {
4779                         Zero(RExC_study_chunk_recursed, RExC_study_chunk_recursed_bytes, U8);
4780                     } else {
4781                         Copy(RExC_study_chunk_recursed + ((recursed_depth-1) * RExC_study_chunk_recursed_bytes),
4782                              RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes),
4783                              RExC_study_chunk_recursed_bytes, U8);
4784                     }
4785                     /* we havent recursed into this paren yet, so recurse into it */
4786                     DEBUG_STUDYDATA("gosub-set:", data,depth);
4787                     PAREN_SET(RExC_study_chunk_recursed + (recursed_depth * RExC_study_chunk_recursed_bytes), paren);
4788                     my_recursed_depth= recursed_depth + 1;
4789                 } else {
4790                     DEBUG_STUDYDATA("gosub-inf:", data,depth);
4791                     /* some form of infinite recursion, assume infinite length
4792                      * */
4793                     if (flags & SCF_DO_SUBSTR) {
4794                         scan_commit(pRExC_state, data, minlenp, is_inf);
4795                         data->longest = &(data->longest_float);
4796                     }
4797                     is_inf = is_inf_internal = 1;
4798                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4799                         ssc_anything(data->start_class);
4800                     flags &= ~SCF_DO_STCLASS;
4801
4802                     start= NULL; /* reset start so we dont recurse later on. */
4803                 }
4804             } else {
4805                 paren = stopparen;
4806                 start = scan + 2;
4807                 end = regnext(scan);
4808             }
4809             if (start) {
4810                 scan_frame *newframe;
4811                 assert(end);
4812                 if (!RExC_frame_last) {
4813                     Newxz(newframe, 1, scan_frame);
4814                     SAVEDESTRUCTOR_X(S_unwind_scan_frames, newframe);
4815                     RExC_frame_head= newframe;
4816                     RExC_frame_count++;
4817                 } else if (!RExC_frame_last->next_frame) {
4818                     Newxz(newframe,1,scan_frame);
4819                     RExC_frame_last->next_frame= newframe;
4820                     newframe->prev_frame= RExC_frame_last;
4821                     RExC_frame_count++;
4822                 } else {
4823                     newframe= RExC_frame_last->next_frame;
4824                 }
4825                 RExC_frame_last= newframe;
4826
4827                 newframe->next_regnode = regnext(scan);
4828                 newframe->last_regnode = last;
4829                 newframe->stopparen = stopparen;
4830                 newframe->prev_recursed_depth = recursed_depth;
4831                 newframe->this_prev_frame= frame;
4832
4833                 DEBUG_STUDYDATA("frame-new:",data,depth);
4834                 DEBUG_PEEP("fnew", scan, depth);
4835
4836                 frame = newframe;
4837                 scan =  start;
4838                 stopparen = paren;
4839                 last = end;
4840                 depth = depth + 1;
4841                 recursed_depth= my_recursed_depth;
4842
4843                 continue;
4844             }
4845         }
4846         else if (OP(scan) == EXACT || OP(scan) == EXACTL) {
4847             SSize_t l = STR_LEN(scan);
4848             UV uc;
4849             if (UTF) {
4850                 const U8 * const s = (U8*)STRING(scan);
4851                 uc = utf8_to_uvchr_buf(s, s + l, NULL);
4852                 l = utf8_length(s, s + l);
4853             } else {
4854                 uc = *((U8*)STRING(scan));
4855             }
4856             min += l;
4857             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
4858                 /* The code below prefers earlier match for fixed
4859                    offset, later match for variable offset.  */
4860                 if (data->last_end == -1) { /* Update the start info. */
4861                     data->last_start_min = data->pos_min;
4862                     data->last_start_max = is_inf
4863                         ? SSize_t_MAX : data->pos_min + data->pos_delta;
4864                 }
4865                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
4866                 if (UTF)
4867                     SvUTF8_on(data->last_found);
4868                 {
4869                     SV * const sv = data->last_found;
4870                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4871                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4872                     if (mg && mg->mg_len >= 0)
4873                         mg->mg_len += utf8_length((U8*)STRING(scan),
4874                                               (U8*)STRING(scan)+STR_LEN(scan));
4875                 }
4876                 data->last_end = data->pos_min + l;
4877                 data->pos_min += l; /* As in the first entry. */
4878                 data->flags &= ~SF_BEFORE_EOL;
4879             }
4880
4881             /* ANDing the code point leaves at most it, and not in locale, and
4882              * can't match null string */
4883             if (flags & SCF_DO_STCLASS_AND) {
4884                 ssc_cp_and(data->start_class, uc);
4885                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4886                 ssc_clear_locale(data->start_class);
4887             }
4888             else if (flags & SCF_DO_STCLASS_OR) {
4889                 ssc_add_cp(data->start_class, uc);
4890                 ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4891
4892                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4893                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4894             }
4895             flags &= ~SCF_DO_STCLASS;
4896         }
4897         else if (PL_regkind[OP(scan)] == EXACT) {
4898             /* But OP != EXACT!, so is EXACTFish */
4899             SSize_t l = STR_LEN(scan);
4900             const U8 * s = (U8*)STRING(scan);
4901
4902             /* Search for fixed substrings supports EXACT only. */
4903             if (flags & SCF_DO_SUBSTR) {
4904                 assert(data);
4905                 scan_commit(pRExC_state, data, minlenp, is_inf);
4906             }
4907             if (UTF) {
4908                 l = utf8_length(s, s + l);
4909             }
4910             if (unfolded_multi_char) {
4911                 RExC_seen |= REG_UNFOLDED_MULTI_SEEN;
4912             }
4913             min += l - min_subtract;
4914             assert (min >= 0);
4915             delta += min_subtract;
4916             if (flags & SCF_DO_SUBSTR) {
4917                 data->pos_min += l - min_subtract;
4918                 if (data->pos_min < 0) {
4919                     data->pos_min = 0;
4920                 }
4921                 data->pos_delta += min_subtract;
4922                 if (min_subtract) {
4923                     data->longest = &(data->longest_float);
4924                 }
4925             }
4926
4927             if (flags & SCF_DO_STCLASS) {
4928                 SV* EXACTF_invlist = _make_exactf_invlist(pRExC_state, scan);
4929
4930                 assert(EXACTF_invlist);
4931                 if (flags & SCF_DO_STCLASS_AND) {
4932                     if (OP(scan) != EXACTFL)
4933                         ssc_clear_locale(data->start_class);
4934                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4935                     ANYOF_POSIXL_ZERO(data->start_class);
4936                     ssc_intersection(data->start_class, EXACTF_invlist, FALSE);
4937                 }
4938                 else {  /* SCF_DO_STCLASS_OR */
4939                     ssc_union(data->start_class, EXACTF_invlist, FALSE);
4940                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
4941
4942                     /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
4943                     ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
4944                 }
4945                 flags &= ~SCF_DO_STCLASS;
4946                 SvREFCNT_dec(EXACTF_invlist);
4947             }
4948         }
4949         else if (REGNODE_VARIES(OP(scan))) {
4950             SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0;
4951             I32 fl = 0, f = flags;
4952             regnode * const oscan = scan;
4953             regnode_ssc this_class;
4954             regnode_ssc *oclass = NULL;
4955             I32 next_is_eval = 0;
4956
4957             switch (PL_regkind[OP(scan)]) {
4958             case WHILEM:                /* End of (?:...)* . */
4959                 scan = NEXTOPER(scan);
4960                 goto finish;
4961             case PLUS:
4962                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
4963                     next = NEXTOPER(scan);
4964                     if (OP(next) == EXACT
4965                         || OP(next) == EXACTL
4966                         || (flags & SCF_DO_STCLASS))
4967                     {
4968                         mincount = 1;
4969                         maxcount = REG_INFTY;
4970                         next = regnext(scan);
4971                         scan = NEXTOPER(scan);
4972                         goto do_curly;
4973                     }
4974                 }
4975                 if (flags & SCF_DO_SUBSTR)
4976                     data->pos_min++;
4977                 min++;
4978                 /* FALLTHROUGH */
4979             case STAR:
4980                 if (flags & SCF_DO_STCLASS) {
4981                     mincount = 0;
4982                     maxcount = REG_INFTY;
4983                     next = regnext(scan);
4984                     scan = NEXTOPER(scan);
4985                     goto do_curly;
4986                 }
4987                 if (flags & SCF_DO_SUBSTR) {
4988                     scan_commit(pRExC_state, data, minlenp, is_inf);
4989                     /* Cannot extend fixed substrings */
4990                     data->longest = &(data->longest_float);
4991                 }
4992                 is_inf = is_inf_internal = 1;
4993                 scan = regnext(scan);
4994                 goto optimize_curly_tail;
4995             case CURLY:
4996                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
4997                     && (scan->flags == stopparen))
4998                 {
4999                     mincount = 1;
5000                     maxcount = 1;
5001                 } else {
5002                     mincount = ARG1(scan);
5003                     maxcount = ARG2(scan);
5004                 }
5005                 next = regnext(scan);
5006                 if (OP(scan) == CURLYX) {
5007                     I32 lp = (data ? *(data->last_closep) : 0);
5008                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
5009                 }
5010                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
5011                 next_is_eval = (OP(scan) == EVAL);
5012               do_curly:
5013                 if (flags & SCF_DO_SUBSTR) {
5014                     if (mincount == 0)
5015                         scan_commit(pRExC_state, data, minlenp, is_inf);
5016                     /* Cannot extend fixed substrings */
5017                     pos_before = data->pos_min;
5018                 }
5019                 if (data) {
5020                     fl = data->flags;
5021                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
5022                     if (is_inf)
5023                         data->flags |= SF_IS_INF;
5024                 }
5025                 if (flags & SCF_DO_STCLASS) {
5026                     ssc_init(pRExC_state, &this_class);
5027                     oclass = data->start_class;
5028                     data->start_class = &this_class;
5029                     f |= SCF_DO_STCLASS_AND;
5030                     f &= ~SCF_DO_STCLASS_OR;
5031                 }
5032                 /* Exclude from super-linear cache processing any {n,m}
5033                    regops for which the combination of input pos and regex
5034                    pos is not enough information to determine if a match
5035                    will be possible.
5036
5037                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
5038                    regex pos at the \s*, the prospects for a match depend not
5039                    only on the input position but also on how many (bar\s*)
5040                    repeats into the {4,8} we are. */
5041                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
5042                     f &= ~SCF_WHILEM_VISITED_POS;
5043
5044                 /* This will finish on WHILEM, setting scan, or on NULL: */
5045                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
5046                                   last, data, stopparen, recursed_depth, NULL,
5047                                   (mincount == 0
5048                                    ? (f & ~SCF_DO_SUBSTR)
5049                                    : f)
5050                                   ,depth+1);
5051
5052                 if (flags & SCF_DO_STCLASS)
5053                     data->start_class = oclass;
5054                 if (mincount == 0 || minnext == 0) {
5055                     if (flags & SCF_DO_STCLASS_OR) {
5056                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5057                     }
5058                     else if (flags & SCF_DO_STCLASS_AND) {
5059                         /* Switch to OR mode: cache the old value of
5060                          * data->start_class */
5061                         INIT_AND_WITHP;
5062                         StructCopy(data->start_class, and_withp, regnode_ssc);
5063                         flags &= ~SCF_DO_STCLASS_AND;
5064                         StructCopy(&this_class, data->start_class, regnode_ssc);
5065                         flags |= SCF_DO_STCLASS_OR;
5066                         ANYOF_FLAGS(data->start_class)
5067                                                 |= SSC_MATCHES_EMPTY_STRING;
5068                     }
5069                 } else {                /* Non-zero len */
5070                     if (flags & SCF_DO_STCLASS_OR) {
5071                         ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5072                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5073                     }
5074                     else if (flags & SCF_DO_STCLASS_AND)
5075                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class);
5076                     flags &= ~SCF_DO_STCLASS;
5077                 }
5078                 if (!scan)              /* It was not CURLYX, but CURLY. */
5079                     scan = next;
5080                 if (!(flags & SCF_TRIE_DOING_RESTUDY)
5081                     /* ? quantifier ok, except for (?{ ... }) */
5082                     && (next_is_eval || !(mincount == 0 && maxcount == 1))
5083                     && (minnext == 0) && (deltanext == 0)
5084                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
5085                     && maxcount <= REG_INFTY/3) /* Complement check for big
5086                                                    count */
5087                 {
5088                     /* Fatal warnings may leak the regexp without this: */
5089                     SAVEFREESV(RExC_rx_sv);
5090                     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
5091                         "Quantifier unexpected on zero-length expression "
5092                         "in regex m/%" UTF8f "/",
5093                          UTF8fARG(UTF, RExC_precomp_end - RExC_precomp,
5094                                   RExC_precomp));
5095                     (void)ReREFCNT_inc(RExC_rx_sv);
5096                 }
5097
5098                 min += minnext * mincount;
5099                 is_inf_internal |= deltanext == SSize_t_MAX
5100                          || (maxcount == REG_INFTY && minnext + deltanext > 0);
5101                 is_inf |= is_inf_internal;
5102                 if (is_inf) {
5103                     delta = SSize_t_MAX;
5104                 } else {
5105                     delta += (minnext + deltanext) * maxcount
5106                              - minnext * mincount;
5107                 }
5108                 /* Try powerful optimization CURLYX => CURLYN. */
5109                 if (  OP(oscan) == CURLYX && data
5110                       && data->flags & SF_IN_PAR
5111                       && !(data->flags & SF_HAS_EVAL)
5112                       && !deltanext && minnext == 1 ) {
5113                     /* Try to optimize to CURLYN.  */
5114                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
5115                     regnode * const nxt1 = nxt;
5116 #ifdef DEBUGGING
5117                     regnode *nxt2;
5118 #endif
5119
5120                     /* Skip open. */
5121                     nxt = regnext(nxt);
5122                     if (!REGNODE_SIMPLE(OP(nxt))
5123                         && !(PL_regkind[OP(nxt)] == EXACT
5124                              && STR_LEN(nxt) == 1))
5125                         goto nogo;
5126 #ifdef DEBUGGING
5127                     nxt2 = nxt;
5128 #endif
5129                     nxt = regnext(nxt);
5130                     if (OP(nxt) != CLOSE)
5131                         goto nogo;
5132                     if (RExC_open_parens) {
5133                         RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5134                         RExC_close_parens[ARG(nxt1)]=nxt+2; /*close->while*/
5135                     }
5136                     /* Now we know that nxt2 is the only contents: */
5137                     oscan->flags = (U8)ARG(nxt);
5138                     OP(oscan) = CURLYN;
5139                     OP(nxt1) = NOTHING; /* was OPEN. */
5140
5141 #ifdef DEBUGGING
5142                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5143                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
5144                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
5145                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
5146                     OP(nxt + 1) = OPTIMIZED; /* was count. */
5147                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
5148 #endif
5149                 }
5150               nogo:
5151
5152                 /* Try optimization CURLYX => CURLYM. */
5153                 if (  OP(oscan) == CURLYX && data
5154                       && !(data->flags & SF_HAS_PAR)
5155                       && !(data->flags & SF_HAS_EVAL)
5156                       && !deltanext     /* atom is fixed width */
5157                       && minnext != 0   /* CURLYM can't handle zero width */
5158
5159                          /* Nor characters whose fold at run-time may be
5160                           * multi-character */
5161                       && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN)
5162                 ) {
5163                     /* XXXX How to optimize if data == 0? */
5164                     /* Optimize to a simpler form.  */
5165                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
5166                     regnode *nxt2;
5167
5168                     OP(oscan) = CURLYM;
5169                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
5170                             && (OP(nxt2) != WHILEM))
5171                         nxt = nxt2;
5172                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
5173                     /* Need to optimize away parenths. */
5174                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
5175                         /* Set the parenth number.  */
5176                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
5177
5178                         oscan->flags = (U8)ARG(nxt);
5179                         if (RExC_open_parens) {
5180                             RExC_open_parens[ARG(nxt1)]=oscan; /*open->CURLYM*/
5181                             RExC_close_parens[ARG(nxt1)]=nxt2+1; /*close->NOTHING*/
5182                         }
5183                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
5184                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
5185
5186 #ifdef DEBUGGING
5187                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
5188                         OP(nxt + 1) = OPTIMIZED; /* was count. */
5189                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
5190                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
5191 #endif
5192 #if 0
5193                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
5194                             regnode *nnxt = regnext(nxt1);
5195                             if (nnxt == nxt) {
5196                                 if (reg_off_by_arg[OP(nxt1)])
5197                                     ARG_SET(nxt1, nxt2 - nxt1);
5198                                 else if (nxt2 - nxt1 < U16_MAX)
5199                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
5200                                 else
5201                                     OP(nxt) = NOTHING;  /* Cannot beautify */
5202                             }
5203                             nxt1 = nnxt;
5204                         }
5205 #endif
5206                         /* Optimize again: */
5207                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
5208                                     NULL, stopparen, recursed_depth, NULL, 0,depth+1);
5209                     }
5210                     else
5211                         oscan->flags = 0;
5212                 }
5213                 else if ((OP(oscan) == CURLYX)
5214                          && (flags & SCF_WHILEM_VISITED_POS)
5215                          /* See the comment on a similar expression above.
5216                             However, this time it's not a subexpression
5217                             we care about, but the expression itself. */
5218                          && (maxcount == REG_INFTY)
5219                          && data && ++data->whilem_c < 16) {
5220                     /* This stays as CURLYX, we can put the count/of pair. */
5221                     /* Find WHILEM (as in regexec.c) */
5222                     regnode *nxt = oscan + NEXT_OFF(oscan);
5223
5224                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
5225                         nxt += ARG(nxt);
5226                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
5227                         | (RExC_whilem_seen << 4)); /* On WHILEM */
5228                 }
5229                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
5230                     pars++;
5231                 if (flags & SCF_DO_SUBSTR) {
5232                     SV *last_str = NULL;
5233                     STRLEN last_chrs = 0;
5234                     int counted = mincount != 0;
5235
5236                     if (data->last_end > 0 && mincount != 0) { /* Ends with a
5237                                                                   string. */
5238                         SSize_t b = pos_before >= data->last_start_min
5239                             ? pos_before : data->last_start_min;
5240                         STRLEN l;
5241                         const char * const s = SvPV_const(data->last_found, l);
5242                         SSize_t old = b - data->last_start_min;
5243
5244                         if (UTF)
5245                             old = utf8_hop((U8*)s, old) - (U8*)s;
5246                         l -= old;
5247                         /* Get the added string: */
5248                         last_str = newSVpvn_utf8(s  + old, l, UTF);
5249                         last_chrs = UTF ? utf8_length((U8*)(s + old),
5250                                             (U8*)(s + old + l)) : l;
5251                         if (deltanext == 0 && pos_before == b) {
5252                             /* What was added is a constant string */
5253                             if (mincount > 1) {
5254
5255                                 SvGROW(last_str, (mincount * l) + 1);
5256                                 repeatcpy(SvPVX(last_str) + l,
5257                                           SvPVX_const(last_str), l,
5258                                           mincount - 1);
5259                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
5260                                 /* Add additional parts. */
5261                                 SvCUR_set(data->last_found,
5262                                           SvCUR(data->last_found) - l);
5263                                 sv_catsv(data->last_found, last_str);
5264                                 {
5265                                     SV * sv = data->last_found;
5266                                     MAGIC *mg =
5267                                         SvUTF8(sv) && SvMAGICAL(sv) ?
5268                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
5269                                     if (mg && mg->mg_len >= 0)
5270                                         mg->mg_len += last_chrs * (mincount-1);
5271                                 }
5272                                 last_chrs *= mincount;
5273                                 data->last_end += l * (mincount - 1);
5274                             }
5275                         } else {
5276                             /* start offset must point into the last copy */
5277                             data->last_start_min += minnext * (mincount - 1);
5278                             data->last_start_max =
5279                               is_inf
5280                                ? SSize_t_MAX
5281                                : data->last_start_max +
5282                                  (maxcount - 1) * (minnext + data->pos_delta);
5283                         }
5284                     }
5285                     /* It is counted once already... */
5286                     data->pos_min += minnext * (mincount - counted);
5287 #if 0
5288 Perl_re_printf( aTHX_  "counted=%" UVuf " deltanext=%" UVuf
5289                               " SSize_t_MAX=%" UVuf " minnext=%" UVuf
5290                               " maxcount=%" UVuf " mincount=%" UVuf "\n",
5291     (UV)counted, (UV)deltanext, (UV)SSize_t_MAX, (UV)minnext, (UV)maxcount,
5292     (UV)mincount);
5293 if (deltanext != SSize_t_MAX)
5294 Perl_re_printf( aTHX_  "LHS=%" UVuf " RHS=%" UVuf "\n",
5295     (UV)(-counted * deltanext + (minnext + deltanext) * maxcount
5296           - minnext * mincount), (UV)(SSize_t_MAX - data->pos_delta));
5297 #endif
5298                     if (deltanext == SSize_t_MAX
5299                         || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= SSize_t_MAX - data->pos_delta)
5300                         data->pos_delta = SSize_t_MAX;
5301                     else
5302                         data->pos_delta += - counted * deltanext +
5303                         (minnext + deltanext) * maxcount - minnext * mincount;
5304                     if (mincount != maxcount) {
5305                          /* Cannot extend fixed substrings found inside
5306                             the group.  */
5307                         scan_commit(pRExC_state, data, minlenp, is_inf);
5308                         if (mincount && last_str) {
5309                             SV * const sv = data->last_found;
5310                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
5311                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
5312
5313                             if (mg)
5314                                 mg->mg_len = -1;
5315                             sv_setsv(sv, last_str);
5316                             data->last_end = data->pos_min;
5317                             data->last_start_min = data->pos_min - last_chrs;
5318                             data->last_start_max = is_inf
5319                                 ? SSize_t_MAX
5320                                 : data->pos_min + data->pos_delta - last_chrs;
5321                         }
5322                         data->longest = &(data->longest_float);
5323                     }
5324                     SvREFCNT_dec(last_str);
5325                 }
5326                 if (data && (fl & SF_HAS_EVAL))
5327                     data->flags |= SF_HAS_EVAL;
5328               optimize_curly_tail:
5329                 if (OP(oscan) != CURLYX) {
5330                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
5331                            && NEXT_OFF(next))
5332                         NEXT_OFF(oscan) += NEXT_OFF(next);
5333                 }
5334                 continue;
5335
5336             default:
5337 #ifdef DEBUGGING
5338                 Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d",
5339                                                                     OP(scan));
5340 #endif
5341             case REF:
5342             case CLUMP:
5343                 if (flags & SCF_DO_SUBSTR) {
5344                     /* Cannot expect anything... */
5345                     scan_commit(pRExC_state, data, minlenp, is_inf);
5346                     data->longest = &(data->longest_float);
5347                 }
5348                 is_inf = is_inf_internal = 1;
5349                 if (flags & SCF_DO_STCLASS_OR) {
5350                     if (OP(scan) == CLUMP) {
5351                         /* Actually is any start char, but very few code points
5352                          * aren't start characters */
5353                         ssc_match_all_cp(data->start_class);
5354                     }
5355                     else {
5356                         ssc_anything(data->start_class);
5357                     }
5358                 }
5359                 flags &= ~SCF_DO_STCLASS;
5360                 break;
5361             }
5362         }
5363         else if (OP(scan) == LNBREAK) {
5364             if (flags & SCF_DO_STCLASS) {
5365                 if (flags & SCF_DO_STCLASS_AND) {
5366                     ssc_intersection(data->start_class,
5367                                     PL_XPosix_ptrs[_CC_VERTSPACE], FALSE);
5368                     ssc_clear_locale(data->start_class);
5369                     ANYOF_FLAGS(data->start_class)
5370                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5371                 }
5372                 else if (flags & SCF_DO_STCLASS_OR) {
5373                     ssc_union(data->start_class,
5374                               PL_XPosix_ptrs[_CC_VERTSPACE],
5375                               FALSE);
5376                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5377
5378                     /* See commit msg for
5379                      * 749e076fceedeb708a624933726e7989f2302f6a */
5380                     ANYOF_FLAGS(data->start_class)
5381                                                 &= ~SSC_MATCHES_EMPTY_STRING;
5382                 }
5383                 flags &= ~SCF_DO_STCLASS;
5384             }
5385             min++;
5386             if (delta != SSize_t_MAX)
5387                 delta++;    /* Because of the 2 char string cr-lf */
5388             if (flags & SCF_DO_SUBSTR) {
5389                 /* Cannot expect anything... */
5390                 scan_commit(pRExC_state, data, minlenp, is_inf);
5391                 data->pos_min += 1;
5392                 data->pos_delta += 1;
5393                 data->longest = &(data->longest_float);
5394             }
5395         }
5396         else if (REGNODE_SIMPLE(OP(scan))) {
5397
5398             if (flags & SCF_DO_SUBSTR) {
5399                 scan_commit(pRExC_state, data, minlenp, is_inf);
5400                 data->pos_min++;
5401             }
5402             min++;
5403             if (flags & SCF_DO_STCLASS) {
5404                 bool invert = 0;
5405                 SV* my_invlist = NULL;
5406                 U8 namedclass;
5407
5408                 /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */
5409                 ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING;
5410
5411                 /* Some of the logic below assumes that switching
5412                    locale on will only add false positives. */
5413                 switch (OP(scan)) {
5414
5415                 default:
5416 #ifdef DEBUGGING
5417                    Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d",
5418                                                                      OP(scan));
5419 #endif
5420                 case SANY:
5421                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5422                         ssc_match_all_cp(data->start_class);
5423                     break;
5424
5425                 case REG_ANY:
5426                     {
5427                         SV* REG_ANY_invlist = _new_invlist(2);
5428                         REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist,
5429                                                             '\n');
5430                         if (flags & SCF_DO_STCLASS_OR) {
5431                             ssc_union(data->start_class,
5432                                       REG_ANY_invlist,
5433                                       TRUE /* TRUE => invert, hence all but \n
5434                                             */
5435                                       );
5436                         }
5437                         else if (flags & SCF_DO_STCLASS_AND) {
5438                             ssc_intersection(data->start_class,
5439                                              REG_ANY_invlist,
5440                                              TRUE  /* TRUE => invert */
5441                                              );
5442                             ssc_clear_locale(data->start_class);
5443                         }
5444                         SvREFCNT_dec_NN(REG_ANY_invlist);
5445                     }
5446                     break;
5447
5448                 case ANYOFD:
5449                 case ANYOFL:
5450                 case ANYOF:
5451                     if (flags & SCF_DO_STCLASS_AND)
5452                         ssc_and(pRExC_state, data->start_class,
5453                                 (regnode_charclass *) scan);
5454                     else
5455                         ssc_or(pRExC_state, data->start_class,
5456                                                           (regnode_charclass *) scan);
5457                     break;
5458
5459                 case NPOSIXL:
5460                     invert = 1;
5461                     /* FALLTHROUGH */
5462
5463                 case POSIXL:
5464                     namedclass = classnum_to_namedclass(FLAGS(scan)) + invert;
5465                     if (flags & SCF_DO_STCLASS_AND) {
5466                         bool was_there = cBOOL(
5467                                           ANYOF_POSIXL_TEST(data->start_class,
5468                                                                  namedclass));
5469                         ANYOF_POSIXL_ZERO(data->start_class);
5470                         if (was_there) {    /* Do an AND */
5471                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5472                         }
5473                         /* No individual code points can now match */
5474                         data->start_class->invlist
5475                                                 = sv_2mortal(_new_invlist(0));
5476                     }
5477                     else {
5478                         int complement = namedclass + ((invert) ? -1 : 1);
5479
5480                         assert(flags & SCF_DO_STCLASS_OR);
5481
5482                         /* If the complement of this class was already there,
5483                          * the result is that they match all code points,
5484                          * (\d + \D == everything).  Remove the classes from
5485                          * future consideration.  Locale is not relevant in
5486                          * this case */
5487                         if (ANYOF_POSIXL_TEST(data->start_class, complement)) {
5488                             ssc_match_all_cp(data->start_class);
5489                             ANYOF_POSIXL_CLEAR(data->start_class, namedclass);
5490                             ANYOF_POSIXL_CLEAR(data->start_class, complement);
5491                         }
5492                         else {  /* The usual case; just add this class to the
5493                                    existing set */
5494                             ANYOF_POSIXL_SET(data->start_class, namedclass);
5495                         }
5496                     }
5497                     break;
5498
5499                 case NPOSIXA:   /* For these, we always know the exact set of
5500                                    what's matched */
5501                     invert = 1;
5502                     /* FALLTHROUGH */
5503                 case POSIXA:
5504                     if (FLAGS(scan) == _CC_ASCII) {
5505                         my_invlist = invlist_clone(PL_XPosix_ptrs[_CC_ASCII]);
5506                     }
5507                     else {
5508                         _invlist_intersection(PL_XPosix_ptrs[FLAGS(scan)],
5509                                               PL_XPosix_ptrs[_CC_ASCII],
5510                                               &my_invlist);
5511                     }
5512                     goto join_posix;
5513
5514                 case NPOSIXD:
5515                 case NPOSIXU:
5516                     invert = 1;
5517                     /* FALLTHROUGH */
5518                 case POSIXD:
5519                 case POSIXU:
5520                     my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)]);
5521
5522                     /* NPOSIXD matches all upper Latin1 code points unless the
5523                      * target string being matched is UTF-8, which is
5524                      * unknowable until match time.  Since we are going to
5525                      * invert, we want to get rid of all of them so that the
5526                      * inversion will match all */
5527                     if (OP(scan) == NPOSIXD) {
5528                         _invlist_subtract(my_invlist, PL_UpperLatin1,
5529                                           &my_invlist);
5530                     }
5531
5532                   join_posix:
5533
5534                     if (flags & SCF_DO_STCLASS_AND) {
5535                         ssc_intersection(data->start_class, my_invlist, invert);
5536                         ssc_clear_locale(data->start_class);
5537                     }
5538                     else {
5539                         assert(flags & SCF_DO_STCLASS_OR);
5540                         ssc_union(data->start_class, my_invlist, invert);
5541                     }
5542                     SvREFCNT_dec(my_invlist);
5543                 }
5544                 if (flags & SCF_DO_STCLASS_OR)
5545                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5546                 flags &= ~SCF_DO_STCLASS;
5547             }
5548         }
5549         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
5550             data->flags |= (OP(scan) == MEOL
5551                             ? SF_BEFORE_MEOL
5552                             : SF_BEFORE_SEOL);
5553             scan_commit(pRExC_state, data, minlenp, is_inf);
5554
5555         }
5556         else if (  PL_regkind[OP(scan)] == BRANCHJ
5557                  /* Lookbehind, or need to calculate parens/evals/stclass: */
5558                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
5559                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM))
5560         {
5561             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5562                 || OP(scan) == UNLESSM )
5563             {
5564                 /* Negative Lookahead/lookbehind
5565                    In this case we can't do fixed string optimisation.
5566                 */
5567
5568                 SSize_t deltanext, minnext, fake = 0;
5569                 regnode *nscan;
5570                 regnode_ssc intrnl;
5571                 int f = 0;
5572
5573                 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5574                 if (data) {
5575                     data_fake.whilem_c = data->whilem_c;
5576                     data_fake.last_closep = data->last_closep;
5577                 }
5578                 else
5579                     data_fake.last_closep = &fake;
5580                 data_fake.pos_delta = delta;
5581                 if ( flags & SCF_DO_STCLASS && !scan->flags
5582                      && OP(scan) == IFMATCH ) { /* Lookahead */
5583                     ssc_init(pRExC_state, &intrnl);
5584                     data_fake.start_class = &intrnl;
5585                     f |= SCF_DO_STCLASS_AND;
5586                 }
5587                 if (flags & SCF_WHILEM_VISITED_POS)
5588                     f |= SCF_WHILEM_VISITED_POS;
5589                 next = regnext(scan);
5590                 nscan = NEXTOPER(NEXTOPER(scan));
5591                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
5592                                       last, &data_fake, stopparen,
5593                                       recursed_depth, NULL, f, depth+1);
5594                 if (scan->flags) {
5595                     if (deltanext) {
5596                         FAIL("Variable length lookbehind not implemented");
5597                     }
5598                     else if (minnext > (I32)U8_MAX) {
5599                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5600                               (UV)U8_MAX);
5601                     }
5602                     scan->flags = (U8)minnext;
5603                 }
5604                 if (data) {
5605                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5606                         pars++;
5607                     if (data_fake.flags & SF_HAS_EVAL)
5608                         data->flags |= SF_HAS_EVAL;
5609                     data->whilem_c = data_fake.whilem_c;
5610                 }
5611                 if (f & SCF_DO_STCLASS_AND) {
5612                     if (flags & SCF_DO_STCLASS_OR) {
5613                         /* OR before, AND after: ideally we would recurse with
5614                          * data_fake to get the AND applied by study of the
5615                          * remainder of the pattern, and then derecurse;
5616                          * *** HACK *** for now just treat as "no information".
5617                          * See [perl #56690].
5618                          */
5619                         ssc_init(pRExC_state, data->start_class);
5620                     }  else {
5621                         /* AND before and after: combine and continue.  These
5622                          * assertions are zero-length, so can match an EMPTY
5623                          * string */
5624                         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5625                         ANYOF_FLAGS(data->start_class)
5626                                                    |= SSC_MATCHES_EMPTY_STRING;
5627                     }
5628                 }
5629             }
5630 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
5631             else {
5632                 /* Positive Lookahead/lookbehind
5633                    In this case we can do fixed string optimisation,
5634                    but we must be careful about it. Note in the case of
5635                    lookbehind the positions will be offset by the minimum
5636                    length of the pattern, something we won't know about
5637                    until after the recurse.
5638                 */
5639                 SSize_t deltanext, fake = 0;
5640                 regnode *nscan;
5641                 regnode_ssc intrnl;
5642                 int f = 0;
5643                 /* We use SAVEFREEPV so that when the full compile
5644                     is finished perl will clean up the allocated
5645                     minlens when it's all done. This way we don't
5646                     have to worry about freeing them when we know
5647                     they wont be used, which would be a pain.
5648                  */
5649                 SSize_t *minnextp;
5650                 Newx( minnextp, 1, SSize_t );
5651                 SAVEFREEPV(minnextp);
5652
5653                 if (data) {
5654                     StructCopy(data, &data_fake, scan_data_t);
5655                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
5656                         f |= SCF_DO_SUBSTR;
5657                         if (scan->flags)
5658                             scan_commit(pRExC_state, &data_fake, minlenp, is_inf);
5659                         data_fake.last_found=newSVsv(data->last_found);
5660                     }
5661                 }
5662                 else
5663                     data_fake.last_closep = &fake;
5664                 data_fake.flags = 0;
5665                 data_fake.pos_delta = delta;
5666                 if (is_inf)
5667                     data_fake.flags |= SF_IS_INF;
5668                 if ( flags & SCF_DO_STCLASS && !scan->flags
5669                      && OP(scan) == IFMATCH ) { /* Lookahead */
5670                     ssc_init(pRExC_state, &intrnl);
5671                     data_fake.start_class = &intrnl;
5672                     f |= SCF_DO_STCLASS_AND;
5673                 }
5674                 if (flags & SCF_WHILEM_VISITED_POS)
5675                     f |= SCF_WHILEM_VISITED_POS;
5676                 next = regnext(scan);
5677                 nscan = NEXTOPER(NEXTOPER(scan));
5678
5679                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp,
5680                                         &deltanext, last, &data_fake,
5681                                         stopparen, recursed_depth, NULL,
5682                                         f,depth+1);
5683                 if (scan->flags) {
5684                     if (deltanext) {
5685                         FAIL("Variable length lookbehind not implemented");
5686                     }
5687                     else if (*minnextp > (I32)U8_MAX) {
5688                         FAIL2("Lookbehind longer than %" UVuf " not implemented",
5689                               (UV)U8_MAX);
5690                     }
5691                     scan->flags = (U8)*minnextp;
5692                 }
5693
5694                 *minnextp += min;
5695
5696                 if (f & SCF_DO_STCLASS_AND) {
5697                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl);
5698                     ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING;
5699                 }
5700                 if (data) {
5701                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5702                         pars++;
5703                     if (data_fake.flags & SF_HAS_EVAL)
5704                         data->flags |= SF_HAS_EVAL;
5705                     data->whilem_c = data_fake.whilem_c;
5706                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
5707                         if (RExC_rx->minlen<*minnextp)
5708                             RExC_rx->minlen=*minnextp;
5709                         scan_commit(pRExC_state, &data_fake, minnextp, is_inf);
5710                         SvREFCNT_dec_NN(data_fake.last_found);
5711
5712                         if ( data_fake.minlen_fixed != minlenp )
5713                         {
5714                             data->offset_fixed= data_fake.offset_fixed;
5715                             data->minlen_fixed= data_fake.minlen_fixed;
5716                             data->lookbehind_fixed+= scan->flags;
5717                         }
5718                         if ( data_fake.minlen_float != minlenp )
5719                         {
5720                             data->minlen_float= data_fake.minlen_float;
5721                             data->offset_float_min=data_fake.offset_float_min;
5722                             data->offset_float_max=data_fake.offset_float_max;
5723                             data->lookbehind_float+= scan->flags;
5724                         }
5725                     }
5726                 }
5727             }
5728 #endif
5729         }
5730         else if (OP(scan) == OPEN) {
5731             if (stopparen != (I32)ARG(scan))
5732                 pars++;
5733         }
5734         else if (OP(scan) == CLOSE) {
5735             if (stopparen == (I32)ARG(scan)) {
5736                 break;
5737             }
5738             if ((I32)ARG(scan) == is_par) {
5739                 next = regnext(scan);
5740
5741                 if ( next && (OP(next) != WHILEM) && next < last)
5742                     is_par = 0;         /* Disable optimization */
5743             }
5744             if (data)
5745                 *(data->last_closep) = ARG(scan);
5746         }
5747         else if (OP(scan) == EVAL) {
5748                 if (data)
5749                     data->flags |= SF_HAS_EVAL;
5750         }
5751         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
5752             if (flags & SCF_DO_SUBSTR) {
5753                 scan_commit(pRExC_state, data, minlenp, is_inf);
5754                 flags &= ~SCF_DO_SUBSTR;
5755             }
5756             if (data && OP(scan)==ACCEPT) {
5757                 data->flags |= SCF_SEEN_ACCEPT;
5758                 if (stopmin > min)
5759                     stopmin = min;
5760             }
5761         }
5762         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
5763         {
5764                 if (flags & SCF_DO_SUBSTR) {
5765                     scan_commit(pRExC_state, data, minlenp, is_inf);
5766                     data->longest = &(data->longest_float);
5767                 }
5768                 is_inf = is_inf_internal = 1;
5769                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
5770                     ssc_anything(data->start_class);
5771                 flags &= ~SCF_DO_STCLASS;
5772         }
5773         else if (OP(scan) == GPOS) {
5774             if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) &&
5775                 !(delta || is_inf || (data && data->pos_delta)))
5776             {
5777                 if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR))
5778                     RExC_rx->intflags |= PREGf_ANCH_GPOS;
5779                 if (RExC_rx->gofs < (STRLEN)min)
5780                     RExC_rx->gofs = min;
5781             } else {
5782                 RExC_rx->intflags |= PREGf_GPOS_FLOAT;
5783                 RExC_rx->gofs = 0;
5784             }
5785         }
5786 #ifdef TRIE_STUDY_OPT
5787 #ifdef FULL_TRIE_STUDY
5788         else if (PL_regkind[OP(scan)] == TRIE) {
5789             /* NOTE - There is similar code to this block above for handling
5790                BRANCH nodes on the initial study.  If you change stuff here
5791                check there too. */
5792             regnode *trie_node= scan;
5793             regnode *tail= regnext(scan);
5794             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5795             SSize_t max1 = 0, min1 = SSize_t_MAX;
5796             regnode_ssc accum;
5797
5798             if (flags & SCF_DO_SUBSTR) { /* XXXX Add !SUSPEND? */
5799                 /* Cannot merge strings after this. */
5800                 scan_commit(pRExC_state, data, minlenp, is_inf);
5801             }
5802             if (flags & SCF_DO_STCLASS)
5803                 ssc_init_zero(pRExC_state, &accum);
5804
5805             if (!trie->jump) {
5806                 min1= trie->minlen;
5807                 max1= trie->maxlen;
5808             } else {
5809                 const regnode *nextbranch= NULL;
5810                 U32 word;
5811
5812                 for ( word=1 ; word <= trie->wordcount ; word++)
5813                 {
5814                     SSize_t deltanext=0, minnext=0, f = 0, fake;
5815                     regnode_ssc this_class;
5816
5817                     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
5818                     if (data) {
5819                         data_fake.whilem_c = data->whilem_c;
5820                         data_fake.last_closep = data->last_closep;
5821                     }
5822                     else
5823                         data_fake.last_closep = &fake;
5824                     data_fake.pos_delta = delta;
5825                     if (flags & SCF_DO_STCLASS) {
5826                         ssc_init(pRExC_state, &this_class);
5827                         data_fake.start_class = &this_class;
5828                         f = SCF_DO_STCLASS_AND;
5829                     }
5830                     if (flags & SCF_WHILEM_VISITED_POS)
5831                         f |= SCF_WHILEM_VISITED_POS;
5832
5833                     if (trie->jump[word]) {
5834                         if (!nextbranch)
5835                             nextbranch = trie_node + trie->jump[0];
5836                         scan= trie_node + trie->jump[word];
5837                         /* We go from the jump point to the branch that follows
5838                            it. Note this means we need the vestigal unused
5839                            branches even though they arent otherwise used. */
5840                         minnext = study_chunk(pRExC_state, &scan, minlenp,
5841                             &deltanext, (regnode *)nextbranch, &data_fake,
5842                             stopparen, recursed_depth, NULL, f,depth+1);
5843                     }
5844                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
5845                         nextbranch= regnext((regnode*)nextbranch);
5846
5847                     if (min1 > (SSize_t)(minnext + trie->minlen))
5848                         min1 = minnext + trie->minlen;
5849                     if (deltanext == SSize_t_MAX) {
5850                         is_inf = is_inf_internal = 1;
5851                         max1 = SSize_t_MAX;
5852                     } else if (max1 < (SSize_t)(minnext + deltanext + trie->maxlen))
5853                         max1 = minnext + deltanext + trie->maxlen;
5854
5855                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
5856                         pars++;
5857                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
5858                         if ( stopmin > min + min1)
5859                             stopmin = min + min1;
5860                         flags &= ~SCF_DO_SUBSTR;
5861                         if (data)
5862                             data->flags |= SCF_SEEN_ACCEPT;
5863                     }
5864                     if (data) {
5865                         if (data_fake.flags & SF_HAS_EVAL)
5866                             data->flags |= SF_HAS_EVAL;
5867                         data->whilem_c = data_fake.whilem_c;
5868                     }
5869                     if (flags & SCF_DO_STCLASS)
5870                         ssc_or(pRExC_state, &accum, (regnode_charclass *) &this_class);
5871                 }
5872             }
5873             if (flags & SCF_DO_SUBSTR) {
5874                 data->pos_min += min1;
5875                 data->pos_delta += max1 - min1;
5876                 if (max1 != min1 || is_inf)
5877                     data->longest = &(data->longest_float);
5878             }
5879             min += min1;
5880             if (delta != SSize_t_MAX)
5881                 delta += max1 - min1;
5882             if (flags & SCF_DO_STCLASS_OR) {
5883                 ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5884                 if (min1) {
5885                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5886                     flags &= ~SCF_DO_STCLASS;
5887                 }
5888             }
5889             else if (flags & SCF_DO_STCLASS_AND) {
5890                 if (min1) {
5891                     ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum);
5892                     flags &= ~SCF_DO_STCLASS;
5893                 }
5894                 else {
5895                     /* Switch to OR mode: cache the old value of
5896                      * data->start_class */
5897                     INIT_AND_WITHP;
5898                     StructCopy(data->start_class, and_withp, regnode_ssc);
5899                     flags &= ~SCF_DO_STCLASS_AND;
5900                     StructCopy(&accum, data->start_class, regnode_ssc);
5901                     flags |= SCF_DO_STCLASS_OR;
5902                 }
5903             }
5904             scan= tail;
5905             continue;
5906         }
5907 #else
5908         else if (PL_regkind[OP(scan)] == TRIE) {
5909             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
5910             U8*bang=NULL;
5911
5912             min += trie->minlen;
5913             delta += (trie->maxlen - trie->minlen);
5914             flags &= ~SCF_DO_STCLASS; /* xxx */
5915             if (flags & SCF_DO_SUBSTR) {
5916                 /* Cannot expect anything... */
5917                 scan_commit(pRExC_state, data, minlenp, is_inf);
5918                 data->pos_min += trie->minlen;
5919                 data->pos_delta += (trie->maxlen - trie->minlen);
5920                 if (trie->maxlen != trie->minlen)
5921                     data->longest = &(data->longest_float);
5922             }
5923             if (trie->jump) /* no more substrings -- for now /grr*/
5924                flags &= ~SCF_DO_SUBSTR;
5925         }
5926 #endif /* old or new */
5927 #endif /* TRIE_STUDY_OPT */
5928
5929         /* Else: zero-length, ignore. */
5930         scan = regnext(scan);
5931     }
5932
5933   finish:
5934     if (frame) {
5935         /* we need to unwind recursion. */
5936         depth = depth - 1;
5937
5938         DEBUG_STUDYDATA("frame-end:",data,depth);
5939         DEBUG_PEEP("fend", scan, depth);
5940
5941         /* restore previous context */
5942         last = frame->last_regnode;
5943         scan = frame->next_regnode;
5944         stopparen = frame->stopparen;
5945         recursed_depth = frame->prev_recursed_depth;
5946
5947         RExC_frame_last = frame->prev_frame;
5948         frame = frame->this_prev_frame;
5949         goto fake_study_recurse;
5950     }
5951
5952     assert(!frame);
5953     DEBUG_STUDYDATA("pre-fin:",data,depth);
5954
5955     *scanp = scan;
5956     *deltap = is_inf_internal ? SSize_t_MAX : delta;
5957
5958     if (flags & SCF_DO_SUBSTR && is_inf)
5959         data->pos_delta = SSize_t_MAX - data->pos_min;
5960     if (is_par > (I32)U8_MAX)
5961         is_par = 0;
5962     if (is_par && pars==1 && data) {
5963         data->flags |= SF_IN_PAR;
5964         data->flags &= ~SF_HAS_PAR;
5965     }
5966     else if (pars && data) {
5967         data->flags |= SF_HAS_PAR;
5968         data->flags &= ~SF_IN_PAR;
5969     }
5970     if (flags & SCF_DO_STCLASS_OR)
5971         ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp);
5972     if (flags & SCF_TRIE_RESTUDY)
5973         data->flags |=  SCF_TRIE_RESTUDY;
5974
5975     DEBUG_STUDYDATA("post-fin:",data,depth);
5976
5977     {
5978         SSize_t final_minlen= min < stopmin ? min : stopmin;
5979
5980         if (!(RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)) {
5981             if (final_minlen > SSize_t_MAX - delta)
5982                 RExC_maxlen = SSize_t_MAX;
5983             else if (RExC_maxlen < final_minlen + delta)
5984                 RExC_maxlen = final_minlen + delta;
5985         }
5986         return final_minlen;
5987     }
5988     NOT_REACHED; /* NOTREACHED */
5989 }
5990
5991 STATIC U32
5992 S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n)
5993 {
5994     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
5995
5996     PERL_ARGS_ASSERT_ADD_DATA;
5997
5998     Renewc(RExC_rxi->data,
5999            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
6000            char, struct reg_data);
6001     if(count)
6002         Renew(RExC_rxi->data->what, count + n, U8);
6003     else
6004         Newx(RExC_rxi->data->what, n, U8);
6005     RExC_rxi->data->count = count + n;
6006     Copy(s, RExC_rxi->data->what + count, n, U8);
6007     return count;
6008 }
6009
6010 /*XXX: todo make this not included in a non debugging perl, but appears to be
6011  * used anyway there, in 'use re' */
6012 #ifndef PERL_IN_XSUB_RE
6013 void
6014 Perl_reginitcolors(pTHX)
6015 {
6016     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
6017     if (s) {
6018         char *t = savepv(s);
6019         int i = 0;
6020         PL_colors[0] = t;
6021         while (++i < 6) {
6022             t = strchr(t, '\t');
6023             if (t) {
6024                 *t = '\0';
6025                 PL_colors[i] = ++t;
6026             }
6027             else
6028                 PL_colors[i] = t = (char *)"";
6029         }
6030     } else {
6031         int i = 0;
6032         while (i < 6)
6033             PL_colors[i++] = (char *)"";
6034     }
6035     PL_colorset = 1;
6036 }
6037 #endif
6038
6039
6040 #ifdef TRIE_STUDY_OPT
6041 #define CHECK_RESTUDY_GOTO_butfirst(dOsomething)            \
6042     STMT_START {                                            \
6043         if (                                                \
6044               (data.flags & SCF_TRIE_RESTUDY)               \
6045               && ! restudied++                              \
6046         ) {                                                 \
6047             dOsomething;                                    \
6048             goto reStudy;                                   \
6049         }                                                   \
6050     } STMT_END
6051 #else
6052 #define CHECK_RESTUDY_GOTO_butfirst
6053 #endif
6054
6055 /*
6056  * pregcomp - compile a regular expression into internal code
6057  *
6058  * Decides which engine's compiler to call based on the hint currently in
6059  * scope
6060  */
6061
6062 #ifndef PERL_IN_XSUB_RE
6063
6064 /* return the currently in-scope regex engine (or the default if none)  */
6065
6066 regexp_engine const *
6067 Perl_current_re_engine(pTHX)
6068 {
6069     if (IN_PERL_COMPILETIME) {
6070         HV * const table = GvHV(PL_hintgv);
6071         SV **ptr;
6072
6073         if (!table || !(PL_hints & HINT_LOCALIZE_HH))
6074             return &PL_core_reg_engine;
6075         ptr = hv_fetchs(table, "regcomp", FALSE);
6076         if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
6077             return &PL_core_reg_engine;
6078         return INT2PTR(regexp_engine*,SvIV(*ptr));
6079     }
6080     else {
6081         SV *ptr;
6082         if (!PL_curcop->cop_hints_hash)
6083             return &PL_core_reg_engine;
6084         ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
6085         if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
6086             return &PL_core_reg_engine;
6087         return INT2PTR(regexp_engine*,SvIV(ptr));
6088     }
6089 }
6090
6091
6092 REGEXP *
6093 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
6094 {
6095     regexp_engine const *eng = current_re_engine();
6096     GET_RE_DEBUG_FLAGS_DECL;
6097
6098     PERL_ARGS_ASSERT_PREGCOMP;
6099
6100     /* Dispatch a request to compile a regexp to correct regexp engine. */
6101     DEBUG_COMPILE_r({
6102         Perl_re_printf( aTHX_  "Using engine %" UVxf "\n",
6103                         PTR2UV(eng));
6104     });
6105     return CALLREGCOMP_ENG(eng, pattern, flags);
6106 }
6107 #endif
6108
6109 /* public(ish) entry point for the perl core's own regex compiling code.
6110  * It's actually a wrapper for Perl_re_op_compile that only takes an SV
6111  * pattern rather than a list of OPs, and uses the internal engine rather
6112  * than the current one */
6113
6114 REGEXP *
6115 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
6116 {
6117     SV *pat = pattern; /* defeat constness! */
6118     PERL_ARGS_ASSERT_RE_COMPILE;
6119     return Perl_re_op_compile(aTHX_ &pat, 1, NULL,
6120 #ifdef PERL_IN_XSUB_RE
6121                                 &my_reg_engine,
6122 #else
6123                                 &PL_core_reg_engine,
6124 #endif
6125                                 NULL, NULL, rx_flags, 0);
6126 }
6127
6128
6129 /* upgrade pattern pat_p of length plen_p to UTF8, and if there are code
6130  * blocks, recalculate the indices. Update pat_p and plen_p in-place to
6131  * point to the realloced string and length.
6132  *
6133  * This is essentially a copy of Perl_bytes_to_utf8() with the code index
6134  * stuff added */
6135
6136 static void
6137 S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state,
6138                     char **pat_p, STRLEN *plen_p, int num_code_blocks)
6139 {
6140     U8 *const src = (U8*)*pat_p;
6141     U8 *dst, *d;
6142     int n=0;
6143     STRLEN s = 0;
6144     bool do_end = 0;
6145     GET_RE_DEBUG_FLAGS_DECL;
6146
6147     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6148         "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
6149
6150     Newx(dst, *plen_p * 2 + 1, U8);
6151     d = dst;
6152
6153     while (s < *plen_p) {
6154         append_utf8_from_native_byte(src[s], &d);
6155         if (n < num_code_blocks) {
6156             if (!do_end && pRExC_state->code_blocks[n].start == s) {
6157                 pRExC_state->code_blocks[n].start = d - dst - 1;
6158                 assert(*(d - 1) == '(');
6159                 do_end = 1;
6160             }
6161             else if (do_end && pRExC_state->code_blocks[n].end == s) {
6162                 pRExC_state->code_blocks[n].end = d - dst - 1;
6163                 assert(*(d - 1) == ')');
6164                 do_end = 0;
6165                 n++;
6166             }
6167         }
6168         s++;
6169     }
6170     *d = '\0';
6171     *plen_p = d - dst;
6172     *pat_p = (char*) dst;
6173     SAVEFREEPV(*pat_p);
6174     RExC_orig_utf8 = RExC_utf8 = 1;
6175 }
6176
6177
6178
6179 /* S_concat_pat(): concatenate a list of args to the pattern string pat,
6180  * while recording any code block indices, and handling overloading,
6181  * nested qr// objects etc.  If pat is null, it will allocate a new
6182  * string, or just return the first arg, if there's only one.
6183  *
6184  * Returns the malloced/updated pat.
6185  * patternp and pat_count is the array of SVs to be concatted;
6186  * oplist is the optional list of ops that generated the SVs;
6187  * recompile_p is a pointer to a boolean that will be set if
6188  *   the regex will need to be recompiled.
6189  * delim, if non-null is an SV that will be inserted between each element
6190  */
6191
6192 static SV*
6193 S_concat_pat(pTHX_ RExC_state_t * const pRExC_state,
6194                 SV *pat, SV ** const patternp, int pat_count,
6195                 OP *oplist, bool *recompile_p, SV *delim)
6196 {
6197     SV **svp;
6198     int n = 0;
6199     bool use_delim = FALSE;
6200     bool alloced = FALSE;
6201
6202     /* if we know we have at least two args, create an empty string,
6203      * then concatenate args to that. For no args, return an empty string */
6204     if (!pat && pat_count != 1) {
6205         pat = newSVpvs("");
6206         SAVEFREESV(pat);
6207         alloced = TRUE;
6208     }
6209
6210     for (svp = patternp; svp < patternp + pat_count; svp++) {
6211         SV *sv;
6212         SV *rx  = NULL;
6213         STRLEN orig_patlen = 0;
6214         bool code = 0;
6215         SV *msv = use_delim ? delim : *svp;
6216         if (!msv) msv = &PL_sv_undef;
6217
6218         /* if we've got a delimiter, we go round the loop twice for each
6219          * svp slot (except the last), using the delimiter the second
6220          * time round */
6221         if (use_delim) {
6222             svp--;
6223             use_delim = FALSE;
6224         }
6225         else if (delim)
6226             use_delim = TRUE;
6227
6228         if (SvTYPE(msv) == SVt_PVAV) {
6229             /* we've encountered an interpolated array within
6230              * the pattern, e.g. /...@a..../. Expand the list of elements,
6231              * then recursively append elements.
6232              * The code in this block is based on S_pushav() */
6233
6234             AV *const av = (AV*)msv;
6235             const SSize_t maxarg = AvFILL(av) + 1;
6236             SV **array;
6237
6238             if (oplist) {
6239                 assert(oplist->op_type == OP_PADAV
6240                     || oplist->op_type == OP_RV2AV);
6241                 oplist = OpSIBLING(oplist);
6242             }
6243
6244             if (SvRMAGICAL(av)) {
6245                 SSize_t i;
6246
6247                 Newx(array, maxarg, SV*);
6248                 SAVEFREEPV(array);
6249                 for (i=0; i < maxarg; i++) {
6250                     SV ** const svp = av_fetch(av, i, FALSE);
6251                     array[i] = svp ? *svp : &PL_sv_undef;
6252                 }
6253             }
6254             else
6255                 array = AvARRAY(av);
6256
6257             pat = S_concat_pat(aTHX_ pRExC_state, pat,
6258                                 array, maxarg, NULL, recompile_p,
6259                                 /* $" */
6260                                 GvSV((gv_fetchpvs("\"", GV_ADDMULTI, SVt_PV))));
6261
6262             continue;
6263         }
6264
6265
6266         /* we make the assumption here that each op in the list of
6267          * op_siblings maps to one SV pushed onto the stack,
6268          * except for code blocks, with have both an OP_NULL and
6269          * and OP_CONST.
6270          * This allows us to match up the list of SVs against the
6271          * list of OPs to find the next code block.
6272          *
6273          * Note that       PUSHMARK PADSV PADSV ..
6274          * is optimised to
6275          *                 PADRANGE PADSV  PADSV  ..
6276          * so the alignment still works. */
6277
6278         if (oplist) {
6279             if (oplist->op_type == OP_NULL
6280                 && (oplist->op_flags & OPf_SPECIAL))
6281             {
6282                 assert(n < pRExC_state->num_code_blocks);
6283                 pRExC_state->code_blocks[n].start = pat ? SvCUR(pat) : 0;
6284                 pRExC_state->code_blocks[n].block = oplist;
6285                 pRExC_state->code_blocks[n].src_regex = NULL;
6286                 n++;
6287                 code = 1;
6288                 oplist = OpSIBLING(oplist); /* skip CONST */
6289                 assert(oplist);
6290             }
6291             oplist = OpSIBLING(oplist);;
6292         }
6293
6294         /* apply magic and QR overloading to arg */
6295
6296         SvGETMAGIC(msv);
6297         if (SvROK(msv) && SvAMAGIC(msv)) {
6298             SV *sv = AMG_CALLunary(msv, regexp_amg);
6299             if (sv) {
6300                 if (SvROK(sv))
6301                     sv = SvRV(sv);
6302                 if (SvTYPE(sv) != SVt_REGEXP)
6303                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
6304                 msv = sv;
6305             }
6306         }
6307
6308         /* try concatenation overload ... */
6309         if (pat && (SvAMAGIC(pat) || SvAMAGIC(msv)) &&
6310                 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
6311         {
6312             sv_setsv(pat, sv);
6313             /* overloading involved: all bets are off over literal
6314              * code. Pretend we haven't seen it */
6315             pRExC_state->num_code_blocks -= n;
6316             n = 0;
6317         }
6318         else  {
6319             /* ... or failing that, try "" overload */
6320             while (SvAMAGIC(msv)
6321                     && (sv = AMG_CALLunary(msv, string_amg))
6322                     && sv != msv
6323                     &&  !(   SvROK(msv)
6324                           && SvROK(sv)
6325                           && SvRV(msv) == SvRV(sv))
6326             ) {
6327                 msv = sv;
6328                 SvGETMAGIC(msv);
6329             }
6330             if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
6331                 msv = SvRV(msv);
6332
6333             if (pat) {
6334                 /* this is a partially unrolled
6335                  *     sv_catsv_nomg(pat, msv);
6336                  * that allows us to adjust code block indices if
6337                  * needed */
6338                 STRLEN dlen;
6339                 char *dst = SvPV_force_nomg(pat, dlen);
6340                 orig_patlen = dlen;
6341                 if (SvUTF8(msv) && !SvUTF8(pat)) {
6342                     S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &dst, &dlen, n);
6343                     sv_setpvn(pat, dst, dlen);
6344                     SvUTF8_on(pat);
6345                 }
6346                 sv_catsv_nomg(pat, msv);
6347                 rx = msv;
6348             }
6349             else {
6350                 /* We have only one SV to process, but we need to verify
6351                  * it is properly null terminated or we will fail asserts
6352                  * later. In theory we probably shouldn't get such SV's,
6353                  * but if we do we should handle it gracefully. */
6354                 if ( SvTYPE(msv) != SVt_PV || (SvLEN(msv) > SvCUR(msv) && *(SvEND(msv)) == 0) ) {
6355                     /* not a string, or a string with a trailing null */
6356                     pat = msv;
6357                 } else {
6358                     /* a string with no trailing null, we need to copy it
6359                      * so it we have a trailing null */
6360                     pat = newSVsv(msv);
6361                 }
6362             }
6363
6364             if (code)
6365                 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
6366         }
6367
6368         /* extract any code blocks within any embedded qr//'s */
6369         if (rx && SvTYPE(rx) == SVt_REGEXP
6370             && RX_ENGINE((REGEXP*)rx)->op_comp)
6371         {
6372
6373             RXi_GET_DECL(ReANY((REGEXP *)rx), ri);
6374             if (ri->num_code_blocks) {
6375                 int i;
6376                 /* the presence of an embedded qr// with code means
6377                  * we should always recompile: the text of the
6378                  * qr// may not have changed, but it may be a
6379                  * different closure than last time */
6380                 *recompile_p = 1;
6381                 Renew(pRExC_state->code_blocks,
6382                     pRExC_state->num_code_blocks + ri->num_code_blocks,
6383                     struct reg_code_block);
6384                 pRExC_state->num_code_blocks += ri->num_code_blocks;
6385
6386                 for (i=0; i < ri->num_code_blocks; i++) {
6387                     struct reg_code_block *src, *dst;
6388                     STRLEN offset =  orig_patlen
6389                         + ReANY((REGEXP *)rx)->pre_prefix;
6390                     assert(n < pRExC_state->num_code_blocks);
6391                     src = &ri->code_blocks[i];
6392                     dst = &pRExC_state->code_blocks[n];
6393                     dst->start      = src->start + offset;
6394                     dst->end        = src->end   + offset;
6395                     dst->block      = src->block;
6396                     dst->src_regex  = (REGEXP*) SvREFCNT_inc( (SV*)
6397                                             src->src_regex
6398                                                 ? src->src_regex
6399                                                 : (REGEXP*)rx);
6400                     n++;
6401                 }
6402             }
6403         }
6404     }
6405     /* avoid calling magic multiple times on a single element e.g. =~ $qr */
6406     if (alloced)
6407         SvSETMAGIC(pat);
6408
6409     return pat;
6410 }
6411
6412
6413
6414 /* see if there are any run-time code blocks in the pattern.
6415  * False positives are allowed */
6416
6417 static bool
6418 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6419                     char *pat, STRLEN plen)
6420 {
6421     int n = 0;
6422     STRLEN s;
6423     
6424     PERL_UNUSED_CONTEXT;
6425
6426     for (s = 0; s < plen; s++) {
6427         if (n < pRExC_state->num_code_blocks
6428             && s == pRExC_state->code_blocks[n].start)
6429         {
6430             s = pRExC_state->code_blocks[n].end;
6431             n++;
6432             continue;
6433         }
6434         /* TODO ideally should handle [..], (#..), /#.../x to reduce false
6435          * positives here */
6436         if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' &&
6437             (pat[s+2] == '{'
6438                 || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{'))
6439         )
6440             return 1;
6441     }
6442     return 0;
6443 }
6444
6445 /* Handle run-time code blocks. We will already have compiled any direct
6446  * or indirect literal code blocks. Now, take the pattern 'pat' and make a
6447  * copy of it, but with any literal code blocks blanked out and
6448  * appropriate chars escaped; then feed it into
6449  *
6450  *    eval "qr'modified_pattern'"
6451  *
6452  * For example,
6453  *
6454  *       a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
6455  *
6456  * becomes
6457  *
6458  *    qr'a\\bc_______________________def\'ghi\\\\jkl(?{"this is runtime"})mno'
6459  *
6460  * After eval_sv()-ing that, grab any new code blocks from the returned qr
6461  * and merge them with any code blocks of the original regexp.
6462  *
6463  * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
6464  * instead, just save the qr and return FALSE; this tells our caller that
6465  * the original pattern needs upgrading to utf8.
6466  */
6467
6468 static bool
6469 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
6470     char *pat, STRLEN plen)
6471 {
6472     SV *qr;
6473
6474     GET_RE_DEBUG_FLAGS_DECL;
6475
6476     if (pRExC_state->runtime_code_qr) {
6477         /* this is the second time we've been called; this should
6478          * only happen if the main pattern got upgraded to utf8
6479          * during compilation; re-use the qr we compiled first time
6480          * round (which should be utf8 too)
6481          */
6482         qr = pRExC_state->runtime_code_qr;
6483         pRExC_state->runtime_code_qr = NULL;
6484         assert(RExC_utf8 && SvUTF8(qr));
6485     }
6486     else {
6487         int n = 0;
6488         STRLEN s;
6489         char *p, *newpat;
6490         int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
6491         SV *sv, *qr_ref;
6492         dSP;
6493
6494         /* determine how many extra chars we need for ' and \ escaping */
6495         for (s = 0; s < plen; s++) {
6496             if (pat[s] == '\'' || pat[s] == '\\')
6497                 newlen++;
6498         }
6499
6500         Newx(newpat, newlen, char);
6501         p = newpat;
6502         *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
6503
6504         for (s = 0; s < plen; s++) {
6505             if (n < pRExC_state->num_code_blocks
6506                 && s == pRExC_state->code_blocks[n].start)
6507             {
6508                 /* blank out literal code block */
6509                 assert(pat[s] == '(');
6510                 while (s <= pRExC_state->code_blocks[n].end) {
6511                     *p++ = '_';
6512                     s++;
6513                 }
6514                 s--;
6515                 n++;
6516                 continue;
6517             }
6518             if (pat[s] == '\'' || pat[s] == '\\')
6519                 *p++ = '\\';
6520             *p++ = pat[s];
6521         }
6522         *p++ = '\'';
6523         if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
6524             *p++ = 'x';
6525         *p++ = '\0';
6526         DEBUG_COMPILE_r({
6527             Perl_re_printf( aTHX_
6528                 "%sre-parsing pattern for runtime code:%s %s\n",
6529                 PL_colors[4],PL_colors[5],newpat);
6530         });
6531
6532         sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
6533         Safefree(newpat);
6534
6535         ENTER;
6536         SAVETMPS;
6537         save_re_context();
6538         PUSHSTACKi(PERLSI_REQUIRE);
6539         /* G_RE_REPARSING causes the toker to collapse \\ into \ when
6540          * parsing qr''; normally only q'' does this. It also alters
6541          * hints handling */
6542         eval_sv(sv, G_SCALAR|G_RE_REPARSING);
6543         SvREFCNT_dec_NN(sv);
6544         SPAGAIN;
6545         qr_ref = POPs;
6546         PUTBACK;
6547         {
6548             SV * const errsv = ERRSV;
6549             if (SvTRUE_NN(errsv))
6550             {
6551                 Safefree(pRExC_state->code_blocks);
6552                 /* use croak_sv ? */
6553                 Perl_croak_nocontext("%" SVf, SVfARG(errsv));
6554             }
6555         }
6556         assert(SvROK(qr_ref));
6557         qr = SvRV(qr_ref);
6558         assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
6559         /* the leaving below frees the tmp qr_ref.
6560          * Give qr a life of its own */
6561         SvREFCNT_inc(qr);
6562         POPSTACK;
6563         FREETMPS;
6564         LEAVE;
6565
6566     }
6567
6568     if (!RExC_utf8 && SvUTF8(qr)) {
6569         /* first time through; the pattern got upgraded; save the
6570          * qr for the next time through */
6571         assert(!pRExC_state->runtime_code_qr);
6572         pRExC_state->runtime_code_qr = qr;
6573         return 0;
6574     }
6575
6576
6577     /* extract any code blocks within the returned qr//  */
6578
6579
6580     /* merge the main (r1) and run-time (r2) code blocks into one */
6581     {
6582         RXi_GET_DECL(ReANY((REGEXP *)qr), r2);
6583         struct reg_code_block *new_block, *dst;
6584         RExC_state_t * const r1 = pRExC_state; /* convenient alias */
6585         int i1 = 0, i2 = 0;
6586
6587         if (!r2->num_code_blocks) /* we guessed wrong */
6588         {
6589             SvREFCNT_dec_NN(qr);
6590             return 1;
6591         }
6592
6593         Newx(new_block,
6594             r1->num_code_blocks + r2->num_code_blocks,
6595             struct reg_code_block);
6596         dst = new_block;
6597
6598         while (    i1 < r1->num_code_blocks
6599                 || i2 < r2->num_code_blocks)
6600         {
6601             struct reg_code_block *src;
6602             bool is_qr = 0;
6603
6604             if (i1 == r1->num_code_blocks) {
6605                 src = &r2->code_blocks[i2++];
6606                 is_qr = 1;
6607             }
6608             else if (i2 == r2->num_code_blocks)
6609                 src = &r1->code_blocks[i1++];
6610             else if (  r1->code_blocks[i1].start
6611                      < r2->code_blocks[i2].start)
6612             {
6613                 src = &r1->code_blocks[i1++];
6614                 assert(src->end < r2->code_blocks[i2].start);
6615             }
6616             else {
6617                 assert(  r1->code_blocks[i1].start
6618                        > r2->code_blocks[i2].start);
6619                 src = &r2->code_blocks[i2++];
6620                 is_qr = 1;
6621                 assert(src->end < r1->code_blocks[i1].start);
6622             }
6623
6624             assert(pat[src->start] == '(');
6625             assert(pat[src->end]   == ')');
6626             dst->start      = src->start;
6627             dst->end        = src->end;
6628             dst->block      = src->block;
6629             dst->src_regex  = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
6630                                     : src->src_regex;
6631             dst++;
6632         }
6633         r1->num_code_blocks += r2->num_code_blocks;
6634         Safefree(r1->code_blocks);
6635         r1->code_blocks = new_block;
6636     }
6637
6638     SvREFCNT_dec_NN(qr);
6639     return 1;
6640 }
6641
6642
6643 STATIC bool
6644 S_setup_longest(pTHX_ RExC_state_t *pRExC_state, SV* sv_longest,
6645                       SV** rx_utf8, SV** rx_substr, SSize_t* rx_end_shift,
6646                       SSize_t lookbehind, SSize_t offset, SSize_t *minlen,
6647                       STRLEN longest_length, bool eol, bool meol)
6648 {
6649     /* This is the common code for setting up the floating and fixed length
6650      * string data extracted from Perl_re_op_compile() below.  Returns a boolean
6651      * as to whether succeeded or not */
6652
6653     I32 t;
6654     SSize_t ml;
6655
6656     if (! (longest_length
6657            || (eol /* Can't have SEOL and MULTI */
6658                && (! meol || (RExC_flags & RXf_PMf_MULTILINE)))
6659           )
6660             /* See comments for join_exact for why REG_UNFOLDED_MULTI_SEEN */
6661         || (RExC_seen & REG_UNFOLDED_MULTI_SEEN))
6662     {
6663         return FALSE;
6664     }
6665
6666     /* copy the information about the longest from the reg_scan_data
6667         over to the program. */
6668     if (SvUTF8(sv_longest)) {
6669         *rx_utf8 = sv_longest;
6670         *rx_substr = NULL;
6671     } else {
6672         *rx_substr = sv_longest;
6673         *rx_utf8 = NULL;
6674     }
6675     /* end_shift is how many chars that must be matched that
6676         follow this item. We calculate it ahead of time as once the
6677         lookbehind offset is added in we lose the ability to correctly
6678         calculate it.*/
6679     ml = minlen ? *(minlen) : (SSize_t)longest_length;
6680     *rx_end_shift = ml - offset
6681         - longest_length
6682             /* XXX SvTAIL is always false here - did you mean FBMcf_TAIL
6683              * intead? - DAPM
6684             + (SvTAIL(sv_longest) != 0)
6685             */
6686         + lookbehind;
6687
6688     t = (eol/* Can't have SEOL and MULTI */
6689          && (! meol || (RExC_flags & RXf_PMf_MULTILINE)));
6690     fbm_compile(sv_longest, t ? FBMcf_TAIL : 0);
6691
6692     return TRUE;
6693 }
6694
6695 /*
6696  * Perl_re_op_compile - the perl internal RE engine's function to compile a
6697  * regular expression into internal code.
6698  * The pattern may be passed either as:
6699  *    a list of SVs (patternp plus pat_count)
6700  *    a list of OPs (expr)
6701  * If both are passed, the SV list is used, but the OP list indicates
6702  * which SVs are actually pre-compiled code blocks
6703  *
6704  * The SVs in the list have magic and qr overloading applied to them (and
6705  * the list may be modified in-place with replacement SVs in the latter
6706  * case).
6707  *
6708  * If the pattern hasn't changed from old_re, then old_re will be
6709  * returned.
6710  *
6711  * eng is the current engine. If that engine has an op_comp method, then
6712  * handle directly (i.e. we assume that op_comp was us); otherwise, just
6713  * do the initial concatenation of arguments and pass on to the external
6714  * engine.
6715  *
6716  * If is_bare_re is not null, set it to a boolean indicating whether the
6717  * arg list reduced (after overloading) to a single bare regex which has
6718  * been returned (i.e. /$qr/).
6719  *
6720  * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
6721  *
6722  * pm_flags contains the PMf_* flags, typically based on those from the
6723  * pm_flags field of the related PMOP. Currently we're only interested in
6724  * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
6725  *
6726  * We can't allocate space until we know how big the compiled form will be,
6727  * but we can't compile it (and thus know how big it is) until we've got a
6728  * place to put the code.  So we cheat:  we compile it twice, once with code
6729  * generation turned off and size counting turned on, and once "for real".
6730  * This also means that we don't allocate space until we are sure that the
6731  * thing really will compile successfully, and we never have to move the
6732  * code and thus invalidate pointers into it.  (Note that it has to be in
6733  * one piece because free() must be able to free it all.) [NB: not true in perl]
6734  *
6735  * Beware that the optimization-preparation code in here knows about some
6736  * of the structure of the compiled regexp.  [I'll say.]
6737  */
6738
6739 REGEXP *
6740 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
6741                     OP *expr, const regexp_engine* eng, REGEXP *old_re,
6742                      bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
6743 {
6744     REGEXP *rx;
6745     struct regexp *r;
6746     regexp_internal *ri;
6747     STRLEN plen;
6748     char *exp;
6749     regnode *scan;
6750     I32 flags;
6751     SSize_t minlen = 0;
6752     U32 rx_flags;
6753     SV *pat;
6754     SV *code_blocksv = NULL;
6755     SV** new_patternp = patternp;
6756
6757     /* these are all flags - maybe they should be turned
6758      * into a single int with different bit masks */
6759     I32 sawlookahead = 0;
6760     I32 sawplus = 0;
6761     I32 sawopen = 0;
6762     I32 sawminmod = 0;
6763
6764     regex_charset initial_charset = get_regex_charset(orig_rx_flags);
6765     bool recompile = 0;
6766     bool runtime_code = 0;
6767     scan_data_t data;
6768     RExC_state_t RExC_state;
6769     RExC_state_t * const pRExC_state = &RExC_state;
6770 #ifdef TRIE_STUDY_OPT
6771     int restudied = 0;
6772     RExC_state_t copyRExC_state;
6773 #endif
6774     GET_RE_DEBUG_FLAGS_DECL;
6775
6776     PERL_ARGS_ASSERT_RE_OP_COMPILE;
6777
6778     DEBUG_r(if (!PL_colorset) reginitcolors());
6779
6780     /* Initialize these here instead of as-needed, as is quick and avoids
6781      * having to test them each time otherwise */
6782     if (! PL_AboveLatin1) {
6783 #ifdef DEBUGGING
6784         char * dump_len_string;
6785 #endif
6786
6787         PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
6788         PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
6789         PL_UpperLatin1 = _new_invlist_C_array(UpperLatin1_invlist);
6790         PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist);
6791         PL_HasMultiCharFold =
6792                        _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist);
6793
6794         /* This is calculated here, because the Perl program that generates the
6795          * static global ones doesn't currently have access to
6796          * NUM_ANYOF_CODE_POINTS */
6797         PL_InBitmap = _new_invlist(2);
6798         PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0,
6799                                                     NUM_ANYOF_CODE_POINTS - 1);
6800 #ifdef DEBUGGING
6801         dump_len_string = PerlEnv_getenv("PERL_DUMP_RE_MAX_LEN");
6802         if (   ! dump_len_string
6803             || ! grok_atoUV(dump_len_string, (UV *)&PL_dump_re_max_len, NULL))
6804         {
6805             PL_dump_re_max_len = 0;
6806         }
6807 #endif
6808     }
6809
6810     pRExC_state->warn_text = NULL;
6811     pRExC_state->code_blocks = NULL;
6812     pRExC_state->num_code_blocks = 0;
6813
6814     if (is_bare_re)
6815         *is_bare_re = FALSE;
6816
6817     if (expr && (expr->op_type == OP_LIST ||
6818                 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
6819         /* allocate code_blocks if needed */
6820         OP *o;
6821         int ncode = 0;
6822
6823         for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o))
6824             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
6825                 ncode++; /* count of DO blocks */
6826         if (ncode) {
6827             pRExC_state->num_code_blocks = ncode;
6828             Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
6829         }
6830     }
6831
6832     if (!pat_count) {
6833         /* compile-time pattern with just OP_CONSTs and DO blocks */
6834
6835         int n;
6836         OP *o;
6837
6838         /* find how many CONSTs there are */
6839         assert(expr);
6840         n = 0;
6841         if (expr->op_type == OP_CONST)
6842             n = 1;
6843         else
6844             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6845                 if (o->op_type == OP_CONST)
6846                     n++;
6847             }
6848
6849         /* fake up an SV array */
6850
6851         assert(!new_patternp);
6852         Newx(new_patternp, n, SV*);
6853         SAVEFREEPV(new_patternp);
6854         pat_count = n;
6855
6856         n = 0;
6857         if (expr->op_type == OP_CONST)
6858             new_patternp[n] = cSVOPx_sv(expr);
6859         else
6860             for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) {
6861                 if (o->op_type == OP_CONST)
6862                     new_patternp[n++] = cSVOPo_sv;
6863             }
6864
6865     }
6866
6867     DEBUG_PARSE_r(Perl_re_printf( aTHX_
6868         "Assembling pattern from %d elements%s\n", pat_count,
6869             orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6870
6871     /* set expr to the first arg op */
6872
6873     if (pRExC_state->num_code_blocks
6874          && expr->op_type != OP_CONST)
6875     {
6876             expr = cLISTOPx(expr)->op_first;
6877             assert(   expr->op_type == OP_PUSHMARK
6878                    || (expr->op_type == OP_NULL && expr->op_targ == OP_PUSHMARK)
6879                    || expr->op_type == OP_PADRANGE);
6880             expr = OpSIBLING(expr);
6881     }
6882
6883     pat = S_concat_pat(aTHX_ pRExC_state, NULL, new_patternp, pat_count,
6884                         expr, &recompile, NULL);
6885
6886     /* handle bare (possibly after overloading) regex: foo =~ $re */
6887     {
6888         SV *re = pat;
6889         if (SvROK(re))
6890             re = SvRV(re);
6891         if (SvTYPE(re) == SVt_REGEXP) {
6892             if (is_bare_re)
6893                 *is_bare_re = TRUE;
6894             SvREFCNT_inc(re);
6895             Safefree(pRExC_state->code_blocks);
6896             DEBUG_PARSE_r(Perl_re_printf( aTHX_
6897                 "Precompiled pattern%s\n",
6898                     orig_rx_flags & RXf_SPLIT ? " for split" : ""));
6899
6900             return (REGEXP*)re;
6901         }
6902     }
6903
6904     exp = SvPV_nomg(pat, plen);
6905
6906     if (!eng->op_comp) {
6907         if ((SvUTF8(pat) && IN_BYTES)
6908                 || SvGMAGICAL(pat) || SvAMAGIC(pat))
6909         {
6910             /* make a temporary copy; either to convert to bytes,
6911              * or to avoid repeating get-magic / overloaded stringify */
6912             pat = newSVpvn_flags(exp, plen, SVs_TEMP |
6913                                         (IN_BYTES ? 0 : SvUTF8(pat)));
6914         }
6915         Safefree(pRExC_state->code_blocks);
6916         return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
6917     }
6918
6919     /* ignore the utf8ness if the pattern is 0 length */
6920     RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
6921
6922     RExC_uni_semantics = 0;
6923     RExC_seen_unfolded_sharp_s = 0;
6924     RExC_contains_locale = 0;
6925     RExC_contains_i = 0;
6926     RExC_strict = cBOOL(pm_flags & RXf_PMf_STRICT);
6927     RExC_study_started = 0;
6928     pRExC_state->runtime_code_qr = NULL;
6929     RExC_frame_head= NULL;
6930     RExC_frame_last= NULL;
6931     RExC_frame_count= 0;
6932
6933     DEBUG_r({
6934         RExC_mysv1= sv_newmortal();
6935         RExC_mysv2= sv_newmortal();
6936     });
6937     DEBUG_COMPILE_r({
6938             SV *dsv= sv_newmortal();
6939             RE_PV_QUOTED_DECL(s, RExC_utf8, dsv, exp, plen, 60);
6940             Perl_re_printf( aTHX_  "%sCompiling REx%s %s\n",
6941                           PL_colors[4],PL_colors[5],s);
6942         });
6943
6944   redo_first_pass:
6945     /* we jump here if we have to recompile, e.g., from upgrading the pattern
6946      * to utf8 */
6947
6948     if ((pm_flags & PMf_USE_RE_EVAL)
6949                 /* this second condition covers the non-regex literal case,
6950                  * i.e.  $foo =~ '(?{})'. */
6951                 || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL))
6952     )
6953         runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen);
6954
6955     /* return old regex if pattern hasn't changed */
6956     /* XXX: note in the below we have to check the flags as well as the
6957      * pattern.
6958      *
6959      * Things get a touch tricky as we have to compare the utf8 flag
6960      * independently from the compile flags.  */
6961
6962     if (   old_re
6963         && !recompile
6964         && !!RX_UTF8(old_re) == !!RExC_utf8
6965         && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) )
6966         && RX_PRECOMP(old_re)
6967         && RX_PRELEN(old_re) == plen
6968         && memEQ(RX_PRECOMP(old_re), exp, plen)
6969         && !runtime_code /* with runtime code, always recompile */ )
6970     {
6971         Safefree(pRExC_state->code_blocks);
6972         return old_re;
6973     }
6974
6975     rx_flags = orig_rx_flags;
6976
6977     if (rx_flags & PMf_FOLD) {
6978         RExC_contains_i = 1;
6979     }
6980     if (   initial_charset == REGEX_DEPENDS_CHARSET
6981         && (RExC_utf8 ||RExC_uni_semantics))
6982     {
6983
6984         /* Set to use unicode semantics if the pattern is in utf8 and has the
6985          * 'depends' charset specified, as it means unicode when utf8  */
6986         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
6987     }
6988
6989     RExC_precomp = exp;
6990     RExC_precomp_adj = 0;
6991     RExC_flags = rx_flags;
6992     RExC_pm_flags = pm_flags;
6993
6994     if (runtime_code) {
6995         assert(TAINTING_get || !TAINT_get);
6996         if (TAINT_get)
6997             Perl_croak(aTHX_ "Eval-group in insecure regular expression");
6998
6999         if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
7000             /* whoops, we have a non-utf8 pattern, whilst run-time code
7001              * got compiled as utf8. Try again with a utf8 pattern */
7002             S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7003                                     pRExC_state->num_code_blocks);
7004             goto redo_first_pass;
7005         }
7006     }
7007     assert(!pRExC_state->runtime_code_qr);
7008
7009     RExC_sawback = 0;
7010
7011     RExC_seen = 0;
7012     RExC_maxlen = 0;
7013     RExC_in_lookbehind = 0;
7014     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
7015     RExC_extralen = 0;
7016     RExC_override_recoding = 0;
7017 #ifdef EBCDIC
7018     RExC_recode_x_to_native = 0;
7019 #endif
7020     RExC_in_multi_char_class = 0;
7021
7022     /* First pass: determine size, legality. */
7023     RExC_parse = exp;
7024     RExC_start = RExC_adjusted_start = exp;
7025     RExC_end = exp + plen;
7026     RExC_precomp_end = RExC_end;
7027     RExC_naughty = 0;
7028     RExC_npar = 1;
7029     RExC_nestroot = 0;
7030     RExC_size = 0L;
7031     RExC_emit = (regnode *) &RExC_emit_dummy;
7032     RExC_whilem_seen = 0;
7033     RExC_open_parens = NULL;
7034     RExC_close_parens = NULL;
7035     RExC_end_op = NULL;
7036     RExC_paren_names = NULL;
7037 #ifdef DEBUGGING
7038     RExC_paren_name_list = NULL;
7039 #endif
7040     RExC_recurse = NULL;
7041     RExC_study_chunk_recursed = NULL;
7042     RExC_study_chunk_recursed_bytes= 0;
7043     RExC_recurse_count = 0;
7044     pRExC_state->code_index = 0;
7045
7046     /* This NUL is guaranteed because the pattern comes from an SV*, and the sv
7047      * code makes sure the final byte is an uncounted NUL.  But should this
7048      * ever not be the case, lots of things could read beyond the end of the
7049      * buffer: loops like
7050      *      while(isFOO(*RExC_parse)) RExC_parse++;
7051      *      strchr(RExC_parse, "foo");
7052      * etc.  So it is worth noting. */
7053     assert(*RExC_end == '\0');
7054
7055     DEBUG_PARSE_r(
7056         Perl_re_printf( aTHX_  "Starting first pass (sizing)\n");
7057         RExC_lastnum=0;
7058         RExC_lastparse=NULL;
7059     );
7060     /* reg may croak on us, not giving us a chance to free
7061        pRExC_state->code_blocks.  We cannot SAVEFREEPV it now, as we may
7062        need it to survive as long as the regexp (qr/(?{})/).
7063        We must check that code_blocksv is not already set, because we may
7064        have jumped back to restart the sizing pass. */
7065     if (pRExC_state->code_blocks && !code_blocksv) {
7066         code_blocksv = newSV_type(SVt_PV);
7067         SAVEFREESV(code_blocksv);
7068         SvPV_set(code_blocksv, (char *)pRExC_state->code_blocks);
7069         SvLEN_set(code_blocksv, 1); /*sufficient to make sv_clear free it*/
7070     }
7071     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7072         /* It's possible to write a regexp in ascii that represents Unicode
7073         codepoints outside of the byte range, such as via \x{100}. If we
7074         detect such a sequence we have to convert the entire pattern to utf8
7075         and then recompile, as our sizing calculation will have been based
7076         on 1 byte == 1 character, but we will need to use utf8 to encode
7077         at least some part of the pattern, and therefore must convert the whole
7078         thing.
7079         -- dmq */
7080         if (flags & RESTART_PASS1) {
7081             if (flags & NEED_UTF8) {
7082                 S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen,
7083                                     pRExC_state->num_code_blocks);
7084             }
7085             else {
7086                 DEBUG_PARSE_r(Perl_re_printf( aTHX_
7087                 "Need to redo pass 1\n"));
7088             }
7089
7090             goto redo_first_pass;
7091         }
7092         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for sizing pass, flags=%#" UVxf, (UV) flags);
7093     }
7094     if (code_blocksv)
7095         SvLEN_set(code_blocksv,0); /* no you can't have it, sv_clear */
7096
7097     DEBUG_PARSE_r({
7098         Perl_re_printf( aTHX_
7099             "Required size %" IVdf " nodes\n"
7100             "Starting second pass (creation)\n",
7101             (IV)RExC_size);
7102         RExC_lastnum=0;
7103         RExC_lastparse=NULL;
7104     });
7105
7106     /* The first pass could have found things that force Unicode semantics */
7107     if ((RExC_utf8 || RExC_uni_semantics)
7108          && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
7109     {
7110         set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
7111     }
7112
7113     /* Small enough for pointer-storage convention?
7114        If extralen==0, this means that we will not need long jumps. */
7115     if (RExC_size >= 0x10000L && RExC_extralen)
7116         RExC_size += RExC_extralen;
7117     else
7118         RExC_extralen = 0;
7119     if (RExC_whilem_seen > 15)
7120         RExC_whilem_seen = 15;
7121
7122     /* Allocate space and zero-initialize. Note, the two step process
7123        of zeroing when in debug mode, thus anything assigned has to
7124        happen after that */
7125     rx = (REGEXP*) newSV_type(SVt_REGEXP);
7126     r = ReANY(rx);
7127     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7128          char, regexp_internal);
7129     if ( r == NULL || ri == NULL )
7130         FAIL("Regexp out of space");
7131 #ifdef DEBUGGING
7132     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
7133     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
7134          char);
7135 #else
7136     /* bulk initialize base fields with 0. */
7137     Zero(ri, sizeof(regexp_internal), char);
7138 #endif
7139
7140     /* non-zero initialization begins here */
7141     RXi_SET( r, ri );
7142     r->engine= eng;
7143     r->extflags = rx_flags;
7144     RXp_COMPFLAGS(r) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK;
7145
7146     if (pm_flags & PMf_IS_QR) {
7147         ri->code_blocks = pRExC_state->code_blocks;
7148         ri->num_code_blocks = pRExC_state->num_code_blocks;
7149     }
7150     else
7151     {
7152         int n;
7153         for (n = 0; n < pRExC_state->num_code_blocks; n++)
7154             if (pRExC_state->code_blocks[n].src_regex)
7155                 SAVEFREESV(pRExC_state->code_blocks[n].src_regex);
7156         if(pRExC_state->code_blocks)
7157             SAVEFREEPV(pRExC_state->code_blocks); /* often null */
7158     }
7159
7160     {
7161         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
7162         bool has_charset = (get_regex_charset(r->extflags)
7163                                                     != REGEX_DEPENDS_CHARSET);
7164
7165         /* The caret is output if there are any defaults: if not all the STD
7166          * flags are set, or if no character set specifier is needed */
7167         bool has_default =
7168                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
7169                     || ! has_charset);
7170         bool has_runon = ((RExC_seen & REG_RUN_ON_COMMENT_SEEN)
7171                                                    == REG_RUN_ON_COMMENT_SEEN);
7172         U8 reganch = (U8)((r->extflags & RXf_PMf_STD_PMMOD)
7173                             >> RXf_PMf_STD_PMMOD_SHIFT);
7174         const char *fptr = STD_PAT_MODS;        /*"msixn"*/
7175         char *p;
7176
7177         /* We output all the necessary flags; we never output a minus, as all
7178          * those are defaults, so are
7179          * covered by the caret */
7180         const STRLEN wraplen = plen + has_p + has_runon
7181             + has_default       /* If needs a caret */
7182             + PL_bitcount[reganch] /* 1 char for each set standard flag */
7183
7184                 /* If needs a character set specifier */
7185             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
7186             + (sizeof("(?:)") - 1);
7187
7188         /* make sure PL_bitcount bounds not exceeded */
7189         assert(sizeof(STD_PAT_MODS) <= 8);
7190
7191         Newx(p, wraplen + 1, char); /* +1 for the ending NUL */
7192         r->xpv_len_u.xpvlenu_pv = p;
7193         if (RExC_utf8)
7194             SvFLAGS(rx) |= SVf_UTF8;
7195         *p++='('; *p++='?';
7196
7197         /* If a default, cover it using the caret */
7198         if (has_default) {
7199             *p++= DEFAULT_PAT_MOD;
7200         }
7201         if (has_charset) {
7202             STRLEN len;
7203             const char* const name = get_regex_charset_name(r->extflags, &len);
7204             Copy(name, p, len, char);
7205             p += len;
7206         }
7207         if (has_p)
7208             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
7209         {
7210             char ch;
7211             while((ch = *fptr++)) {
7212                 if(reganch & 1)
7213                     *p++ = ch;
7214                 reganch >>= 1;
7215             }
7216         }
7217
7218         *p++ = ':';
7219         Copy(RExC_precomp, p, plen, char);
7220         assert ((RX_WRAPPED(rx) - p) < 16);
7221         r->pre_prefix = p - RX_WRAPPED(rx);
7222         p += plen;
7223         if (has_runon)
7224             *p++ = '\n';
7225         *p++ = ')';
7226         *p = 0;
7227         SvCUR_set(rx, p - RX_WRAPPED(rx));
7228     }
7229
7230     r->intflags = 0;
7231     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
7232
7233     /* Useful during FAIL. */
7234 #ifdef RE_TRACK_PATTERN_OFFSETS
7235     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
7236     DEBUG_OFFSETS_r(Perl_re_printf( aTHX_
7237                           "%s %" UVuf " bytes for offset annotations.\n",
7238                           ri->u.offsets ? "Got" : "Couldn't get",
7239                           (UV)((2*RExC_size+1) * sizeof(U32))));
7240 #endif
7241     SetProgLen(ri,RExC_size);
7242     RExC_rx_sv = rx;
7243     RExC_rx = r;
7244     RExC_rxi = ri;
7245
7246     /* Second pass: emit code. */
7247     RExC_flags = rx_flags;      /* don't let top level (?i) bleed */
7248     RExC_pm_flags = pm_flags;
7249     RExC_parse = exp;
7250     RExC_end = exp + plen;
7251     RExC_naughty = 0;
7252     RExC_emit_start = ri->program;
7253     RExC_emit = ri->program;
7254     RExC_emit_bound = ri->program + RExC_size + 1;
7255     pRExC_state->code_index = 0;
7256
7257     *((char*) RExC_emit++) = (char) REG_MAGIC;
7258     /* setup various meta data about recursion, this all requires
7259      * RExC_npar to be correctly set, and a bit later on we clear it */
7260     if (RExC_seen & REG_RECURSE_SEEN) {
7261         DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
7262             "%*s%*s Setting up open/close parens\n",
7263                   22, "|    |", (int)(0 * 2 + 1), ""));
7264
7265         /* setup RExC_open_parens, which holds the address of each
7266          * OPEN tag, and to make things simpler for the 0 index
7267          * the start of the program - this is used later for offsets */
7268         Newxz(RExC_open_parens, RExC_npar,regnode *);
7269         SAVEFREEPV(RExC_open_parens);
7270         RExC_open_parens[0] = RExC_emit;
7271
7272         /* setup RExC_close_parens, which holds the address of each
7273          * CLOSE tag, and to make things simpler for the 0 index
7274          * the end of the program - this is used later for offsets */
7275         Newxz(RExC_close_parens, RExC_npar,regnode *);
7276         SAVEFREEPV(RExC_close_parens);
7277         /* we dont know where end op starts yet, so we dont
7278          * need to set RExC_close_parens[0] like we do RExC_open_parens[0] above */
7279
7280         /* Note, RExC_npar is 1 + the number of parens in a pattern.
7281          * So its 1 if there are no parens. */
7282         RExC_study_chunk_recursed_bytes= (RExC_npar >> 3) +
7283                                          ((RExC_npar & 0x07) != 0);
7284         Newx(RExC_study_chunk_recursed,
7285              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7286         SAVEFREEPV(RExC_study_chunk_recursed);
7287     }
7288     RExC_npar = 1;
7289     if (reg(pRExC_state, 0, &flags,1) == NULL) {
7290         ReREFCNT_dec(rx);
7291         Perl_croak(aTHX_ "panic: reg returned NULL to re_op_compile for generation pass, flags=%#" UVxf, (UV) flags);
7292     }
7293     DEBUG_OPTIMISE_r(
7294         Perl_re_printf( aTHX_  "Starting post parse optimization\n");
7295     );
7296
7297     /* XXXX To minimize changes to RE engine we always allocate
7298        3-units-long substrs field. */
7299     Newx(r->substrs, 1, struct reg_substr_data);
7300     if (RExC_recurse_count) {
7301         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
7302         SAVEFREEPV(RExC_recurse);
7303     }
7304
7305   reStudy:
7306     r->minlen = minlen = sawlookahead = sawplus = sawopen = sawminmod = 0;
7307     DEBUG_r(
7308         RExC_study_chunk_recursed_count= 0;
7309     );
7310     Zero(r->substrs, 1, struct reg_substr_data);
7311     if (RExC_study_chunk_recursed) {
7312         Zero(RExC_study_chunk_recursed,
7313              RExC_study_chunk_recursed_bytes * RExC_npar, U8);
7314     }
7315
7316
7317 #ifdef TRIE_STUDY_OPT
7318     if (!restudied) {
7319         StructCopy(&zero_scan_data, &data, scan_data_t);
7320         copyRExC_state = RExC_state;
7321     } else {
7322         U32 seen=RExC_seen;
7323         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "Restudying\n"));
7324
7325         RExC_state = copyRExC_state;
7326         if (seen & REG_TOP_LEVEL_BRANCHES_SEEN)
7327             RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
7328         else
7329             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN;
7330         StructCopy(&zero_scan_data, &data, scan_data_t);
7331     }
7332 #else
7333     StructCopy(&zero_scan_data, &data, scan_data_t);
7334 #endif
7335
7336     /* Dig out information for optimizations. */
7337     r->extflags = RExC_flags; /* was pm_op */
7338     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
7339
7340     if (UTF)
7341         SvUTF8_on(rx);  /* Unicode in it? */
7342     ri->regstclass = NULL;
7343     if (RExC_naughty >= TOO_NAUGHTY)    /* Probably an expensive pattern. */
7344         r->intflags |= PREGf_NAUGHTY;
7345     scan = ri->program + 1;             /* First BRANCH. */
7346
7347     /* testing for BRANCH here tells us whether there is "must appear"
7348        data in the pattern. If there is then we can use it for optimisations */
7349     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /*  Only one top-level choice.
7350                                                   */
7351         SSize_t fake;
7352         STRLEN longest_float_length, longest_fixed_length;
7353         regnode_ssc ch_class; /* pointed to by data */
7354         int stclass_flag;
7355         SSize_t last_close = 0; /* pointed to by data */
7356         regnode *first= scan;
7357         regnode *first_next= regnext(first);
7358         /*
7359          * Skip introductions and multiplicators >= 1
7360          * so that we can extract the 'meat' of the pattern that must
7361          * match in the large if() sequence following.
7362          * NOTE that EXACT is NOT covered here, as it is normally
7363          * picked up by the optimiser separately.
7364          *
7365          * This is unfortunate as the optimiser isnt handling lookahead
7366          * properly currently.
7367          *
7368          */
7369         while ((OP(first) == OPEN && (sawopen = 1)) ||
7370                /* An OR of *one* alternative - should not happen now. */
7371             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
7372             /* for now we can't handle lookbehind IFMATCH*/
7373             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
7374             (OP(first) == PLUS) ||
7375             (OP(first) == MINMOD) ||
7376                /* An {n,m} with n>0 */
7377             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
7378             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
7379         {
7380                 /*
7381                  * the only op that could be a regnode is PLUS, all the rest
7382                  * will be regnode_1 or regnode_2.
7383                  *
7384                  * (yves doesn't think this is true)
7385                  */
7386                 if (OP(first) == PLUS)
7387                     sawplus = 1;
7388                 else {
7389                     if (OP(first) == MINMOD)
7390                         sawminmod = 1;
7391                     first += regarglen[OP(first)];
7392                 }
7393                 first = NEXTOPER(first);
7394                 first_next= regnext(first);
7395         }
7396
7397         /* Starting-point info. */
7398       again:
7399         DEBUG_PEEP("first:",first,0);
7400         /* Ignore EXACT as we deal with it later. */
7401         if (PL_regkind[OP(first)] == EXACT) {
7402             if (OP(first) == EXACT || OP(first) == EXACTL)
7403                 NOOP;   /* Empty, get anchored substr later. */
7404             else
7405                 ri->regstclass = first;
7406         }
7407 #ifdef TRIE_STCLASS
7408         else if (PL_regkind[OP(first)] == TRIE &&
7409                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
7410         {
7411             /* this can happen only on restudy */
7412             ri->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0);
7413         }
7414 #endif
7415         else if (REGNODE_SIMPLE(OP(first)))
7416             ri->regstclass = first;
7417         else if (PL_regkind[OP(first)] == BOUND ||
7418                  PL_regkind[OP(first)] == NBOUND)
7419             ri->regstclass = first;
7420         else if (PL_regkind[OP(first)] == BOL) {
7421             r->intflags |= (OP(first) == MBOL
7422                            ? PREGf_ANCH_MBOL
7423                            : PREGf_ANCH_SBOL);
7424             first = NEXTOPER(first);
7425             goto again;
7426         }
7427         else if (OP(first) == GPOS) {
7428             r->intflags |= PREGf_ANCH_GPOS;
7429             first = NEXTOPER(first);
7430             goto again;
7431         }
7432         else if ((!sawopen || !RExC_sawback) &&
7433             !sawlookahead &&
7434             (OP(first) == STAR &&
7435             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
7436             !(r->intflags & PREGf_ANCH) && !pRExC_state->num_code_blocks)
7437         {
7438             /* turn .* into ^.* with an implied $*=1 */
7439             const int type =
7440                 (OP(NEXTOPER(first)) == REG_ANY)
7441                     ? PREGf_ANCH_MBOL
7442                     : PREGf_ANCH_SBOL;
7443             r->intflags |= (type | PREGf_IMPLICIT);
7444             first = NEXTOPER(first);
7445             goto again;
7446         }
7447         if (sawplus && !sawminmod && !sawlookahead
7448             && (!sawopen || !RExC_sawback)
7449             && !pRExC_state->num_code_blocks) /* May examine pos and $& */
7450             /* x+ must match at the 1st pos of run of x's */
7451             r->intflags |= PREGf_SKIP;
7452
7453         /* Scan is after the zeroth branch, first is atomic matcher. */
7454 #ifdef TRIE_STUDY_OPT
7455         DEBUG_PARSE_r(
7456             if (!restudied)
7457                 Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7458                               (IV)(first - scan + 1))
7459         );
7460 #else
7461         DEBUG_PARSE_r(
7462             Perl_re_printf( aTHX_  "first at %" IVdf "\n",
7463                 (IV)(first - scan + 1))
7464         );
7465 #endif
7466
7467
7468         /*
7469         * If there's something expensive in the r.e., find the
7470         * longest literal string that must appear and make it the
7471         * regmust.  Resolve ties in favor of later strings, since
7472         * the regstart check works with the beginning of the r.e.
7473         * and avoiding duplication strengthens checking.  Not a
7474         * strong reason, but sufficient in the absence of others.
7475         * [Now we resolve ties in favor of the earlier string if
7476         * it happens that c_offset_min has been invalidated, since the
7477         * earlier string may buy us something the later one won't.]
7478         */
7479
7480         data.longest_fixed = newSVpvs("");
7481         data.longest_float = newSVpvs("");
7482         data.last_found = newSVpvs("");
7483         data.longest = &(data.longest_fixed);
7484         ENTER_with_name("study_chunk");
7485         SAVEFREESV(data.longest_fixed);
7486         SAVEFREESV(data.longest_float);
7487         SAVEFREESV(data.last_found);
7488         first = scan;
7489         if (!ri->regstclass) {
7490             ssc_init(pRExC_state, &ch_class);
7491             data.start_class = &ch_class;
7492             stclass_flag = SCF_DO_STCLASS_AND;
7493         } else                          /* XXXX Check for BOUND? */
7494             stclass_flag = 0;
7495         data.last_closep = &last_close;
7496
7497         DEBUG_RExC_seen();
7498         minlen = study_chunk(pRExC_state, &first, &minlen, &fake,
7499                              scan + RExC_size, /* Up to end */
7500             &data, -1, 0, NULL,
7501             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag
7502                           | (restudied ? SCF_TRIE_DOING_RESTUDY : 0),
7503             0);
7504
7505
7506         CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk"));
7507
7508
7509         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
7510              && data.last_start_min == 0 && data.last_end > 0
7511              && !RExC_seen_zerolen
7512              && !(RExC_seen & REG_VERBARG_SEEN)
7513              && !(RExC_seen & REG_GPOS_SEEN)
7514         ){
7515             r->extflags |= RXf_CHECK_ALL;
7516         }
7517         scan_commit(pRExC_state, &data,&minlen,0);
7518
7519         longest_float_length = CHR_SVLEN(data.longest_float);
7520
7521         if (! ((SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
7522                    && data.offset_fixed == data.offset_float_min
7523                    && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
7524             && S_setup_longest (aTHX_ pRExC_state,
7525                                     data.longest_float,
7526                                     &(r->float_utf8),
7527                                     &(r->float_substr),
7528                                     &(r->float_end_shift),
7529                                     data.lookbehind_float,
7530                                     data.offset_float_min,
7531                                     data.minlen_float,
7532                                     longest_float_length,
7533                                     cBOOL(data.flags & SF_FL_BEFORE_EOL),
7534                                     cBOOL(data.flags & SF_FL_BEFORE_MEOL)))
7535         {
7536             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
7537             r->float_max_offset = data.offset_float_max;
7538             if (data.offset_float_max < SSize_t_MAX) /* Don't offset infinity */
7539                 r->float_max_offset -= data.lookbehind_float;
7540             SvREFCNT_inc_simple_void_NN(data.longest_float);
7541         }
7542         else {
7543             r->float_substr = r->float_utf8 = NULL;
7544             longest_float_length = 0;
7545         }
7546
7547         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
7548
7549         if (S_setup_longest (aTHX_ pRExC_state,
7550                                 data.longest_fixed,
7551                                 &(r->anchored_utf8),
7552                                 &(r->anchored_substr),
7553                                 &(r->anchored_end_shift),
7554                                 data.lookbehind_fixed,
7555                                 data.offset_fixed,
7556                                 data.minlen_fixed,
7557                                 longest_fixed_length,
7558                                 cBOOL(data.flags & SF_FIX_BEFORE_EOL),
7559                                 cBOOL(data.flags & SF_FIX_BEFORE_MEOL)))
7560         {
7561             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
7562             SvREFCNT_inc_simple_void_NN(data.longest_fixed);
7563         }
7564         else {
7565             r->anchored_substr = r->anchored_utf8 = NULL;
7566             longest_fixed_length = 0;
7567         }
7568         LEAVE_with_name("study_chunk");
7569
7570         if (ri->regstclass
7571             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
7572             ri->regstclass = NULL;
7573
7574         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
7575             && stclass_flag
7576             && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7577             && is_ssc_worth_it(pRExC_state, data.start_class))
7578         {
7579             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7580
7581             ssc_finalize(pRExC_state, data.start_class);
7582
7583             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7584             StructCopy(data.start_class,
7585                        (regnode_ssc*)RExC_rxi->data->data[n],
7586                        regnode_ssc);
7587             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7588             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7589             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
7590                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7591                       Perl_re_printf( aTHX_
7592                                     "synthetic stclass \"%s\".\n",
7593                                     SvPVX_const(sv));});
7594             data.start_class = NULL;
7595         }
7596
7597         /* A temporary algorithm prefers floated substr to fixed one to dig
7598          * more info. */
7599         if (longest_fixed_length > longest_float_length) {
7600             r->substrs->check_ix = 0;
7601             r->check_end_shift = r->anchored_end_shift;
7602             r->check_substr = r->anchored_substr;
7603             r->check_utf8 = r->anchored_utf8;
7604             r->check_offset_min = r->check_offset_max = r->anchored_offset;
7605             if (r->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))
7606                 r->intflags |= PREGf_NOSCAN;
7607         }
7608         else {
7609             r->substrs->check_ix = 1;
7610             r->check_end_shift = r->float_end_shift;
7611             r->check_substr = r->float_substr;
7612             r->check_utf8 = r->float_utf8;
7613             r->check_offset_min = r->float_min_offset;
7614             r->check_offset_max = r->float_max_offset;
7615         }
7616         if ((r->check_substr || r->check_utf8) ) {
7617             r->extflags |= RXf_USE_INTUIT;
7618             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
7619                 r->extflags |= RXf_INTUIT_TAIL;
7620         }
7621         r->substrs->data[0].max_offset = r->substrs->data[0].min_offset;
7622
7623         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
7624         if ( (STRLEN)minlen < longest_float_length )
7625             minlen= longest_float_length;
7626         if ( (STRLEN)minlen < longest_fixed_length )
7627             minlen= longest_fixed_length;
7628         */
7629     }
7630     else {
7631         /* Several toplevels. Best we can is to set minlen. */
7632         SSize_t fake;
7633         regnode_ssc ch_class;
7634         SSize_t last_close = 0;
7635
7636         DEBUG_PARSE_r(Perl_re_printf( aTHX_  "\nMulti Top Level\n"));
7637
7638         scan = ri->program + 1;
7639         ssc_init(pRExC_state, &ch_class);
7640         data.start_class = &ch_class;
7641         data.last_closep = &last_close;
7642
7643         DEBUG_RExC_seen();
7644         minlen = study_chunk(pRExC_state,
7645             &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL,
7646             SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied
7647                                                       ? SCF_TRIE_DOING_RESTUDY
7648                                                       : 0),
7649             0);
7650
7651         CHECK_RESTUDY_GOTO_butfirst(NOOP);
7652
7653         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
7654                 = r->float_substr = r->float_utf8 = NULL;
7655
7656         if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING)
7657             && is_ssc_worth_it(pRExC_state, data.start_class))
7658         {
7659             const U32 n = add_data(pRExC_state, STR_WITH_LEN("f"));
7660
7661             ssc_finalize(pRExC_state, data.start_class);
7662
7663             Newx(RExC_rxi->data->data[n], 1, regnode_ssc);
7664             StructCopy(data.start_class,
7665                        (regnode_ssc*)RExC_rxi->data->data[n],
7666                        regnode_ssc);
7667             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
7668             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
7669             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
7670                       regprop(r, sv, (regnode*)data.start_class, NULL, pRExC_state);
7671                       Perl_re_printf( aTHX_
7672                                     "synthetic stclass \"%s\".\n",
7673                                     SvPVX_const(sv));});
7674             data.start_class = NULL;
7675         }
7676     }
7677
7678     if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) {
7679         r->extflags |= RXf_UNBOUNDED_QUANTIFIER_SEEN;
7680         r->maxlen = REG_INFTY;
7681     }
7682     else {
7683         r->maxlen = RExC_maxlen;
7684     }
7685
7686     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
7687        the "real" pattern. */
7688     DEBUG_OPTIMISE_r({
7689         Perl_re_printf( aTHX_ "minlen: %" IVdf " r->minlen:%" IVdf " maxlen:%" IVdf "\n",
7690                       (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen);
7691     });
7692     r->minlenret = minlen;
7693     if (r->minlen < minlen)
7694         r->minlen = minlen;
7695
7696     if (RExC_seen & REG_RECURSE_SEEN ) {
7697         r->intflags |= PREGf_RECURSE_SEEN;
7698         Newxz(r->recurse_locinput, r->nparens + 1, char *);
7699     }
7700     if (RExC_seen & REG_GPOS_SEEN)
7701         r->intflags |= PREGf_GPOS_SEEN;
7702     if (RExC_seen & REG_LOOKBEHIND_SEEN)
7703         r->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the
7704                                                 lookbehind */
7705     if (pRExC_state->num_code_blocks)
7706         r->extflags |= RXf_EVAL_SEEN;
7707     if (RExC_seen & REG_VERBARG_SEEN)
7708     {
7709         r->intflags |= PREGf_VERBARG_SEEN;
7710         r->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */
7711     }
7712     if (RExC_seen & REG_CUTGROUP_SEEN)
7713         r->intflags |= PREGf_CUTGROUP_SEEN;
7714     if (pm_flags & PMf_USE_RE_EVAL)
7715         r->intflags |= PREGf_USE_RE_EVAL;
7716     if (RExC_paren_names)
7717         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
7718     else
7719         RXp_PAREN_NAMES(r) = NULL;
7720
7721     /* If we have seen an anchor in our pattern then we set the extflag RXf_IS_ANCHORED
7722      * so it can be used in pp.c */
7723     if (r->intflags & PREGf_ANCH)
7724         r->extflags |= RXf_IS_ANCHORED;
7725
7726
7727     {
7728         /* this is used to identify "special" patterns that might result
7729          * in Perl NOT calling the regex engine and instead doing the match "itself",
7730          * particularly special cases in split//. By having the regex compiler
7731          * do this pattern matching at a regop level (instead of by inspecting the pattern)
7732          * we avoid weird issues with equivalent patterns resulting in different behavior,
7733          * AND we allow non Perl engines to get the same optimizations by the setting the
7734          * flags appropriately - Yves */
7735         regnode *first = ri->program + 1;
7736         U8 fop = OP(first);
7737         regnode *next = regnext(first);
7738         U8 nop = OP(next);
7739
7740         if (PL_regkind[fop] == NOTHING && nop == END)
7741             r->extflags |= RXf_NULL;
7742         else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END)
7743             /* when fop is SBOL first->flags will be true only when it was
7744              * produced by parsing /\A/, and not when parsing /^/. This is
7745              * very important for the split code as there we want to
7746              * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m.
7747              * See rt #122761 for more details. -- Yves */
7748             r->extflags |= RXf_START_ONLY;
7749         else if (fop == PLUS
7750                  && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE
7751                  && nop == END)
7752             r->extflags |= RXf_WHITE;
7753         else if ( r->extflags & RXf_SPLIT
7754                   && (fop == EXACT || fop == EXACTL)
7755                   && STR_LEN(first) == 1
7756                   && *(STRING(first)) == ' '
7757                   && nop == END )
7758             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
7759
7760     }
7761
7762     if (RExC_contains_locale) {
7763         RXp_EXTFLAGS(r) |= RXf_TAINTED;
7764     }
7765
7766 #ifdef DEBUGGING
7767     if (RExC_paren_names) {
7768         ri->name_list_idx = add_data( pRExC_state, STR_WITH_LEN("a"));
7769         ri->data->data[ri->name_list_idx]
7770                                    = (void*)SvREFCNT_inc(RExC_paren_name_list);
7771     } else
7772 #endif
7773     ri->name_list_idx = 0;
7774
7775     while ( RExC_recurse_count > 0 ) {
7776         const regnode *scan = RExC_recurse[ --RExC_recurse_count ];
7777         ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan );
7778     }
7779
7780     Newxz(r->offs, RExC_npar, regexp_paren_pair);
7781     /* assume we don't need to swap parens around before we match */
7782     DEBUG_TEST_r({
7783         Perl_re_printf( aTHX_ "study_chunk_recursed_count: %lu\n",
7784             (unsigned long)RExC_study_chunk_recursed_count);
7785     });
7786     DEBUG_DUMP_r({
7787         DEBUG_RExC_seen();
7788         Perl_re_printf( aTHX_ "Final program:\n");
7789         regdump(r);
7790     });
7791 #ifdef RE_TRACK_PATTERN_OFFSETS
7792     DEBUG_OFFSETS_r(if (ri->u.offsets) {
7793         const STRLEN len = ri->u.offsets[0];
7794         STRLEN i;
7795         GET_RE_DEBUG_FLAGS_DECL;
7796         Perl_re_printf( aTHX_
7797                       "Offsets: [%" UVuf "]\n\t", (UV)ri->u.offsets[0]);
7798         for (i = 1; i <= len; i++) {
7799             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
7800                 Perl_re_printf( aTHX_  "%" UVuf ":%" UVuf "[%" UVuf "] ",
7801                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
7802             }
7803         Perl_re_printf( aTHX_  "\n");
7804     });
7805 #endif
7806
7807 #ifdef USE_ITHREADS
7808     /* under ithreads the ?pat? PMf_USED flag on the pmop is simulated
7809      * by setting the regexp SV to readonly-only instead. If the
7810      * pattern's been recompiled, the USEDness should remain. */
7811     if (old_re && SvREADONLY(old_re))
7812         SvREADONLY_on(rx);
7813 #endif
7814     return rx;
7815 }
7816
7817
7818 SV*
7819 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
7820                     const U32 flags)
7821 {
7822     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
7823
7824     PERL_UNUSED_ARG(value);
7825
7826     if (flags & RXapif_FETCH) {
7827         return reg_named_buff_fetch(rx, key, flags);
7828     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
7829         Perl_croak_no_modify();
7830         return NULL;
7831     } else if (flags & RXapif_EXISTS) {
7832         return reg_named_buff_exists(rx, key, flags)
7833             ? &PL_sv_yes
7834             : &PL_sv_no;
7835     } else if (flags & RXapif_REGNAMES) {
7836         return reg_named_buff_all(rx, flags);
7837     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
7838         return reg_named_buff_scalar(rx, flags);
7839     } else {
7840         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
7841         return NULL;
7842     }
7843 }
7844
7845 SV*
7846 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
7847                          const U32 flags)
7848 {
7849     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
7850     PERL_UNUSED_ARG(lastkey);
7851
7852     if (flags & RXapif_FIRSTKEY)
7853         return reg_named_buff_firstkey(rx, flags);
7854     else if (flags & RXapif_NEXTKEY)
7855         return reg_named_buff_nextkey(rx, flags);
7856     else {
7857         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter",
7858                                             (int)flags);
7859         return NULL;
7860     }
7861 }
7862
7863 SV*
7864 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
7865                           const U32 flags)
7866 {
7867     AV *retarray = NULL;
7868     SV *ret;
7869     struct regexp *const rx = ReANY(r);
7870
7871     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
7872
7873     if (flags & RXapif_ALL)
7874         retarray=newAV();
7875
7876     if (rx && RXp_PAREN_NAMES(rx)) {
7877         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
7878         if (he_str) {
7879             IV i;
7880             SV* sv_dat=HeVAL(he_str);
7881             I32 *nums=(I32*)SvPVX(sv_dat);
7882             for ( i=0; i<SvIVX(sv_dat); i++ ) {
7883                 if ((I32)(rx->nparens) >= nums[i]
7884                     && rx->offs[nums[i]].start != -1
7885                     && rx->offs[nums[i]].end != -1)
7886                 {
7887                     ret = newSVpvs("");
7888                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
7889                     if (!retarray)
7890                         return ret;
7891                 } else {
7892                     if (retarray)
7893                         ret = newSVsv(&PL_sv_undef);
7894                 }
7895                 if (retarray)
7896                     av_push(retarray, ret);
7897             }
7898             if (retarray)
7899                 return newRV_noinc(MUTABLE_SV(retarray));
7900         }
7901     }
7902     return NULL;
7903 }
7904
7905 bool
7906 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
7907                            const U32 flags)
7908 {
7909     struct regexp *const rx = ReANY(r);
7910
7911     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
7912
7913     if (rx && RXp_PAREN_NAMES(rx)) {
7914         if (flags & RXapif_ALL) {
7915             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
7916         } else {
7917             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
7918             if (sv) {
7919                 SvREFCNT_dec_NN(sv);
7920                 return TRUE;
7921             } else {
7922                 return FALSE;
7923             }
7924         }
7925     } else {
7926         return FALSE;
7927     }
7928 }
7929
7930 SV*
7931 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
7932 {
7933     struct regexp *const rx = ReANY(r);
7934
7935     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
7936
7937     if ( rx && RXp_PAREN_NAMES(rx) ) {
7938         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
7939
7940         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
7941     } else {
7942         return FALSE;
7943     }
7944 }
7945
7946 SV*
7947 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
7948 {
7949     struct regexp *const rx = ReANY(r);
7950     GET_RE_DEBUG_FLAGS_DECL;
7951
7952     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
7953
7954     if (rx && RXp_PAREN_NAMES(rx)) {
7955         HV *hv = RXp_PAREN_NAMES(rx);
7956         HE *temphe;
7957         while ( (temphe = hv_iternext_flags(hv,0)) ) {
7958             IV i;
7959             IV parno = 0;
7960             SV* sv_dat = HeVAL(temphe);
7961             I32 *nums = (I32*)SvPVX(sv_dat);
7962             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
7963                 if ((I32)(rx->lastparen) >= nums[i] &&
7964                     rx->offs[nums[i]].start != -1 &&
7965                     rx->offs[nums[i]].end != -1)
7966                 {
7967                     parno = nums[i];
7968                     break;
7969                 }
7970             }
7971             if (parno || flags & RXapif_ALL) {
7972                 return newSVhek(HeKEY_hek(temphe));
7973             }
7974         }
7975     }
7976     return NULL;
7977 }
7978
7979 SV*
7980 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
7981 {
7982     SV *ret;
7983     AV *av;
7984     SSize_t length;
7985     struct regexp *const rx = ReANY(r);
7986
7987     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
7988
7989     if (rx && RXp_PAREN_NAMES(rx)) {
7990         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
7991             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
7992         } else if (flags & RXapif_ONE) {
7993             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
7994             av = MUTABLE_AV(SvRV(ret));
7995             length = av_tindex(av);
7996             SvREFCNT_dec_NN(ret);
7997             return newSViv(length + 1);
7998         } else {
7999             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar",
8000                                                 (int)flags);
8001             return NULL;
8002         }
8003     }
8004     return &PL_sv_undef;
8005 }
8006
8007 SV*
8008 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
8009 {
8010     struct regexp *const rx = ReANY(r);
8011     AV *av = newAV();
8012
8013     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
8014
8015     if (rx && RXp_PAREN_NAMES(rx)) {
8016         HV *hv= RXp_PAREN_NAMES(rx);
8017         HE *temphe;
8018         (void)hv_iterinit(hv);
8019         while ( (temphe = hv_iternext_flags(hv,0)) ) {
8020             IV i;
8021             IV parno = 0;
8022             SV* sv_dat = HeVAL(temphe);
8023             I32 *nums = (I32*)SvPVX(sv_dat);
8024             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
8025                 if ((I32)(rx->lastparen) >= nums[i] &&
8026                     rx->offs[nums[i]].start != -1 &&
8027                     rx->offs[nums[i]].end != -1)
8028                 {
8029                     parno = nums[i];
8030                     break;
8031                 }
8032             }
8033             if (parno || flags & RXapif_ALL) {
8034                 av_push(av, newSVhek(HeKEY_hek(temphe)));
8035             }
8036         }
8037     }
8038
8039     return newRV_noinc(MUTABLE_SV(av));
8040 }
8041
8042 void
8043 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
8044                              SV * const sv)
8045 {
8046     struct regexp *const rx = ReANY(r);
8047     char *s = NULL;
8048     SSize_t i = 0;
8049     SSize_t s1, t1;
8050     I32 n = paren;
8051
8052     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
8053
8054     if (      n == RX_BUFF_IDX_CARET_PREMATCH
8055            || n == RX_BUFF_IDX_CARET_FULLMATCH
8056            || n == RX_BUFF_IDX_CARET_POSTMATCH
8057        )
8058     {
8059         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8060         if (!keepcopy) {
8061             /* on something like
8062              *    $r = qr/.../;
8063              *    /$qr/p;
8064              * the KEEPCOPY is set on the PMOP rather than the regex */
8065             if (PL_curpm && r == PM_GETRE(PL_curpm))
8066                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8067         }
8068         if (!keepcopy)
8069             goto ret_undef;
8070     }
8071
8072     if (!rx->subbeg)
8073         goto ret_undef;
8074
8075     if (n == RX_BUFF_IDX_CARET_FULLMATCH)
8076         /* no need to distinguish between them any more */
8077         n = RX_BUFF_IDX_FULLMATCH;
8078
8079     if ((n == RX_BUFF_IDX_PREMATCH || n == RX_BUFF_IDX_CARET_PREMATCH)
8080         && rx->offs[0].start != -1)
8081     {
8082         /* $`, ${^PREMATCH} */
8083         i = rx->offs[0].start;
8084         s = rx->subbeg;
8085     }
8086     else
8087     if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH)
8088         && rx->offs[0].end != -1)
8089     {
8090         /* $', ${^POSTMATCH} */
8091         s = rx->subbeg - rx->suboffset + rx->offs[0].end;
8092         i = rx->sublen + rx->suboffset - rx->offs[0].end;
8093     }
8094     else
8095     if ( 0 <= n && n <= (I32)rx->nparens &&
8096         (s1 = rx->offs[n].start) != -1 &&
8097         (t1 = rx->offs[n].end) != -1)
8098     {
8099         /* $&, ${^MATCH},  $1 ... */
8100         i = t1 - s1;
8101         s = rx->subbeg + s1 - rx->suboffset;
8102     } else {
8103         goto ret_undef;
8104     }
8105
8106     assert(s >= rx->subbeg);
8107     assert((STRLEN)rx->sublen >= (STRLEN)((s - rx->subbeg) + i) );
8108     if (i >= 0) {
8109 #ifdef NO_TAINT_SUPPORT
8110         sv_setpvn(sv, s, i);
8111 #else
8112         const int oldtainted = TAINT_get;
8113         TAINT_NOT;
8114         sv_setpvn(sv, s, i);
8115         TAINT_set(oldtainted);
8116 #endif
8117         if (RXp_MATCH_UTF8(rx))
8118             SvUTF8_on(sv);
8119         else
8120             SvUTF8_off(sv);
8121         if (TAINTING_get) {
8122             if (RXp_MATCH_TAINTED(rx)) {
8123                 if (SvTYPE(sv) >= SVt_PVMG) {
8124                     MAGIC* const mg = SvMAGIC(sv);
8125                     MAGIC* mgt;
8126                     TAINT;
8127                     SvMAGIC_set(sv, mg->mg_moremagic);
8128                     SvTAINT(sv);
8129                     if ((mgt = SvMAGIC(sv))) {
8130                         mg->mg_moremagic = mgt;
8131                         SvMAGIC_set(sv, mg);
8132                     }
8133                 } else {
8134                     TAINT;
8135                     SvTAINT(sv);
8136                 }
8137             } else
8138                 SvTAINTED_off(sv);
8139         }
8140     } else {
8141       ret_undef:
8142         sv_set_undef(sv);
8143         return;
8144     }
8145 }
8146
8147 void
8148 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
8149                                                          SV const * const value)
8150 {
8151     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
8152
8153     PERL_UNUSED_ARG(rx);
8154     PERL_UNUSED_ARG(paren);
8155     PERL_UNUSED_ARG(value);
8156
8157     if (!PL_localizing)
8158         Perl_croak_no_modify();
8159 }
8160
8161 I32
8162 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
8163                               const I32 paren)
8164 {
8165     struct regexp *const rx = ReANY(r);
8166     I32 i;
8167     I32 s1, t1;
8168
8169     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
8170
8171     if (   paren == RX_BUFF_IDX_CARET_PREMATCH
8172         || paren == RX_BUFF_IDX_CARET_FULLMATCH
8173         || paren == RX_BUFF_IDX_CARET_POSTMATCH
8174     )
8175     {
8176         bool keepcopy = cBOOL(rx->extflags & RXf_PMf_KEEPCOPY);
8177         if (!keepcopy) {
8178             /* on something like
8179              *    $r = qr/.../;
8180              *    /$qr/p;
8181              * the KEEPCOPY is set on the PMOP rather than the regex */
8182             if (PL_curpm && r == PM_GETRE(PL_curpm))
8183                  keepcopy = cBOOL(PL_curpm->op_pmflags & PMf_KEEPCOPY);
8184         }
8185         if (!keepcopy)
8186             goto warn_undef;
8187     }
8188
8189     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
8190     switch (paren) {
8191       case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */
8192       case RX_BUFF_IDX_PREMATCH:       /* $` */
8193         if (rx->offs[0].start != -1) {
8194                         i = rx->offs[0].start;
8195                         if (i > 0) {
8196                                 s1 = 0;
8197                                 t1 = i;
8198                                 goto getlen;
8199                         }
8200             }
8201         return 0;
8202
8203       case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */
8204       case RX_BUFF_IDX_POSTMATCH:       /* $' */
8205             if (rx->offs[0].end != -1) {
8206                         i = rx->sublen - rx->offs[0].end;
8207                         if (i > 0) {
8208                                 s1 = rx->offs[0].end;
8209                                 t1 = rx->sublen;
8210                                 goto getlen;
8211                         }
8212             }
8213         return 0;
8214
8215       default: /* $& / ${^MATCH}, $1, $2, ... */
8216             if (paren <= (I32)rx->nparens &&
8217             (s1 = rx->offs[paren].start) != -1 &&
8218             (t1 = rx->offs[paren].end) != -1)
8219             {
8220             i = t1 - s1;
8221             goto getlen;
8222         } else {
8223           warn_undef:
8224             if (ckWARN(WARN_UNINITIALIZED))
8225                 report_uninit((const SV *)sv);
8226             return 0;
8227         }
8228     }
8229   getlen:
8230     if (i > 0 && RXp_MATCH_UTF8(rx)) {
8231         const char * const s = rx->subbeg - rx->suboffset + s1;
8232         const U8 *ep;
8233         STRLEN el;
8234
8235         i = t1 - s1;
8236         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
8237                         i = el;
8238     }
8239     return i;
8240 }
8241
8242 SV*
8243 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
8244 {
8245     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
8246         PERL_UNUSED_ARG(rx);
8247         if (0)
8248             return NULL;
8249         else
8250             return newSVpvs("Regexp");
8251 }
8252
8253 /* Scans the name of a named buffer from the pattern.
8254  * If flags is REG_RSN_RETURN_NULL returns null.
8255  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
8256  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
8257  * to the parsed name as looked up in the RExC_paren_names hash.
8258  * If there is an error throws a vFAIL().. type exception.
8259  */
8260
8261 #define REG_RSN_RETURN_NULL    0
8262 #define REG_RSN_RETURN_NAME    1
8263 #define REG_RSN_RETURN_DATA    2
8264
8265 STATIC SV*
8266 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
8267 {
8268     char *name_start = RExC_parse;
8269
8270     PERL_ARGS_ASSERT_REG_SCAN_NAME;
8271
8272     assert (RExC_parse <= RExC_end);
8273     if (RExC_parse == RExC_end) NOOP;
8274     else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) {
8275          /* Note that the code here assumes well-formed UTF-8.  Skip IDFIRST by
8276           * using do...while */
8277         if (UTF)
8278             do {
8279                 RExC_parse += UTF8SKIP(RExC_parse);
8280             } while (   RExC_parse < RExC_end
8281                      && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end));
8282         else
8283             do {
8284                 RExC_parse++;
8285             } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse));
8286     } else {
8287         RExC_parse++; /* so the <- from the vFAIL is after the offending
8288                          character */
8289         vFAIL("Group name must start with a non-digit word character");
8290     }
8291     if ( flags ) {
8292         SV* sv_name
8293             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
8294                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8295         if ( flags == REG_RSN_RETURN_NAME)
8296             return sv_name;
8297         else if (flags==REG_RSN_RETURN_DATA) {
8298             HE *he_str = NULL;
8299             SV *sv_dat = NULL;
8300             if ( ! sv_name )      /* should not happen*/
8301                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
8302             if (RExC_paren_names)
8303                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
8304             if ( he_str )
8305                 sv_dat = HeVAL(he_str);
8306             if ( ! sv_dat )
8307                 vFAIL("Reference to nonexistent named group");
8308             return sv_dat;
8309         }
8310         else {
8311             Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
8312                        (unsigned long) flags);
8313         }
8314         NOT_REACHED; /* NOTREACHED */
8315     }
8316     return NULL;
8317 }
8318
8319 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
8320     int num;                                                    \
8321     if (RExC_lastparse!=RExC_parse) {                           \
8322         Perl_re_printf( aTHX_  "%s",                                        \
8323             Perl_pv_pretty(aTHX_ RExC_mysv1, RExC_parse,        \
8324                 RExC_end - RExC_parse, 16,                      \
8325                 "", "",                                         \
8326                 PERL_PV_ESCAPE_UNI_DETECT |                     \
8327                 PERL_PV_PRETTY_ELLIPSES   |                     \
8328                 PERL_PV_PRETTY_LTGT       |                     \
8329                 PERL_PV_ESCAPE_RE         |                     \
8330                 PERL_PV_PRETTY_EXACTSIZE                        \
8331             )                                                   \
8332         );                                                      \
8333     } else                                                      \
8334         Perl_re_printf( aTHX_ "%16s","");                                   \
8335                                                                 \
8336     if (SIZE_ONLY)                                              \
8337        num = RExC_size + 1;                                     \
8338     else                                                        \
8339        num=REG_NODE_NUM(RExC_emit);                             \
8340     if (RExC_lastnum!=num)                                      \
8341        Perl_re_printf( aTHX_ "|%4d",num);                                   \
8342     else                                                        \
8343        Perl_re_printf( aTHX_ "|%4s","");                                    \
8344     Perl_re_printf( aTHX_ "|%*s%-4s",                                       \
8345         (int)((depth*2)), "",                                   \
8346         (funcname)                                              \
8347     );                                                          \
8348     RExC_lastnum=num;                                           \
8349     RExC_lastparse=RExC_parse;                                  \
8350 })
8351
8352
8353
8354 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
8355     DEBUG_PARSE_MSG((funcname));                            \
8356     Perl_re_printf( aTHX_ "%4s","\n");                                  \
8357 })
8358 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({\
8359     DEBUG_PARSE_MSG((funcname));                            \
8360     Perl_re_printf( aTHX_ fmt "\n",args);                               \
8361 })
8362
8363 /* This section of code defines the inversion list object and its methods.  The
8364  * interfaces are highly subject to change, so as much as possible is static to
8365  * this file.  An inversion list is here implemented as a malloc'd C UV array
8366  * as an SVt_INVLIST scalar.
8367  *
8368  * An inversion list for Unicode is an array of code points, sorted by ordinal
8369  * number.  Each element gives the code point that begins a range that extends
8370  * up-to but not including the code point given by the next element.  The final
8371  * element gives the first code point of a range that extends to the platform's
8372  * infinity.  The even-numbered elements (invlist[0], invlist[2], invlist[4],
8373  * ...) give ranges whose code points are all in the inversion list.  We say
8374  * that those ranges are in the set.  The odd-numbered elements give ranges
8375  * whose code points are not in the inversion list, and hence not in the set.
8376  * Thus, element [0] is the first code point in the list.  Element [1]
8377  * is the first code point beyond that not in the list; and element [2] is the
8378  * first code point beyond that that is in the list.  In other words, the first
8379  * range is invlist[0]..(invlist[1]-1), and all code points in that range are
8380  * in the inversion list.  The second range is invlist[1]..(invlist[2]-1), and
8381  * all code points in that range are not in the inversion list.  The third
8382  * range invlist[2]..(invlist[3]-1) gives code points that are in the inversion
8383  * list, and so forth.  Thus every element whose index is divisible by two
8384  * gives the beginning of a range that is in the list, and every element whose
8385  * index is not divisible by two gives the beginning of a range not in the
8386  * list.  If the final element's index is divisible by two, the inversion list
8387  * extends to the platform's infinity; otherwise the highest code point in the
8388  * inversion list is the contents of that element minus 1.
8389  *
8390  * A range that contains just a single code point N will look like
8391  *  invlist[i]   == N
8392  *  invlist[i+1] == N+1
8393  *
8394  * If N is UV_MAX (the highest representable code point on the machine), N+1 is
8395  * impossible to represent, so element [i+1] is omitted.  The single element
8396  * inversion list
8397  *  invlist[0] == UV_MAX
8398  * contains just UV_MAX, but is interpreted as matching to infinity.
8399  *
8400  * Taking the complement (inverting) an inversion list is quite simple, if the
8401  * first element is 0, remove it; otherwise add a 0 element at the beginning.
8402  * This implementation reserves an element at the beginning of each inversion
8403  * list to always contain 0; there is an additional flag in the header which
8404  * indicates if the list begins at the 0, or is offset to begin at the next
8405  * element.  This means that the inversion list can be inverted without any
8406  * copying; just flip the flag.
8407  *
8408  * More about inversion lists can be found in "Unicode Demystified"
8409  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
8410  *
8411  * The inversion list data structure is currently implemented as an SV pointing
8412  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
8413  * array of UV whose memory management is automatically handled by the existing
8414  * facilities for SV's.
8415  *
8416  * Some of the methods should always be private to the implementation, and some
8417  * should eventually be made public */
8418
8419 /* The header definitions are in F<invlist_inline.h> */
8420
8421 #ifndef PERL_IN_XSUB_RE
8422
8423 PERL_STATIC_INLINE UV*
8424 S__invlist_array_init(SV* const invlist, const bool will_have_0)
8425 {
8426     /* Returns a pointer to the first element in the inversion list's array.
8427      * This is called upon initialization of an inversion list.  Where the
8428      * array begins depends on whether the list has the code point U+0000 in it
8429      * or not.  The other parameter tells it whether the code that follows this
8430      * call is about to put a 0 in the inversion list or not.  The first
8431      * element is either the element reserved for 0, if TRUE, or the element
8432      * after it, if FALSE */
8433
8434     bool* offset = get_invlist_offset_addr(invlist);
8435     UV* zero_addr = (UV *) SvPVX(invlist);
8436
8437     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
8438
8439     /* Must be empty */
8440     assert(! _invlist_len(invlist));
8441
8442     *zero_addr = 0;
8443
8444     /* 1^1 = 0; 1^0 = 1 */
8445     *offset = 1 ^ will_have_0;
8446     return zero_addr + *offset;
8447 }
8448
8449 #endif
8450
8451 PERL_STATIC_INLINE void
8452 S_invlist_set_len(pTHX_ SV* const invlist, const UV len, const bool offset)
8453 {
8454     /* Sets the current number of elements stored in the inversion list.
8455      * Updates SvCUR correspondingly */
8456     PERL_UNUSED_CONTEXT;
8457     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
8458
8459     assert(SvTYPE(invlist) == SVt_INVLIST);
8460
8461     SvCUR_set(invlist,
8462               (len == 0)
8463                ? 0
8464                : TO_INTERNAL_SIZE(len + offset));
8465     assert(SvLEN(invlist) == 0 || SvCUR(invlist) <= SvLEN(invlist));
8466 }
8467
8468 #ifndef PERL_IN_XSUB_RE
8469
8470 STATIC void
8471 S_invlist_replace_list_destroys_src(pTHX_ SV * dest, SV * src)
8472 {
8473     /* Replaces the inversion list in 'dest' with the one from 'src'.  It
8474      * steals the list from 'src', so 'src' is made to have a NULL list.  This
8475      * is similar to what SvSetMagicSV() would do, if it were implemented on
8476      * inversion lists, though this routine avoids a copy */
8477
8478     const UV src_len          = _invlist_len(src);
8479     const bool src_offset     = *get_invlist_offset_addr(src);
8480     const STRLEN src_byte_len = SvLEN(src);
8481     char * array              = SvPVX(src);
8482
8483     const int oldtainted = TAINT_get;
8484
8485     PERL_ARGS_ASSERT_INVLIST_REPLACE_LIST_DESTROYS_SRC;
8486
8487     assert(SvTYPE(src) == SVt_INVLIST);
8488     assert(SvTYPE(dest) == SVt_INVLIST);
8489     assert(! invlist_is_iterating(src));
8490     assert(SvCUR(src) == 0 || SvCUR(src) < SvLEN(src));
8491
8492     /* Make sure it ends in the right place with a NUL, as our inversion list
8493      * manipulations aren't careful to keep this true, but sv_usepvn_flags()
8494      * asserts it */
8495     array[src_byte_len - 1] = '\0';
8496
8497     TAINT_NOT;      /* Otherwise it breaks */
8498     sv_usepvn_flags(dest,
8499                     (char *) array,
8500                     src_byte_len - 1,
8501
8502                     /* This flag is documented to cause a copy to be avoided */
8503                     SV_HAS_TRAILING_NUL);
8504     TAINT_set(oldtainted);
8505     SvPV_set(src, 0);
8506     SvLEN_set(src, 0);
8507     SvCUR_set(src, 0);
8508
8509     /* Finish up copying over the other fields in an inversion list */
8510     *get_invlist_offset_addr(dest) = src_offset;
8511     invlist_set_len(dest, src_len, src_offset);
8512     *get_invlist_previous_index_addr(dest) = 0;
8513     invlist_iterfinish(dest);
8514 }
8515
8516 PERL_STATIC_INLINE IV*
8517 S_get_invlist_previous_index_addr(SV* invlist)
8518 {
8519     /* Return the address of the IV that is reserved to hold the cached index
8520      * */
8521     PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR;
8522
8523     assert(SvTYPE(invlist) == SVt_INVLIST);
8524
8525     return &(((XINVLIST*) SvANY(invlist))->prev_index);
8526 }
8527
8528 PERL_STATIC_INLINE IV
8529 S_invlist_previous_index(SV* const invlist)
8530 {
8531     /* Returns cached index of previous search */
8532
8533     PERL_ARGS_ASSERT_INVLIST_PREVIOUS_INDEX;
8534
8535     return *get_invlist_previous_index_addr(invlist);
8536 }
8537
8538 PERL_STATIC_INLINE void
8539 S_invlist_set_previous_index(SV* const invlist, const IV index)
8540 {
8541     /* Caches <index> for later retrieval */
8542
8543     PERL_ARGS_ASSERT_INVLIST_SET_PREVIOUS_INDEX;
8544
8545     assert(index == 0 || index < (int) _invlist_len(invlist));
8546
8547     *get_invlist_previous_index_addr(invlist) = index;
8548 }
8549
8550 PERL_STATIC_INLINE void
8551 S_invlist_trim(SV* invlist)
8552 {
8553     /* Free the not currently-being-used space in an inversion list */
8554
8555     /* But don't free up the space needed for the 0 UV that is always at the
8556      * beginning of the list, nor the trailing NUL */
8557     const UV min_size = TO_INTERNAL_SIZE(1) + 1;
8558
8559     PERL_ARGS_ASSERT_INVLIST_TRIM;
8560
8561     assert(SvTYPE(invlist) == SVt_INVLIST);
8562
8563     SvPV_renew(invlist, MAX(min_size, SvCUR(invlist) + 1));
8564 }
8565
8566 PERL_STATIC_INLINE void
8567 S_invlist_clear(pTHX_ SV* invlist)    /* Empty the inversion list */
8568 {
8569     PERL_ARGS_ASSERT_INVLIST_CLEAR;
8570
8571     assert(SvTYPE(invlist) == SVt_INVLIST);
8572
8573     invlist_set_len(invlist, 0, 0);
8574     invlist_trim(invlist);
8575 }
8576
8577 #endif /* ifndef PERL_IN_XSUB_RE */
8578
8579 PERL_STATIC_INLINE bool
8580 S_invlist_is_iterating(SV* const invlist)
8581 {
8582     PERL_ARGS_ASSERT_INVLIST_IS_ITERATING;
8583
8584     return *(get_invlist_iter_addr(invlist)) < (STRLEN) UV_MAX;
8585 }
8586
8587 #ifndef PERL_IN_XSUB_RE
8588
8589 PERL_STATIC_INLINE UV
8590 S_invlist_max(SV* const invlist)
8591 {
8592     /* Returns the maximum number of elements storable in the inversion list's
8593      * array, without having to realloc() */
8594
8595     PERL_ARGS_ASSERT_INVLIST_MAX;
8596
8597     assert(SvTYPE(invlist) == SVt_INVLIST);
8598
8599     /* Assumes worst case, in which the 0 element is not counted in the
8600      * inversion list, so subtracts 1 for that */
8601     return SvLEN(invlist) == 0  /* This happens under _new_invlist_C_array */
8602            ? FROM_INTERNAL_SIZE(SvCUR(invlist)) - 1
8603            : FROM_INTERNAL_SIZE(SvLEN(invlist)) - 1;
8604 }
8605 SV*
8606 Perl__new_invlist(pTHX_ IV initial_size)
8607 {
8608
8609     /* Return a pointer to a newly constructed inversion list, with enough
8610      * space to store 'initial_size' elements.  If that number is negative, a
8611      * system default is used instead */
8612
8613     SV* new_list;
8614
8615     if (initial_size < 0) {
8616         initial_size = 10;
8617     }
8618
8619     /* Allocate the initial space */
8620     new_list = newSV_type(SVt_INVLIST);
8621
8622     /* First 1 is in case the zero element isn't in the list; second 1 is for
8623      * trailing NUL */
8624     SvGROW(new_list, TO_INTERNAL_SIZE(initial_size + 1) + 1);
8625     invlist_set_len(new_list, 0, 0);
8626
8627     /* Force iterinit() to be used to get iteration to work */
8628     *get_invlist_iter_addr(new_list) = (STRLEN) UV_MAX;
8629
8630     *get_invlist_previous_index_addr(new_list) = 0;
8631
8632     return new_list;
8633 }
8634
8635 SV*
8636 Perl__new_invlist_C_array(pTHX_ const UV* const list)
8637 {
8638     /* Return a pointer to a newly constructed inversion list, initialized to
8639      * point to <list>, which has to be in the exact correct inversion list
8640      * form, including internal fields.  Thus this is a dangerous routine that
8641      * should not be used in the wrong hands.  The passed in 'list' contains
8642      * several header fields at the beginning that are not part of the
8643      * inversion list body proper */
8644
8645     const STRLEN length = (STRLEN) list[0];
8646     const UV version_id =          list[1];
8647     const bool offset   =    cBOOL(list[2]);
8648 #define HEADER_LENGTH 3
8649     /* If any of the above changes in any way, you must change HEADER_LENGTH
8650      * (if appropriate) and regenerate INVLIST_VERSION_ID by running
8651      *      perl -E 'say int(rand 2**31-1)'
8652      */
8653 #define INVLIST_VERSION_ID 148565664 /* This is a combination of a version and
8654                                         data structure type, so that one being
8655                                         passed in can be validated to be an
8656                                         inversion list of the correct vintage.
8657                                        */
8658
8659     SV* invlist = newSV_type(SVt_INVLIST);
8660
8661     PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
8662
8663     if (version_id != INVLIST_VERSION_ID) {
8664         Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
8665     }
8666
8667     /* The generated array passed in includes header elements that aren't part
8668      * of the list proper, so start it just after them */
8669     SvPV_set(invlist, (char *) (list + HEADER_LENGTH));
8670
8671     SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
8672                                shouldn't touch it */
8673
8674     *(get_invlist_offset_addr(invlist)) = offset;
8675
8676     /* The 'length' passed to us is the physical number of elements in the
8677      * inversion list.  But if there is an offset the logical number is one
8678      * less than that */
8679     invlist_set_len(invlist, length  - offset, offset);
8680
8681     invlist_set_previous_index(invlist, 0);
8682
8683     /* Initialize the iteration pointer. */
8684     invlist_iterfinish(invlist);
8685
8686     SvREADONLY_on(invlist);
8687
8688     return invlist;
8689 }
8690
8691 STATIC void
8692 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
8693 {
8694     /* Grow the maximum size of an inversion list */
8695
8696     PERL_ARGS_ASSERT_INVLIST_EXTEND;
8697
8698     assert(SvTYPE(invlist) == SVt_INVLIST);
8699
8700     /* Add one to account for the zero element at the beginning which may not
8701      * be counted by the calling parameters */
8702     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max + 1));
8703 }
8704
8705 STATIC void
8706 S__append_range_to_invlist(pTHX_ SV* const invlist,
8707                                  const UV start, const UV end)
8708 {
8709    /* Subject to change or removal.  Append the range from 'start' to 'end' at
8710     * the end of the inversion list.  The range must be above any existing
8711     * ones. */
8712
8713     UV* array;
8714     UV max = invlist_max(invlist);
8715     UV len = _invlist_len(invlist);
8716     bool offset;
8717
8718     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
8719
8720     if (len == 0) { /* Empty lists must be initialized */
8721         offset = start != 0;
8722         array = _invlist_array_init(invlist, ! offset);
8723     }
8724     else {
8725         /* Here, the existing list is non-empty. The current max entry in the
8726          * list is generally the first value not in the set, except when the
8727          * set extends to the end of permissible values, in which case it is
8728          * the first entry in that final set, and so this call is an attempt to
8729          * append out-of-order */
8730
8731         UV final_element = len - 1;
8732         array = invlist_array(invlist);
8733         if (   array[final_element] > start
8734             || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
8735         {
8736             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",
8737                      array[final_element], start,
8738                      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
8739         }
8740
8741         /* Here, it is a legal append.  If the new range begins 1 above the end
8742          * of the range below it, it is extending the range below it, so the
8743          * new first value not in the set is one greater than the newly
8744          * extended range.  */
8745         offset = *get_invlist_offset_addr(invlist);
8746         if (array[final_element] == start) {
8747             if (end != UV_MAX) {
8748                 array[final_element] = end + 1;
8749             }
8750             else {
8751                 /* But if the end is the maximum representable on the machine,
8752                  * assume that infinity was actually what was meant.  Just let
8753                  * the range that this would extend to have no end */
8754                 invlist_set_len(invlist, len - 1, offset);
8755             }
8756             return;
8757         }
8758     }
8759
8760     /* Here the new range doesn't extend any existing set.  Add it */
8761
8762     len += 2;   /* Includes an element each for the start and end of range */
8763
8764     /* If wll overflow the existing space, extend, which may cause the array to
8765      * be moved */
8766     if (max < len) {
8767         invlist_extend(invlist, len);
8768
8769         /* Have to set len here to avoid assert failure in invlist_array() */
8770         invlist_set_len(invlist, len, offset);
8771
8772         array = invlist_array(invlist);
8773     }
8774     else {
8775         invlist_set_len(invlist, len, offset);
8776     }
8777
8778     /* The next item on the list starts the range, the one after that is
8779      * one past the new range.  */
8780     array[len - 2] = start;
8781     if (end != UV_MAX) {
8782         array[len - 1] = end + 1;
8783     }
8784     else {
8785         /* But if the end is the maximum representable on the machine, just let
8786          * the range have no end */
8787         invlist_set_len(invlist, len - 1, offset);
8788     }
8789 }
8790
8791 SSize_t
8792 Perl__invlist_search(SV* const invlist, const UV cp)
8793 {
8794     /* Searches the inversion list for the entry that contains the input code
8795      * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
8796      * return value is the index into the list's array of the range that
8797      * contains <cp>, that is, 'i' such that
8798      *  array[i] <= cp < array[i+1]
8799      */
8800
8801     IV low = 0;
8802     IV mid;
8803     IV high = _invlist_len(invlist);
8804     const IV highest_element = high - 1;
8805     const UV* array;
8806
8807     PERL_ARGS_ASSERT__INVLIST_SEARCH;
8808
8809     /* If list is empty, return failure. */
8810     if (high == 0) {
8811         return -1;
8812     }
8813
8814     /* (We can't get the array unless we know the list is non-empty) */
8815     array = invlist_array(invlist);
8816
8817     mid = invlist_previous_index(invlist);
8818     assert(mid >=0);
8819     if (mid > highest_element) {
8820         mid = highest_element;
8821     }
8822
8823     /* <mid> contains the cache of the result of the previous call to this
8824      * function (0 the first time).  See if this call is for the same result,
8825      * or if it is for mid-1.  This is under the theory that calls to this
8826      * function will often be for related code points that are near each other.
8827      * And benchmarks show that caching gives better results.  We also test
8828      * here if the code point is within the bounds of the list.  These tests
8829      * replace others that would have had to be made anyway to make sure that
8830      * the array bounds were not exceeded, and these give us extra information
8831      * at the same time */
8832     if (cp >= array[mid]) {
8833         if (cp >= array[highest_element]) {
8834             return highest_element;
8835         }
8836
8837         /* Here, array[mid] <= cp < array[highest_element].  This means that
8838          * the final element is not the answer, so can exclude it; it also
8839          * means that <mid> is not the final element, so can refer to 'mid + 1'
8840          * safely */
8841         if (cp < array[mid + 1]) {
8842             return mid;
8843         }
8844         high--;
8845         low = mid + 1;
8846     }
8847     else { /* cp < aray[mid] */
8848         if (cp < array[0]) { /* Fail if outside the array */
8849             return -1;
8850         }
8851         high = mid;
8852         if (cp >= array[mid - 1]) {
8853             goto found_entry;
8854         }
8855     }
8856
8857     /* Binary search.  What we are looking for is <i> such that
8858      *  array[i] <= cp < array[i+1]
8859      * The loop below converges on the i+1.  Note that there may not be an
8860      * (i+1)th element in the array, and things work nonetheless */
8861     while (low < high) {
8862         mid = (low + high) / 2;
8863         assert(mid <= highest_element);
8864         if (array[mid] <= cp) { /* cp >= array[mid] */
8865             low = mid + 1;
8866
8867             /* We could do this extra test to exit the loop early.
8868             if (cp < array[low]) {
8869                 return mid;
8870             }
8871             */
8872         }
8873         else { /* cp < array[mid] */
8874             high = mid;
8875         }
8876     }
8877
8878   found_entry:
8879     high--;
8880     invlist_set_previous_index(invlist, high);
8881     return high;
8882 }
8883
8884 void
8885 Perl__invlist_populate_swatch(SV* const invlist,
8886                               const UV start, const UV end, U8* swatch)
8887 {
8888     /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
8889      * but is used when the swash has an inversion list.  This makes this much
8890      * faster, as it uses a binary search instead of a linear one.  This is
8891      * intimately tied to that function, and perhaps should be in utf8.c,
8892      * except it is intimately tied to inversion lists as well.  It assumes
8893      * that <swatch> is all 0's on input */
8894
8895     UV current = start;
8896     const IV len = _invlist_len(invlist);
8897     IV i;
8898     const UV * array;
8899
8900     PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
8901
8902     if (len == 0) { /* Empty inversion list */
8903         return;
8904     }
8905
8906     array = invlist_array(invlist);
8907
8908     /* Find which element it is */
8909     i = _invlist_search(invlist, start);
8910
8911     /* We populate from <start> to <end> */
8912     while (current < end) {
8913         UV upper;
8914
8915         /* The inversion list gives the results for every possible code point
8916          * after the first one in the list.  Only those ranges whose index is
8917          * even are ones that the inversion list matches.  For the odd ones,
8918          * and if the initial code point is not in the list, we have to skip
8919          * forward to the next element */
8920         if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
8921             i++;
8922             if (i >= len) { /* Finished if beyond the end of the array */
8923                 return;
8924             }
8925             current = array[i];
8926             if (current >= end) {   /* Finished if beyond the end of what we
8927                                        are populating */
8928                 if (LIKELY(end < UV_MAX)) {
8929                     return;
8930                 }
8931
8932                 /* We get here when the upper bound is the maximum
8933                  * representable on the machine, and we are looking for just
8934                  * that code point.  Have to special case it */
8935                 i = len;
8936                 goto join_end_of_list;
8937             }
8938         }
8939         assert(current >= start);
8940
8941         /* The current range ends one below the next one, except don't go past
8942          * <end> */
8943         i++;
8944         upper = (i < len && array[i] < end) ? array[i] : end;
8945
8946         /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
8947          * for each code point in it */
8948         for (; current < upper; current++) {
8949             const STRLEN offset = (STRLEN)(current - start);
8950             swatch[offset >> 3] |= 1 << (offset & 7);
8951         }
8952
8953       join_end_of_list:
8954
8955         /* Quit if at the end of the list */
8956         if (i >= len) {
8957
8958             /* But first, have to deal with the highest possible code point on
8959              * the platform.  The previous code assumes that <end> is one
8960              * beyond where we want to populate, but that is impossible at the
8961              * platform's infinity, so have to handle it specially */
8962             if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
8963             {
8964                 const STRLEN offset = (STRLEN)(end - start);
8965                 swatch[offset >> 3] |= 1 << (offset & 7);
8966             }
8967             return;
8968         }
8969
8970         /* Advance to the next range, which will be for code points not in the
8971          * inversion list */
8972         current = array[i];
8973     }
8974
8975     return;
8976 }
8977
8978 void
8979 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
8980                                          const bool complement_b, SV** output)
8981 {
8982     /* Take the union of two inversion lists and point '*output' to it.  On
8983      * input, '*output' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
8984      * even 'a' or 'b').  If to an inversion list, the contents of the original
8985      * list will be replaced by the union.  The first list, 'a', may be
8986      * NULL, in which case a copy of the second list is placed in '*output'.
8987      * If 'complement_b' is TRUE, the union is taken of the complement
8988      * (inversion) of 'b' instead of b itself.
8989      *
8990      * The basis for this comes from "Unicode Demystified" Chapter 13 by
8991      * Richard Gillam, published by Addison-Wesley, and explained at some
8992      * length there.  The preface says to incorporate its examples into your
8993      * code at your own risk.
8994      *
8995      * The algorithm is like a merge sort. */
8996
8997     const UV* array_a;    /* a's array */
8998     const UV* array_b;
8999     UV len_a;       /* length of a's array */
9000     UV len_b;
9001
9002     SV* u;                      /* the resulting union */
9003     UV* array_u;
9004     UV len_u = 0;
9005
9006     UV i_a = 0;             /* current index into a's array */
9007     UV i_b = 0;
9008     UV i_u = 0;
9009
9010     /* running count, as explained in the algorithm source book; items are
9011      * stopped accumulating and are output when the count changes to/from 0.
9012      * The count is incremented when we start a range that's in an input's set,
9013      * and decremented when we start a range that's not in a set.  So this
9014      * variable can be 0, 1, or 2.  When it is 0 neither input is in their set,
9015      * and hence nothing goes into the union; 1, just one of the inputs is in
9016      * its set (and its current range gets added to the union); and 2 when both
9017      * inputs are in their sets.  */
9018     UV count = 0;
9019
9020     PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
9021     assert(a != b);
9022     assert(*output == NULL || SvTYPE(*output) == SVt_INVLIST);
9023
9024     len_b = _invlist_len(b);
9025     if (len_b == 0) {
9026
9027         /* Here, 'b' is empty, hence it's complement is all possible code
9028          * points.  So if the union includes the complement of 'b', it includes
9029          * everything, and we need not even look at 'a'.  It's easiest to
9030          * create a new inversion list that matches everything.  */
9031         if (complement_b) {
9032             SV* everything = _add_range_to_invlist(NULL, 0, UV_MAX);
9033
9034             if (*output == NULL) { /* If the output didn't exist, just point it
9035                                       at the new list */
9036                 *output = everything;
9037             }
9038             else { /* Otherwise, replace its contents with the new list */
9039                 invlist_replace_list_destroys_src(*output, everything);
9040                 SvREFCNT_dec_NN(everything);
9041             }
9042
9043             return;
9044         }
9045
9046         /* Here, we don't want the complement of 'b', and since 'b' is empty,
9047          * the union will come entirely from 'a'.  If 'a' is NULL or empty, the
9048          * output will be empty */
9049
9050         if (a == NULL || _invlist_len(a) == 0) {
9051             if (*output == NULL) {
9052                 *output = _new_invlist(0);
9053             }
9054             else {
9055                 invlist_clear(*output);
9056             }
9057             return;
9058         }
9059
9060         /* Here, 'a' is not empty, but 'b' is, so 'a' entirely determines the
9061          * union.  We can just return a copy of 'a' if '*output' doesn't point
9062          * to an existing list */
9063         if (*output == NULL) {
9064             *output = invlist_clone(a);
9065             return;
9066         }
9067
9068         /* If the output is to overwrite 'a', we have a no-op, as it's
9069          * already in 'a' */
9070         if (*output == a) {
9071             return;
9072         }
9073
9074         /* Here, '*output' is to be overwritten by 'a' */
9075         u = invlist_clone(a);
9076         invlist_replace_list_destroys_src(*output, u);
9077         SvREFCNT_dec_NN(u);
9078
9079         return;
9080     }
9081
9082     /* Here 'b' is not empty.  See about 'a' */
9083
9084     if (a == NULL || ((len_a = _invlist_len(a)) == 0)) {
9085
9086         /* Here, 'a' is empty (and b is not).  That means the union will come
9087          * entirely from 'b'.  If '*output' is NULL, we can directly return a
9088          * clone of 'b'.  Otherwise, we replace the contents of '*output' with
9089          * the clone */
9090
9091         SV ** dest = (*output == NULL) ? output : &u;
9092         *dest = invlist_clone(b);
9093         if (complement_b) {
9094             _invlist_invert(*dest);
9095         }
9096
9097         if (dest == &u) {
9098             invlist_replace_list_destroys_src(*output, u);
9099             SvREFCNT_dec_NN(u);
9100         }
9101
9102         return;
9103     }
9104
9105     /* Here both lists exist and are non-empty */
9106     array_a = invlist_array(a);
9107     array_b = invlist_array(b);
9108
9109     /* If are to take the union of 'a' with the complement of b, set it
9110      * up so are looking at b's complement. */
9111     if (complement_b) {
9112
9113         /* To complement, we invert: if the first element is 0, remove it.  To
9114          * do this, we just pretend the array starts one later */
9115         if (array_b[0] == 0) {
9116             array_b++;
9117             len_b--;
9118         }
9119         else {
9120
9121             /* But if the first element is not zero, we pretend the list starts
9122              * at the 0 that is always stored immediately before the array. */
9123             array_b--;
9124             len_b++;
9125         }
9126     }
9127
9128     /* Size the union for the worst case: that the sets are completely
9129      * disjoint */
9130     u = _new_invlist(len_a + len_b);
9131
9132     /* Will contain U+0000 if either component does */
9133     array_u = _invlist_array_init(u, (    len_a > 0 && array_a[0] == 0)
9134                                       || (len_b > 0 && array_b[0] == 0));
9135
9136     /* Go through each input list item by item, stopping when have exhausted
9137      * one of them */
9138     while (i_a < len_a && i_b < len_b) {
9139         UV cp;      /* The element to potentially add to the union's array */
9140         bool cp_in_set;   /* is it in the the input list's set or not */
9141
9142         /* We need to take one or the other of the two inputs for the union.
9143          * Since we are merging two sorted lists, we take the smaller of the
9144          * next items.  In case of a tie, we take first the one that is in its
9145          * set.  If we first took the one not in its set, it would decrement
9146          * the count, possibly to 0 which would cause it to be output as ending
9147          * the range, and the next time through we would take the same number,
9148          * and output it again as beginning the next range.  By doing it the
9149          * opposite way, there is no possibility that the count will be
9150          * momentarily decremented to 0, and thus the two adjoining ranges will
9151          * be seamlessly merged.  (In a tie and both are in the set or both not
9152          * in the set, it doesn't matter which we take first.) */
9153         if (       array_a[i_a] < array_b[i_b]
9154             || (   array_a[i_a] == array_b[i_b]
9155                 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9156         {
9157             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9158             cp = array_a[i_a++];
9159         }
9160         else {
9161             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9162             cp = array_b[i_b++];
9163         }
9164
9165         /* Here, have chosen which of the two inputs to look at.  Only output
9166          * if the running count changes to/from 0, which marks the
9167          * beginning/end of a range that's in the set */
9168         if (cp_in_set) {
9169             if (count == 0) {
9170                 array_u[i_u++] = cp;
9171             }
9172             count++;
9173         }
9174         else {
9175             count--;
9176             if (count == 0) {
9177                 array_u[i_u++] = cp;
9178             }
9179         }
9180     }
9181
9182
9183     /* The loop above increments the index into exactly one of the input lists
9184      * each iteration, and ends when either index gets to its list end.  That
9185      * means the other index is lower than its end, and so something is
9186      * remaining in that one.  We decrement 'count', as explained below, if
9187      * that list is in its set.  (i_a and i_b each currently index the element
9188      * beyond the one we care about.) */
9189     if (   (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9190         || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9191     {
9192         count--;
9193     }
9194
9195     /* Above we decremented 'count' if the list that had unexamined elements in
9196      * it was in its set.  This has made it so that 'count' being non-zero
9197      * means there isn't anything left to output; and 'count' equal to 0 means
9198      * that what is left to output is precisely that which is left in the
9199      * non-exhausted input list.
9200      *
9201      * To see why, note first that the exhausted input obviously has nothing
9202      * left to add to the union.  If it was in its set at its end, that means
9203      * the set extends from here to the platform's infinity, and hence so does
9204      * the union and the non-exhausted set is irrelevant.  The exhausted set
9205      * also contributed 1 to 'count'.  If 'count' was 2, it got decremented to
9206      * 1, but if it was 1, the non-exhausted set wasn't in its set, and so
9207      * 'count' remains at 1.  This is consistent with the decremented 'count'
9208      * != 0 meaning there's nothing left to add to the union.
9209      *
9210      * But if the exhausted input wasn't in its set, it contributed 0 to
9211      * 'count', and the rest of the union will be whatever the other input is.
9212      * If 'count' was 0, neither list was in its set, and 'count' remains 0;
9213      * otherwise it gets decremented to 0.  This is consistent with 'count'
9214      * == 0 meaning the remainder of the union is whatever is left in the
9215      * non-exhausted list. */
9216     if (count != 0) {
9217         len_u = i_u;
9218     }
9219     else {
9220         IV copy_count = len_a - i_a;
9221         if (copy_count > 0) {   /* The non-exhausted input is 'a' */
9222             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
9223         }
9224         else { /* The non-exhausted input is b */
9225             copy_count = len_b - i_b;
9226             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
9227         }
9228         len_u = i_u + copy_count;
9229     }
9230
9231     /* Set the result to the final length, which can change the pointer to
9232      * array_u, so re-find it.  (Note that it is unlikely that this will
9233      * change, as we are shrinking the space, not enlarging it) */
9234     if (len_u != _invlist_len(u)) {
9235         invlist_set_len(u, len_u, *get_invlist_offset_addr(u));
9236         invlist_trim(u);
9237         array_u = invlist_array(u);
9238     }
9239
9240     if (*output == NULL) {  /* Simply return the new inversion list */
9241         *output = u;
9242     }
9243     else {
9244         /* Otherwise, overwrite the inversion list that was in '*output'.  We
9245          * could instead free '*output', and then set it to 'u', but experience
9246          * has shown [perl #127392] that if the input is a mortal, we can get a
9247          * huge build-up of these during regex compilation before they get
9248          * freed. */
9249         invlist_replace_list_destroys_src(*output, u);
9250         SvREFCNT_dec_NN(u);
9251     }
9252
9253     return;
9254 }
9255
9256 void
9257 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b,
9258                                                const bool complement_b, SV** i)
9259 {
9260     /* Take the intersection of two inversion lists and point '*i' to it.  On
9261      * input, '*i' MUST POINT TO NULL OR TO AN SV* INVERSION LIST (possibly
9262      * even 'a' or 'b').  If to an inversion list, the contents of the original
9263      * list will be replaced by the intersection.  The first list, 'a', may be
9264      * NULL, in which case '*i' will be an empty list.  If 'complement_b' is
9265      * TRUE, the result will be the intersection of 'a' and the complement (or
9266      * inversion) of 'b' instead of 'b' directly.
9267      *
9268      * The basis for this comes from "Unicode Demystified" Chapter 13 by
9269      * Richard Gillam, published by Addison-Wesley, and explained at some
9270      * length there.  The preface says to incorporate its examples into your
9271      * code at your own risk.  In fact, it had bugs
9272      *
9273      * The algorithm is like a merge sort, and is essentially the same as the
9274      * union above
9275      */
9276
9277     const UV* array_a;          /* a's array */
9278     const UV* array_b;
9279     UV len_a;   /* length of a's array */
9280     UV len_b;
9281
9282     SV* r;                   /* the resulting intersection */
9283     UV* array_r;
9284     UV len_r = 0;
9285
9286     UV i_a = 0;             /* current index into a's array */
9287     UV i_b = 0;
9288     UV i_r = 0;
9289
9290     /* running count of how many of the two inputs are postitioned at ranges
9291      * that are in their sets.  As explained in the algorithm source book,
9292      * items are stopped accumulating and are output when the count changes
9293      * to/from 2.  The count is incremented when we start a range that's in an
9294      * input's set, and decremented when we start a range that's not in a set.
9295      * Only when it is 2 are we in the intersection. */
9296     UV count = 0;
9297
9298     PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
9299     assert(a != b);
9300     assert(*i == NULL || SvTYPE(*i) == SVt_INVLIST);
9301
9302     /* Special case if either one is empty */
9303     len_a = (a == NULL) ? 0 : _invlist_len(a);
9304     if ((len_a == 0) || ((len_b = _invlist_len(b)) == 0)) {
9305         if (len_a != 0 && complement_b) {
9306
9307             /* Here, 'a' is not empty, therefore from the enclosing 'if', 'b'
9308              * must be empty.  Here, also we are using 'b's complement, which
9309              * hence must be every possible code point.  Thus the intersection
9310              * is simply 'a'. */
9311
9312             if (*i == a) {  /* No-op */
9313                 return;
9314             }
9315
9316             if (*i == NULL) {
9317                 *i = invlist_clone(a);
9318                 return;
9319             }
9320
9321             r = invlist_clone(a);
9322             invlist_replace_list_destroys_src(*i, r);
9323             SvREFCNT_dec_NN(r);
9324             return;
9325         }
9326
9327         /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
9328          * intersection must be empty */
9329         if (*i == NULL) {
9330             *i = _new_invlist(0);
9331             return;
9332         }
9333
9334         invlist_clear(*i);
9335         return;
9336     }
9337
9338     /* Here both lists exist and are non-empty */
9339     array_a = invlist_array(a);
9340     array_b = invlist_array(b);
9341
9342     /* If are to take the intersection of 'a' with the complement of b, set it
9343      * up so are looking at b's complement. */
9344     if (complement_b) {
9345
9346         /* To complement, we invert: if the first element is 0, remove it.  To
9347          * do this, we just pretend the array starts one later */
9348         if (array_b[0] == 0) {
9349             array_b++;
9350             len_b--;
9351         }
9352         else {
9353
9354             /* But if the first element is not zero, we pretend the list starts
9355              * at the 0 that is always stored immediately before the array. */
9356             array_b--;
9357             len_b++;
9358         }
9359     }
9360
9361     /* Size the intersection for the worst case: that the intersection ends up
9362      * fragmenting everything to be completely disjoint */
9363     r= _new_invlist(len_a + len_b);
9364
9365     /* Will contain U+0000 iff both components do */
9366     array_r = _invlist_array_init(r,    len_a > 0 && array_a[0] == 0
9367                                      && len_b > 0 && array_b[0] == 0);
9368
9369     /* Go through each list item by item, stopping when have exhausted one of
9370      * them */
9371     while (i_a < len_a && i_b < len_b) {
9372         UV cp;      /* The element to potentially add to the intersection's
9373                        array */
9374         bool cp_in_set; /* Is it in the input list's set or not */
9375
9376         /* We need to take one or the other of the two inputs for the
9377          * intersection.  Since we are merging two sorted lists, we take the
9378          * smaller of the next items.  In case of a tie, we take first the one
9379          * that is not in its set (a difference from the union algorithm).  If
9380          * we first took the one in its set, it would increment the count,
9381          * possibly to 2 which would cause it to be output as starting a range
9382          * in the intersection, and the next time through we would take that
9383          * same number, and output it again as ending the set.  By doing the
9384          * opposite of this, there is no possibility that the count will be
9385          * momentarily incremented to 2.  (In a tie and both are in the set or
9386          * both not in the set, it doesn't matter which we take first.) */
9387         if (       array_a[i_a] < array_b[i_b]
9388             || (   array_a[i_a] == array_b[i_b]
9389                 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
9390         {
9391             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
9392             cp = array_a[i_a++];
9393         }
9394         else {
9395             cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
9396             cp= array_b[i_b++];
9397         }
9398
9399         /* Here, have chosen which of the two inputs to look at.  Only output
9400          * if the running count changes to/from 2, which marks the
9401          * beginning/end of a range that's in the intersection */
9402         if (cp_in_set) {
9403             count++;
9404             if (count == 2) {
9405                 array_r[i_r++] = cp;
9406             }
9407         }
9408         else {
9409             if (count == 2) {
9410                 array_r[i_r++] = cp;
9411             }
9412             count--;
9413         }
9414
9415     }
9416
9417     /* The loop above increments the index into exactly one of the input lists
9418      * each iteration, and ends when either index gets to its list end.  That
9419      * means the other index is lower than its end, and so something is
9420      * remaining in that one.  We increment 'count', as explained below, if the
9421      * exhausted list was in its set.  (i_a and i_b each currently index the
9422      * element beyond the one we care about.) */
9423     if (   (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
9424         || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
9425     {
9426         count++;
9427     }
9428
9429     /* Above we incremented 'count' if the exhausted list was in its set.  This
9430      * has made it so that 'count' being below 2 means there is nothing left to
9431      * output; otheriwse what's left to add to the intersection is precisely
9432      * that which is left in the non-exhausted input list.
9433      *
9434      * To see why, note first that the exhausted input obviously has nothing
9435      * left to affect the intersection.  If it was in its set at its end, that
9436      * means the set extends from here to the platform's infinity, and hence
9437      * anything in the non-exhausted's list will be in the intersection, and
9438      * anything not in it won't be.  Hence, the rest of the intersection is
9439      * precisely what's in the non-exhausted list  The exhausted set also
9440      * contributed 1 to 'count', meaning 'count' was at least 1.  Incrementing
9441      * it means 'count' is now at least 2.  This is consistent with the
9442      * incremented 'count' being >= 2 means to add the non-exhausted list to
9443      * the intersection.
9444      *
9445      * But if the exhausted input wasn't in its set, it contributed 0 to
9446      * 'count', and the intersection can't include anything further; the
9447      * non-exhausted set is irrelevant.  'count' was at most 1, and doesn't get
9448      * incremented.  This is consistent with 'count' being < 2 meaning nothing
9449      * further to add to the intersection. */
9450     if (count < 2) { /* Nothing left to put in the intersection. */
9451         len_r = i_r;
9452     }
9453     else { /* copy the non-exhausted list, unchanged. */
9454         IV copy_count = len_a - i_a;
9455         if (copy_count > 0) {   /* a is the one with stuff left */
9456             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
9457         }
9458         else {  /* b is the one with stuff left */
9459             copy_count = len_b - i_b;
9460             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
9461         }
9462         len_r = i_r + copy_count;
9463     }
9464
9465     /* Set the result to the final length, which can change the pointer to
9466      * array_r, so re-find it.  (Note that it is unlikely that this will
9467      * change, as we are shrinking the space, not enlarging it) */
9468     if (len_r != _invlist_len(r)) {
9469         invlist_set_len(r, len_r, *get_invlist_offset_addr(r));
9470         invlist_trim(r);
9471         array_r = invlist_array(r);
9472     }
9473
9474     if (*i == NULL) { /* Simply return the calculated intersection */
9475         *i = r;
9476     }
9477     else { /* Otherwise, replace the existing inversion list in '*i'.  We could
9478               instead free '*i', and then set it to 'r', but experience has
9479               shown [perl #127392] that if the input is a mortal, we can get a
9480               huge build-up of these during regex compilation before they get
9481               freed. */
9482         if (len_r) {
9483             invlist_replace_list_destroys_src(*i, r);
9484         }
9485         else {
9486             invlist_clear(*i);
9487         }
9488         SvREFCNT_dec_NN(r);
9489     }
9490
9491     return;
9492 }
9493
9494 SV*
9495 Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end)
9496 {
9497     /* Add the range from 'start' to 'end' inclusive to the inversion list's
9498      * set.  A pointer to the inversion list is returned.  This may actually be
9499      * a new list, in which case the passed in one has been destroyed.  The
9500      * passed-in inversion list can be NULL, in which case a new one is created
9501      * with just the one range in it.  The new list is not necessarily
9502      * NUL-terminated.  Space is not freed if the inversion list shrinks as a
9503      * result of this function.  The gain would not be large, and in many
9504      * cases, this is called multiple times on a single inversion list, so
9505      * anything freed may almost immediately be needed again.
9506      *
9507      * This used to mostly call the 'union' routine, but that is much more
9508      * heavyweight than really needed for a single range addition */
9509
9510     UV* array;              /* The array implementing the inversion list */
9511     UV len;                 /* How many elements in 'array' */
9512     SSize_t i_s;            /* index into the invlist array where 'start'
9513                                should go */
9514     SSize_t i_e = 0;        /* And the index where 'end' should go */
9515     UV cur_highest;         /* The highest code point in the inversion list
9516                                upon entry to this function */
9517
9518     /* This range becomes the whole inversion list if none already existed */
9519     if (invlist == NULL) {
9520         invlist = _new_invlist(2);
9521         _append_range_to_invlist(invlist, start, end);
9522         return invlist;
9523     }
9524
9525     /* Likewise, if the inversion list is currently empty */
9526     len = _invlist_len(invlist);
9527     if (len == 0) {
9528         _append_range_to_invlist(invlist, start, end);
9529         return invlist;
9530     }
9531
9532     /* Starting here, we have to know the internals of the list */
9533     array = invlist_array(invlist);
9534
9535     /* If the new range ends higher than the current highest ... */
9536     cur_highest = invlist_highest(invlist);
9537     if (end > cur_highest) {
9538
9539         /* If the whole range is higher, we can just append it */
9540         if (start > cur_highest) {
9541             _append_range_to_invlist(invlist, start, end);
9542             return invlist;
9543         }
9544
9545         /* Otherwise, add the portion that is higher ... */
9546         _append_range_to_invlist(invlist, cur_highest + 1, end);
9547
9548         /* ... and continue on below to handle the rest.  As a result of the
9549          * above append, we know that the index of the end of the range is the
9550          * final even numbered one of the array.  Recall that the final element
9551          * always starts a range that extends to infinity.  If that range is in
9552          * the set (meaning the set goes from here to infinity), it will be an
9553          * even index, but if it isn't in the set, it's odd, and the final
9554          * range in the set is one less, which is even. */
9555         if (end == UV_MAX) {
9556             i_e = len;
9557         }
9558         else {
9559             i_e = len - 2;
9560         }
9561     }
9562
9563     /* We have dealt with appending, now see about prepending.  If the new
9564      * range starts lower than the current lowest ... */
9565     if (start < array[0]) {
9566
9567         /* Adding something which has 0 in it is somewhat tricky, and uncommon.
9568          * Let the union code handle it, rather than having to know the
9569          * trickiness in two code places.  */
9570         if (UNLIKELY(start == 0)) {
9571             SV* range_invlist;
9572
9573             range_invlist = _new_invlist(2);
9574             _append_range_to_invlist(range_invlist, start, end);
9575
9576             _invlist_union(invlist, range_invlist, &invlist);
9577
9578             SvREFCNT_dec_NN(range_invlist);
9579
9580             return invlist;
9581         }
9582
9583         /* If the whole new range comes before the first entry, and doesn't
9584          * extend it, we have to insert it as an additional range */
9585         if (end < array[0] - 1) {
9586             i_s = i_e = -1;
9587             goto splice_in_new_range;
9588         }
9589
9590         /* Here the new range adjoins the existing first range, extending it
9591          * downwards. */
9592         array[0] = start;
9593
9594         /* And continue on below to handle the rest.  We know that the index of
9595          * the beginning of the range is the first one of the array */
9596         i_s = 0;
9597     }
9598     else { /* Not prepending any part of the new range to the existing list.
9599             * Find where in the list it should go.  This finds i_s, such that:
9600             *     invlist[i_s] <= start < array[i_s+1]
9601             */
9602         i_s = _invlist_search(invlist, start);
9603     }
9604
9605     /* At this point, any extending before the beginning of the inversion list
9606      * and/or after the end has been done.  This has made it so that, in the
9607      * code below, each endpoint of the new range is either in a range that is
9608      * in the set, or is in a gap between two ranges that are.  This means we
9609      * don't have to worry about exceeding the array bounds.
9610      *
9611      * Find where in the list the new range ends (but we can skip this if we
9612      * have already determined what it is, or if it will be the same as i_s,
9613      * which we already have computed) */
9614     if (i_e == 0) {
9615         i_e = (start == end)
9616               ? i_s
9617               : _invlist_search(invlist, end);
9618     }
9619
9620     /* Here generally invlist[i_e] <= end < array[i_e+1].  But if invlist[i_e]
9621      * is a range that goes to infinity there is no element at invlist[i_e+1],
9622      * so only the first relation holds. */
9623
9624     if ( ! ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9625
9626         /* Here, the ranges on either side of the beginning of the new range
9627          * are in the set, and this range starts in the gap between them.
9628          *
9629          * The new range extends the range above it downwards if the new range
9630          * ends at or above that range's start */
9631         const bool extends_the_range_above = (   end == UV_MAX
9632                                               || end + 1 >= array[i_s+1]);
9633
9634         /* The new range extends the range below it upwards if it begins just
9635          * after where that range ends */
9636         if (start == array[i_s]) {
9637
9638             /* If the new range fills the entire gap between the other ranges,
9639              * they will get merged together.  Other ranges may also get
9640              * merged, depending on how many of them the new range spans.  In
9641              * the general case, we do the merge later, just once, after we
9642              * figure out how many to merge.  But in the case where the new
9643              * range exactly spans just this one gap (possibly extending into
9644              * the one above), we do the merge here, and an early exit.  This
9645              * is done here to avoid having to special case later. */
9646             if (i_e - i_s <= 1) {
9647
9648                 /* If i_e - i_s == 1, it means that the new range terminates
9649                  * within the range above, and hence 'extends_the_range_above'
9650                  * must be true.  (If the range above it extends to infinity,
9651                  * 'i_s+2' will be above the array's limit, but 'len-i_s-2'
9652                  * will be 0, so no harm done.) */
9653                 if (extends_the_range_above) {
9654                     Move(array + i_s + 2, array + i_s, len - i_s - 2, UV);
9655                     invlist_set_len(invlist,
9656                                     len - 2,
9657                                     *(get_invlist_offset_addr(invlist)));
9658                     return invlist;
9659                 }
9660
9661                 /* Here, i_e must == i_s.  We keep them in sync, as they apply
9662                  * to the same range, and below we are about to decrement i_s
9663                  * */
9664                 i_e--;
9665             }
9666
9667             /* Here, the new range is adjacent to the one below.  (It may also
9668              * span beyond the range above, but that will get resolved later.)
9669              * Extend the range below to include this one. */
9670             array[i_s] = (end == UV_MAX) ? UV_MAX : end + 1;
9671             i_s--;
9672             start = array[i_s];
9673         }
9674         else if (extends_the_range_above) {
9675
9676             /* Here the new range only extends the range above it, but not the
9677              * one below.  It merges with the one above.  Again, we keep i_e
9678              * and i_s in sync if they point to the same range */
9679             if (i_e == i_s) {
9680                 i_e++;
9681             }
9682             i_s++;
9683             array[i_s] = start;
9684         }
9685     }
9686
9687     /* Here, we've dealt with the new range start extending any adjoining
9688      * existing ranges.
9689      *
9690      * If the new range extends to infinity, it is now the final one,
9691      * regardless of what was there before */
9692     if (UNLIKELY(end == UV_MAX)) {
9693         invlist_set_len(invlist, i_s + 1, *(get_invlist_offset_addr(invlist)));
9694         return invlist;
9695     }
9696
9697     /* If i_e started as == i_s, it has also been dealt with,
9698      * and been updated to the new i_s, which will fail the following if */
9699     if (! ELEMENT_RANGE_MATCHES_INVLIST(i_e)) {
9700
9701         /* Here, the ranges on either side of the end of the new range are in
9702          * the set, and this range ends in the gap between them.
9703          *
9704          * If this range is adjacent to (hence extends) the range above it, it
9705          * becomes part of that range; likewise if it extends the range below,
9706          * it becomes part of that range */
9707         if (end + 1 == array[i_e+1]) {
9708             i_e++;
9709             array[i_e] = start;
9710         }
9711         else if (start <= array[i_e]) {
9712             array[i_e] = end + 1;
9713             i_e--;
9714         }
9715     }
9716
9717     if (i_s == i_e) {
9718
9719         /* If the range fits entirely in an existing range (as possibly already
9720          * extended above), it doesn't add anything new */
9721         if (ELEMENT_RANGE_MATCHES_INVLIST(i_s)) {
9722             return invlist;
9723         }
9724
9725         /* Here, no part of the range is in the list.  Must add it.  It will
9726          * occupy 2 more slots */
9727       splice_in_new_range:
9728
9729         invlist_extend(invlist, len + 2);
9730         array = invlist_array(invlist);
9731         /* Move the rest of the array down two slots. Don't include any
9732          * trailing NUL */
9733         Move(array + i_e + 1, array + i_e + 3, len - i_e - 1, UV);
9734
9735         /* Do the actual splice */
9736         array[i_e+1] = start;
9737         array[i_e+2] = end + 1;
9738         invlist_set_len(invlist, len + 2, *(get_invlist_offset_addr(invlist)));
9739         return invlist;
9740     }
9741
9742     /* Here the new range crossed the boundaries of a pre-existing range.  The
9743      * code above has adjusted things so that both ends are in ranges that are
9744      * in the set.  This means everything in between must also be in the set.
9745      * Just squash things together */
9746     Move(array + i_e + 1, array + i_s + 1, len - i_e - 1, UV);
9747     invlist_set_len(invlist,
9748                     len - i_e + i_s,
9749                     *(get_invlist_offset_addr(invlist)));
9750
9751     return invlist;
9752 }
9753
9754 SV*
9755 Perl__setup_canned_invlist(pTHX_ const STRLEN size, const UV element0,
9756                                  UV** other_elements_ptr)
9757 {
9758     /* Create and return an inversion list whose contents are to be populated
9759      * by the caller.  The caller gives the number of elements (in 'size') and
9760      * the very first element ('element0').  This function will set
9761      * '*other_elements_ptr' to an array of UVs, where the remaining elements
9762      * are to be placed.
9763      *
9764      * Obviously there is some trust involved that the caller will properly
9765      * fill in the other elements of the array.
9766      *
9767      * (The first element needs to be passed in, as the underlying code does
9768      * things differently depending on whether it is zero or non-zero) */
9769
9770     SV* invlist = _new_invlist(size);
9771     bool offset;
9772
9773     PERL_ARGS_ASSERT__SETUP_CANNED_INVLIST;
9774
9775     invlist = add_cp_to_invlist(invlist, element0);
9776     offset = *get_invlist_offset_addr(invlist);
9777
9778     invlist_set_len(invlist, size, offset);
9779     *other_elements_ptr = invlist_array(invlist) + 1;
9780     return invlist;
9781 }
9782
9783 #endif
9784
9785 PERL_STATIC_INLINE SV*
9786 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
9787     return _add_range_to_invlist(invlist, cp, cp);
9788 }
9789
9790 #ifndef PERL_IN_XSUB_RE
9791 void
9792 Perl__invlist_invert(pTHX_ SV* const invlist)
9793 {
9794     /* Complement the input inversion list.  This adds a 0 if the list didn't
9795      * have a zero; removes it otherwise.  As described above, the data
9796      * structure is set up so that this is very efficient */
9797
9798     PERL_ARGS_ASSERT__INVLIST_INVERT;
9799
9800     assert(! invlist_is_iterating(invlist));
9801
9802     /* The inverse of matching nothing is matching everything */
9803     if (_invlist_len(invlist) == 0) {
9804         _append_range_to_invlist(invlist, 0, UV_MAX);
9805         return;
9806     }
9807
9808     *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist);
9809 }
9810
9811 #endif
9812
9813 PERL_STATIC_INLINE SV*
9814 S_invlist_clone(pTHX_ SV* const invlist)
9815 {
9816
9817     /* Return a new inversion list that is a copy of the input one, which is
9818      * unchanged.  The new list will not be mortal even if the old one was. */
9819
9820     /* Need to allocate extra space to accommodate Perl's addition of a
9821      * trailing NUL to SvPV's, since it thinks they are always strings */
9822     SV* new_invlist = _new_invlist(_invlist_len(invlist) + 1);
9823     STRLEN physical_length = SvCUR(invlist);
9824     bool offset = *(get_invlist_offset_addr(invlist));
9825
9826     PERL_ARGS_ASSERT_INVLIST_CLONE;
9827
9828     *(get_invlist_offset_addr(new_invlist)) = offset;
9829     invlist_set_len(new_invlist, _invlist_len(invlist), offset);
9830     Copy(SvPVX(invlist), SvPVX(new_invlist), physical_length, char);
9831
9832     return new_invlist;
9833 }
9834
9835 PERL_STATIC_INLINE STRLEN*
9836 S_get_invlist_iter_addr(SV* invlist)
9837 {
9838     /* Return the address of the UV that contains the current iteration
9839      * position */
9840
9841     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
9842
9843     assert(SvTYPE(invlist) == SVt_INVLIST);
9844
9845     return &(((XINVLIST*) SvANY(invlist))->iterator);
9846 }
9847
9848 PERL_STATIC_INLINE void
9849 S_invlist_iterinit(SV* invlist) /* Initialize iterator for invlist */
9850 {
9851     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
9852
9853     *get_invlist_iter_addr(invlist) = 0;
9854 }
9855
9856 PERL_STATIC_INLINE void
9857 S_invlist_iterfinish(SV* invlist)
9858 {
9859     /* Terminate iterator for invlist.  This is to catch development errors.
9860      * Any iteration that is interrupted before completed should call this
9861      * function.  Functions that add code points anywhere else but to the end
9862      * of an inversion list assert that they are not in the middle of an
9863      * iteration.  If they were, the addition would make the iteration
9864      * problematical: if the iteration hadn't reached the place where things
9865      * were being added, it would be ok */
9866
9867     PERL_ARGS_ASSERT_INVLIST_ITERFINISH;
9868
9869     *get_invlist_iter_addr(invlist) = (STRLEN) UV_MAX;
9870 }
9871
9872 STATIC bool
9873 S_invlist_iternext(SV* invlist, UV* start, UV* end)
9874 {
9875     /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
9876      * This call sets in <*start> and <*end>, the next range in <invlist>.
9877      * Returns <TRUE> if successful and the next call will return the next
9878      * range; <FALSE> if was already at the end of the list.  If the latter,
9879      * <*start> and <*end> are unchanged, and the next call to this function
9880      * will start over at the beginning of the list */
9881
9882     STRLEN* pos = get_invlist_iter_addr(invlist);
9883     UV len = _invlist_len(invlist);
9884     UV *array;
9885
9886     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
9887
9888     if (*pos >= len) {
9889         *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */
9890         return FALSE;
9891     }
9892
9893     array = invlist_array(invlist);
9894
9895     *start = array[(*pos)++];
9896
9897     if (*pos >= len) {
9898         *end = UV_MAX;
9899     }
9900     else {
9901         *end = array[(*pos)++] - 1;
9902     }
9903
9904     return TRUE;
9905 }
9906
9907 PERL_STATIC_INLINE UV
9908 S_invlist_highest(SV* const invlist)
9909 {
9910     /* Returns the highest code point that matches an inversion list.  This API
9911      * has an ambiguity, as it returns 0 under either the highest is actually
9912      * 0, or if the list is empty.  If this distinction matters to you, check
9913      * for emptiness before calling this function */
9914
9915     UV len = _invlist_len(invlist);
9916     UV *array;
9917
9918     PERL_ARGS_ASSERT_INVLIST_HIGHEST;
9919
9920     if (len == 0) {
9921         return 0;
9922     }
9923
9924     array = invlist_array(invlist);
9925
9926     /* The last element in the array in the inversion list always starts a
9927      * range that goes to infinity.  That range may be for code points that are
9928      * matched in the inversion list, or it may be for ones that aren't
9929      * matched.  In the latter case, the highest code point in the set is one
9930      * less than the beginning of this range; otherwise it is the final element
9931      * of this range: infinity */
9932     return (ELEMENT_RANGE_MATCHES_INVLIST(len - 1))
9933            ? UV_MAX
9934            : array[len - 1] - 1;
9935 }
9936
9937 STATIC SV *
9938 S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style)
9939 {
9940     /* Get the contents of an inversion list into a string SV so that they can
9941      * be printed out.  If 'traditional_style' is TRUE, it uses the format
9942      * traditionally done for debug tracing; otherwise it uses a format
9943      * suitable for just copying to the output, with blanks between ranges and
9944      * a dash between range components */
9945
9946     UV start, end;
9947     SV* output;
9948     const char intra_range_delimiter = (traditional_style ? '\t' : '-');
9949     const char inter_range_delimiter = (traditional_style ? '\n' : ' ');
9950
9951     if (traditional_style) {
9952         output = newSVpvs("\n");
9953     }
9954     else {
9955         output = newSVpvs("");
9956     }
9957
9958     PERL_ARGS_ASSERT_INVLIST_CONTENTS;
9959
9960     assert(! invlist_is_iterating(invlist));
9961
9962     invlist_iterinit(invlist);
9963     while (invlist_iternext(invlist, &start, &end)) {
9964         if (end == UV_MAX) {
9965             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFINITY%c",
9966                                           start, intra_range_delimiter,
9967                                                  inter_range_delimiter);
9968         }
9969         else if (end != start) {
9970             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c",
9971                                           start,
9972                                                    intra_range_delimiter,
9973                                                   end, inter_range_delimiter);
9974         }
9975         else {
9976             Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c",
9977                                           start, inter_range_delimiter);
9978         }
9979     }
9980
9981     if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */
9982         SvCUR_set(output, SvCUR(output) - 1);
9983     }
9984
9985     return output;
9986 }
9987
9988 #ifndef PERL_IN_XSUB_RE
9989 void
9990 Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
9991                          const char * const indent, SV* const invlist)
9992 {
9993     /* Designed to be called only by do_sv_dump().  Dumps out the ranges of the
9994      * inversion list 'invlist' to 'file' at 'level'  Each line is prefixed by
9995      * the string 'indent'.  The output looks like this:
9996          [0] 0x000A .. 0x000D
9997          [2] 0x0085
9998          [4] 0x2028 .. 0x2029
9999          [6] 0x3104 .. INFINITY
10000      * This means that the first range of code points matched by the list are
10001      * 0xA through 0xD; the second range contains only the single code point
10002      * 0x85, etc.  An inversion list is an array of UVs.  Two array elements
10003      * are used to define each range (except if the final range extends to
10004      * infinity, only a single element is needed).  The array index of the
10005      * first element for the corresponding range is given in brackets. */
10006
10007     UV start, end;
10008     STRLEN count = 0;
10009
10010     PERL_ARGS_ASSERT__INVLIST_DUMP;
10011
10012     if (invlist_is_iterating(invlist)) {
10013         Perl_dump_indent(aTHX_ level, file,
10014              "%sCan't dump inversion list because is in middle of iterating\n",
10015              indent);
10016         return;
10017     }
10018
10019     invlist_iterinit(invlist);
10020     while (invlist_iternext(invlist, &start, &end)) {
10021         if (end == UV_MAX) {
10022             Perl_dump_indent(aTHX_ level, file,
10023                                        "%s[%" UVuf "] 0x%04" UVXf " .. INFINITY\n",
10024                                    indent, (UV)count, start);
10025         }
10026         else if (end != start) {
10027             Perl_dump_indent(aTHX_ level, file,
10028                                     "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n",
10029                                 indent, (UV)count, start,         end);
10030         }
10031         else {
10032             Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n",
10033                                             indent, (UV)count, start);
10034         }
10035         count += 2;
10036     }
10037 }
10038
10039 void
10040 Perl__load_PL_utf8_foldclosures (pTHX)
10041 {
10042     assert(! PL_utf8_foldclosures);
10043
10044     /* If the folds haven't been read in, call a fold function
10045      * to force that */
10046     if (! PL_utf8_tofold) {
10047         U8 dummy[UTF8_MAXBYTES_CASE+1];
10048
10049         /* This string is just a short named one above \xff */
10050         toFOLD_utf8((U8*) HYPHEN_UTF8, dummy, NULL);
10051         assert(PL_utf8_tofold); /* Verify that worked */
10052     }
10053     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10054 }
10055 #endif
10056
10057 #if defined(PERL_ARGS_ASSERT__INVLISTEQ) && !defined(PERL_IN_XSUB_RE)
10058 bool
10059 Perl__invlistEQ(pTHX_ SV* const a, SV* const b, const bool complement_b)
10060 {
10061     /* Return a boolean as to if the two passed in inversion lists are
10062      * identical.  The final argument, if TRUE, says to take the complement of
10063      * the second inversion list before doing the comparison */
10064
10065     const UV* array_a = invlist_array(a);
10066     const UV* array_b = invlist_array(b);
10067     UV len_a = _invlist_len(a);
10068     UV len_b = _invlist_len(b);
10069
10070     UV i = 0;               /* current index into the arrays */
10071     bool retval = TRUE;     /* Assume are identical until proven otherwise */
10072
10073     PERL_ARGS_ASSERT__INVLISTEQ;
10074
10075     /* If are to compare 'a' with the complement of b, set it
10076      * up so are looking at b's complement. */
10077     if (complement_b) {
10078
10079         /* The complement of nothing is everything, so <a> would have to have
10080          * just one element, starting at zero (ending at infinity) */
10081         if (len_b == 0) {
10082             return (len_a == 1 && array_a[0] == 0);
10083         }
10084         else if (array_b[0] == 0) {
10085
10086             /* Otherwise, to complement, we invert.  Here, the first element is
10087              * 0, just remove it.  To do this, we just pretend the array starts
10088              * one later */
10089
10090             array_b++;
10091             len_b--;
10092         }
10093         else {
10094
10095             /* But if the first element is not zero, we pretend the list starts
10096              * at the 0 that is always stored immediately before the array. */
10097             array_b--;
10098             len_b++;
10099         }
10100     }
10101
10102     /* Make sure that the lengths are the same, as well as the final element
10103      * before looping through the remainder.  (Thus we test the length, final,
10104      * and first elements right off the bat) */
10105     if (len_a != len_b || array_a[len_a-1] != array_b[len_a-1]) {
10106         retval = FALSE;
10107     }
10108     else for (i = 0; i < len_a - 1; i++) {
10109         if (array_a[i] != array_b[i]) {
10110             retval = FALSE;
10111             break;
10112         }
10113     }
10114
10115     return retval;
10116 }
10117 #endif
10118
10119 /*
10120  * As best we can, determine the characters that can match the start of
10121  * the given EXACTF-ish node.
10122  *
10123  * Returns the invlist as a new SV*; it is the caller's responsibility to
10124  * call SvREFCNT_dec() when done with it.
10125  */
10126 STATIC SV*
10127 S__make_exactf_invlist(pTHX_ RExC_state_t *pRExC_state, regnode *node)
10128 {
10129     const U8 * s = (U8*)STRING(node);
10130     SSize_t bytelen = STR_LEN(node);
10131     UV uc;
10132     /* Start out big enough for 2 separate code points */
10133     SV* invlist = _new_invlist(4);
10134
10135     PERL_ARGS_ASSERT__MAKE_EXACTF_INVLIST;
10136
10137     if (! UTF) {
10138         uc = *s;
10139
10140         /* We punt and assume can match anything if the node begins
10141          * with a multi-character fold.  Things are complicated.  For
10142          * example, /ffi/i could match any of:
10143          *  "\N{LATIN SMALL LIGATURE FFI}"
10144          *  "\N{LATIN SMALL LIGATURE FF}I"
10145          *  "F\N{LATIN SMALL LIGATURE FI}"
10146          *  plus several other things; and making sure we have all the
10147          *  possibilities is hard. */
10148         if (is_MULTI_CHAR_FOLD_latin1_safe(s, s + bytelen)) {
10149             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10150         }
10151         else {
10152             /* Any Latin1 range character can potentially match any
10153              * other depending on the locale */
10154             if (OP(node) == EXACTFL) {
10155                 _invlist_union(invlist, PL_Latin1, &invlist);
10156             }
10157             else {
10158                 /* But otherwise, it matches at least itself.  We can
10159                  * quickly tell if it has a distinct fold, and if so,
10160                  * it matches that as well */
10161                 invlist = add_cp_to_invlist(invlist, uc);
10162                 if (IS_IN_SOME_FOLD_L1(uc))
10163                     invlist = add_cp_to_invlist(invlist, PL_fold_latin1[uc]);
10164             }
10165
10166             /* Some characters match above-Latin1 ones under /i.  This
10167              * is true of EXACTFL ones when the locale is UTF-8 */
10168             if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(uc)
10169                 && (! isASCII(uc) || (OP(node) != EXACTFA
10170                                     && OP(node) != EXACTFA_NO_TRIE)))
10171             {
10172                 add_above_Latin1_folds(pRExC_state, (U8) uc, &invlist);
10173             }
10174         }
10175     }
10176     else {  /* Pattern is UTF-8 */
10177         U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
10178         STRLEN foldlen = UTF8SKIP(s);
10179         const U8* e = s + bytelen;
10180         SV** listp;
10181
10182         uc = utf8_to_uvchr_buf(s, s + bytelen, NULL);
10183
10184         /* The only code points that aren't folded in a UTF EXACTFish
10185          * node are are the problematic ones in EXACTFL nodes */
10186         if (OP(node) == EXACTFL && is_PROBLEMATIC_LOCALE_FOLDEDS_START_cp(uc)) {
10187             /* We need to check for the possibility that this EXACTFL
10188              * node begins with a multi-char fold.  Therefore we fold
10189              * the first few characters of it so that we can make that
10190              * check */
10191             U8 *d = folded;
10192             int i;
10193
10194             for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < e; i++) {
10195                 if (isASCII(*s)) {
10196                     *(d++) = (U8) toFOLD(*s);
10197                     s++;
10198                 }
10199                 else {
10200                     STRLEN len;
10201                     toFOLD_utf8(s, d, &len);
10202                     d += len;
10203                     s += UTF8SKIP(s);
10204                 }
10205             }
10206
10207             /* And set up so the code below that looks in this folded
10208              * buffer instead of the node's string */
10209             e = d;
10210             foldlen = UTF8SKIP(folded);
10211             s = folded;
10212         }
10213
10214         /* When we reach here 's' points to the fold of the first
10215          * character(s) of the node; and 'e' points to far enough along
10216          * the folded string to be just past any possible multi-char
10217          * fold. 'foldlen' is the length in bytes of the first
10218          * character in 's'
10219          *
10220          * Unlike the non-UTF-8 case, the macro for determining if a
10221          * string is a multi-char fold requires all the characters to
10222          * already be folded.  This is because of all the complications
10223          * if not.  Note that they are folded anyway, except in EXACTFL
10224          * nodes.  Like the non-UTF case above, we punt if the node
10225          * begins with a multi-char fold  */
10226
10227         if (is_MULTI_CHAR_FOLD_utf8_safe(s, e)) {
10228             invlist = _add_range_to_invlist(invlist, 0, UV_MAX);
10229         }
10230         else {  /* Single char fold */
10231
10232             /* It matches all the things that fold to it, which are
10233              * found in PL_utf8_foldclosures (including itself) */
10234             invlist = add_cp_to_invlist(invlist, uc);
10235             if (! PL_utf8_foldclosures)
10236                 _load_PL_utf8_foldclosures();
10237             if ((listp = hv_fetch(PL_utf8_foldclosures,
10238                                 (char *) s, foldlen, FALSE)))
10239             {
10240                 AV* list = (AV*) *listp;
10241                 IV k;
10242                 for (k = 0; k <= av_tindex_nomg(list); k++) {
10243                     SV** c_p = av_fetch(list, k, FALSE);
10244                     UV c;
10245                     assert(c_p);
10246
10247                     c = SvUV(*c_p);
10248
10249                     /* /aa doesn't allow folds between ASCII and non- */
10250                     if ((OP(node) == EXACTFA || OP(node) == EXACTFA_NO_TRIE)
10251                         && isASCII(c) != isASCII(uc))
10252                     {
10253                         continue;
10254                     }
10255
10256                     invlist = add_cp_to_invlist(invlist, c);
10257                 }
10258             }
10259         }
10260     }
10261
10262     return invlist;
10263 }
10264
10265 #undef HEADER_LENGTH
10266 #undef TO_INTERNAL_SIZE
10267 #undef FROM_INTERNAL_SIZE
10268 #undef INVLIST_VERSION_ID
10269
10270 /* End of inversion list object */
10271
10272 STATIC void
10273 S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state)
10274 {
10275     /* This parses the flags that are in either the '(?foo)' or '(?foo:bar)'
10276      * constructs, and updates RExC_flags with them.  On input, RExC_parse
10277      * should point to the first flag; it is updated on output to point to the
10278      * final ')' or ':'.  There needs to be at least one flag, or this will
10279      * abort */
10280
10281     /* for (?g), (?gc), and (?o) warnings; warning
10282        about (?c) will warn about (?g) -- japhy    */
10283
10284 #define WASTED_O  0x01
10285 #define WASTED_G  0x02
10286 #define WASTED_C  0x04
10287 #define WASTED_GC (WASTED_G|WASTED_C)
10288     I32 wastedflags = 0x00;
10289     U32 posflags = 0, negflags = 0;
10290     U32 *flagsp = &posflags;
10291     char has_charset_modifier = '\0';
10292     regex_charset cs;
10293     bool has_use_defaults = FALSE;
10294     const char* const seqstart = RExC_parse - 1; /* Point to the '?' */
10295     int x_mod_count = 0;
10296
10297     PERL_ARGS_ASSERT_PARSE_LPAREN_QUESTION_FLAGS;
10298
10299     /* '^' as an initial flag sets certain defaults */
10300     if (UCHARAT(RExC_parse) == '^') {
10301         RExC_parse++;
10302         has_use_defaults = TRUE;
10303         STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
10304         set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
10305                                         ? REGEX_UNICODE_CHARSET
10306                                         : REGEX_DEPENDS_CHARSET);
10307     }
10308
10309     cs = get_regex_charset(RExC_flags);
10310     if (cs == REGEX_DEPENDS_CHARSET
10311         && (RExC_utf8 || RExC_uni_semantics))
10312     {
10313         cs = REGEX_UNICODE_CHARSET;
10314     }
10315
10316     while (RExC_parse < RExC_end) {
10317         /* && strchr("iogcmsx", *RExC_parse) */
10318         /* (?g), (?gc) and (?o) are useless here
10319            and must be globally applied -- japhy */
10320         switch (*RExC_parse) {
10321
10322             /* Code for the imsxn flags */
10323             CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp, x_mod_count);
10324
10325             case LOCALE_PAT_MOD:
10326                 if (has_charset_modifier) {
10327                     goto excess_modifier;
10328                 }
10329                 else if (flagsp == &negflags) {
10330                     goto neg_modifier;
10331                 }
10332                 cs = REGEX_LOCALE_CHARSET;
10333                 has_charset_modifier = LOCALE_PAT_MOD;
10334                 break;
10335             case UNICODE_PAT_MOD:
10336                 if (has_charset_modifier) {
10337                     goto excess_modifier;
10338                 }
10339                 else if (flagsp == &negflags) {
10340                     goto neg_modifier;
10341                 }
10342                 cs = REGEX_UNICODE_CHARSET;
10343                 has_charset_modifier = UNICODE_PAT_MOD;
10344                 break;
10345             case ASCII_RESTRICT_PAT_MOD:
10346                 if (flagsp == &negflags) {
10347                     goto neg_modifier;
10348                 }
10349                 if (has_charset_modifier) {
10350                     if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
10351                         goto excess_modifier;
10352                     }
10353                     /* Doubled modifier implies more restricted */
10354                     cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
10355                 }
10356                 else {
10357                     cs = REGEX_ASCII_RESTRICTED_CHARSET;
10358                 }
10359                 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
10360                 break;
10361             case DEPENDS_PAT_MOD:
10362                 if (has_use_defaults) {
10363                     goto fail_modifiers;
10364                 }
10365                 else if (flagsp == &negflags) {
10366                     goto neg_modifier;
10367                 }
10368                 else if (has_charset_modifier) {
10369                     goto excess_modifier;
10370                 }
10371
10372                 /* The dual charset means unicode semantics if the
10373                  * pattern (or target, not known until runtime) are
10374                  * utf8, or something in the pattern indicates unicode
10375                  * semantics */
10376                 cs = (RExC_utf8 || RExC_uni_semantics)
10377                      ? REGEX_UNICODE_CHARSET
10378                      : REGEX_DEPENDS_CHARSET;
10379                 has_charset_modifier = DEPENDS_PAT_MOD;
10380                 break;
10381               excess_modifier:
10382                 RExC_parse++;
10383                 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
10384                     vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
10385                 }
10386                 else if (has_charset_modifier == *(RExC_parse - 1)) {
10387                     vFAIL2("Regexp modifier \"%c\" may not appear twice",
10388                                         *(RExC_parse - 1));
10389                 }
10390                 else {
10391                     vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
10392                 }
10393                 NOT_REACHED; /*NOTREACHED*/
10394               neg_modifier:
10395                 RExC_parse++;
10396                 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"",
10397                                     *(RExC_parse - 1));
10398                 NOT_REACHED; /*NOTREACHED*/
10399             case ONCE_PAT_MOD: /* 'o' */
10400             case GLOBAL_PAT_MOD: /* 'g' */
10401                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10402                     const I32 wflagbit = *RExC_parse == 'o'
10403                                          ? WASTED_O
10404                                          : WASTED_G;
10405                     if (! (wastedflags & wflagbit) ) {
10406                         wastedflags |= wflagbit;
10407                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10408                         vWARN5(
10409                             RExC_parse + 1,
10410                             "Useless (%s%c) - %suse /%c modifier",
10411                             flagsp == &negflags ? "?-" : "?",
10412                             *RExC_parse,
10413                             flagsp == &negflags ? "don't " : "",
10414                             *RExC_parse
10415                         );
10416                     }
10417                 }
10418                 break;
10419
10420             case CONTINUE_PAT_MOD: /* 'c' */
10421                 if (PASS2 && ckWARN(WARN_REGEXP)) {
10422                     if (! (wastedflags & WASTED_C) ) {
10423                         wastedflags |= WASTED_GC;
10424                         /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */
10425                         vWARN3(
10426                             RExC_parse + 1,
10427                             "Useless (%sc) - %suse /gc modifier",
10428                             flagsp == &negflags ? "?-" : "?",
10429                             flagsp == &negflags ? "don't " : ""
10430                         );
10431                     }
10432                 }
10433                 break;
10434             case KEEPCOPY_PAT_MOD: /* 'p' */
10435                 if (flagsp == &negflags) {
10436                     if (PASS2)
10437                         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
10438                 } else {
10439                     *flagsp |= RXf_PMf_KEEPCOPY;
10440                 }
10441                 break;
10442             case '-':
10443                 /* A flag is a default iff it is following a minus, so
10444                  * if there is a minus, it means will be trying to
10445                  * re-specify a default which is an error */
10446                 if (has_use_defaults || flagsp == &negflags) {
10447                     goto fail_modifiers;
10448                 }
10449                 flagsp = &negflags;
10450                 wastedflags = 0;  /* reset so (?g-c) warns twice */
10451                 break;
10452             case ':':
10453             case ')':
10454                 RExC_flags |= posflags;
10455                 RExC_flags &= ~negflags;
10456                 set_regex_charset(&RExC_flags, cs);
10457                 if (RExC_flags & RXf_PMf_FOLD) {
10458                     RExC_contains_i = 1;
10459                 }
10460
10461                 if (UNLIKELY((x_mod_count) > 1)) {
10462                     vFAIL("Only one /x regex modifier is allowed");
10463                 }
10464                 return;
10465                 /*NOTREACHED*/
10466             default:
10467               fail_modifiers:
10468                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10469                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10470                 vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized",
10471                       UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
10472                 NOT_REACHED; /*NOTREACHED*/
10473         }
10474
10475         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10476     }
10477
10478     vFAIL("Sequence (?... not terminated");
10479 }
10480
10481 /*
10482  - reg - regular expression, i.e. main body or parenthesized thing
10483  *
10484  * Caller must absorb opening parenthesis.
10485  *
10486  * Combining parenthesis handling with the base level of regular expression
10487  * is a trifle forced, but the need to tie the tails of the branches to what
10488  * follows makes it hard to avoid.
10489  */
10490 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
10491 #ifdef DEBUGGING
10492 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
10493 #else
10494 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
10495 #endif
10496
10497 PERL_STATIC_INLINE regnode *
10498 S_handle_named_backref(pTHX_ RExC_state_t *pRExC_state,
10499                              I32 *flagp,
10500                              char * parse_start,
10501                              char ch
10502                       )
10503 {
10504     regnode *ret;
10505     char* name_start = RExC_parse;
10506     U32 num = 0;
10507     SV *sv_dat = reg_scan_name(pRExC_state, SIZE_ONLY
10508                                             ? REG_RSN_RETURN_NULL
10509                                             : REG_RSN_RETURN_DATA);
10510     GET_RE_DEBUG_FLAGS_DECL;
10511
10512     PERL_ARGS_ASSERT_HANDLE_NAMED_BACKREF;
10513
10514     if (RExC_parse == name_start || *RExC_parse != ch) {
10515         /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
10516         vFAIL2("Sequence %.3s... not terminated",parse_start);
10517     }
10518
10519     if (!SIZE_ONLY) {
10520         num = add_data( pRExC_state, STR_WITH_LEN("S"));
10521         RExC_rxi->data->data[num]=(void*)sv_dat;
10522         SvREFCNT_inc_simple_void(sv_dat);
10523     }
10524     RExC_sawback = 1;
10525     ret = reganode(pRExC_state,
10526                    ((! FOLD)
10527                      ? NREF
10528                      : (ASCII_FOLD_RESTRICTED)
10529                        ? NREFFA
10530                        : (AT_LEAST_UNI_SEMANTICS)
10531                          ? NREFFU
10532                          : (LOC)
10533                            ? NREFFL
10534                            : NREFF),
10535                     num);
10536     *flagp |= HASWIDTH;
10537
10538     Set_Node_Offset(ret, parse_start+1);
10539     Set_Node_Cur_Length(ret, parse_start);
10540
10541     nextchar(pRExC_state);
10542     return ret;
10543 }
10544
10545 /* Returns NULL, setting *flagp to TRYAGAIN at the end of (?) that only sets
10546    flags. Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan
10547    needs to be restarted, or'd with NEED_UTF8 if the pattern needs to be
10548    upgraded to UTF-8.  Otherwise would only return NULL if regbranch() returns
10549    NULL, which cannot happen.  */
10550 STATIC regnode *
10551 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
10552     /* paren: Parenthesized? 0=top; 1,2=inside '(': changed to letter.
10553      * 2 is like 1, but indicates that nextchar() has been called to advance
10554      * RExC_parse beyond the '('.  Things like '(?' are indivisible tokens, and
10555      * this flag alerts us to the need to check for that */
10556 {
10557     regnode *ret;               /* Will be the head of the group. */
10558     regnode *br;
10559     regnode *lastbr;
10560     regnode *ender = NULL;
10561     I32 parno = 0;
10562     I32 flags;
10563     U32 oregflags = RExC_flags;
10564     bool have_branch = 0;
10565     bool is_open = 0;
10566     I32 freeze_paren = 0;
10567     I32 after_freeze = 0;
10568     I32 num; /* numeric backreferences */
10569
10570     char * parse_start = RExC_parse; /* MJD */
10571     char * const oregcomp_parse = RExC_parse;
10572
10573     GET_RE_DEBUG_FLAGS_DECL;
10574
10575     PERL_ARGS_ASSERT_REG;
10576     DEBUG_PARSE("reg ");
10577
10578     *flagp = 0;                         /* Tentatively. */
10579
10580     /* Having this true makes it feasible to have a lot fewer tests for the
10581      * parse pointer being in scope.  For example, we can write
10582      *      while(isFOO(*RExC_parse)) RExC_parse++;
10583      * instead of
10584      *      while(RExC_parse < RExC_end && isFOO(*RExC_parse)) RExC_parse++;
10585      */
10586     assert(*RExC_end == '\0');
10587
10588     /* Make an OPEN node, if parenthesized. */
10589     if (paren) {
10590
10591         /* Under /x, space and comments can be gobbled up between the '(' and
10592          * here (if paren ==2).  The forms '(*VERB' and '(?...' disallow such
10593          * intervening space, as the sequence is a token, and a token should be
10594          * indivisible */
10595         bool has_intervening_patws = paren == 2 && *(RExC_parse - 1) != '(';
10596
10597         if (RExC_parse >= RExC_end) {
10598             vFAIL("Unmatched (");
10599         }
10600
10601         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
10602             char *start_verb = RExC_parse + 1;
10603             STRLEN verb_len;
10604             char *start_arg = NULL;
10605             unsigned char op = 0;
10606             int arg_required = 0;
10607             int internal_argval = -1; /* if >-1 we are not allowed an argument*/
10608
10609             if (has_intervening_patws) {
10610                 RExC_parse++;   /* past the '*' */
10611                 vFAIL("In '(*VERB...)', the '(' and '*' must be adjacent");
10612             }
10613             while (RExC_parse < RExC_end && *RExC_parse != ')' ) {
10614                 if ( *RExC_parse == ':' ) {
10615                     start_arg = RExC_parse + 1;
10616                     break;
10617                 }
10618                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10619             }
10620             verb_len = RExC_parse - start_verb;
10621             if ( start_arg ) {
10622                 if (RExC_parse >= RExC_end) {
10623                     goto unterminated_verb_pattern;
10624                 }
10625                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10626                 while ( RExC_parse < RExC_end && *RExC_parse != ')' )
10627                     RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10628                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10629                   unterminated_verb_pattern:
10630                     vFAIL("Unterminated verb pattern argument");
10631                 if ( RExC_parse == start_arg )
10632                     start_arg = NULL;
10633             } else {
10634                 if ( RExC_parse >= RExC_end || *RExC_parse != ')' )
10635                     vFAIL("Unterminated verb pattern");
10636             }
10637
10638             /* Here, we know that RExC_parse < RExC_end */
10639
10640             switch ( *start_verb ) {
10641             case 'A':  /* (*ACCEPT) */
10642                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
10643                     op = ACCEPT;
10644                     internal_argval = RExC_nestroot;
10645                 }
10646                 break;
10647             case 'C':  /* (*COMMIT) */
10648                 if ( memEQs(start_verb,verb_len,"COMMIT") )
10649                     op = COMMIT;
10650                 break;
10651             case 'F':  /* (*FAIL) */
10652                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
10653                     op = OPFAIL;
10654                 }
10655                 break;
10656             case ':':  /* (*:NAME) */
10657             case 'M':  /* (*MARK:NAME) */
10658                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
10659                     op = MARKPOINT;
10660                     arg_required = 1;
10661                 }
10662                 break;
10663             case 'P':  /* (*PRUNE) */
10664                 if ( memEQs(start_verb,verb_len,"PRUNE") )
10665                     op = PRUNE;
10666                 break;
10667             case 'S':   /* (*SKIP) */
10668                 if ( memEQs(start_verb,verb_len,"SKIP") )
10669                     op = SKIP;
10670                 break;
10671             case 'T':  /* (*THEN) */
10672                 /* [19:06] <TimToady> :: is then */
10673                 if ( memEQs(start_verb,verb_len,"THEN") ) {
10674                     op = CUTGROUP;
10675                     RExC_seen |= REG_CUTGROUP_SEEN;
10676                 }
10677                 break;
10678             }
10679             if ( ! op ) {
10680                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10681                 vFAIL2utf8f(
10682                     "Unknown verb pattern '%" UTF8f "'",
10683                     UTF8fARG(UTF, verb_len, start_verb));
10684             }
10685             if ( arg_required && !start_arg ) {
10686                 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
10687                     verb_len, start_verb);
10688             }
10689             if (internal_argval == -1) {
10690                 ret = reganode(pRExC_state, op, 0);
10691             } else {
10692                 ret = reg2Lanode(pRExC_state, op, 0, internal_argval);
10693             }
10694             RExC_seen |= REG_VERBARG_SEEN;
10695             if ( ! SIZE_ONLY ) {
10696                 if (start_arg) {
10697                     SV *sv = newSVpvn( start_arg,
10698                                        RExC_parse - start_arg);
10699                     ARG(ret) = add_data( pRExC_state,
10700                                          STR_WITH_LEN("S"));
10701                     RExC_rxi->data->data[ARG(ret)]=(void*)sv;
10702                     ret->flags = 1;
10703                 } else {
10704                     ret->flags = 0;
10705                 }
10706                 if ( internal_argval != -1 )
10707                     ARG2L_SET(ret, internal_argval);
10708             }
10709             nextchar(pRExC_state);
10710             return ret;
10711         }
10712         else if (*RExC_parse == '?') { /* (?...) */
10713             bool is_logical = 0;
10714             const char * const seqstart = RExC_parse;
10715             const char * endptr;
10716             if (has_intervening_patws) {
10717                 RExC_parse++;
10718                 vFAIL("In '(?...)', the '(' and '?' must be adjacent");
10719             }
10720
10721             RExC_parse++;           /* past the '?' */
10722             paren = *RExC_parse;    /* might be a trailing NUL, if not
10723                                        well-formed */
10724             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
10725             if (RExC_parse > RExC_end) {
10726                 paren = '\0';
10727             }
10728             ret = NULL;                 /* For look-ahead/behind. */
10729             switch (paren) {
10730
10731             case 'P':   /* (?P...) variants for those used to PCRE/Python */
10732                 paren = *RExC_parse;
10733                 if ( paren == '<') {    /* (?P<...>) named capture */
10734                     RExC_parse++;
10735                     if (RExC_parse >= RExC_end) {
10736                         vFAIL("Sequence (?P<... not terminated");
10737                     }
10738                     goto named_capture;
10739                 }
10740                 else if (paren == '>') {   /* (?P>name) named recursion */
10741                     RExC_parse++;
10742                     if (RExC_parse >= RExC_end) {
10743                         vFAIL("Sequence (?P>... not terminated");
10744                     }
10745                     goto named_recursion;
10746                 }
10747                 else if (paren == '=') {   /* (?P=...)  named backref */
10748                     RExC_parse++;
10749                     return handle_named_backref(pRExC_state, flagp,
10750                                                 parse_start, ')');
10751                 }
10752                 RExC_parse += SKIP_IF_CHAR(RExC_parse);
10753                 /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
10754                 vFAIL3("Sequence (%.*s...) not recognized",
10755                                 RExC_parse-seqstart, seqstart);
10756                 NOT_REACHED; /*NOTREACHED*/
10757             case '<':           /* (?<...) */
10758                 if (*RExC_parse == '!')
10759                     paren = ',';
10760                 else if (*RExC_parse != '=')
10761               named_capture:
10762                 {               /* (?<...>) */
10763                     char *name_start;
10764                     SV *svname;
10765                     paren= '>';
10766                 /* FALLTHROUGH */
10767             case '\'':          /* (?'...') */
10768                     name_start = RExC_parse;
10769                     svname = reg_scan_name(pRExC_state,
10770                         SIZE_ONLY    /* reverse test from the others */
10771                         ? REG_RSN_RETURN_NAME
10772                         : REG_RSN_RETURN_NULL);
10773                     if (   RExC_parse == name_start
10774                         || RExC_parse >= RExC_end
10775                         || *RExC_parse != paren)
10776                     {
10777                         vFAIL2("Sequence (?%c... not terminated",
10778                             paren=='>' ? '<' : paren);
10779                     }
10780                     if (SIZE_ONLY) {
10781                         HE *he_str;
10782                         SV *sv_dat = NULL;
10783                         if (!svname) /* shouldn't happen */
10784                             Perl_croak(aTHX_
10785                                 "panic: reg_scan_name returned NULL");
10786                         if (!RExC_paren_names) {
10787                             RExC_paren_names= newHV();
10788                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
10789 #ifdef DEBUGGING
10790                             RExC_paren_name_list= newAV();
10791                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
10792 #endif
10793                         }
10794                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
10795                         if ( he_str )
10796                             sv_dat = HeVAL(he_str);
10797                         if ( ! sv_dat ) {
10798                             /* croak baby croak */
10799                             Perl_croak(aTHX_
10800                                 "panic: paren_name hash element allocation failed");
10801                         } else if ( SvPOK(sv_dat) ) {
10802                             /* (?|...) can mean we have dupes so scan to check
10803                                its already been stored. Maybe a flag indicating
10804                                we are inside such a construct would be useful,
10805                                but the arrays are likely to be quite small, so
10806                                for now we punt -- dmq */
10807                             IV count = SvIV(sv_dat);
10808                             I32 *pv = (I32*)SvPVX(sv_dat);
10809                             IV i;
10810                             for ( i = 0 ; i < count ; i++ ) {
10811                                 if ( pv[i] == RExC_npar ) {
10812                                     count = 0;
10813                                     break;
10814                                 }
10815                             }
10816                             if ( count ) {
10817                                 pv = (I32*)SvGROW(sv_dat,
10818                                                 SvCUR(sv_dat) + sizeof(I32)+1);
10819                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
10820                                 pv[count] = RExC_npar;
10821                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
10822                             }
10823                         } else {
10824                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
10825                             sv_setpvn(sv_dat, (char *)&(RExC_npar),
10826                                                                 sizeof(I32));
10827                             SvIOK_on(sv_dat);
10828                             SvIV_set(sv_dat, 1);
10829                         }
10830 #ifdef DEBUGGING
10831                         /* Yes this does cause a memory leak in debugging Perls
10832                          * */
10833                         if (!av_store(RExC_paren_name_list,
10834                                       RExC_npar, SvREFCNT_inc(svname)))
10835                             SvREFCNT_dec_NN(svname);
10836 #endif
10837
10838                         /*sv_dump(sv_dat);*/
10839                     }
10840                     nextchar(pRExC_state);
10841                     paren = 1;
10842                     goto capturing_parens;
10843                 }
10844                 RExC_seen |= REG_LOOKBEHIND_SEEN;
10845                 RExC_in_lookbehind++;
10846                 RExC_parse++;
10847                 if (RExC_parse >= RExC_end) {
10848                     vFAIL("Sequence (?... not terminated");
10849                 }
10850
10851                 /* FALLTHROUGH */
10852             case '=':           /* (?=...) */
10853                 RExC_seen_zerolen++;
10854                 break;
10855             case '!':           /* (?!...) */
10856                 RExC_seen_zerolen++;
10857                 /* check if we're really just a "FAIL" assertion */
10858                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
10859                                         FALSE /* Don't force to /x */ );
10860                 if (*RExC_parse == ')') {
10861                     ret=reganode(pRExC_state, OPFAIL, 0);
10862                     nextchar(pRExC_state);
10863                     return ret;
10864                 }
10865                 break;
10866             case '|':           /* (?|...) */
10867                 /* branch reset, behave like a (?:...) except that
10868                    buffers in alternations share the same numbers */
10869                 paren = ':';
10870                 after_freeze = freeze_paren = RExC_npar;
10871                 break;
10872             case ':':           /* (?:...) */
10873             case '>':           /* (?>...) */
10874                 break;
10875             case '$':           /* (?$...) */
10876             case '@':           /* (?@...) */
10877                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
10878                 break;
10879             case '0' :           /* (?0) */
10880             case 'R' :           /* (?R) */
10881                 if (RExC_parse == RExC_end || *RExC_parse != ')')
10882                     FAIL("Sequence (?R) not terminated");
10883                 num = 0;
10884                 RExC_seen |= REG_RECURSE_SEEN;
10885                 *flagp |= POSTPONED;
10886                 goto gen_recurse_regop;
10887                 /*notreached*/
10888             /* named and numeric backreferences */
10889             case '&':            /* (?&NAME) */
10890                 parse_start = RExC_parse - 1;
10891               named_recursion:
10892                 {
10893                     SV *sv_dat = reg_scan_name(pRExC_state,
10894                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10895                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
10896                 }
10897                 if (RExC_parse >= RExC_end || *RExC_parse != ')')
10898                     vFAIL("Sequence (?&... not terminated");
10899                 goto gen_recurse_regop;
10900                 /* NOTREACHED */
10901             case '+':
10902                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10903                     RExC_parse++;
10904                     vFAIL("Illegal pattern");
10905                 }
10906                 goto parse_recursion;
10907                 /* NOTREACHED*/
10908             case '-': /* (?-1) */
10909                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
10910                     RExC_parse--; /* rewind to let it be handled later */
10911                     goto parse_flags;
10912                 }
10913                 /* FALLTHROUGH */
10914             case '1': case '2': case '3': case '4': /* (?1) */
10915             case '5': case '6': case '7': case '8': case '9':
10916                 RExC_parse = (char *) seqstart + 1;  /* Point to the digit */
10917               parse_recursion:
10918                 {
10919                     bool is_neg = FALSE;
10920                     UV unum;
10921                     parse_start = RExC_parse - 1; /* MJD */
10922                     if (*RExC_parse == '-') {
10923                         RExC_parse++;
10924                         is_neg = TRUE;
10925                     }
10926                     if (grok_atoUV(RExC_parse, &unum, &endptr)
10927                         && unum <= I32_MAX
10928                     ) {
10929                         num = (I32)unum;
10930                         RExC_parse = (char*)endptr;
10931                     } else
10932                         num = I32_MAX;
10933                     if (is_neg) {
10934                         /* Some limit for num? */
10935                         num = -num;
10936                     }
10937                 }
10938                 if (*RExC_parse!=')')
10939                     vFAIL("Expecting close bracket");
10940
10941               gen_recurse_regop:
10942                 if ( paren == '-' ) {
10943                     /*
10944                     Diagram of capture buffer numbering.
10945                     Top line is the normal capture buffer numbers
10946                     Bottom line is the negative indexing as from
10947                     the X (the (?-2))
10948
10949                     +   1 2    3 4 5 X          6 7
10950                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
10951                     -   5 4    3 2 1 X          x x
10952
10953                     */
10954                     num = RExC_npar + num;
10955                     if (num < 1)  {
10956                         RExC_parse++;
10957                         vFAIL("Reference to nonexistent group");
10958                     }
10959                 } else if ( paren == '+' ) {
10960                     num = RExC_npar + num - 1;
10961                 }
10962                 /* We keep track how many GOSUB items we have produced.
10963                    To start off the ARG2L() of the GOSUB holds its "id",
10964                    which is used later in conjunction with RExC_recurse
10965                    to calculate the offset we need to jump for the GOSUB,
10966                    which it will store in the final representation.
10967                    We have to defer the actual calculation until much later
10968                    as the regop may move.
10969                  */
10970
10971                 ret = reg2Lanode(pRExC_state, GOSUB, num, RExC_recurse_count);
10972                 if (!SIZE_ONLY) {
10973                     if (num > (I32)RExC_rx->nparens) {
10974                         RExC_parse++;
10975                         vFAIL("Reference to nonexistent group");
10976                     }
10977                     RExC_recurse_count++;
10978                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
10979                         "%*s%*s Recurse #%" UVuf " to %" IVdf "\n",
10980                               22, "|    |", (int)(depth * 2 + 1), "",
10981                               (UV)ARG(ret), (IV)ARG2L(ret)));
10982                 }
10983                 RExC_seen |= REG_RECURSE_SEEN;
10984
10985                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
10986                 Set_Node_Offset(ret, parse_start); /* MJD */
10987
10988                 *flagp |= POSTPONED;
10989                 assert(*RExC_parse == ')');
10990                 nextchar(pRExC_state);
10991                 return ret;
10992
10993             /* NOTREACHED */
10994
10995             case '?':           /* (??...) */
10996                 is_logical = 1;
10997                 if (*RExC_parse != '{') {
10998                     RExC_parse += SKIP_IF_CHAR(RExC_parse);
10999                     /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */
11000                     vFAIL2utf8f(
11001                         "Sequence (%" UTF8f "...) not recognized",
11002                         UTF8fARG(UTF, RExC_parse-seqstart, seqstart));
11003                     NOT_REACHED; /*NOTREACHED*/
11004                 }
11005                 *flagp |= POSTPONED;
11006                 paren = '{';
11007                 RExC_parse++;
11008                 /* FALLTHROUGH */
11009             case '{':           /* (?{...}) */
11010             {
11011                 U32 n = 0;
11012                 struct reg_code_block *cb;
11013
11014                 RExC_seen_zerolen++;
11015
11016                 if (   !pRExC_state->num_code_blocks
11017                     || pRExC_state->code_index >= pRExC_state->num_code_blocks
11018                     || pRExC_state->code_blocks[pRExC_state->code_index].start
11019                         != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
11020                             - RExC_start)
11021                 ) {
11022                     if (RExC_pm_flags & PMf_USE_RE_EVAL)
11023                         FAIL("panic: Sequence (?{...}): no code block found\n");
11024                     FAIL("Eval-group not allowed at runtime, use re 'eval'");
11025                 }
11026                 /* this is a pre-compiled code block (?{...}) */
11027                 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
11028                 RExC_parse = RExC_start + cb->end;
11029                 if (!SIZE_ONLY) {
11030                     OP *o = cb->block;
11031                     if (cb->src_regex) {
11032                         n = add_data(pRExC_state, STR_WITH_LEN("rl"));
11033                         RExC_rxi->data->data[n] =
11034                             (void*)SvREFCNT_inc((SV*)cb->src_regex);
11035                         RExC_rxi->data->data[n+1] = (void*)o;
11036                     }
11037                     else {
11038                         n = add_data(pRExC_state,
11039                                (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1);
11040                         RExC_rxi->data->data[n] = (void*)o;
11041                     }
11042                 }
11043                 pRExC_state->code_index++;
11044                 nextchar(pRExC_state);
11045
11046                 if (is_logical) {
11047                     regnode *eval;
11048                     ret = reg_node(pRExC_state, LOGICAL);
11049
11050                     eval = reg2Lanode(pRExC_state, EVAL,
11051                                        n,
11052
11053                                        /* for later propagation into (??{})
11054                                         * return value */
11055                                        RExC_flags & RXf_PMf_COMPILETIME
11056                                       );
11057                     if (!SIZE_ONLY) {
11058                         ret->flags = 2;
11059                     }
11060                     REGTAIL(pRExC_state, ret, eval);
11061                     /* deal with the length of this later - MJD */
11062                     return ret;
11063                 }
11064                 ret = reg2Lanode(pRExC_state, EVAL, n, 0);
11065                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
11066                 Set_Node_Offset(ret, parse_start);
11067                 return ret;
11068             }
11069             case '(':           /* (?(?{...})...) and (?(?=...)...) */
11070             {
11071                 int is_define= 0;
11072                 const int DEFINE_len = sizeof("DEFINE") - 1;
11073                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
11074                     if (   RExC_parse < RExC_end - 1
11075                         && (   RExC_parse[1] == '='
11076                             || RExC_parse[1] == '!'
11077                             || RExC_parse[1] == '<'
11078                             || RExC_parse[1] == '{')
11079                     ) { /* Lookahead or eval. */
11080                         I32 flag;
11081                         regnode *tail;
11082
11083                         ret = reg_node(pRExC_state, LOGICAL);
11084                         if (!SIZE_ONLY)
11085                             ret->flags = 1;
11086
11087                         tail = reg(pRExC_state, 1, &flag, depth+1);
11088                         if (flag & (RESTART_PASS1|NEED_UTF8)) {
11089                             *flagp = flag & (RESTART_PASS1|NEED_UTF8);
11090                             return NULL;
11091                         }
11092                         REGTAIL(pRExC_state, ret, tail);
11093                         goto insert_if;
11094                     }
11095                     /* Fall through to ‘Unknown switch condition’ at the
11096                        end of the if/else chain. */
11097                 }
11098                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
11099                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
11100                 {
11101                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
11102                     char *name_start= RExC_parse++;
11103                     U32 num = 0;
11104                     SV *sv_dat=reg_scan_name(pRExC_state,
11105                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
11106                     if (   RExC_parse == name_start
11107                         || RExC_parse >= RExC_end
11108                         || *RExC_parse != ch)
11109                     {
11110                         vFAIL2("Sequence (?(%c... not terminated",
11111                             (ch == '>' ? '<' : ch));
11112                     }
11113                     RExC_parse++;
11114                     if (!SIZE_ONLY) {
11115                         num = add_data( pRExC_state, STR_WITH_LEN("S"));
11116                         RExC_rxi->data->data[num]=(void*)sv_dat;
11117                         SvREFCNT_inc_simple_void(sv_dat);
11118                     }
11119                     ret = reganode(pRExC_state,NGROUPP,num);
11120                     goto insert_if_check_paren;
11121                 }
11122                 else if (RExC_end - RExC_parse >= DEFINE_len
11123                         && strnEQ(RExC_parse, "DEFINE", DEFINE_len))
11124                 {
11125                     ret = reganode(pRExC_state,DEFINEP,0);
11126                     RExC_parse += DEFINE_len;
11127                     is_define = 1;
11128                     goto insert_if_check_paren;
11129                 }
11130                 else if (RExC_parse[0] == 'R') {
11131                     RExC_parse++;
11132                     /* parno == 0 => /(?(R)YES|NO)/  "in any form of recursion OR eval"
11133                      * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)"
11134                      * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)"
11135                      */
11136                     parno = 0;
11137                     if (RExC_parse[0] == '0') {
11138                         parno = 1;
11139                         RExC_parse++;
11140                     }
11141                     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11142                         UV uv;
11143                         if (grok_atoUV(RExC_parse, &uv, &endptr)
11144                             && uv <= I32_MAX
11145                         ) {
11146                             parno = (I32)uv + 1;
11147                             RExC_parse = (char*)endptr;
11148                         }
11149                         /* else "Switch condition not recognized" below */
11150                     } else if (RExC_parse[0] == '&') {
11151                         SV *sv_dat;
11152                         RExC_parse++;
11153                         sv_dat = reg_scan_name(pRExC_state,
11154                             SIZE_ONLY
11155                             ? REG_RSN_RETURN_NULL
11156                             : REG_RSN_RETURN_DATA);
11157
11158                         /* we should only have a false sv_dat when
11159                          * SIZE_ONLY is true, and we always have false
11160                          * sv_dat when SIZE_ONLY is true.
11161                          * reg_scan_name() will VFAIL() if the name is
11162                          * unknown when SIZE_ONLY is false, and otherwise
11163                          * will return something, and when SIZE_ONLY is
11164                          * true, reg_scan_name() just parses the string,
11165                          * and doesnt return anything. (in theory) */
11166                         assert(SIZE_ONLY ? !sv_dat : !!sv_dat);
11167
11168                         if (sv_dat)
11169                             parno = 1 + *((I32 *)SvPVX(sv_dat));
11170                     }
11171                     ret = reganode(pRExC_state,INSUBP,parno);
11172                     goto insert_if_check_paren;
11173                 }
11174                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
11175                     /* (?(1)...) */
11176                     char c;
11177                     UV uv;
11178                     if (grok_atoUV(RExC_parse, &uv, &endptr)
11179                         && uv <= I32_MAX
11180                     ) {
11181                         parno = (I32)uv;
11182                         RExC_parse = (char*)endptr;
11183                     }
11184                     else {
11185                         vFAIL("panic: grok_atoUV returned FALSE");
11186                     }
11187                     ret = reganode(pRExC_state, GROUPP, parno);
11188
11189                  insert_if_check_paren:
11190                     if (UCHARAT(RExC_parse) != ')') {
11191                         RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11192                         vFAIL("Switch condition not recognized");
11193                     }
11194                     nextchar(pRExC_state);
11195                   insert_if:
11196                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
11197                     br = regbranch(pRExC_state, &flags, 1,depth+1);
11198                     if (br == NULL) {
11199                         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11200                             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11201                             return NULL;
11202                         }
11203                         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11204                               (UV) flags);
11205                     } else
11206                         REGTAIL(pRExC_state, br, reganode(pRExC_state,
11207                                                           LONGJMP, 0));
11208                     c = UCHARAT(RExC_parse);
11209                     nextchar(pRExC_state);
11210                     if (flags&HASWIDTH)
11211                         *flagp |= HASWIDTH;
11212                     if (c == '|') {
11213                         if (is_define)
11214                             vFAIL("(?(DEFINE)....) does not allow branches");
11215
11216                         /* Fake one for optimizer.  */
11217                         lastbr = reganode(pRExC_state, IFTHEN, 0);
11218
11219                         if (!regbranch(pRExC_state, &flags, 1,depth+1)) {
11220                             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11221                                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11222                                 return NULL;
11223                             }
11224                             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf,
11225                                   (UV) flags);
11226                         }
11227                         REGTAIL(pRExC_state, ret, lastbr);
11228                         if (flags&HASWIDTH)
11229                             *flagp |= HASWIDTH;
11230                         c = UCHARAT(RExC_parse);
11231                         nextchar(pRExC_state);
11232                     }
11233                     else
11234                         lastbr = NULL;
11235                     if (c != ')') {
11236                         if (RExC_parse >= RExC_end)
11237                             vFAIL("Switch (?(condition)... not terminated");
11238                         else
11239                             vFAIL("Switch (?(condition)... contains too many branches");
11240                     }
11241                     ender = reg_node(pRExC_state, TAIL);
11242                     REGTAIL(pRExC_state, br, ender);
11243                     if (lastbr) {
11244                         REGTAIL(pRExC_state, lastbr, ender);
11245                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11246                     }
11247                     else
11248                         REGTAIL(pRExC_state, ret, ender);
11249                     RExC_size++; /* XXX WHY do we need this?!!
11250                                     For large programs it seems to be required
11251                                     but I can't figure out why. -- dmq*/
11252                     return ret;
11253                 }
11254                 RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
11255                 vFAIL("Unknown switch condition (?(...))");
11256             }
11257             case '[':           /* (?[ ... ]) */
11258                 return handle_regex_sets(pRExC_state, NULL, flagp, depth,
11259                                          oregcomp_parse);
11260             case 0: /* A NUL */
11261                 RExC_parse--; /* for vFAIL to print correctly */
11262                 vFAIL("Sequence (? incomplete");
11263                 break;
11264             default: /* e.g., (?i) */
11265                 RExC_parse = (char *) seqstart + 1;
11266               parse_flags:
11267                 parse_lparen_question_flags(pRExC_state);
11268                 if (UCHARAT(RExC_parse) != ':') {
11269                     if (RExC_parse < RExC_end)
11270                         nextchar(pRExC_state);
11271                     *flagp = TRYAGAIN;
11272                     return NULL;
11273                 }
11274                 paren = ':';
11275                 nextchar(pRExC_state);
11276                 ret = NULL;
11277                 goto parse_rest;
11278             } /* end switch */
11279         }
11280         else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) {   /* (...) */
11281           capturing_parens:
11282             parno = RExC_npar;
11283             RExC_npar++;
11284
11285             ret = reganode(pRExC_state, OPEN, parno);
11286             if (!SIZE_ONLY ){
11287                 if (!RExC_nestroot)
11288                     RExC_nestroot = parno;
11289                 if (RExC_open_parens && !RExC_open_parens[parno])
11290                 {
11291                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11292                         "%*s%*s Setting open paren #%" IVdf " to %d\n",
11293                         22, "|    |", (int)(depth * 2 + 1), "",
11294                         (IV)parno, REG_NODE_NUM(ret)));
11295                     RExC_open_parens[parno]= ret;
11296                 }
11297             }
11298             Set_Node_Length(ret, 1); /* MJD */
11299             Set_Node_Offset(ret, RExC_parse); /* MJD */
11300             is_open = 1;
11301         } else {
11302             /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */
11303             paren = ':';
11304             ret = NULL;
11305         }
11306     }
11307     else                        /* ! paren */
11308         ret = NULL;
11309
11310    parse_rest:
11311     /* Pick up the branches, linking them together. */
11312     parse_start = RExC_parse;   /* MJD */
11313     br = regbranch(pRExC_state, &flags, 1,depth+1);
11314
11315     /*     branch_len = (paren != 0); */
11316
11317     if (br == NULL) {
11318         if (flags & (RESTART_PASS1|NEED_UTF8)) {
11319             *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11320             return NULL;
11321         }
11322         FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11323     }
11324     if (*RExC_parse == '|') {
11325         if (!SIZE_ONLY && RExC_extralen) {
11326             reginsert(pRExC_state, BRANCHJ, br, depth+1);
11327         }
11328         else {                  /* MJD */
11329             reginsert(pRExC_state, BRANCH, br, depth+1);
11330             Set_Node_Length(br, paren != 0);
11331             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
11332         }
11333         have_branch = 1;
11334         if (SIZE_ONLY)
11335             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
11336     }
11337     else if (paren == ':') {
11338         *flagp |= flags&SIMPLE;
11339     }
11340     if (is_open) {                              /* Starts with OPEN. */
11341         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
11342     }
11343     else if (paren != '?')              /* Not Conditional */
11344         ret = br;
11345     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11346     lastbr = br;
11347     while (*RExC_parse == '|') {
11348         if (!SIZE_ONLY && RExC_extralen) {
11349             ender = reganode(pRExC_state, LONGJMP,0);
11350
11351             /* Append to the previous. */
11352             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
11353         }
11354         if (SIZE_ONLY)
11355             RExC_extralen += 2;         /* Account for LONGJMP. */
11356         nextchar(pRExC_state);
11357         if (freeze_paren) {
11358             if (RExC_npar > after_freeze)
11359                 after_freeze = RExC_npar;
11360             RExC_npar = freeze_paren;
11361         }
11362         br = regbranch(pRExC_state, &flags, 0, depth+1);
11363
11364         if (br == NULL) {
11365             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11366                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11367                 return NULL;
11368             }
11369             FAIL2("panic: regbranch returned NULL, flags=%#" UVxf, (UV) flags);
11370         }
11371         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
11372         lastbr = br;
11373         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
11374     }
11375
11376     if (have_branch || paren != ':') {
11377         /* Make a closing node, and hook it on the end. */
11378         switch (paren) {
11379         case ':':
11380             ender = reg_node(pRExC_state, TAIL);
11381             break;
11382         case 1: case 2:
11383             ender = reganode(pRExC_state, CLOSE, parno);
11384             if ( RExC_close_parens ) {
11385                 DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11386                         "%*s%*s Setting close paren #%" IVdf " to %d\n",
11387                         22, "|    |", (int)(depth * 2 + 1), "", (IV)parno, REG_NODE_NUM(ender)));
11388                 RExC_close_parens[parno]= ender;
11389                 if (RExC_nestroot == parno)
11390                     RExC_nestroot = 0;
11391             }
11392             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
11393             Set_Node_Length(ender,1); /* MJD */
11394             break;
11395         case '<':
11396         case ',':
11397         case '=':
11398         case '!':
11399             *flagp &= ~HASWIDTH;
11400             /* FALLTHROUGH */
11401         case '>':
11402             ender = reg_node(pRExC_state, SUCCEED);
11403             break;
11404         case 0:
11405             ender = reg_node(pRExC_state, END);
11406             if (!SIZE_ONLY) {
11407                 assert(!RExC_end_op); /* there can only be one! */
11408                 RExC_end_op = ender;
11409                 if (RExC_close_parens) {
11410                     DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_
11411                         "%*s%*s Setting close paren #0 (END) to %d\n",
11412                         22, "|    |", (int)(depth * 2 + 1), "", REG_NODE_NUM(ender)));
11413
11414                     RExC_close_parens[0]= ender;
11415                 }
11416             }
11417             break;
11418         }
11419         DEBUG_PARSE_r(if (!SIZE_ONLY) {
11420             DEBUG_PARSE_MSG("lsbr");
11421             regprop(RExC_rx, RExC_mysv1, lastbr, NULL, pRExC_state);
11422             regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11423             Perl_re_printf( aTHX_  "~ tying lastbr %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11424                           SvPV_nolen_const(RExC_mysv1),
11425                           (IV)REG_NODE_NUM(lastbr),
11426                           SvPV_nolen_const(RExC_mysv2),
11427                           (IV)REG_NODE_NUM(ender),
11428                           (IV)(ender - lastbr)
11429             );
11430         });
11431         REGTAIL(pRExC_state, lastbr, ender);
11432
11433         if (have_branch && !SIZE_ONLY) {
11434             char is_nothing= 1;
11435             if (depth==1)
11436                 RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN;
11437
11438             /* Hook the tails of the branches to the closing node. */
11439             for (br = ret; br; br = regnext(br)) {
11440                 const U8 op = PL_regkind[OP(br)];
11441                 if (op == BRANCH) {
11442                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
11443                     if ( OP(NEXTOPER(br)) != NOTHING
11444                          || regnext(NEXTOPER(br)) != ender)
11445                         is_nothing= 0;
11446                 }
11447                 else if (op == BRANCHJ) {
11448                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
11449                     /* for now we always disable this optimisation * /
11450                     if ( OP(NEXTOPER(NEXTOPER(br))) != NOTHING
11451                          || regnext(NEXTOPER(NEXTOPER(br))) != ender)
11452                     */
11453                         is_nothing= 0;
11454                 }
11455             }
11456             if (is_nothing) {
11457                 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
11458                 DEBUG_PARSE_r(if (!SIZE_ONLY) {
11459                     DEBUG_PARSE_MSG("NADA");
11460                     regprop(RExC_rx, RExC_mysv1, ret, NULL, pRExC_state);
11461                     regprop(RExC_rx, RExC_mysv2, ender, NULL, pRExC_state);
11462                     Perl_re_printf( aTHX_  "~ converting ret %s (%" IVdf ") to ender %s (%" IVdf ") offset %" IVdf "\n",
11463                                   SvPV_nolen_const(RExC_mysv1),
11464                                   (IV)REG_NODE_NUM(ret),
11465                                   SvPV_nolen_const(RExC_mysv2),
11466                                   (IV)REG_NODE_NUM(ender),
11467                                   (IV)(ender - ret)
11468                     );
11469                 });
11470                 OP(br)= NOTHING;
11471                 if (OP(ender) == TAIL) {
11472                     NEXT_OFF(br)= 0;
11473                     RExC_emit= br + 1;
11474                 } else {
11475                     regnode *opt;
11476                     for ( opt= br + 1; opt < ender ; opt++ )
11477                         OP(opt)= OPTIMIZED;
11478                     NEXT_OFF(br)= ender - br;
11479                 }
11480             }
11481         }
11482     }
11483
11484     {
11485         const char *p;
11486         static const char parens[] = "=!<,>";
11487
11488         if (paren && (p = strchr(parens, paren))) {
11489             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
11490             int flag = (p - parens) > 1;
11491
11492             if (paren == '>')
11493                 node = SUSPEND, flag = 0;
11494             reginsert(pRExC_state, node,ret, depth+1);
11495             Set_Node_Cur_Length(ret, parse_start);
11496             Set_Node_Offset(ret, parse_start + 1);
11497             ret->flags = flag;
11498             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
11499         }
11500     }
11501
11502     /* Check for proper termination. */
11503     if (paren) {
11504         /* restore original flags, but keep (?p) and, if we've changed from /d
11505          * rules to /u, keep the /u */
11506         RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
11507         if (DEPENDS_SEMANTICS && RExC_uni_semantics) {
11508             set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
11509         }
11510         if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') {
11511             RExC_parse = oregcomp_parse;
11512             vFAIL("Unmatched (");
11513         }
11514         nextchar(pRExC_state);
11515     }
11516     else if (!paren && RExC_parse < RExC_end) {
11517         if (*RExC_parse == ')') {
11518             RExC_parse++;
11519             vFAIL("Unmatched )");
11520         }
11521         else
11522             FAIL("Junk on end of regexp");      /* "Can't happen". */
11523         NOT_REACHED; /* NOTREACHED */
11524     }
11525
11526     if (RExC_in_lookbehind) {
11527         RExC_in_lookbehind--;
11528     }
11529     if (after_freeze > RExC_npar)
11530         RExC_npar = after_freeze;
11531     return(ret);
11532 }
11533
11534 /*
11535  - regbranch - one alternative of an | operator
11536  *
11537  * Implements the concatenation operator.
11538  *
11539  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11540  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11541  */
11542 STATIC regnode *
11543 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
11544 {
11545     regnode *ret;
11546     regnode *chain = NULL;
11547     regnode *latest;
11548     I32 flags = 0, c = 0;
11549     GET_RE_DEBUG_FLAGS_DECL;
11550
11551     PERL_ARGS_ASSERT_REGBRANCH;
11552
11553     DEBUG_PARSE("brnc");
11554
11555     if (first)
11556         ret = NULL;
11557     else {
11558         if (!SIZE_ONLY && RExC_extralen)
11559             ret = reganode(pRExC_state, BRANCHJ,0);
11560         else {
11561             ret = reg_node(pRExC_state, BRANCH);
11562             Set_Node_Length(ret, 1);
11563         }
11564     }
11565
11566     if (!first && SIZE_ONLY)
11567         RExC_extralen += 1;                     /* BRANCHJ */
11568
11569     *flagp = WORST;                     /* Tentatively. */
11570
11571     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
11572                             FALSE /* Don't force to /x */ );
11573     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
11574         flags &= ~TRYAGAIN;
11575         latest = regpiece(pRExC_state, &flags,depth+1);
11576         if (latest == NULL) {
11577             if (flags & TRYAGAIN)
11578                 continue;
11579             if (flags & (RESTART_PASS1|NEED_UTF8)) {
11580                 *flagp = flags & (RESTART_PASS1|NEED_UTF8);
11581                 return NULL;
11582             }
11583             FAIL2("panic: regpiece returned NULL, flags=%#" UVxf, (UV) flags);
11584         }
11585         else if (ret == NULL)
11586             ret = latest;
11587         *flagp |= flags&(HASWIDTH|POSTPONED);
11588         if (chain == NULL)      /* First piece. */
11589             *flagp |= flags&SPSTART;
11590         else {
11591             /* FIXME adding one for every branch after the first is probably
11592              * excessive now we have TRIE support. (hv) */
11593             MARK_NAUGHTY(1);
11594             REGTAIL(pRExC_state, chain, latest);
11595         }
11596         chain = latest;
11597         c++;
11598     }
11599     if (chain == NULL) {        /* Loop ran zero times. */
11600         chain = reg_node(pRExC_state, NOTHING);
11601         if (ret == NULL)
11602             ret = chain;
11603     }
11604     if (c == 1) {
11605         *flagp |= flags&SIMPLE;
11606     }
11607
11608     return ret;
11609 }
11610
11611 /*
11612  - regpiece - something followed by possible [*+?]
11613  *
11614  * Note that the branching code sequences used for ? and the general cases
11615  * of * and + are somewhat optimized:  they use the same NOTHING node as
11616  * both the endmarker for their branch list and the body of the last branch.
11617  * It might seem that this node could be dispensed with entirely, but the
11618  * endmarker role is not redundant.
11619  *
11620  * Returns NULL, setting *flagp to TRYAGAIN if regatom() returns NULL with
11621  * TRYAGAIN.
11622  * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
11623  * restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
11624  */
11625 STATIC regnode *
11626 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
11627 {
11628     regnode *ret;
11629     char op;
11630     char *next;
11631     I32 flags;
11632     const char * const origparse = RExC_parse;
11633     I32 min;
11634     I32 max = REG_INFTY;
11635 #ifdef RE_TRACK_PATTERN_OFFSETS
11636     char *parse_start;
11637 #endif
11638     const char *maxpos = NULL;
11639     UV uv;
11640
11641     /* Save the original in case we change the emitted regop to a FAIL. */
11642     regnode * const orig_emit = RExC_emit;
11643
11644     GET_RE_DEBUG_FLAGS_DECL;
11645
11646     PERL_ARGS_ASSERT_REGPIECE;
11647
11648     DEBUG_PARSE("piec");
11649
11650     ret = regatom(pRExC_state, &flags,depth+1);
11651     if (ret == NULL) {
11652         if (flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8))
11653             *flagp |= flags & (TRYAGAIN|RESTART_PASS1|NEED_UTF8);
11654         else
11655             FAIL2("panic: regatom returned NULL, flags=%#" UVxf, (UV) flags);
11656         return(NULL);
11657     }
11658
11659     op = *RExC_parse;
11660
11661     if (op == '{' && regcurly(RExC_parse)) {
11662         maxpos = NULL;
11663 #ifdef RE_TRACK_PATTERN_OFFSETS
11664         parse_start = RExC_parse; /* MJD */
11665 #endif
11666         next = RExC_parse + 1;
11667         while (isDIGIT(*next) || *next == ',') {
11668             if (*next == ',') {
11669                 if (maxpos)
11670                     break;
11671                 else
11672                     maxpos = next;
11673             }
11674             next++;
11675         }
11676         if (*next == '}') {             /* got one */
11677             const char* endptr;
11678             if (!maxpos)
11679                 maxpos = next;
11680             RExC_parse++;
11681             if (isDIGIT(*RExC_parse)) {
11682                 if (!grok_atoUV(RExC_parse, &uv, &endptr))
11683                     vFAIL("Invalid quantifier in {,}");
11684                 if (uv >= REG_INFTY)
11685                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11686                 min = (I32)uv;
11687             } else {
11688                 min = 0;
11689             }
11690             if (*maxpos == ',')
11691                 maxpos++;
11692             else
11693                 maxpos = RExC_parse;
11694             if (isDIGIT(*maxpos)) {
11695                 if (!grok_atoUV(maxpos, &uv, &endptr))
11696                     vFAIL("Invalid quantifier in {,}");
11697                 if (uv >= REG_INFTY)
11698                     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
11699                 max = (I32)uv;
11700             } else {
11701                 max = REG_INFTY;                /* meaning "infinity" */
11702             }
11703             RExC_parse = next;
11704             nextchar(pRExC_state);
11705             if (max < min) {    /* If can't match, warn and optimize to fail
11706                                    unconditionally */
11707                 if (SIZE_ONLY) {
11708
11709                     /* We can't back off the size because we have to reserve
11710                      * enough space for all the things we are about to throw
11711                      * away, but we can shrink it by the amount we are about
11712                      * to re-use here */
11713                     RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL];
11714                 }
11715                 else {
11716                     ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match");
11717                     RExC_emit = orig_emit;
11718                 }
11719                 ret = reganode(pRExC_state, OPFAIL, 0);
11720                 return ret;
11721             }
11722             else if (min == max && *RExC_parse == '?')
11723             {
11724                 if (PASS2) {
11725                     ckWARN2reg(RExC_parse + 1,
11726                                "Useless use of greediness modifier '%c'",
11727                                *RExC_parse);
11728                 }
11729             }
11730
11731           do_curly:
11732             if ((flags&SIMPLE)) {
11733                 if (min == 0 && max == REG_INFTY) {
11734                     reginsert(pRExC_state, STAR, ret, depth+1);
11735                     ret->flags = 0;
11736                     MARK_NAUGHTY(4);
11737                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11738                     goto nest_check;
11739                 }
11740                 if (min == 1 && max == REG_INFTY) {
11741                     reginsert(pRExC_state, PLUS, ret, depth+1);
11742                     ret->flags = 0;
11743                     MARK_NAUGHTY(3);
11744                     RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11745                     goto nest_check;
11746                 }
11747                 MARK_NAUGHTY_EXP(2, 2);
11748                 reginsert(pRExC_state, CURLY, ret, depth+1);
11749                 Set_Node_Offset(ret, parse_start+1); /* MJD */
11750                 Set_Node_Cur_Length(ret, parse_start);
11751             }
11752             else {
11753                 regnode * const w = reg_node(pRExC_state, WHILEM);
11754
11755                 w->flags = 0;
11756                 REGTAIL(pRExC_state, ret, w);
11757                 if (!SIZE_ONLY && RExC_extralen) {
11758                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
11759                     reginsert(pRExC_state, NOTHING,ret, depth+1);
11760                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
11761                 }
11762                 reginsert(pRExC_state, CURLYX,ret, depth+1);
11763                                 /* MJD hk */
11764                 Set_Node_Offset(ret, parse_start+1);
11765                 Set_Node_Length(ret,
11766                                 op == '{' ? (RExC_parse - parse_start) : 1);
11767
11768                 if (!SIZE_ONLY && RExC_extralen)
11769                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
11770                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
11771                 if (SIZE_ONLY)
11772                     RExC_whilem_seen++, RExC_extralen += 3;
11773                 MARK_NAUGHTY_EXP(1, 4);     /* compound interest */
11774             }
11775             ret->flags = 0;
11776
11777             if (min > 0)
11778                 *flagp = WORST;
11779             if (max > 0)
11780                 *flagp |= HASWIDTH;
11781             if (!SIZE_ONLY) {
11782                 ARG1_SET(ret, (U16)min);
11783                 ARG2_SET(ret, (U16)max);
11784             }
11785             if (max == REG_INFTY)
11786                 RExC_seen |= REG_UNBOUNDED_QUANTIFIER_SEEN;
11787
11788             goto nest_check;
11789         }
11790     }
11791
11792     if (!ISMULT1(op)) {
11793         *flagp = flags;
11794         return(ret);
11795     }
11796
11797 #if 0                           /* Now runtime fix should be reliable. */
11798
11799     /* if this is reinstated, don't forget to put this back into perldiag:
11800
11801             =item Regexp *+ operand could be empty at {#} in regex m/%s/
11802
11803            (F) The part of the regexp subject to either the * or + quantifier
11804            could match an empty string. The {#} shows in the regular
11805            expression about where the problem was discovered.
11806
11807     */
11808
11809     if (!(flags&HASWIDTH) && op != '?')
11810       vFAIL("Regexp *+ operand could be empty");
11811 #endif
11812
11813 #ifdef RE_TRACK_PATTERN_OFFSETS
11814     parse_start = RExC_parse;
11815 #endif
11816     nextchar(pRExC_state);
11817
11818     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
11819
11820     if (op == '*') {
11821         min = 0;
11822         goto do_curly;
11823     }
11824     else if (op == '+') {
11825         min = 1;
11826         goto do_curly;
11827     }
11828     else if (op == '?') {
11829         min = 0; max = 1;
11830         goto do_curly;
11831     }
11832   nest_check:
11833     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
11834         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
11835         ckWARN2reg(RExC_parse,
11836                    "%" UTF8f " matches null string many times",
11837                    UTF8fARG(UTF, (RExC_parse >= origparse
11838                                  ? RExC_parse - origparse
11839                                  : 0),
11840                    origparse));
11841         (void)ReREFCNT_inc(RExC_rx_sv);
11842     }
11843
11844     if (*RExC_parse == '?') {
11845         nextchar(pRExC_state);
11846         reginsert(pRExC_state, MINMOD, ret, depth+1);
11847         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
11848     }
11849     else if (*RExC_parse == '+') {
11850         regnode *ender;
11851         nextchar(pRExC_state);
11852         ender = reg_node(pRExC_state, SUCCEED);
11853         REGTAIL(pRExC_state, ret, ender);
11854         reginsert(pRExC_state, SUSPEND, ret, depth+1);
11855         ret->flags = 0;
11856         ender = reg_node(pRExC_state, TAIL);
11857         REGTAIL(pRExC_state, ret, ender);
11858     }
11859
11860     if (ISMULT2(RExC_parse)) {
11861         RExC_parse++;
11862         vFAIL("Nested quantifiers");
11863     }
11864
11865     return(ret);
11866 }
11867
11868 STATIC bool
11869 S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state,
11870                 regnode ** node_p,
11871                 UV * code_point_p,
11872                 int * cp_count,
11873                 I32 * flagp,
11874                 const bool strict,
11875                 const U32 depth
11876     )
11877 {
11878  /* This routine teases apart the various meanings of \N and returns
11879   * accordingly.  The input parameters constrain which meaning(s) is/are valid
11880   * in the current context.
11881   *
11882   * Exactly one of <node_p> and <code_point_p> must be non-NULL.
11883   *
11884   * If <code_point_p> is not NULL, the context is expecting the result to be a
11885   * single code point.  If this \N instance turns out to a single code point,
11886   * the function returns TRUE and sets *code_point_p to that code point.
11887   *
11888   * If <node_p> is not NULL, the context is expecting the result to be one of
11889   * the things representable by a regnode.  If this \N instance turns out to be
11890   * one such, the function generates the regnode, returns TRUE and sets *node_p
11891   * to point to that regnode.
11892   *
11893   * If this instance of \N isn't legal in any context, this function will
11894   * generate a fatal error and not return.
11895   *
11896   * On input, RExC_parse should point to the first char following the \N at the
11897   * time of the call.  On successful return, RExC_parse will have been updated
11898   * to point to just after the sequence identified by this routine.  Also
11899   * *flagp has been updated as needed.
11900   *
11901   * When there is some problem with the current context and this \N instance,
11902   * the function returns FALSE, without advancing RExC_parse, nor setting
11903   * *node_p, nor *code_point_p, nor *flagp.
11904   *
11905   * If <cp_count> is not NULL, the caller wants to know the length (in code
11906   * points) that this \N sequence matches.  This is set even if the function
11907   * returns FALSE, as detailed below.
11908   *
11909   * There are 5 possibilities here, as detailed in the next 5 paragraphs.
11910   *
11911   * Probably the most common case is for the \N to specify a single code point.
11912   * *cp_count will be set to 1, and *code_point_p will be set to that code
11913   * point.
11914   *
11915   * Another possibility is for the input to be an empty \N{}, which for
11916   * backwards compatibility we accept.  *cp_count will be set to 0. *node_p
11917   * will be set to a generated NOTHING node.
11918   *
11919   * Still another possibility is for the \N to mean [^\n]. *cp_count will be
11920   * set to 0. *node_p will be set to a generated REG_ANY node.
11921   *
11922   * The fourth possibility is that \N resolves to a sequence of more than one
11923   * code points.  *cp_count will be set to the number of code points in the
11924   * sequence. *node_p * will be set to a generated node returned by this
11925   * function calling S_reg().
11926   *
11927   * The final possibility is that it is premature to be calling this function;
11928   * that pass1 needs to be restarted.  This can happen when this changes from
11929   * /d to /u rules, or when the pattern needs to be upgraded to UTF-8.  The
11930   * latter occurs only when the fourth possibility would otherwise be in
11931   * effect, and is because one of those code points requires the pattern to be
11932   * recompiled as UTF-8.  The function returns FALSE, and sets the
11933   * RESTART_PASS1 and NEED_UTF8 flags in *flagp, as appropriate.  When this
11934   * happens, the caller needs to desist from continuing parsing, and return
11935   * this information to its caller.  This is not set for when there is only one
11936   * code point, as this can be called as part of an ANYOF node, and they can
11937   * store above-Latin1 code points without the pattern having to be in UTF-8.
11938   *
11939   * For non-single-quoted regexes, the tokenizer has resolved character and
11940   * sequence names inside \N{...} into their Unicode values, normalizing the
11941   * result into what we should see here: '\N{U+c1.c2...}', where c1... are the
11942   * hex-represented code points in the sequence.  This is done there because
11943   * the names can vary based on what charnames pragma is in scope at the time,
11944   * so we need a way to take a snapshot of what they resolve to at the time of
11945   * the original parse. [perl #56444].
11946   *
11947   * That parsing is skipped for single-quoted regexes, so we may here get
11948   * '\N{NAME}'.  This is a fatal error.  These names have to be resolved by the
11949   * parser.  But if the single-quoted regex is something like '\N{U+41}', that
11950   * is legal and handled here.  The code point is Unicode, and has to be
11951   * translated into the native character set for non-ASCII platforms.
11952   */
11953
11954     char * endbrace;    /* points to '}' following the name */
11955     char *endchar;      /* Points to '.' or '}' ending cur char in the input
11956                            stream */
11957     char* p = RExC_parse; /* Temporary */
11958
11959     GET_RE_DEBUG_FLAGS_DECL;
11960
11961     PERL_ARGS_ASSERT_GROK_BSLASH_N;
11962
11963     GET_RE_DEBUG_FLAGS;
11964
11965     assert(cBOOL(node_p) ^ cBOOL(code_point_p));  /* Exactly one should be set */
11966     assert(! (node_p && cp_count));               /* At most 1 should be set */
11967
11968     if (cp_count) {     /* Initialize return for the most common case */
11969         *cp_count = 1;
11970     }
11971
11972     /* The [^\n] meaning of \N ignores spaces and comments under the /x
11973      * modifier.  The other meanings do not, so use a temporary until we find
11974      * out which we are being called with */
11975     skip_to_be_ignored_text(pRExC_state, &p,
11976                             FALSE /* Don't force to /x */ );
11977
11978     /* Disambiguate between \N meaning a named character versus \N meaning
11979      * [^\n].  The latter is assumed when the {...} following the \N is a legal
11980      * quantifier, or there is no '{' at all */
11981     if (*p != '{' || regcurly(p)) {
11982         RExC_parse = p;
11983         if (cp_count) {
11984             *cp_count = -1;
11985         }
11986
11987         if (! node_p) {
11988             return FALSE;
11989         }
11990
11991         *node_p = reg_node(pRExC_state, REG_ANY);
11992         *flagp |= HASWIDTH|SIMPLE;
11993         MARK_NAUGHTY(1);
11994         Set_Node_Length(*node_p, 1); /* MJD */
11995         return TRUE;
11996     }
11997
11998     /* Here, we have decided it should be a named character or sequence */
11999
12000     /* The test above made sure that the next real character is a '{', but
12001      * under the /x modifier, it could be separated by space (or a comment and
12002      * \n) and this is not allowed (for consistency with \x{...} and the
12003      * tokenizer handling of \N{NAME}). */
12004     if (*RExC_parse != '{') {
12005         vFAIL("Missing braces on \\N{}");
12006     }
12007
12008     RExC_parse++;       /* Skip past the '{' */
12009
12010     if (! (endbrace = strchr(RExC_parse, '}'))) { /* no trailing brace */
12011         vFAIL2("Missing right brace on \\%c{}", 'N');
12012     }
12013     else if(!(endbrace == RExC_parse            /* nothing between the {} */
12014               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked... */
12015                   && strnEQ(RExC_parse, "U+", 2)))) /* ... below for a better
12016                                                        error msg) */
12017     {
12018         RExC_parse = endbrace;  /* position msg's '<--HERE' */
12019         vFAIL("\\N{NAME} must be resolved by the lexer");
12020     }
12021
12022     REQUIRE_UNI_RULES(flagp, FALSE); /* Unicode named chars imply Unicode
12023                                         semantics */
12024
12025     if (endbrace == RExC_parse) {   /* empty: \N{} */
12026         if (strict) {
12027             RExC_parse++;   /* Position after the "}" */
12028             vFAIL("Zero length \\N{}");
12029         }
12030         if (cp_count) {
12031             *cp_count = 0;
12032         }
12033         nextchar(pRExC_state);
12034         if (! node_p) {
12035             return FALSE;
12036         }
12037
12038         *node_p = reg_node(pRExC_state,NOTHING);
12039         return TRUE;
12040     }
12041
12042     RExC_parse += 2;    /* Skip past the 'U+' */
12043
12044     /* Because toke.c has generated a special construct for us guaranteed not
12045      * to have NULs, we can use a str function */
12046     endchar = RExC_parse + strcspn(RExC_parse, ".}");
12047
12048     /* Code points are separated by dots.  If none, there is only one code
12049      * point, and is terminated by the brace */
12050
12051     if (endchar >= endbrace) {
12052         STRLEN length_of_hex;
12053         I32 grok_hex_flags;
12054
12055         /* Here, exactly one code point.  If that isn't what is wanted, fail */
12056         if (! code_point_p) {
12057             RExC_parse = p;
12058             return FALSE;
12059         }
12060
12061         /* Convert code point from hex */
12062         length_of_hex = (STRLEN)(endchar - RExC_parse);
12063         grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES
12064                            | PERL_SCAN_DISALLOW_PREFIX
12065
12066                              /* No errors in the first pass (See [perl
12067                               * #122671].)  We let the code below find the
12068                               * errors when there are multiple chars. */
12069                            | ((SIZE_ONLY)
12070                               ? PERL_SCAN_SILENT_ILLDIGIT
12071                               : 0);
12072
12073         /* This routine is the one place where both single- and double-quotish
12074          * \N{U+xxxx} are evaluated.  The value is a Unicode code point which
12075          * must be converted to native. */
12076         *code_point_p = UNI_TO_NATIVE(grok_hex(RExC_parse,
12077                                          &length_of_hex,
12078                                          &grok_hex_flags,
12079                                          NULL));
12080
12081         /* The tokenizer should have guaranteed validity, but it's possible to
12082          * bypass it by using single quoting, so check.  Don't do the check
12083          * here when there are multiple chars; we do it below anyway. */
12084         if (length_of_hex == 0
12085             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
12086         {
12087             RExC_parse += length_of_hex;        /* Includes all the valid */
12088             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
12089                             ? UTF8SKIP(RExC_parse)
12090                             : 1;
12091             /* Guard against malformed utf8 */
12092             if (RExC_parse >= endchar) {
12093                 RExC_parse = endchar;
12094             }
12095             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12096         }
12097
12098         RExC_parse = endbrace + 1;
12099         return TRUE;
12100     }
12101     else {  /* Is a multiple character sequence */
12102         SV * substitute_parse;
12103         STRLEN len;
12104         char *orig_end = RExC_end;
12105         char *save_start = RExC_start;
12106         I32 flags;
12107
12108         /* Count the code points, if desired, in the sequence */
12109         if (cp_count) {
12110             *cp_count = 0;
12111             while (RExC_parse < endbrace) {
12112                 /* Point to the beginning of the next character in the sequence. */
12113                 RExC_parse = endchar + 1;
12114                 endchar = RExC_parse + strcspn(RExC_parse, ".}");
12115                 (*cp_count)++;
12116             }
12117         }
12118
12119         /* Fail if caller doesn't want to handle a multi-code-point sequence.
12120          * But don't backup up the pointer if the caller want to know how many
12121          * code points there are (they can then handle things) */
12122         if (! node_p) {
12123             if (! cp_count) {
12124                 RExC_parse = p;
12125             }
12126             return FALSE;
12127         }
12128
12129         /* What is done here is to convert this to a sub-pattern of the form
12130          * \x{char1}\x{char2}...  and then call reg recursively to parse it
12131          * (enclosing in "(?: ... )" ).  That way, it retains its atomicness,
12132          * while not having to worry about special handling that some code
12133          * points may have. */
12134
12135         substitute_parse = newSVpvs("?:");
12136
12137         while (RExC_parse < endbrace) {
12138
12139             /* Convert to notation the rest of the code understands */
12140             sv_catpv(substitute_parse, "\\x{");
12141             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
12142             sv_catpv(substitute_parse, "}");
12143
12144             /* Point to the beginning of the next character in the sequence. */
12145             RExC_parse = endchar + 1;
12146             endchar = RExC_parse + strcspn(RExC_parse, ".}");
12147
12148         }
12149         sv_catpv(substitute_parse, ")");
12150
12151         RExC_parse = RExC_start = RExC_adjusted_start = SvPV(substitute_parse,
12152                                                              len);
12153
12154         /* Don't allow empty number */
12155         if (len < (STRLEN) 8) {
12156             RExC_parse = endbrace;
12157             vFAIL("Invalid hexadecimal number in \\N{U+...}");
12158         }
12159         RExC_end = RExC_parse + len;
12160
12161         /* The values are Unicode, and therefore not subject to recoding, but
12162          * have to be converted to native on a non-Unicode (meaning non-ASCII)
12163          * platform. */
12164         RExC_override_recoding = 1;
12165 #ifdef EBCDIC
12166         RExC_recode_x_to_native = 1;
12167 #endif
12168
12169         if (node_p) {
12170             if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) {
12171                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12172                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12173                     return FALSE;
12174                 }
12175                 FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#" UVxf,
12176                     (UV) flags);
12177             }
12178             *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12179         }
12180
12181         /* Restore the saved values */
12182         RExC_start = RExC_adjusted_start = save_start;
12183         RExC_parse = endbrace;
12184         RExC_end = orig_end;
12185         RExC_override_recoding = 0;
12186 #ifdef EBCDIC
12187         RExC_recode_x_to_native = 0;
12188 #endif
12189
12190         SvREFCNT_dec_NN(substitute_parse);
12191         nextchar(pRExC_state);
12192
12193         return TRUE;
12194     }
12195 }
12196
12197
12198 PERL_STATIC_INLINE U8
12199 S_compute_EXACTish(RExC_state_t *pRExC_state)
12200 {
12201     U8 op;
12202
12203     PERL_ARGS_ASSERT_COMPUTE_EXACTISH;
12204
12205     if (! FOLD) {
12206         return (LOC)
12207                 ? EXACTL
12208                 : EXACT;
12209     }
12210
12211     op = get_regex_charset(RExC_flags);
12212     if (op >= REGEX_ASCII_RESTRICTED_CHARSET) {
12213         op--; /* /a is same as /u, and map /aa's offset to what /a's would have
12214                  been, so there is no hole */
12215     }
12216
12217     return op + EXACTF;
12218 }
12219
12220 PERL_STATIC_INLINE void
12221 S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state,
12222                          regnode *node, I32* flagp, STRLEN len, UV code_point,
12223                          bool downgradable)
12224 {
12225     /* This knows the details about sizing an EXACTish node, setting flags for
12226      * it (by setting <*flagp>, and potentially populating it with a single
12227      * character.
12228      *
12229      * If <len> (the length in bytes) is non-zero, this function assumes that
12230      * the node has already been populated, and just does the sizing.  In this
12231      * case <code_point> should be the final code point that has already been
12232      * placed into the node.  This value will be ignored except that under some
12233      * circumstances <*flagp> is set based on it.
12234      *
12235      * If <len> is zero, the function assumes that the node is to contain only
12236      * the single character given by <code_point> and calculates what <len>
12237      * should be.  In pass 1, it sizes the node appropriately.  In pass 2, it
12238      * additionally will populate the node's STRING with <code_point> or its
12239      * fold if folding.
12240      *
12241      * In both cases <*flagp> is appropriately set
12242      *
12243      * It knows that under FOLD, the Latin Sharp S and UTF characters above
12244      * 255, must be folded (the former only when the rules indicate it can
12245      * match 'ss')
12246      *
12247      * When it does the populating, it looks at the flag 'downgradable'.  If
12248      * true with a node that folds, it checks if the single code point
12249      * participates in a fold, and if not downgrades the node to an EXACT.
12250      * This helps the optimizer */
12251
12252     bool len_passed_in = cBOOL(len != 0);
12253     U8 character[UTF8_MAXBYTES_CASE+1];
12254
12255     PERL_ARGS_ASSERT_ALLOC_MAYBE_POPULATE_EXACT;
12256
12257     /* Don't bother to check for downgrading in PASS1, as it doesn't make any
12258      * sizing difference, and is extra work that is thrown away */
12259     if (downgradable && ! PASS2) {
12260         downgradable = FALSE;
12261     }
12262
12263     if (! len_passed_in) {
12264         if (UTF) {
12265             if (UVCHR_IS_INVARIANT(code_point)) {
12266                 if (LOC || ! FOLD) {    /* /l defers folding until runtime */
12267                     *character = (U8) code_point;
12268                 }
12269                 else { /* Here is /i and not /l. (toFOLD() is defined on just
12270                           ASCII, which isn't the same thing as INVARIANT on
12271                           EBCDIC, but it works there, as the extra invariants
12272                           fold to themselves) */
12273                     *character = toFOLD((U8) code_point);
12274
12275                     /* We can downgrade to an EXACT node if this character
12276                      * isn't a folding one.  Note that this assumes that
12277                      * nothing above Latin1 folds to some other invariant than
12278                      * one of these alphabetics; otherwise we would also have
12279                      * to check:
12280                      *  && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12281                      *      || ASCII_FOLD_RESTRICTED))
12282                      */
12283                     if (downgradable && PL_fold[code_point] == code_point) {
12284                         OP(node) = EXACT;
12285                     }
12286                 }
12287                 len = 1;
12288             }
12289             else if (FOLD && (! LOC
12290                               || ! is_PROBLEMATIC_LOCALE_FOLD_cp(code_point)))
12291             {   /* Folding, and ok to do so now */
12292                 UV folded = _to_uni_fold_flags(
12293                                    code_point,
12294                                    character,
12295                                    &len,
12296                                    FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
12297                                                       ? FOLD_FLAGS_NOMIX_ASCII
12298                                                       : 0));
12299                 if (downgradable
12300                     && folded == code_point /* This quickly rules out many
12301                                                cases, avoiding the
12302                                                _invlist_contains_cp() overhead
12303                                                for those.  */
12304                     && ! _invlist_contains_cp(PL_utf8_foldable, code_point))
12305                 {
12306                     OP(node) = (LOC)
12307                                ? EXACTL
12308                                : EXACT;
12309                 }
12310             }
12311             else if (code_point <= MAX_UTF8_TWO_BYTE) {
12312
12313                 /* Not folding this cp, and can output it directly */
12314                 *character = UTF8_TWO_BYTE_HI(code_point);
12315                 *(character + 1) = UTF8_TWO_BYTE_LO(code_point);
12316                 len = 2;
12317             }
12318             else {
12319                 uvchr_to_utf8( character, code_point);
12320                 len = UTF8SKIP(character);
12321             }
12322         } /* Else pattern isn't UTF8.  */
12323         else if (! FOLD) {
12324             *character = (U8) code_point;
12325             len = 1;
12326         } /* Else is folded non-UTF8 */
12327 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12328    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12329                                       || UNICODE_DOT_DOT_VERSION > 0)
12330         else if (LIKELY(code_point != LATIN_SMALL_LETTER_SHARP_S)) {
12331 #else
12332         else if (1) {
12333 #endif
12334             /* We don't fold any non-UTF8 except possibly the Sharp s  (see
12335              * comments at join_exact()); */
12336             *character = (U8) code_point;
12337             len = 1;
12338
12339             /* Can turn into an EXACT node if we know the fold at compile time,
12340              * and it folds to itself and doesn't particpate in other folds */
12341             if (downgradable
12342                 && ! LOC
12343                 && PL_fold_latin1[code_point] == code_point
12344                 && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point)
12345                     || (isASCII(code_point) && ASCII_FOLD_RESTRICTED)))
12346             {
12347                 OP(node) = EXACT;
12348             }
12349         } /* else is Sharp s.  May need to fold it */
12350         else if (AT_LEAST_UNI_SEMANTICS && ! ASCII_FOLD_RESTRICTED) {
12351             *character = 's';
12352             *(character + 1) = 's';
12353             len = 2;
12354         }
12355         else {
12356             *character = LATIN_SMALL_LETTER_SHARP_S;
12357             len = 1;
12358         }
12359     }
12360
12361     if (SIZE_ONLY) {
12362         RExC_size += STR_SZ(len);
12363     }
12364     else {
12365         RExC_emit += STR_SZ(len);
12366         STR_LEN(node) = len;
12367         if (! len_passed_in) {
12368             Copy((char *) character, STRING(node), len, char);
12369         }
12370     }
12371
12372     *flagp |= HASWIDTH;
12373
12374     /* A single character node is SIMPLE, except for the special-cased SHARP S
12375      * under /di. */
12376     if ((len == 1 || (UTF && len == UVCHR_SKIP(code_point)))
12377 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
12378    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
12379                                       || UNICODE_DOT_DOT_VERSION > 0)
12380         && ( code_point != LATIN_SMALL_LETTER_SHARP_S
12381             || ! FOLD || ! DEPENDS_SEMANTICS)
12382 #endif
12383     ) {
12384         *flagp |= SIMPLE;
12385     }
12386
12387     /* The OP may not be well defined in PASS1 */
12388     if (PASS2 && OP(node) == EXACTFL) {
12389         RExC_contains_locale = 1;
12390     }
12391 }
12392
12393
12394 /* Parse backref decimal value, unless it's too big to sensibly be a backref,
12395  * in which case return I32_MAX (rather than possibly 32-bit wrapping) */
12396
12397 static I32
12398 S_backref_value(char *p)
12399 {
12400     const char* endptr;
12401     UV val;
12402     if (grok_atoUV(p, &val, &endptr) && val <= I32_MAX)
12403         return (I32)val;
12404     return I32_MAX;
12405 }
12406
12407
12408 /*
12409  - regatom - the lowest level
12410
12411    Try to identify anything special at the start of the current parse position.
12412    If there is, then handle it as required. This may involve generating a
12413    single regop, such as for an assertion; or it may involve recursing, such as
12414    to handle a () structure.
12415
12416    If the string doesn't start with something special then we gobble up
12417    as much literal text as we can.  If we encounter a quantifier, we have to
12418    back off the final literal character, as that quantifier applies to just it
12419    and not to the whole string of literals.
12420
12421    Once we have been able to handle whatever type of thing started the
12422    sequence, we return.
12423
12424    Note: we have to be careful with escapes, as they can be both literal
12425    and special, and in the case of \10 and friends, context determines which.
12426
12427    A summary of the code structure is:
12428
12429    switch (first_byte) {
12430         cases for each special:
12431             handle this special;
12432             break;
12433         case '\\':
12434             switch (2nd byte) {
12435                 cases for each unambiguous special:
12436                     handle this special;
12437                     break;
12438                 cases for each ambigous special/literal:
12439                     disambiguate;
12440                     if (special)  handle here
12441                     else goto defchar;
12442                 default: // unambiguously literal:
12443                     goto defchar;
12444             }
12445         default:  // is a literal char
12446             // FALL THROUGH
12447         defchar:
12448             create EXACTish node for literal;
12449             while (more input and node isn't full) {
12450                 switch (input_byte) {
12451                    cases for each special;
12452                        make sure parse pointer is set so that the next call to
12453                            regatom will see this special first
12454                        goto loopdone; // EXACTish node terminated by prev. char
12455                    default:
12456                        append char to EXACTISH node;
12457                 }
12458                 get next input byte;
12459             }
12460         loopdone:
12461    }
12462    return the generated node;
12463
12464    Specifically there are two separate switches for handling
12465    escape sequences, with the one for handling literal escapes requiring
12466    a dummy entry for all of the special escapes that are actually handled
12467    by the other.
12468
12469    Returns NULL, setting *flagp to TRYAGAIN if reg() returns NULL with
12470    TRYAGAIN.
12471    Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs to be
12472    restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded to UTF-8
12473    Otherwise does not return NULL.
12474 */
12475
12476 STATIC regnode *
12477 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
12478 {
12479     regnode *ret = NULL;
12480     I32 flags = 0;
12481     char *parse_start;
12482     U8 op;
12483     int invert = 0;
12484     U8 arg;
12485
12486     GET_RE_DEBUG_FLAGS_DECL;
12487
12488     *flagp = WORST;             /* Tentatively. */
12489
12490     DEBUG_PARSE("atom");
12491
12492     PERL_ARGS_ASSERT_REGATOM;
12493
12494   tryagain:
12495     parse_start = RExC_parse;
12496     assert(RExC_parse < RExC_end);
12497     switch ((U8)*RExC_parse) {
12498     case '^':
12499         RExC_seen_zerolen++;
12500         nextchar(pRExC_state);
12501         if (RExC_flags & RXf_PMf_MULTILINE)
12502             ret = reg_node(pRExC_state, MBOL);
12503         else
12504             ret = reg_node(pRExC_state, SBOL);
12505         Set_Node_Length(ret, 1); /* MJD */
12506         break;
12507     case '$':
12508         nextchar(pRExC_state);
12509         if (*RExC_parse)
12510             RExC_seen_zerolen++;
12511         if (RExC_flags & RXf_PMf_MULTILINE)
12512             ret = reg_node(pRExC_state, MEOL);
12513         else
12514             ret = reg_node(pRExC_state, SEOL);
12515         Set_Node_Length(ret, 1); /* MJD */
12516         break;
12517     case '.':
12518         nextchar(pRExC_state);
12519         if (RExC_flags & RXf_PMf_SINGLELINE)
12520             ret = reg_node(pRExC_state, SANY);
12521         else
12522             ret = reg_node(pRExC_state, REG_ANY);
12523         *flagp |= HASWIDTH|SIMPLE;
12524         MARK_NAUGHTY(1);
12525         Set_Node_Length(ret, 1); /* MJD */
12526         break;
12527     case '[':
12528     {
12529         char * const oregcomp_parse = ++RExC_parse;
12530         ret = regclass(pRExC_state, flagp,depth+1,
12531                        FALSE, /* means parse the whole char class */
12532                        TRUE, /* allow multi-char folds */
12533                        FALSE, /* don't silence non-portable warnings. */
12534                        (bool) RExC_strict,
12535                        TRUE, /* Allow an optimized regnode result */
12536                        NULL,
12537                        NULL);
12538         if (ret == NULL) {
12539             if (*flagp & (RESTART_PASS1|NEED_UTF8))
12540                 return NULL;
12541             FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12542                   (UV) *flagp);
12543         }
12544         if (*RExC_parse != ']') {
12545             RExC_parse = oregcomp_parse;
12546             vFAIL("Unmatched [");
12547         }
12548         nextchar(pRExC_state);
12549         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
12550         break;
12551     }
12552     case '(':
12553         nextchar(pRExC_state);
12554         ret = reg(pRExC_state, 2, &flags,depth+1);
12555         if (ret == NULL) {
12556                 if (flags & TRYAGAIN) {
12557                     if (RExC_parse >= RExC_end) {
12558                          /* Make parent create an empty node if needed. */
12559                         *flagp |= TRYAGAIN;
12560                         return(NULL);
12561                     }
12562                     goto tryagain;
12563                 }
12564                 if (flags & (RESTART_PASS1|NEED_UTF8)) {
12565                     *flagp = flags & (RESTART_PASS1|NEED_UTF8);
12566                     return NULL;
12567                 }
12568                 FAIL2("panic: reg returned NULL to regatom, flags=%#" UVxf,
12569                                                                  (UV) flags);
12570         }
12571         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
12572         break;
12573     case '|':
12574     case ')':
12575         if (flags & TRYAGAIN) {
12576             *flagp |= TRYAGAIN;
12577             return NULL;
12578         }
12579         vFAIL("Internal urp");
12580                                 /* Supposed to be caught earlier. */
12581         break;
12582     case '?':
12583     case '+':
12584     case '*':
12585         RExC_parse++;
12586         vFAIL("Quantifier follows nothing");
12587         break;
12588     case '\\':
12589         /* Special Escapes
12590
12591            This switch handles escape sequences that resolve to some kind
12592            of special regop and not to literal text. Escape sequnces that
12593            resolve to literal text are handled below in the switch marked
12594            "Literal Escapes".
12595
12596            Every entry in this switch *must* have a corresponding entry
12597            in the literal escape switch. However, the opposite is not
12598            required, as the default for this switch is to jump to the
12599            literal text handling code.
12600         */
12601         RExC_parse++;
12602         switch ((U8)*RExC_parse) {
12603         /* Special Escapes */
12604         case 'A':
12605             RExC_seen_zerolen++;
12606             ret = reg_node(pRExC_state, SBOL);
12607             /* SBOL is shared with /^/ so we set the flags so we can tell
12608              * /\A/ from /^/ in split. We check ret because first pass we
12609              * have no regop struct to set the flags on. */
12610             if (PASS2)
12611                 ret->flags = 1;
12612             *flagp |= SIMPLE;
12613             goto finish_meta_pat;
12614         case 'G':
12615             ret = reg_node(pRExC_state, GPOS);
12616             RExC_seen |= REG_GPOS_SEEN;
12617             *flagp |= SIMPLE;
12618             goto finish_meta_pat;
12619         case 'K':
12620             RExC_seen_zerolen++;
12621             ret = reg_node(pRExC_state, KEEPS);
12622             *flagp |= SIMPLE;
12623             /* XXX:dmq : disabling in-place substitution seems to
12624              * be necessary here to avoid cases of memory corruption, as
12625              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
12626              */
12627             RExC_seen |= REG_LOOKBEHIND_SEEN;
12628             goto finish_meta_pat;
12629         case 'Z':
12630             ret = reg_node(pRExC_state, SEOL);
12631             *flagp |= SIMPLE;
12632             RExC_seen_zerolen++;                /* Do not optimize RE away */
12633             goto finish_meta_pat;
12634         case 'z':
12635             ret = reg_node(pRExC_state, EOS);
12636             *flagp |= SIMPLE;
12637             RExC_seen_zerolen++;                /* Do not optimize RE away */
12638             goto finish_meta_pat;
12639         case 'C':
12640             vFAIL("\\C no longer supported");
12641         case 'X':
12642             ret = reg_node(pRExC_state, CLUMP);
12643             *flagp |= HASWIDTH;
12644             goto finish_meta_pat;
12645
12646         case 'W':
12647             invert = 1;
12648             /* FALLTHROUGH */
12649         case 'w':
12650             arg = ANYOF_WORDCHAR;
12651             goto join_posix;
12652
12653         case 'B':
12654             invert = 1;
12655             /* FALLTHROUGH */
12656         case 'b':
12657           {
12658             regex_charset charset = get_regex_charset(RExC_flags);
12659
12660             RExC_seen_zerolen++;
12661             RExC_seen |= REG_LOOKBEHIND_SEEN;
12662             op = BOUND + charset;
12663
12664             if (op == BOUNDL) {
12665                 RExC_contains_locale = 1;
12666             }
12667
12668             ret = reg_node(pRExC_state, op);
12669             *flagp |= SIMPLE;
12670             if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') {
12671                 FLAGS(ret) = TRADITIONAL_BOUND;
12672                 if (PASS2 && op > BOUNDA) {  /* /aa is same as /a */
12673                     OP(ret) = BOUNDA;
12674                 }
12675             }
12676             else {
12677                 STRLEN length;
12678                 char name = *RExC_parse;
12679                 char * endbrace;
12680                 RExC_parse += 2;
12681                 endbrace = strchr(RExC_parse, '}');
12682
12683                 if (! endbrace) {
12684                     vFAIL2("Missing right brace on \\%c{}", name);
12685                 }
12686                 /* XXX Need to decide whether to take spaces or not.  Should be
12687                  * consistent with \p{}, but that currently is SPACE, which
12688                  * means vertical too, which seems wrong
12689                  * while (isBLANK(*RExC_parse)) {
12690                     RExC_parse++;
12691                 }*/
12692                 if (endbrace == RExC_parse) {
12693                     RExC_parse++;  /* After the '}' */
12694                     vFAIL2("Empty \\%c{}", name);
12695                 }
12696                 length = endbrace - RExC_parse;
12697                 /*while (isBLANK(*(RExC_parse + length - 1))) {
12698                     length--;
12699                 }*/
12700                 switch (*RExC_parse) {
12701                     case 'g':
12702                         if (length != 1
12703                             && (length != 3 || strnNE(RExC_parse + 1, "cb", 2)))
12704                         {
12705                             goto bad_bound_type;
12706                         }
12707                         FLAGS(ret) = GCB_BOUND;
12708                         break;
12709                     case 'l':
12710                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12711                             goto bad_bound_type;
12712                         }
12713                         FLAGS(ret) = LB_BOUND;
12714                         break;
12715                     case 's':
12716                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12717                             goto bad_bound_type;
12718                         }
12719                         FLAGS(ret) = SB_BOUND;
12720                         break;
12721                     case 'w':
12722                         if (length != 2 || *(RExC_parse + 1) != 'b') {
12723                             goto bad_bound_type;
12724                         }
12725                         FLAGS(ret) = WB_BOUND;
12726                         break;
12727                     default:
12728                       bad_bound_type:
12729                         RExC_parse = endbrace;
12730                         vFAIL2utf8f(
12731                             "'%" UTF8f "' is an unknown bound type",
12732                             UTF8fARG(UTF, length, endbrace - length));
12733                         NOT_REACHED; /*NOTREACHED*/
12734                 }
12735                 RExC_parse = endbrace;
12736                 REQUIRE_UNI_RULES(flagp, NULL);
12737
12738                 if (PASS2 && op >= BOUNDA) {  /* /aa is same as /a */
12739                     OP(ret) = BOUNDU;
12740                     length += 4;
12741
12742                     /* Don't have to worry about UTF-8, in this message because
12743                      * to get here the contents of the \b must be ASCII */
12744                     ckWARN4reg(RExC_parse + 1,  /* Include the '}' in msg */
12745                               "Using /u for '%.*s' instead of /%s",
12746                               (unsigned) length,
12747                               endbrace - length + 1,
12748                               (charset == REGEX_ASCII_RESTRICTED_CHARSET)
12749                               ? ASCII_RESTRICT_PAT_MODS
12750                               : ASCII_MORE_RESTRICT_PAT_MODS);
12751                 }
12752             }
12753
12754             if (PASS2 && invert) {
12755                 OP(ret) += NBOUND - BOUND;
12756             }
12757             goto finish_meta_pat;
12758           }
12759
12760         case 'D':
12761             invert = 1;
12762             /* FALLTHROUGH */
12763         case 'd':
12764             arg = ANYOF_DIGIT;
12765             if (! DEPENDS_SEMANTICS) {
12766                 goto join_posix;
12767             }
12768
12769             /* \d doesn't have any matches in the upper Latin1 range, hence /d
12770              * is equivalent to /u.  Changing to /u saves some branches at
12771              * runtime */
12772             op = POSIXU;
12773             goto join_posix_op_known;
12774
12775         case 'R':
12776             ret = reg_node(pRExC_state, LNBREAK);
12777             *flagp |= HASWIDTH|SIMPLE;
12778             goto finish_meta_pat;
12779
12780         case 'H':
12781             invert = 1;
12782             /* FALLTHROUGH */
12783         case 'h':
12784             arg = ANYOF_BLANK;
12785             op = POSIXU;
12786             goto join_posix_op_known;
12787
12788         case 'V':
12789             invert = 1;
12790             /* FALLTHROUGH */
12791         case 'v':
12792             arg = ANYOF_VERTWS;
12793             op = POSIXU;
12794             goto join_posix_op_known;
12795
12796         case 'S':
12797             invert = 1;
12798             /* FALLTHROUGH */
12799         case 's':
12800             arg = ANYOF_SPACE;
12801
12802           join_posix:
12803
12804             op = POSIXD + get_regex_charset(RExC_flags);
12805             if (op > POSIXA) {  /* /aa is same as /a */
12806                 op = POSIXA;
12807             }
12808             else if (op == POSIXL) {
12809                 RExC_contains_locale = 1;
12810             }
12811
12812           join_posix_op_known:
12813
12814             if (invert) {
12815                 op += NPOSIXD - POSIXD;
12816             }
12817
12818             ret = reg_node(pRExC_state, op);
12819             if (! SIZE_ONLY) {
12820                 FLAGS(ret) = namedclass_to_classnum(arg);
12821             }
12822
12823             *flagp |= HASWIDTH|SIMPLE;
12824             /* FALLTHROUGH */
12825
12826           finish_meta_pat:
12827             nextchar(pRExC_state);
12828             Set_Node_Length(ret, 2); /* MJD */
12829             break;
12830         case 'p':
12831         case 'P':
12832             RExC_parse--;
12833
12834             ret = regclass(pRExC_state, flagp,depth+1,
12835                            TRUE, /* means just parse this element */
12836                            FALSE, /* don't allow multi-char folds */
12837                            FALSE, /* don't silence non-portable warnings.  It
12838                                      would be a bug if these returned
12839                                      non-portables */
12840                            (bool) RExC_strict,
12841                            TRUE, /* Allow an optimized regnode result */
12842                            NULL,
12843                            NULL);
12844             if (*flagp & RESTART_PASS1)
12845                 return NULL;
12846             /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
12847              * multi-char folds are allowed.  */
12848             if (!ret)
12849                 FAIL2("panic: regclass returned NULL to regatom, flags=%#" UVxf,
12850                       (UV) *flagp);
12851
12852             RExC_parse--;
12853
12854             Set_Node_Offset(ret, parse_start);
12855             Set_Node_Cur_Length(ret, parse_start - 2);
12856             nextchar(pRExC_state);
12857             break;
12858         case 'N':
12859             /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the
12860              * \N{...} evaluates to a sequence of more than one code points).
12861              * The function call below returns a regnode, which is our result.
12862              * The parameters cause it to fail if the \N{} evaluates to a
12863              * single code point; we handle those like any other literal.  The
12864              * reason that the multicharacter case is handled here and not as
12865              * part of the EXACtish code is because of quantifiers.  In
12866              * /\N{BLAH}+/, the '+' applies to the whole thing, and doing it
12867              * this way makes that Just Happen. dmq.
12868              * join_exact() will join this up with adjacent EXACTish nodes
12869              * later on, if appropriate. */
12870             ++RExC_parse;
12871             if (grok_bslash_N(pRExC_state,
12872                               &ret,     /* Want a regnode returned */
12873                               NULL,     /* Fail if evaluates to a single code
12874                                            point */
12875                               NULL,     /* Don't need a count of how many code
12876                                            points */
12877                               flagp,
12878                               RExC_strict,
12879                               depth)
12880             ) {
12881                 break;
12882             }
12883
12884             if (*flagp & RESTART_PASS1)
12885                 return NULL;
12886
12887             /* Here, evaluates to a single code point.  Go get that */
12888             RExC_parse = parse_start;
12889             goto defchar;
12890
12891         case 'k':    /* Handle \k<NAME> and \k'NAME' */
12892       parse_named_seq:
12893         {
12894             char ch;
12895             if (   RExC_parse >= RExC_end - 1
12896                 || ((   ch = RExC_parse[1]) != '<'
12897                                       && ch != '\''
12898                                       && ch != '{'))
12899             {
12900                 RExC_parse++;
12901                 /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */
12902                 vFAIL2("Sequence %.2s... not terminated",parse_start);
12903             } else {
12904                 RExC_parse += 2;
12905                 ret = handle_named_backref(pRExC_state,
12906                                            flagp,
12907                                            parse_start,
12908                                            (ch == '<')
12909                                            ? '>'
12910                                            : (ch == '{')
12911                                              ? '}'
12912                                              : '\'');
12913             }
12914             break;
12915         }
12916         case 'g':
12917         case '1': case '2': case '3': case '4':
12918         case '5': case '6': case '7': case '8': case '9':
12919             {
12920                 I32 num;
12921                 bool hasbrace = 0;
12922
12923                 if (*RExC_parse == 'g') {
12924                     bool isrel = 0;
12925
12926                     RExC_parse++;
12927                     if (*RExC_parse == '{') {
12928                         RExC_parse++;
12929                         hasbrace = 1;
12930                     }
12931                     if (*RExC_parse == '-') {
12932                         RExC_parse++;
12933                         isrel = 1;
12934                     }
12935                     if (hasbrace && !isDIGIT(*RExC_parse)) {
12936                         if (isrel) RExC_parse--;
12937                         RExC_parse -= 2;
12938                         goto parse_named_seq;
12939                     }
12940
12941                     if (RExC_parse >= RExC_end) {
12942                         goto unterminated_g;
12943                     }
12944                     num = S_backref_value(RExC_parse);
12945                     if (num == 0)
12946                         vFAIL("Reference to invalid group 0");
12947                     else if (num == I32_MAX) {
12948                          if (isDIGIT(*RExC_parse))
12949                             vFAIL("Reference to nonexistent group");
12950                         else
12951                           unterminated_g:
12952                             vFAIL("Unterminated \\g... pattern");
12953                     }
12954
12955                     if (isrel) {
12956                         num = RExC_npar - num;
12957                         if (num < 1)
12958                             vFAIL("Reference to nonexistent or unclosed group");
12959                     }
12960                 }
12961                 else {
12962                     num = S_backref_value(RExC_parse);
12963                     /* bare \NNN might be backref or octal - if it is larger
12964                      * than or equal RExC_npar then it is assumed to be an
12965                      * octal escape. Note RExC_npar is +1 from the actual
12966                      * number of parens. */
12967                     /* Note we do NOT check if num == I32_MAX here, as that is
12968                      * handled by the RExC_npar check */
12969
12970                     if (
12971                         /* any numeric escape < 10 is always a backref */
12972                         num > 9
12973                         /* any numeric escape < RExC_npar is a backref */
12974                         && num >= RExC_npar
12975                         /* cannot be an octal escape if it starts with 8 */
12976                         && *RExC_parse != '8'
12977                         /* cannot be an octal escape it it starts with 9 */
12978                         && *RExC_parse != '9'
12979                     )
12980                     {
12981                         /* Probably not a backref, instead likely to be an
12982                          * octal character escape, e.g. \35 or \777.
12983                          * The above logic should make it obvious why using
12984                          * octal escapes in patterns is problematic. - Yves */
12985                         RExC_parse = parse_start;
12986                         goto defchar;
12987                     }
12988                 }
12989
12990                 /* At this point RExC_parse points at a numeric escape like
12991                  * \12 or \88 or something similar, which we should NOT treat
12992                  * as an octal escape. It may or may not be a valid backref
12993                  * escape. For instance \88888888 is unlikely to be a valid
12994                  * backref. */
12995                 while (isDIGIT(*RExC_parse))
12996                     RExC_parse++;
12997                 if (hasbrace) {
12998                     if (*RExC_parse != '}')
12999                         vFAIL("Unterminated \\g{...} pattern");
13000                     RExC_parse++;
13001                 }
13002                 if (!SIZE_ONLY) {
13003                     if (num > (I32)RExC_rx->nparens)
13004                         vFAIL("Reference to nonexistent group");
13005                 }
13006                 RExC_sawback = 1;
13007                 ret = reganode(pRExC_state,
13008                                ((! FOLD)
13009                                  ? REF
13010                                  : (ASCII_FOLD_RESTRICTED)
13011                                    ? REFFA
13012                                    : (AT_LEAST_UNI_SEMANTICS)
13013                                      ? REFFU
13014                                      : (LOC)
13015                                        ? REFFL
13016                                        : REFF),
13017                                 num);
13018                 *flagp |= HASWIDTH;
13019
13020                 /* override incorrect value set in reganode MJD */
13021                 Set_Node_Offset(ret, parse_start);
13022                 Set_Node_Cur_Length(ret, parse_start-1);
13023                 skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13024                                         FALSE /* Don't force to /x */ );
13025             }
13026             break;
13027         case '\0':
13028             if (RExC_parse >= RExC_end)
13029                 FAIL("Trailing \\");
13030             /* FALLTHROUGH */
13031         default:
13032             /* Do not generate "unrecognized" warnings here, we fall
13033                back into the quick-grab loop below */
13034             RExC_parse = parse_start;
13035             goto defchar;
13036         } /* end of switch on a \foo sequence */
13037         break;
13038
13039     case '#':
13040
13041         /* '#' comments should have been spaced over before this function was
13042          * called */
13043         assert((RExC_flags & RXf_PMf_EXTENDED) == 0);
13044         /*
13045         if (RExC_flags & RXf_PMf_EXTENDED) {
13046             RExC_parse = reg_skipcomment( pRExC_state, RExC_parse );
13047             if (RExC_parse < RExC_end)
13048                 goto tryagain;
13049         }
13050         */
13051
13052         /* FALLTHROUGH */
13053
13054     default:
13055           defchar: {
13056
13057             /* Here, we have determined that the next thing is probably a
13058              * literal character.  RExC_parse points to the first byte of its
13059              * definition.  (It still may be an escape sequence that evaluates
13060              * to a single character) */
13061
13062             STRLEN len = 0;
13063             UV ender = 0;
13064             char *p;
13065             char *s;
13066 #define MAX_NODE_STRING_SIZE 127
13067             char foldbuf[MAX_NODE_STRING_SIZE+UTF8_MAXBYTES_CASE];
13068             char *s0;
13069             U8 upper_parse = MAX_NODE_STRING_SIZE;
13070             U8 node_type = compute_EXACTish(pRExC_state);
13071             bool next_is_quantifier;
13072             char * oldp = NULL;
13073
13074             /* We can convert EXACTF nodes to EXACTFU if they contain only
13075              * characters that match identically regardless of the target
13076              * string's UTF8ness.  The reason to do this is that EXACTF is not
13077              * trie-able, EXACTFU is.
13078              *
13079              * Similarly, we can convert EXACTFL nodes to EXACTFLU8 if they
13080              * contain only above-Latin1 characters (hence must be in UTF8),
13081              * which don't participate in folds with Latin1-range characters,
13082              * as the latter's folds aren't known until runtime.  (We don't
13083              * need to figure this out until pass 2) */
13084             bool maybe_exactfu = PASS2
13085                                && (node_type == EXACTF || node_type == EXACTFL);
13086
13087             /* If a folding node contains only code points that don't
13088              * participate in folds, it can be changed into an EXACT node,
13089              * which allows the optimizer more things to look for */
13090             bool maybe_exact;
13091
13092             ret = reg_node(pRExC_state, node_type);
13093
13094             /* In pass1, folded, we use a temporary buffer instead of the
13095              * actual node, as the node doesn't exist yet */
13096             s = (SIZE_ONLY && FOLD) ? foldbuf : STRING(ret);
13097
13098             s0 = s;
13099
13100           reparse:
13101
13102             /* We look for the EXACTFish to EXACT node optimizaton only if
13103              * folding.  (And we don't need to figure this out until pass 2).
13104              * XXX It might actually make sense to split the node into portions
13105              * that are exact and ones that aren't, so that we could later use
13106              * the exact ones to find the longest fixed and floating strings.
13107              * One would want to join them back into a larger node.  One could
13108              * use a pseudo regnode like 'EXACT_ORIG_FOLD' */
13109             maybe_exact = FOLD && PASS2;
13110
13111             /* XXX The node can hold up to 255 bytes, yet this only goes to
13112              * 127.  I (khw) do not know why.  Keeping it somewhat less than
13113              * 255 allows us to not have to worry about overflow due to
13114              * converting to utf8 and fold expansion, but that value is
13115              * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
13116              * split up by this limit into a single one using the real max of
13117              * 255.  Even at 127, this breaks under rare circumstances.  If
13118              * folding, we do not want to split a node at a character that is a
13119              * non-final in a multi-char fold, as an input string could just
13120              * happen to want to match across the node boundary.  The join
13121              * would solve that problem if the join actually happens.  But a
13122              * series of more than two nodes in a row each of 127 would cause
13123              * the first join to succeed to get to 254, but then there wouldn't
13124              * be room for the next one, which could at be one of those split
13125              * multi-char folds.  I don't know of any fool-proof solution.  One
13126              * could back off to end with only a code point that isn't such a
13127              * non-final, but it is possible for there not to be any in the
13128              * entire node. */
13129
13130             assert(   ! UTF     /* Is at the beginning of a character */
13131                    || UTF8_IS_INVARIANT(UCHARAT(RExC_parse))
13132                    || UTF8_IS_START(UCHARAT(RExC_parse)));
13133
13134             /* Here, we have a literal character.  Find the maximal string of
13135              * them in the input that we can fit into a single EXACTish node.
13136              * We quit at the first non-literal or when the node gets full */
13137             for (p = RExC_parse;
13138                  len < upper_parse && p < RExC_end;
13139                  len++)
13140             {
13141                 oldp = p;
13142
13143                 /* White space has already been ignored */
13144                 assert(   (RExC_flags & RXf_PMf_EXTENDED) == 0
13145                        || ! is_PATWS_safe((p), RExC_end, UTF));
13146
13147                 switch ((U8)*p) {
13148                 case '^':
13149                 case '$':
13150                 case '.':
13151                 case '[':
13152                 case '(':
13153                 case ')':
13154                 case '|':
13155                     goto loopdone;
13156                 case '\\':
13157                     /* Literal Escapes Switch
13158
13159                        This switch is meant to handle escape sequences that
13160                        resolve to a literal character.
13161
13162                        Every escape sequence that represents something
13163                        else, like an assertion or a char class, is handled
13164                        in the switch marked 'Special Escapes' above in this
13165                        routine, but also has an entry here as anything that
13166                        isn't explicitly mentioned here will be treated as
13167                        an unescaped equivalent literal.
13168                     */
13169
13170                     switch ((U8)*++p) {
13171                     /* These are all the special escapes. */
13172                     case 'A':             /* Start assertion */
13173                     case 'b': case 'B':   /* Word-boundary assertion*/
13174                     case 'C':             /* Single char !DANGEROUS! */
13175                     case 'd': case 'D':   /* digit class */
13176                     case 'g': case 'G':   /* generic-backref, pos assertion */
13177                     case 'h': case 'H':   /* HORIZWS */
13178                     case 'k': case 'K':   /* named backref, keep marker */
13179                     case 'p': case 'P':   /* Unicode property */
13180                               case 'R':   /* LNBREAK */
13181                     case 's': case 'S':   /* space class */
13182                     case 'v': case 'V':   /* VERTWS */
13183                     case 'w': case 'W':   /* word class */
13184                     case 'X':             /* eXtended Unicode "combining
13185                                              character sequence" */
13186                     case 'z': case 'Z':   /* End of line/string assertion */
13187                         --p;
13188                         goto loopdone;
13189
13190                     /* Anything after here is an escape that resolves to a
13191                        literal. (Except digits, which may or may not)
13192                      */
13193                     case 'n':
13194                         ender = '\n';
13195                         p++;
13196                         break;
13197                     case 'N': /* Handle a single-code point named character. */
13198                         RExC_parse = p + 1;
13199                         if (! grok_bslash_N(pRExC_state,
13200                                             NULL,   /* Fail if evaluates to
13201                                                        anything other than a
13202                                                        single code point */
13203                                             &ender, /* The returned single code
13204                                                        point */
13205                                             NULL,   /* Don't need a count of
13206                                                        how many code points */
13207                                             flagp,
13208                                             RExC_strict,
13209                                             depth)
13210                         ) {
13211                             if (*flagp & NEED_UTF8)
13212                                 FAIL("panic: grok_bslash_N set NEED_UTF8");
13213                             if (*flagp & RESTART_PASS1)
13214                                 return NULL;
13215
13216                             /* Here, it wasn't a single code point.  Go close
13217                              * up this EXACTish node.  The switch() prior to
13218                              * this switch handles the other cases */
13219                             RExC_parse = p = oldp;
13220                             goto loopdone;
13221                         }
13222                         p = RExC_parse;
13223                         if (ender > 0xff) {
13224                             REQUIRE_UTF8(flagp);
13225                         }
13226                         break;
13227                     case 'r':
13228                         ender = '\r';
13229                         p++;
13230                         break;
13231                     case 't':
13232                         ender = '\t';
13233                         p++;
13234                         break;
13235                     case 'f':
13236                         ender = '\f';
13237                         p++;
13238                         break;
13239                     case 'e':
13240                         ender = ESC_NATIVE;
13241                         p++;
13242                         break;
13243                     case 'a':
13244                         ender = '\a';
13245                         p++;
13246                         break;
13247                     case 'o':
13248                         {
13249                             UV result;
13250                             const char* error_msg;
13251
13252                             bool valid = grok_bslash_o(&p,
13253                                                        &result,
13254                                                        &error_msg,
13255                                                        PASS2, /* out warnings */
13256                                                        (bool) RExC_strict,
13257                                                        TRUE, /* Output warnings
13258                                                                 for non-
13259                                                                 portables */
13260                                                        UTF);
13261                             if (! valid) {
13262                                 RExC_parse = p; /* going to die anyway; point
13263                                                    to exact spot of failure */
13264                                 vFAIL(error_msg);
13265                             }
13266                             ender = result;
13267                             if (ender > 0xff) {
13268                                 REQUIRE_UTF8(flagp);
13269                             }
13270                             break;
13271                         }
13272                     case 'x':
13273                         {
13274                             UV result = UV_MAX; /* initialize to erroneous
13275                                                    value */
13276                             const char* error_msg;
13277
13278                             bool valid = grok_bslash_x(&p,
13279                                                        &result,
13280                                                        &error_msg,
13281                                                        PASS2, /* out warnings */
13282                                                        (bool) RExC_strict,
13283                                                        TRUE, /* Silence warnings
13284                                                                 for non-
13285                                                                 portables */
13286                                                        UTF);
13287                             if (! valid) {
13288                                 RExC_parse = p; /* going to die anyway; point
13289                                                    to exact spot of failure */
13290                                 vFAIL(error_msg);
13291                             }
13292                             ender = result;
13293
13294                             if (ender < 0x100) {
13295 #ifdef EBCDIC
13296                                 if (RExC_recode_x_to_native) {
13297                                     ender = LATIN1_TO_NATIVE(ender);
13298                                 }
13299 #endif
13300                             }
13301                             else {
13302                                 REQUIRE_UTF8(flagp);
13303                             }
13304                             break;
13305                         }
13306                     case 'c':
13307                         p++;
13308                         ender = grok_bslash_c(*p++, PASS2);
13309                         break;
13310                     case '8': case '9': /* must be a backreference */
13311                         --p;
13312                         /* we have an escape like \8 which cannot be an octal escape
13313                          * so we exit the loop, and let the outer loop handle this
13314                          * escape which may or may not be a legitimate backref. */
13315                         goto loopdone;
13316                     case '1': case '2': case '3':case '4':
13317                     case '5': case '6': case '7':
13318                         /* When we parse backslash escapes there is ambiguity
13319                          * between backreferences and octal escapes. Any escape
13320                          * from \1 - \9 is a backreference, any multi-digit
13321                          * escape which does not start with 0 and which when
13322                          * evaluated as decimal could refer to an already
13323                          * parsed capture buffer is a back reference. Anything
13324                          * else is octal.
13325                          *
13326                          * Note this implies that \118 could be interpreted as
13327                          * 118 OR as "\11" . "8" depending on whether there
13328                          * were 118 capture buffers defined already in the
13329                          * pattern.  */
13330
13331                         /* NOTE, RExC_npar is 1 more than the actual number of
13332                          * parens we have seen so far, hence the < RExC_npar below. */
13333
13334                         if ( !isDIGIT(p[1]) || S_backref_value(p) < RExC_npar)
13335                         {  /* Not to be treated as an octal constant, go
13336                                    find backref */
13337                             --p;
13338                             goto loopdone;
13339                         }
13340                         /* FALLTHROUGH */
13341                     case '0':
13342                         {
13343                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
13344                             STRLEN numlen = 3;
13345                             ender = grok_oct(p, &numlen, &flags, NULL);
13346                             if (ender > 0xff) {
13347                                 REQUIRE_UTF8(flagp);
13348                             }
13349                             p += numlen;
13350                             if (PASS2   /* like \08, \178 */
13351                                 && numlen < 3
13352                                 && isDIGIT(*p) && ckWARN(WARN_REGEXP))
13353                             {
13354                                 reg_warn_non_literal_string(
13355                                          p + 1,
13356                                          form_short_octal_warning(p, numlen));
13357                             }
13358                         }
13359                         break;
13360                     case '\0':
13361                         if (p >= RExC_end)
13362                             FAIL("Trailing \\");
13363                         /* FALLTHROUGH */
13364                     default:
13365                         if (!SIZE_ONLY&& isALPHANUMERIC(*p)) {
13366                             /* Include any left brace following the alpha to emphasize
13367                              * that it could be part of an escape at some point
13368                              * in the future */
13369                             int len = (isALPHA(*p) && *(p + 1) == '{') ? 2 : 1;
13370                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
13371                         }
13372                         goto normal_default;
13373                     } /* End of switch on '\' */
13374                     break;
13375                 case '{':
13376                     /* Currently we don't care if the lbrace is at the start
13377                      * of a construct.  This catches it in the middle of a
13378                      * literal string, or when it's the first thing after
13379                      * something like "\b" */
13380                     if (len || (p > RExC_start && isALPHA_A(*(p -1)))) {
13381                         RExC_parse = p + 1;
13382                         vFAIL("Unescaped left brace in regex is illegal here");
13383                     }
13384                     /*FALLTHROUGH*/
13385                 default:    /* A literal character */
13386                   normal_default:
13387                     if (! UTF8_IS_INVARIANT(*p) && UTF) {
13388                         STRLEN numlen;
13389                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
13390                                                &numlen, UTF8_ALLOW_DEFAULT);
13391                         p += numlen;
13392                     }
13393                     else
13394                         ender = (U8) *p++;
13395                     break;
13396                 } /* End of switch on the literal */
13397
13398                 /* Here, have looked at the literal character and <ender>
13399                  * contains its ordinal, <p> points to the character after it.
13400                  * We need to check if the next non-ignored thing is a
13401                  * quantifier.  Move <p> to after anything that should be
13402                  * ignored, which, as a side effect, positions <p> for the next
13403                  * loop iteration */
13404                 skip_to_be_ignored_text(pRExC_state, &p,
13405                                         FALSE /* Don't force to /x */ );
13406
13407                 /* If the next thing is a quantifier, it applies to this
13408                  * character only, which means that this character has to be in
13409                  * its own node and can't just be appended to the string in an
13410                  * existing node, so if there are already other characters in
13411                  * the node, close the node with just them, and set up to do
13412                  * this character again next time through, when it will be the
13413                  * only thing in its new node */
13414
13415                 if ((next_is_quantifier = (   LIKELY(p < RExC_end)
13416                                            && UNLIKELY(ISMULT2(p))))
13417                     && LIKELY(len))
13418                 {
13419                     p = oldp;
13420                     goto loopdone;
13421                 }
13422
13423                 /* Ready to add 'ender' to the node */
13424
13425                 if (! FOLD) {  /* The simple case, just append the literal */
13426
13427                     /* In the sizing pass, we need only the size of the
13428                      * character we are appending, hence we can delay getting
13429                      * its representation until PASS2. */
13430                     if (SIZE_ONLY) {
13431                         if (UTF) {
13432                             const STRLEN unilen = UVCHR_SKIP(ender);
13433                             s += unilen;
13434
13435                             /* We have to subtract 1 just below (and again in
13436                              * the corresponding PASS2 code) because the loop
13437                              * increments <len> each time, as all but this path
13438                              * (and one other) through it add a single byte to
13439                              * the EXACTish node.  But these paths would change
13440                              * len to be the correct final value, so cancel out
13441                              * the increment that follows */
13442                             len += unilen - 1;
13443                         }
13444                         else {
13445                             s++;
13446                         }
13447                     } else { /* PASS2 */
13448                       not_fold_common:
13449                         if (UTF) {
13450                             U8 * new_s = uvchr_to_utf8((U8*)s, ender);
13451                             len += (char *) new_s - s - 1;
13452                             s = (char *) new_s;
13453                         }
13454                         else {
13455                             *(s++) = (char) ender;
13456                         }
13457                     }
13458                 }
13459                 else if (LOC && is_PROBLEMATIC_LOCALE_FOLD_cp(ender)) {
13460
13461                     /* Here are folding under /l, and the code point is
13462                      * problematic.  First, we know we can't simplify things */
13463                     maybe_exact = FALSE;
13464                     maybe_exactfu = FALSE;
13465
13466                     /* A problematic code point in this context means that its
13467                      * fold isn't known until runtime, so we can't fold it now.
13468                      * (The non-problematic code points are the above-Latin1
13469                      * ones that fold to also all above-Latin1.  Their folds
13470                      * don't vary no matter what the locale is.) But here we
13471                      * have characters whose fold depends on the locale.
13472                      * Unlike the non-folding case above, we have to keep track
13473                      * of these in the sizing pass, so that we can make sure we
13474                      * don't split too-long nodes in the middle of a potential
13475                      * multi-char fold.  And unlike the regular fold case
13476                      * handled in the else clauses below, we don't actually
13477                      * fold and don't have special cases to consider.  What we
13478                      * do for both passes is the PASS2 code for non-folding */
13479                     goto not_fold_common;
13480                 }
13481                 else /* A regular FOLD code point */
13482                     if (! (   UTF
13483 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13484    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13485                                       || UNICODE_DOT_DOT_VERSION > 0)
13486                             /* See comments for join_exact() as to why we fold
13487                              * this non-UTF at compile time */
13488                             || (   node_type == EXACTFU
13489                                 && ender == LATIN_SMALL_LETTER_SHARP_S)
13490 #endif
13491                 )) {
13492                     /* Here, are folding and are not UTF-8 encoded; therefore
13493                      * the character must be in the range 0-255, and is not /l
13494                      * (Not /l because we already handled these under /l in
13495                      * is_PROBLEMATIC_LOCALE_FOLD_cp) */
13496                     if (IS_IN_SOME_FOLD_L1(ender)) {
13497                         maybe_exact = FALSE;
13498
13499                         /* See if the character's fold differs between /d and
13500                          * /u.  This includes the multi-char fold SHARP S to
13501                          * 'ss' */
13502                         if (UNLIKELY(ender == LATIN_SMALL_LETTER_SHARP_S)) {
13503                             RExC_seen_unfolded_sharp_s = 1;
13504                             maybe_exactfu = FALSE;
13505                         }
13506                         else if (maybe_exactfu
13507                             && (PL_fold[ender] != PL_fold_latin1[ender]
13508 #if    UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */   \
13509    || (UNICODE_MAJOR_VERSION == 3 && (   UNICODE_DOT_VERSION > 0)       \
13510                                       || UNICODE_DOT_DOT_VERSION > 0)
13511                                 || (   len > 0
13512                                     && isALPHA_FOLD_EQ(ender, 's')
13513                                     && isALPHA_FOLD_EQ(*(s-1), 's'))
13514 #endif
13515                         )) {
13516                             maybe_exactfu = FALSE;
13517                         }
13518                     }
13519
13520                     /* Even when folding, we store just the input character, as
13521                      * we have an array that finds its fold quickly */
13522                     *(s++) = (char) ender;
13523                 }
13524                 else {  /* FOLD, and UTF (or sharp s) */
13525                     /* Unlike the non-fold case, we do actually have to
13526                      * calculate the results here in pass 1.  This is for two
13527                      * reasons, the folded length may be longer than the
13528                      * unfolded, and we have to calculate how many EXACTish
13529                      * nodes it will take; and we may run out of room in a node
13530                      * in the middle of a potential multi-char fold, and have
13531                      * to back off accordingly.  */
13532
13533                     UV folded;
13534                     if (isASCII_uni(ender)) {
13535                         folded = toFOLD(ender);
13536                         *(s)++ = (U8) folded;
13537                     }
13538                     else {
13539                         STRLEN foldlen;
13540
13541                         folded = _to_uni_fold_flags(
13542                                      ender,
13543                                      (U8 *) s,
13544                                      &foldlen,
13545                                      FOLD_FLAGS_FULL | ((ASCII_FOLD_RESTRICTED)
13546                                                         ? FOLD_FLAGS_NOMIX_ASCII
13547                                                         : 0));
13548                         s += foldlen;
13549
13550                         /* The loop increments <len> each time, as all but this
13551                          * path (and one other) through it add a single byte to
13552                          * the EXACTish node.  But this one has changed len to
13553                          * be the correct final value, so subtract one to
13554                          * cancel out the increment that follows */
13555                         len += foldlen - 1;
13556                     }
13557                     /* If this node only contains non-folding code points so
13558                      * far, see if this new one is also non-folding */
13559                     if (maybe_exact) {
13560                         if (folded != ender) {
13561                             maybe_exact = FALSE;
13562                         }
13563                         else {
13564                             /* Here the fold is the original; we have to check
13565                              * further to see if anything folds to it */
13566                             if (_invlist_contains_cp(PL_utf8_foldable,
13567                                                         ender))
13568                             {
13569                                 maybe_exact = FALSE;
13570                             }
13571                         }
13572                     }
13573                     ender = folded;
13574                 }
13575
13576                 if (next_is_quantifier) {
13577
13578                     /* Here, the next input is a quantifier, and to get here,
13579                      * the current character is the only one in the node.
13580                      * Also, here <len> doesn't include the final byte for this
13581                      * character */
13582                     len++;
13583                     goto loopdone;
13584                 }
13585
13586             } /* End of loop through literal characters */
13587
13588             /* Here we have either exhausted the input or ran out of room in
13589              * the node.  (If we encountered a character that can't be in the
13590              * node, transfer is made directly to <loopdone>, and so we
13591              * wouldn't have fallen off the end of the loop.)  In the latter
13592              * case, we artificially have to split the node into two, because
13593              * we just don't have enough space to hold everything.  This
13594              * creates a problem if the final character participates in a
13595              * multi-character fold in the non-final position, as a match that
13596              * should have occurred won't, due to the way nodes are matched,
13597              * and our artificial boundary.  So back off until we find a non-
13598              * problematic character -- one that isn't at the beginning or
13599              * middle of such a fold.  (Either it doesn't participate in any
13600              * folds, or appears only in the final position of all the folds it
13601              * does participate in.)  A better solution with far fewer false
13602              * positives, and that would fill the nodes more completely, would
13603              * be to actually have available all the multi-character folds to
13604              * test against, and to back-off only far enough to be sure that
13605              * this node isn't ending with a partial one.  <upper_parse> is set
13606              * further below (if we need to reparse the node) to include just
13607              * up through that final non-problematic character that this code
13608              * identifies, so when it is set to less than the full node, we can
13609              * skip the rest of this */
13610             if (FOLD && p < RExC_end && upper_parse == MAX_NODE_STRING_SIZE) {
13611
13612                 const STRLEN full_len = len;
13613
13614                 assert(len >= MAX_NODE_STRING_SIZE);
13615
13616                 /* Here, <s> points to the final byte of the final character.
13617                  * Look backwards through the string until find a non-
13618                  * problematic character */
13619
13620                 if (! UTF) {
13621
13622                     /* This has no multi-char folds to non-UTF characters */
13623                     if (ASCII_FOLD_RESTRICTED) {
13624                         goto loopdone;
13625                     }
13626
13627                     while (--s >= s0 && IS_NON_FINAL_FOLD(*s)) { }
13628                     len = s - s0 + 1;
13629                 }
13630                 else {
13631                     if (!  PL_NonL1NonFinalFold) {
13632                         PL_NonL1NonFinalFold = _new_invlist_C_array(
13633                                         NonL1_Perl_Non_Final_Folds_invlist);
13634                     }
13635
13636                     /* Point to the first byte of the final character */
13637                     s = (char *) utf8_hop((U8 *) s, -1);
13638
13639                     while (s >= s0) {   /* Search backwards until find
13640                                            non-problematic char */
13641                         if (UTF8_IS_INVARIANT(*s)) {
13642
13643                             /* There are no ascii characters that participate
13644                              * in multi-char folds under /aa.  In EBCDIC, the
13645                              * non-ascii invariants are all control characters,
13646                              * so don't ever participate in any folds. */
13647                             if (ASCII_FOLD_RESTRICTED
13648                                 || ! IS_NON_FINAL_FOLD(*s))
13649                             {
13650                                 break;
13651                             }
13652                         }
13653                         else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
13654                             if (! IS_NON_FINAL_FOLD(EIGHT_BIT_UTF8_TO_NATIVE(
13655                                                                   *s, *(s+1))))
13656                             {
13657                                 break;
13658                             }
13659                         }
13660                         else if (! _invlist_contains_cp(
13661                                         PL_NonL1NonFinalFold,
13662                                         valid_utf8_to_uvchr((U8 *) s, NULL)))
13663                         {
13664                             break;
13665                         }
13666
13667                         /* Here, the current character is problematic in that
13668                          * it does occur in the non-final position of some
13669                          * fold, so try the character before it, but have to
13670                          * special case the very first byte in the string, so
13671                          * we don't read outside the string */
13672                         s = (s == s0) ? s -1 : (char *) utf8_hop((U8 *) s, -1);
13673                     } /* End of loop backwards through the string */
13674
13675                     /* If there were only problematic characters in the string,
13676                      * <s> will point to before s0, in which case the length
13677                      * should be 0, otherwise include the length of the
13678                      * non-problematic character just found */
13679                     len = (s < s0) ? 0 : s - s0 + UTF8SKIP(s);
13680                 }
13681
13682                 /* Here, have found the final character, if any, that is
13683                  * non-problematic as far as ending the node without splitting
13684                  * it across a potential multi-char fold.  <len> contains the
13685                  * number of bytes in the node up-to and including that
13686                  * character, or is 0 if there is no such character, meaning
13687                  * the whole node contains only problematic characters.  In
13688                  * this case, give up and just take the node as-is.  We can't
13689                  * do any better */
13690                 if (len == 0) {
13691                     len = full_len;
13692
13693                     /* If the node ends in an 's' we make sure it stays EXACTF,
13694                      * as if it turns into an EXACTFU, it could later get
13695                      * joined with another 's' that would then wrongly match
13696                      * the sharp s */
13697                     if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's'))
13698                     {
13699                         maybe_exactfu = FALSE;
13700                     }
13701                 } else {
13702
13703                     /* Here, the node does contain some characters that aren't
13704                      * problematic.  If one such is the final character in the
13705                      * node, we are done */
13706                     if (len == full_len) {
13707                         goto loopdone;
13708                     }
13709                     else if (len + ((UTF) ? UTF8SKIP(s) : 1) == full_len) {
13710
13711                         /* If the final character is problematic, but the
13712                          * penultimate is not, back-off that last character to
13713                          * later start a new node with it */
13714                         p = oldp;
13715                         goto loopdone;
13716                     }
13717
13718                     /* Here, the final non-problematic character is earlier
13719                      * in the input than the penultimate character.  What we do
13720                      * is reparse from the beginning, going up only as far as
13721                      * this final ok one, thus guaranteeing that the node ends
13722                      * in an acceptable character.  The reason we reparse is
13723                      * that we know how far in the character is, but we don't
13724                      * know how to correlate its position with the input parse.
13725                      * An alternate implementation would be to build that
13726                      * correlation as we go along during the original parse,
13727                      * but that would entail extra work for every node, whereas
13728                      * this code gets executed only when the string is too
13729                      * large for the node, and the final two characters are
13730                      * problematic, an infrequent occurrence.  Yet another
13731                      * possible strategy would be to save the tail of the
13732                      * string, and the next time regatom is called, initialize
13733                      * with that.  The problem with this is that unless you
13734                      * back off one more character, you won't be guaranteed
13735                      * regatom will get called again, unless regbranch,
13736                      * regpiece ... are also changed.  If you do back off that
13737                      * extra character, so that there is input guaranteed to
13738                      * force calling regatom, you can't handle the case where
13739                      * just the first character in the node is acceptable.  I
13740                      * (khw) decided to try this method which doesn't have that
13741                      * pitfall; if performance issues are found, we can do a
13742                      * combination of the current approach plus that one */
13743                     upper_parse = len;
13744                     len = 0;
13745                     s = s0;
13746                     goto reparse;
13747                 }
13748             }   /* End of verifying node ends with an appropriate char */
13749
13750           loopdone:   /* Jumped to when encounters something that shouldn't be
13751                          in the node */
13752
13753             /* I (khw) don't know if you can get here with zero length, but the
13754              * old code handled this situation by creating a zero-length EXACT
13755              * node.  Might as well be NOTHING instead */
13756             if (len == 0) {
13757                 OP(ret) = NOTHING;
13758             }
13759             else {
13760                 if (FOLD) {
13761                     /* If 'maybe_exact' is still set here, means there are no
13762                      * code points in the node that participate in folds;
13763                      * similarly for 'maybe_exactfu' and code points that match
13764                      * differently depending on UTF8ness of the target string
13765                      * (for /u), or depending on locale for /l */
13766                     if (maybe_exact) {
13767                         OP(ret) = (LOC)
13768                                   ? EXACTL
13769                                   : EXACT;
13770                     }
13771                     else if (maybe_exactfu) {
13772                         OP(ret) = (LOC)
13773                                   ? EXACTFLU8
13774                                   : EXACTFU;
13775                     }
13776                 }
13777                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, len, ender,
13778                                            FALSE /* Don't look to see if could
13779                                                     be turned into an EXACT
13780                                                     node, as we have already
13781                                                     computed that */
13782                                           );
13783             }
13784
13785             RExC_parse = p - 1;
13786             Set_Node_Cur_Length(ret, parse_start);
13787             RExC_parse = p;
13788             {
13789                 /* len is STRLEN which is unsigned, need to copy to signed */
13790                 IV iv = len;
13791                 if (iv < 0)
13792                     vFAIL("Internal disaster");
13793             }
13794
13795         } /* End of label 'defchar:' */
13796         break;
13797     } /* End of giant switch on input character */
13798
13799     /* Position parse to next real character */
13800     skip_to_be_ignored_text(pRExC_state, &RExC_parse,
13801                                             FALSE /* Don't force to /x */ );
13802     if (PASS2 && *RExC_parse == '{' && OP(ret) != SBOL && ! regcurly(RExC_parse)) {
13803         ckWARNregdep(RExC_parse + 1, "Unescaped left brace in regex is deprecated here, passed through");
13804     }
13805
13806     return(ret);
13807 }
13808
13809
13810 STATIC void
13811 S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr)
13812 {
13813     /* Uses the inversion list '*invlist_ptr' to populate the ANYOF 'node'.  It
13814      * sets up the bitmap and any flags, removing those code points from the
13815      * inversion list, setting it to NULL should it become completely empty */
13816
13817     PERL_ARGS_ASSERT_POPULATE_ANYOF_FROM_INVLIST;
13818     assert(PL_regkind[OP(node)] == ANYOF);
13819
13820     ANYOF_BITMAP_ZERO(node);
13821     if (*invlist_ptr) {
13822
13823         /* This gets set if we actually need to modify things */
13824         bool change_invlist = FALSE;
13825
13826         UV start, end;
13827
13828         /* Start looking through *invlist_ptr */
13829         invlist_iterinit(*invlist_ptr);
13830         while (invlist_iternext(*invlist_ptr, &start, &end)) {
13831             UV high;
13832             int i;
13833
13834             if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) {
13835                 ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP;
13836             }
13837
13838             /* Quit if are above what we should change */
13839             if (start >= NUM_ANYOF_CODE_POINTS) {
13840                 break;
13841             }
13842
13843             change_invlist = TRUE;
13844
13845             /* Set all the bits in the range, up to the max that we are doing */
13846             high = (end < NUM_ANYOF_CODE_POINTS - 1)
13847                    ? end
13848                    : NUM_ANYOF_CODE_POINTS - 1;
13849             for (i = start; i <= (int) high; i++) {
13850                 if (! ANYOF_BITMAP_TEST(node, i)) {
13851                     ANYOF_BITMAP_SET(node, i);
13852                 }
13853             }
13854         }
13855         invlist_iterfinish(*invlist_ptr);
13856
13857         /* Done with loop; remove any code points that are in the bitmap from
13858          * *invlist_ptr; similarly for code points above the bitmap if we have
13859          * a flag to match all of them anyways */
13860         if (change_invlist) {
13861             _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr);
13862         }
13863         if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
13864             _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr);
13865         }
13866
13867         /* If have completely emptied it, remove it completely */
13868         if (_invlist_len(*invlist_ptr) == 0) {
13869             SvREFCNT_dec_NN(*invlist_ptr);
13870             *invlist_ptr = NULL;
13871         }
13872     }
13873 }
13874
13875 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
13876    Character classes ([:foo:]) can also be negated ([:^foo:]).
13877    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
13878    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
13879    but trigger failures because they are currently unimplemented. */
13880
13881 #define POSIXCC_DONE(c)   ((c) == ':')
13882 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
13883 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
13884 #define MAYBE_POSIXCC(c) (POSIXCC(c) || (c) == '^' || (c) == ';')
13885
13886 #define WARNING_PREFIX              "Assuming NOT a POSIX class since "
13887 #define NO_BLANKS_POSIX_WARNING     "no blanks are allowed in one"
13888 #define SEMI_COLON_POSIX_WARNING    "a semi-colon was found instead of a colon"
13889
13890 #define NOT_MEANT_TO_BE_A_POSIX_CLASS (OOB_NAMEDCLASS - 1)
13891
13892 /* 'posix_warnings' and 'warn_text' are names of variables in the following
13893  * routine. q.v. */
13894 #define ADD_POSIX_WARNING(p, text)  STMT_START {                            \
13895         if (posix_warnings) {                                               \
13896             if (! RExC_warn_text ) RExC_warn_text = (AV *) sv_2mortal((SV *) newAV()); \
13897             av_push(RExC_warn_text, Perl_newSVpvf(aTHX_                          \
13898                                              WARNING_PREFIX                 \
13899                                              text                           \
13900                                              REPORT_LOCATION,               \
13901                                              REPORT_LOCATION_ARGS(p)));     \
13902         }                                                                   \
13903     } STMT_END
13904
13905 STATIC int
13906 S_handle_possible_posix(pTHX_ RExC_state_t *pRExC_state,
13907
13908     const char * const s,      /* Where the putative posix class begins.
13909                                   Normally, this is one past the '['.  This
13910                                   parameter exists so it can be somewhere
13911                                   besides RExC_parse. */
13912     char ** updated_parse_ptr, /* Where to set the updated parse pointer, or
13913                                   NULL */
13914     AV ** posix_warnings,      /* Where to place any generated warnings, or
13915                                   NULL */
13916     const bool check_only      /* Don't die if error */
13917 )
13918 {
13919     /* This parses what the caller thinks may be one of the three POSIX
13920      * constructs:
13921      *  1) a character class, like [:blank:]
13922      *  2) a collating symbol, like [. .]
13923      *  3) an equivalence class, like [= =]
13924      * In the latter two cases, it croaks if it finds a syntactically legal
13925      * one, as these are not handled by Perl.
13926      *
13927      * The main purpose is to look for a POSIX character class.  It returns:
13928      *  a) the class number
13929      *      if it is a completely syntactically and semantically legal class.
13930      *      'updated_parse_ptr', if not NULL, is set to point to just after the
13931      *      closing ']' of the class
13932      *  b) OOB_NAMEDCLASS
13933      *      if it appears that one of the three POSIX constructs was meant, but
13934      *      its specification was somehow defective.  'updated_parse_ptr', if
13935      *      not NULL, is set to point to the character just after the end
13936      *      character of the class.  See below for handling of warnings.
13937      *  c) NOT_MEANT_TO_BE_A_POSIX_CLASS
13938      *      if it  doesn't appear that a POSIX construct was intended.
13939      *      'updated_parse_ptr' is not changed.  No warnings nor errors are
13940      *      raised.
13941      *
13942      * In b) there may be errors or warnings generated.  If 'check_only' is
13943      * TRUE, then any errors are discarded.  Warnings are returned to the
13944      * caller via an AV* created into '*posix_warnings' if it is not NULL.  If
13945      * instead it is NULL, warnings are suppressed.  This is done in all
13946      * passes.  The reason for this is that the rest of the parsing is heavily
13947      * dependent on whether this routine found a valid posix class or not.  If
13948      * it did, the closing ']' is absorbed as part of the class.  If no class,
13949      * or an invalid one is found, any ']' will be considered the terminator of
13950      * the outer bracketed character class, leading to very different results.
13951      * In particular, a '(?[ ])' construct will likely have a syntax error if
13952      * the class is parsed other than intended, and this will happen in pass1,
13953      * before the warnings would normally be output.  This mechanism allows the
13954      * caller to output those warnings in pass1 just before dieing, giving a
13955      * much better clue as to what is wrong.
13956      *
13957      * The reason for this function, and its complexity is that a bracketed
13958      * character class can contain just about anything.  But it's easy to
13959      * mistype the very specific posix class syntax but yielding a valid
13960      * regular bracketed class, so it silently gets compiled into something
13961      * quite unintended.
13962      *
13963      * The solution adopted here maintains backward compatibility except that
13964      * it adds a warning if it looks like a posix class was intended but
13965      * improperly specified.  The warning is not raised unless what is input
13966      * very closely resembles one of the 14 legal posix classes.  To do this,
13967      * it uses fuzzy parsing.  It calculates how many single-character edits it
13968      * would take to transform what was input into a legal posix class.  Only
13969      * if that number is quite small does it think that the intention was a
13970      * posix class.  Obviously these are heuristics, and there will be cases
13971      * where it errs on one side or another, and they can be tweaked as
13972      * experience informs.
13973      *
13974      * The syntax for a legal posix class is:
13975      *
13976      * qr/(?xa: \[ : \^? [:lower:]{4,6} : \] )/
13977      *
13978      * What this routine considers syntactically to be an intended posix class
13979      * is this (the comments indicate some restrictions that the pattern
13980      * doesn't show):
13981      *
13982      *  qr/(?x: \[?                         # The left bracket, possibly
13983      *                                      # omitted
13984      *          \h*                         # possibly followed by blanks
13985      *          (?: \^ \h* )?               # possibly a misplaced caret
13986      *          [:;]?                       # The opening class character,
13987      *                                      # possibly omitted.  A typo
13988      *                                      # semi-colon can also be used.
13989      *          \h*
13990      *          \^?                         # possibly a correctly placed
13991      *                                      # caret, but not if there was also
13992      *                                      # a misplaced one
13993      *          \h*
13994      *          .{3,15}                     # The class name.  If there are
13995      *                                      # deviations from the legal syntax,
13996      *                                      # its edit distance must be close
13997      *                                      # to a real class name in order
13998      *                                      # for it to be considered to be
13999      *                                      # an intended posix class.
14000      *          \h*
14001      *          [:punct:]?                  # The closing class character,
14002      *                                      # possibly omitted.  If not a colon
14003      *                                      # nor semi colon, the class name
14004      *                                      # must be even closer to a valid
14005      *                                      # one
14006      *          \h*
14007      *          \]?                         # The right bracket, possibly
14008      *                                      # omitted.
14009      *     )/
14010      *
14011      * In the above, \h must be ASCII-only.
14012      *
14013      * These are heuristics, and can be tweaked as field experience dictates.
14014      * There will be cases when someone didn't intend to specify a posix class
14015      * that this warns as being so.  The goal is to minimize these, while
14016      * maximizing the catching of things intended to be a posix class that
14017      * aren't parsed as such.
14018      */
14019
14020     const char* p             = s;
14021     const char * const e      = RExC_end;
14022     unsigned complement       = 0;      /* If to complement the class */
14023     bool found_problem        = FALSE;  /* Assume OK until proven otherwise */
14024     bool has_opening_bracket  = FALSE;
14025     bool has_opening_colon    = FALSE;
14026     int class_number          = OOB_NAMEDCLASS; /* Out-of-bounds until find
14027                                                    valid class */
14028     const char * possible_end = NULL;   /* used for a 2nd parse pass */
14029     const char* name_start;             /* ptr to class name first char */
14030
14031     /* If the number of single-character typos the input name is away from a
14032      * legal name is no more than this number, it is considered to have meant
14033      * the legal name */
14034     int max_distance          = 2;
14035
14036     /* to store the name.  The size determines the maximum length before we
14037      * decide that no posix class was intended.  Should be at least
14038      * sizeof("alphanumeric") */
14039     UV input_text[15];
14040
14041     PERL_ARGS_ASSERT_HANDLE_POSSIBLE_POSIX;
14042
14043     if (posix_warnings && RExC_warn_text)
14044         av_clear(RExC_warn_text);
14045
14046     if (p >= e) {
14047         return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14048     }
14049
14050     if (*(p - 1) != '[') {
14051         ADD_POSIX_WARNING(p, "it doesn't start with a '['");
14052         found_problem = TRUE;
14053     }
14054     else {
14055         has_opening_bracket = TRUE;
14056     }
14057
14058     /* They could be confused and think you can put spaces between the
14059      * components */
14060     if (isBLANK(*p)) {
14061         found_problem = TRUE;
14062
14063         do {
14064             p++;
14065         } while (p < e && isBLANK(*p));
14066
14067         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14068     }
14069
14070     /* For [. .] and [= =].  These are quite different internally from [: :],
14071      * so they are handled separately.  */
14072     if (POSIXCC_NOTYET(*p) && p < e - 3) /* 1 for the close, and 1 for the ']'
14073                                             and 1 for at least one char in it
14074                                           */
14075     {
14076         const char open_char  = *p;
14077         const char * temp_ptr = p + 1;
14078
14079         /* These two constructs are not handled by perl, and if we find a
14080          * syntactically valid one, we croak.  khw, who wrote this code, finds
14081          * this explanation of them very unclear:
14082          * http://pubs.opengroup.org/onlinepubs/009696899/basedefs/xbd_chap09.html
14083          * And searching the rest of the internet wasn't very helpful either.
14084          * It looks like just about any byte can be in these constructs,
14085          * depending on the locale.  But unless the pattern is being compiled
14086          * under /l, which is very rare, Perl runs under the C or POSIX locale.
14087          * In that case, it looks like [= =] isn't allowed at all, and that
14088          * [. .] could be any single code point, but for longer strings the
14089          * constituent characters would have to be the ASCII alphabetics plus
14090          * the minus-hyphen.  Any sensible locale definition would limit itself
14091          * to these.  And any portable one definitely should.  Trying to parse
14092          * the general case is a nightmare (see [perl #127604]).  So, this code
14093          * looks only for interiors of these constructs that match:
14094          *      qr/.|[-\w]{2,}/
14095          * Using \w relaxes the apparent rules a little, without adding much
14096          * danger of mistaking something else for one of these constructs.
14097          *
14098          * [. .] in some implementations described on the internet is usable to
14099          * escape a character that otherwise is special in bracketed character
14100          * classes.  For example [.].] means a literal right bracket instead of
14101          * the ending of the class
14102          *
14103          * [= =] can legitimately contain a [. .] construct, but we don't
14104          * handle this case, as that [. .] construct will later get parsed
14105          * itself and croak then.  And [= =] is checked for even when not under
14106          * /l, as Perl has long done so.
14107          *
14108          * The code below relies on there being a trailing NUL, so it doesn't
14109          * have to keep checking if the parse ptr < e.
14110          */
14111         if (temp_ptr[1] == open_char) {
14112             temp_ptr++;
14113         }
14114         else while (    temp_ptr < e
14115                     && (isWORDCHAR(*temp_ptr) || *temp_ptr == '-'))
14116         {
14117             temp_ptr++;
14118         }
14119
14120         if (*temp_ptr == open_char) {
14121             temp_ptr++;
14122             if (*temp_ptr == ']') {
14123                 temp_ptr++;
14124                 if (! found_problem && ! check_only) {
14125                     RExC_parse = (char *) temp_ptr;
14126                     vFAIL3("POSIX syntax [%c %c] is reserved for future "
14127                             "extensions", open_char, open_char);
14128                 }
14129
14130                 /* Here, the syntax wasn't completely valid, or else the call
14131                  * is to check-only */
14132                 if (updated_parse_ptr) {
14133                     *updated_parse_ptr = (char *) temp_ptr;
14134                 }
14135
14136                 return OOB_NAMEDCLASS;
14137             }
14138         }
14139
14140         /* If we find something that started out to look like one of these
14141          * constructs, but isn't, we continue below so that it can be checked
14142          * for being a class name with a typo of '.' or '=' instead of a colon.
14143          * */
14144     }
14145
14146     /* Here, we think there is a possibility that a [: :] class was meant, and
14147      * we have the first real character.  It could be they think the '^' comes
14148      * first */
14149     if (*p == '^') {
14150         found_problem = TRUE;
14151         ADD_POSIX_WARNING(p + 1, "the '^' must come after the colon");
14152         complement = 1;
14153         p++;
14154
14155         if (isBLANK(*p)) {
14156             found_problem = TRUE;
14157
14158             do {
14159                 p++;
14160             } while (p < e && isBLANK(*p));
14161
14162             ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14163         }
14164     }
14165
14166     /* But the first character should be a colon, which they could have easily
14167      * mistyped on a qwerty keyboard as a semi-colon (and which may be hard to
14168      * distinguish from a colon, so treat that as a colon).  */
14169     if (*p == ':') {
14170         p++;
14171         has_opening_colon = TRUE;
14172     }
14173     else if (*p == ';') {
14174         found_problem = TRUE;
14175         p++;
14176         ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14177         has_opening_colon = TRUE;
14178     }
14179     else {
14180         found_problem = TRUE;
14181         ADD_POSIX_WARNING(p, "there must be a starting ':'");
14182
14183         /* Consider an initial punctuation (not one of the recognized ones) to
14184          * be a left terminator */
14185         if (*p != '^' && *p != ']' && isPUNCT(*p)) {
14186             p++;
14187         }
14188     }
14189
14190     /* They may think that you can put spaces between the components */
14191     if (isBLANK(*p)) {
14192         found_problem = TRUE;
14193
14194         do {
14195             p++;
14196         } while (p < e && isBLANK(*p));
14197
14198         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14199     }
14200
14201     if (*p == '^') {
14202
14203         /* We consider something like [^:^alnum:]] to not have been intended to
14204          * be a posix class, but XXX maybe we should */
14205         if (complement) {
14206             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14207         }
14208
14209         complement = 1;
14210         p++;
14211     }
14212
14213     /* Again, they may think that you can put spaces between the components */
14214     if (isBLANK(*p)) {
14215         found_problem = TRUE;
14216
14217         do {
14218             p++;
14219         } while (p < e && isBLANK(*p));
14220
14221         ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14222     }
14223
14224     if (*p == ']') {
14225
14226         /* XXX This ']' may be a typo, and something else was meant.  But
14227          * treating it as such creates enough complications, that that
14228          * possibility isn't currently considered here.  So we assume that the
14229          * ']' is what is intended, and if we've already found an initial '[',
14230          * this leaves this construct looking like [:] or [:^], which almost
14231          * certainly weren't intended to be posix classes */
14232         if (has_opening_bracket) {
14233             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14234         }
14235
14236         /* But this function can be called when we parse the colon for
14237          * something like qr/[alpha:]]/, so we back up to look for the
14238          * beginning */
14239         p--;
14240
14241         if (*p == ';') {
14242             found_problem = TRUE;
14243             ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14244         }
14245         else if (*p != ':') {
14246
14247             /* XXX We are currently very restrictive here, so this code doesn't
14248              * consider the possibility that, say, /[alpha.]]/ was intended to
14249              * be a posix class. */
14250             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14251         }
14252
14253         /* Here we have something like 'foo:]'.  There was no initial colon,
14254          * and we back up over 'foo.  XXX Unlike the going forward case, we
14255          * don't handle typos of non-word chars in the middle */
14256         has_opening_colon = FALSE;
14257         p--;
14258
14259         while (p > RExC_start && isWORDCHAR(*p)) {
14260             p--;
14261         }
14262         p++;
14263
14264         /* Here, we have positioned ourselves to where we think the first
14265          * character in the potential class is */
14266     }
14267
14268     /* Now the interior really starts.  There are certain key characters that
14269      * can end the interior, or these could just be typos.  To catch both
14270      * cases, we may have to do two passes.  In the first pass, we keep on
14271      * going unless we come to a sequence that matches
14272      *      qr/ [[:punct:]] [[:blank:]]* \] /xa
14273      * This means it takes a sequence to end the pass, so two typos in a row if
14274      * that wasn't what was intended.  If the class is perfectly formed, just
14275      * this one pass is needed.  We also stop if there are too many characters
14276      * being accumulated, but this number is deliberately set higher than any
14277      * real class.  It is set high enough so that someone who thinks that
14278      * 'alphanumeric' is a correct name would get warned that it wasn't.
14279      * While doing the pass, we keep track of where the key characters were in
14280      * it.  If we don't find an end to the class, and one of the key characters
14281      * was found, we redo the pass, but stop when we get to that character.
14282      * Thus the key character was considered a typo in the first pass, but a
14283      * terminator in the second.  If two key characters are found, we stop at
14284      * the second one in the first pass.  Again this can miss two typos, but
14285      * catches a single one
14286      *
14287      * In the first pass, 'possible_end' starts as NULL, and then gets set to
14288      * point to the first key character.  For the second pass, it starts as -1.
14289      * */
14290
14291     name_start = p;
14292   parse_name:
14293     {
14294         bool has_blank               = FALSE;
14295         bool has_upper               = FALSE;
14296         bool has_terminating_colon   = FALSE;
14297         bool has_terminating_bracket = FALSE;
14298         bool has_semi_colon          = FALSE;
14299         unsigned int name_len        = 0;
14300         int punct_count              = 0;
14301
14302         while (p < e) {
14303
14304             /* Squeeze out blanks when looking up the class name below */
14305             if (isBLANK(*p) ) {
14306                 has_blank = TRUE;
14307                 found_problem = TRUE;
14308                 p++;
14309                 continue;
14310             }
14311
14312             /* The name will end with a punctuation */
14313             if (isPUNCT(*p)) {
14314                 const char * peek = p + 1;
14315
14316                 /* Treat any non-']' punctuation followed by a ']' (possibly
14317                  * with intervening blanks) as trying to terminate the class.
14318                  * ']]' is very likely to mean a class was intended (but
14319                  * missing the colon), but the warning message that gets
14320                  * generated shows the error position better if we exit the
14321                  * loop at the bottom (eventually), so skip it here. */
14322                 if (*p != ']') {
14323                     if (peek < e && isBLANK(*peek)) {
14324                         has_blank = TRUE;
14325                         found_problem = TRUE;
14326                         do {
14327                             peek++;
14328                         } while (peek < e && isBLANK(*peek));
14329                     }
14330
14331                     if (peek < e && *peek == ']') {
14332                         has_terminating_bracket = TRUE;
14333                         if (*p == ':') {
14334                             has_terminating_colon = TRUE;
14335                         }
14336                         else if (*p == ';') {
14337                             has_semi_colon = TRUE;
14338                             has_terminating_colon = TRUE;
14339                         }
14340                         else {
14341                             found_problem = TRUE;
14342                         }
14343                         p = peek + 1;
14344                         goto try_posix;
14345                     }
14346                 }
14347
14348                 /* Here we have punctuation we thought didn't end the class.
14349                  * Keep track of the position of the key characters that are
14350                  * more likely to have been class-enders */
14351                 if (*p == ']' || *p == '[' || *p == ':' || *p == ';') {
14352
14353                     /* Allow just one such possible class-ender not actually
14354                      * ending the class. */
14355                     if (possible_end) {
14356                         break;
14357                     }
14358                     possible_end = p;
14359                 }
14360
14361                 /* If we have too many punctuation characters, no use in
14362                  * keeping going */
14363                 if (++punct_count > max_distance) {
14364                     break;
14365                 }
14366
14367                 /* Treat the punctuation as a typo. */
14368                 input_text[name_len++] = *p;
14369                 p++;
14370             }
14371             else if (isUPPER(*p)) { /* Use lowercase for lookup */
14372                 input_text[name_len++] = toLOWER(*p);
14373                 has_upper = TRUE;
14374                 found_problem = TRUE;
14375                 p++;
14376             } else if (! UTF || UTF8_IS_INVARIANT(*p)) {
14377                 input_text[name_len++] = *p;
14378                 p++;
14379             }
14380             else {
14381                 input_text[name_len++] = utf8_to_uvchr_buf((U8 *) p, e, NULL);
14382                 p+= UTF8SKIP(p);
14383             }
14384
14385             /* The declaration of 'input_text' is how long we allow a potential
14386              * class name to be, before saying they didn't mean a class name at
14387              * all */
14388             if (name_len >= C_ARRAY_LENGTH(input_text)) {
14389                 break;
14390             }
14391         }
14392
14393         /* We get to here when the possible class name hasn't been properly
14394          * terminated before:
14395          *   1) we ran off the end of the pattern; or
14396          *   2) found two characters, each of which might have been intended to
14397          *      be the name's terminator
14398          *   3) found so many punctuation characters in the purported name,
14399          *      that the edit distance to a valid one is exceeded
14400          *   4) we decided it was more characters than anyone could have
14401          *      intended to be one. */
14402
14403         found_problem = TRUE;
14404
14405         /* In the final two cases, we know that looking up what we've
14406          * accumulated won't lead to a match, even a fuzzy one. */
14407         if (   name_len >= C_ARRAY_LENGTH(input_text)
14408             || punct_count > max_distance)
14409         {
14410             /* If there was an intermediate key character that could have been
14411              * an intended end, redo the parse, but stop there */
14412             if (possible_end && possible_end != (char *) -1) {
14413                 possible_end = (char *) -1; /* Special signal value to say
14414                                                we've done a first pass */
14415                 p = name_start;
14416                 goto parse_name;
14417             }
14418
14419             /* Otherwise, it can't have meant to have been a class */
14420             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14421         }
14422
14423         /* If we ran off the end, and the final character was a punctuation
14424          * one, back up one, to look at that final one just below.  Later, we
14425          * will restore the parse pointer if appropriate */
14426         if (name_len && p == e && isPUNCT(*(p-1))) {
14427             p--;
14428             name_len--;
14429         }
14430
14431         if (p < e && isPUNCT(*p)) {
14432             if (*p == ']') {
14433                 has_terminating_bracket = TRUE;
14434
14435                 /* If this is a 2nd ']', and the first one is just below this
14436                  * one, consider that to be the real terminator.  This gives a
14437                  * uniform and better positioning for the warning message  */
14438                 if (   possible_end
14439                     && possible_end != (char *) -1
14440                     && *possible_end == ']'
14441                     && name_len && input_text[name_len - 1] == ']')
14442                 {
14443                     name_len--;
14444                     p = possible_end;
14445
14446                     /* And this is actually equivalent to having done the 2nd
14447                      * pass now, so set it to not try again */
14448                     possible_end = (char *) -1;
14449                 }
14450             }
14451             else {
14452                 if (*p == ':') {
14453                     has_terminating_colon = TRUE;
14454                 }
14455                 else if (*p == ';') {
14456                     has_semi_colon = TRUE;
14457                     has_terminating_colon = TRUE;
14458                 }
14459                 p++;
14460             }
14461         }
14462
14463     try_posix:
14464
14465         /* Here, we have a class name to look up.  We can short circuit the
14466          * stuff below for short names that can't possibly be meant to be a
14467          * class name.  (We can do this on the first pass, as any second pass
14468          * will yield an even shorter name) */
14469         if (name_len < 3) {
14470             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14471         }
14472
14473         /* Find which class it is.  Initially switch on the length of the name.
14474          * */
14475         switch (name_len) {
14476             case 4:
14477                 if (memEQ(name_start, "word", 4)) {
14478                     /* this is not POSIX, this is the Perl \w */
14479                     class_number = ANYOF_WORDCHAR;
14480                 }
14481                 break;
14482             case 5:
14483                 /* Names all of length 5: alnum alpha ascii blank cntrl digit
14484                  *                        graph lower print punct space upper
14485                  * Offset 4 gives the best switch position.  */
14486                 switch (name_start[4]) {
14487                     case 'a':
14488                         if (memEQ(name_start, "alph", 4)) /* alpha */
14489                             class_number = ANYOF_ALPHA;
14490                         break;
14491                     case 'e':
14492                         if (memEQ(name_start, "spac", 4)) /* space */
14493                             class_number = ANYOF_SPACE;
14494                         break;
14495                     case 'h':
14496                         if (memEQ(name_start, "grap", 4)) /* graph */
14497                             class_number = ANYOF_GRAPH;
14498                         break;
14499                     case 'i':
14500                         if (memEQ(name_start, "asci", 4)) /* ascii */
14501                             class_number = ANYOF_ASCII;
14502                         break;
14503                     case 'k':
14504                         if (memEQ(name_start, "blan", 4)) /* blank */
14505                             class_number = ANYOF_BLANK;
14506                         break;
14507                     case 'l':
14508                         if (memEQ(name_start, "cntr", 4)) /* cntrl */
14509                             class_number = ANYOF_CNTRL;
14510                         break;
14511                     case 'm':
14512                         if (memEQ(name_start, "alnu", 4)) /* alnum */
14513                             class_number = ANYOF_ALPHANUMERIC;
14514                         break;
14515                     case 'r':
14516                         if (memEQ(name_start, "lowe", 4)) /* lower */
14517                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_LOWER;
14518                         else if (memEQ(name_start, "uppe", 4)) /* upper */
14519                             class_number = (FOLD) ? ANYOF_CASED : ANYOF_UPPER;
14520                         break;
14521                     case 't':
14522                         if (memEQ(name_start, "digi", 4)) /* digit */
14523                             class_number = ANYOF_DIGIT;
14524                         else if (memEQ(name_start, "prin", 4)) /* print */
14525                             class_number = ANYOF_PRINT;
14526                         else if (memEQ(name_start, "punc", 4)) /* punct */
14527                             class_number = ANYOF_PUNCT;
14528                         break;
14529                 }
14530                 break;
14531             case 6:
14532                 if (memEQ(name_start, "xdigit", 6))
14533                     class_number = ANYOF_XDIGIT;
14534                 break;
14535         }
14536
14537         /* If the name exactly matches a posix class name the class number will
14538          * here be set to it, and the input almost certainly was meant to be a
14539          * posix class, so we can skip further checking.  If instead the syntax
14540          * is exactly correct, but the name isn't one of the legal ones, we
14541          * will return that as an error below.  But if neither of these apply,
14542          * it could be that no posix class was intended at all, or that one
14543          * was, but there was a typo.  We tease these apart by doing fuzzy
14544          * matching on the name */
14545         if (class_number == OOB_NAMEDCLASS && found_problem) {
14546             const UV posix_names[][6] = {
14547                                                 { 'a', 'l', 'n', 'u', 'm' },
14548                                                 { 'a', 'l', 'p', 'h', 'a' },
14549                                                 { 'a', 's', 'c', 'i', 'i' },
14550                                                 { 'b', 'l', 'a', 'n', 'k' },
14551                                                 { 'c', 'n', 't', 'r', 'l' },
14552                                                 { 'd', 'i', 'g', 'i', 't' },
14553                                                 { 'g', 'r', 'a', 'p', 'h' },
14554                                                 { 'l', 'o', 'w', 'e', 'r' },
14555                                                 { 'p', 'r', 'i', 'n', 't' },
14556                                                 { 'p', 'u', 'n', 'c', 't' },
14557                                                 { 's', 'p', 'a', 'c', 'e' },
14558                                                 { 'u', 'p', 'p', 'e', 'r' },
14559                                                 { 'w', 'o', 'r', 'd' },
14560                                                 { 'x', 'd', 'i', 'g', 'i', 't' }
14561                                             };
14562             /* The names of the above all have added NULs to make them the same
14563              * size, so we need to also have the real lengths */
14564             const UV posix_name_lengths[] = {
14565                                                 sizeof("alnum") - 1,
14566                                                 sizeof("alpha") - 1,
14567                                                 sizeof("ascii") - 1,
14568                                                 sizeof("blank") - 1,
14569                                                 sizeof("cntrl") - 1,
14570                                                 sizeof("digit") - 1,
14571                                                 sizeof("graph") - 1,
14572                                                 sizeof("lower") - 1,
14573                                                 sizeof("print") - 1,
14574                                                 sizeof("punct") - 1,
14575                                                 sizeof("space") - 1,
14576                                                 sizeof("upper") - 1,
14577                                                 sizeof("word")  - 1,
14578                                                 sizeof("xdigit")- 1
14579                                             };
14580             unsigned int i;
14581             int temp_max = max_distance;    /* Use a temporary, so if we
14582                                                reparse, we haven't changed the
14583                                                outer one */
14584
14585             /* Use a smaller max edit distance if we are missing one of the
14586              * delimiters */
14587             if (   has_opening_bracket + has_opening_colon < 2
14588                 || has_terminating_bracket + has_terminating_colon < 2)
14589             {
14590                 temp_max--;
14591             }
14592
14593             /* See if the input name is close to a legal one */
14594             for (i = 0; i < C_ARRAY_LENGTH(posix_names); i++) {
14595
14596                 /* Short circuit call if the lengths are too far apart to be
14597                  * able to match */
14598                 if (abs( (int) (name_len - posix_name_lengths[i]))
14599                     > temp_max)
14600                 {
14601                     continue;
14602                 }
14603
14604                 if (edit_distance(input_text,
14605                                   posix_names[i],
14606                                   name_len,
14607                                   posix_name_lengths[i],
14608                                   temp_max
14609                                  )
14610                     > -1)
14611                 { /* If it is close, it probably was intended to be a class */
14612                     goto probably_meant_to_be;
14613                 }
14614             }
14615
14616             /* Here the input name is not close enough to a valid class name
14617              * for us to consider it to be intended to be a posix class.  If
14618              * we haven't already done so, and the parse found a character that
14619              * could have been terminators for the name, but which we absorbed
14620              * as typos during the first pass, repeat the parse, signalling it
14621              * to stop at that character */
14622             if (possible_end && possible_end != (char *) -1) {
14623                 possible_end = (char *) -1;
14624                 p = name_start;
14625                 goto parse_name;
14626             }
14627
14628             /* Here neither pass found a close-enough class name */
14629             return NOT_MEANT_TO_BE_A_POSIX_CLASS;
14630         }
14631
14632     probably_meant_to_be:
14633
14634         /* Here we think that a posix specification was intended.  Update any
14635          * parse pointer */
14636         if (updated_parse_ptr) {
14637             *updated_parse_ptr = (char *) p;
14638         }
14639
14640         /* If a posix class name was intended but incorrectly specified, we
14641          * output or return the warnings */
14642         if (found_problem) {
14643
14644             /* We set flags for these issues in the parse loop above instead of
14645              * adding them to the list of warnings, because we can parse it
14646              * twice, and we only want one warning instance */
14647             if (has_upper) {
14648                 ADD_POSIX_WARNING(p, "the name must be all lowercase letters");
14649             }
14650             if (has_blank) {
14651                 ADD_POSIX_WARNING(p, NO_BLANKS_POSIX_WARNING);
14652             }
14653             if (has_semi_colon) {
14654                 ADD_POSIX_WARNING(p, SEMI_COLON_POSIX_WARNING);
14655             }
14656             else if (! has_terminating_colon) {
14657                 ADD_POSIX_WARNING(p, "there is no terminating ':'");
14658             }
14659             if (! has_terminating_bracket) {
14660                 ADD_POSIX_WARNING(p, "there is no terminating ']'");
14661             }
14662
14663             if (posix_warnings && RExC_warn_text && av_top_index(RExC_warn_text) > -1) {
14664                 *posix_warnings = RExC_warn_text;
14665             }
14666         }
14667         else if (class_number != OOB_NAMEDCLASS) {
14668             /* If it is a known class, return the class.  The class number
14669              * #defines are structured so each complement is +1 to the normal
14670              * one */
14671             return class_number + complement;
14672         }
14673         else if (! check_only) {
14674
14675             /* Here, it is an unrecognized class.  This is an error (unless the
14676             * call is to check only, which we've already handled above) */
14677             const char * const complement_string = (complement)
14678                                                    ? "^"
14679                                                    : "";
14680             RExC_parse = (char *) p;
14681             vFAIL3utf8f("POSIX class [:%s%" UTF8f ":] unknown",
14682                         complement_string,
14683                         UTF8fARG(UTF, RExC_parse - name_start - 2, name_start));
14684         }
14685     }
14686
14687     return OOB_NAMEDCLASS;
14688 }
14689 #undef ADD_POSIX_WARNING
14690
14691 STATIC unsigned  int
14692 S_regex_set_precedence(const U8 my_operator) {
14693
14694     /* Returns the precedence in the (?[...]) construct of the input operator,
14695      * specified by its character representation.  The precedence follows
14696      * general Perl rules, but it extends this so that ')' and ']' have (low)
14697      * precedence even though they aren't really operators */
14698
14699     switch (my_operator) {
14700         case '!':
14701             return 5;
14702         case '&':
14703             return 4;
14704         case '^':
14705         case '|':
14706         case '+':
14707         case '-':
14708             return 3;
14709         case ')':
14710             return 2;
14711         case ']':
14712             return 1;
14713     }
14714
14715     NOT_REACHED; /* NOTREACHED */
14716     return 0;   /* Silence compiler warning */
14717 }
14718
14719 STATIC regnode *
14720 S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist,
14721                     I32 *flagp, U32 depth,
14722                     char * const oregcomp_parse)
14723 {
14724     /* Handle the (?[...]) construct to do set operations */
14725
14726     U8 curchar;                     /* Current character being parsed */
14727     UV start, end;                  /* End points of code point ranges */
14728     SV* final = NULL;               /* The end result inversion list */
14729     SV* result_string;              /* 'final' stringified */
14730     AV* stack;                      /* stack of operators and operands not yet
14731                                        resolved */
14732     AV* fence_stack = NULL;         /* A stack containing the positions in
14733                                        'stack' of where the undealt-with left
14734                                        parens would be if they were actually
14735                                        put there */
14736     /* The 'VOL' (expanding to 'volatile') is a workaround for an optimiser bug
14737      * in Solaris Studio 12.3. See RT #127455 */
14738     VOL IV fence = 0;               /* Position of where most recent undealt-
14739                                        with left paren in stack is; -1 if none.
14740                                      */
14741     STRLEN len;                     /* Temporary */
14742     regnode* node;                  /* Temporary, and final regnode returned by
14743                                        this function */
14744     const bool save_fold = FOLD;    /* Temporary */
14745     char *save_end, *save_parse;    /* Temporaries */
14746     const bool in_locale = LOC;     /* we turn off /l during processing */
14747     AV* posix_warnings = NULL;
14748
14749     GET_RE_DEBUG_FLAGS_DECL;
14750
14751     PERL_ARGS_ASSERT_HANDLE_REGEX_SETS;
14752
14753     if (in_locale) {
14754         set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);
14755     }
14756
14757     REQUIRE_UNI_RULES(flagp, NULL);   /* The use of this operator implies /u.
14758                                          This is required so that the compile
14759                                          time values are valid in all runtime
14760                                          cases */
14761
14762     /* This will return only an ANYOF regnode, or (unlikely) something smaller
14763      * (such as EXACT).  Thus we can skip most everything if just sizing.  We
14764      * call regclass to handle '[]' so as to not have to reinvent its parsing
14765      * rules here (throwing away the size it computes each time).  And, we exit
14766      * upon an unescaped ']' that isn't one ending a regclass.  To do both
14767      * these things, we need to realize that something preceded by a backslash
14768      * is escaped, so we have to keep track of backslashes */
14769     if (SIZE_ONLY) {
14770         UV depth = 0; /* how many nested (?[...]) constructs */
14771
14772         while (RExC_parse < RExC_end) {
14773             SV* current = NULL;
14774
14775             skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14776                                     TRUE /* Force /x */ );
14777
14778             switch (*RExC_parse) {
14779                 case '?':
14780                     if (RExC_parse[1] == '[') depth++, RExC_parse++;
14781                     /* FALLTHROUGH */
14782                 default:
14783                     break;
14784                 case '\\':
14785                     /* Skip past this, so the next character gets skipped, after
14786                      * the switch */
14787                     RExC_parse++;
14788                     if (*RExC_parse == 'c') {
14789                             /* Skip the \cX notation for control characters */
14790                             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14791                     }
14792                     break;
14793
14794                 case '[':
14795                 {
14796                     /* See if this is a [:posix:] class. */
14797                     bool is_posix_class = (OOB_NAMEDCLASS
14798                             < handle_possible_posix(pRExC_state,
14799                                                 RExC_parse + 1,
14800                                                 NULL,
14801                                                 NULL,
14802                                                 TRUE /* checking only */));
14803                     /* If it is a posix class, leave the parse pointer at the
14804                      * '[' to fool regclass() into thinking it is part of a
14805                      * '[[:posix:]]'. */
14806                     if (! is_posix_class) {
14807                         RExC_parse++;
14808                     }
14809
14810                     /* regclass() can only return RESTART_PASS1 and NEED_UTF8
14811                      * if multi-char folds are allowed.  */
14812                     if (!regclass(pRExC_state, flagp,depth+1,
14813                                   is_posix_class, /* parse the whole char
14814                                                      class only if not a
14815                                                      posix class */
14816                                   FALSE, /* don't allow multi-char folds */
14817                                   TRUE, /* silence non-portable warnings. */
14818                                   TRUE, /* strict */
14819                                   FALSE, /* Require return to be an ANYOF */
14820                                   &current,
14821                                   &posix_warnings
14822                                  ))
14823                         FAIL2("panic: regclass returned NULL to handle_sets, "
14824                               "flags=%#" UVxf, (UV) *flagp);
14825
14826                     /* function call leaves parse pointing to the ']', except
14827                      * if we faked it */
14828                     if (is_posix_class) {
14829                         RExC_parse--;
14830                     }
14831
14832                     SvREFCNT_dec(current);   /* In case it returned something */
14833                     break;
14834                 }
14835
14836                 case ']':
14837                     if (depth--) break;
14838                     RExC_parse++;
14839                     if (*RExC_parse == ')') {
14840                         node = reganode(pRExC_state, ANYOF, 0);
14841                         RExC_size += ANYOF_SKIP;
14842                         nextchar(pRExC_state);
14843                         Set_Node_Length(node,
14844                                 RExC_parse - oregcomp_parse + 1); /* MJD */
14845                         if (in_locale) {
14846                             set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
14847                         }
14848
14849                         return node;
14850                     }
14851                     goto no_close;
14852             }
14853
14854             RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1;
14855         }
14856
14857       no_close:
14858         /* We output the messages even if warnings are off, because we'll fail
14859          * the very next thing, and these give a likely diagnosis for that */
14860         if (posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
14861             output_or_return_posix_warnings(pRExC_state, posix_warnings, NULL);
14862         }
14863
14864         FAIL("Syntax error in (?[...])");
14865     }
14866
14867     /* Pass 2 only after this. */
14868     Perl_ck_warner_d(aTHX_
14869         packWARN(WARN_EXPERIMENTAL__REGEX_SETS),
14870         "The regex_sets feature is experimental" REPORT_LOCATION,
14871         REPORT_LOCATION_ARGS(RExC_parse));
14872
14873     /* Everything in this construct is a metacharacter.  Operands begin with
14874      * either a '\' (for an escape sequence), or a '[' for a bracketed
14875      * character class.  Any other character should be an operator, or
14876      * parenthesis for grouping.  Both types of operands are handled by calling
14877      * regclass() to parse them.  It is called with a parameter to indicate to
14878      * return the computed inversion list.  The parsing here is implemented via
14879      * a stack.  Each entry on the stack is a single character representing one
14880      * of the operators; or else a pointer to an operand inversion list. */
14881
14882 #define IS_OPERATOR(a) SvIOK(a)
14883 #define IS_OPERAND(a)  (! IS_OPERATOR(a))
14884
14885     /* The stack is kept in Łukasiewicz order.  (That's pronounced similar
14886      * to luke-a-shave-itch (or -itz), but people who didn't want to bother
14887      * with pronouncing it called it Reverse Polish instead, but now that YOU
14888      * know how to pronounce it you can use the correct term, thus giving due
14889      * credit to the person who invented it, and impressing your geek friends.
14890      * Wikipedia says that the pronounciation of "Ł" has been changing so that
14891      * it is now more like an English initial W (as in wonk) than an L.)
14892      *
14893      * This means that, for example, 'a | b & c' is stored on the stack as
14894      *
14895      * c  [4]
14896      * b  [3]
14897      * &  [2]
14898      * a  [1]
14899      * |  [0]
14900      *
14901      * where the numbers in brackets give the stack [array] element number.
14902      * In this implementation, parentheses are not stored on the stack.
14903      * Instead a '(' creates a "fence" so that the part of the stack below the
14904      * fence is invisible except to the corresponding ')' (this allows us to
14905      * replace testing for parens, by using instead subtraction of the fence
14906      * position).  As new operands are processed they are pushed onto the stack
14907      * (except as noted in the next paragraph).  New operators of higher
14908      * precedence than the current final one are inserted on the stack before
14909      * the lhs operand (so that when the rhs is pushed next, everything will be
14910      * in the correct positions shown above.  When an operator of equal or
14911      * lower precedence is encountered in parsing, all the stacked operations
14912      * of equal or higher precedence are evaluated, leaving the result as the
14913      * top entry on the stack.  This makes higher precedence operations
14914      * evaluate before lower precedence ones, and causes operations of equal
14915      * precedence to left associate.
14916      *
14917      * The only unary operator '!' is immediately pushed onto the stack when
14918      * encountered.  When an operand is encountered, if the top of the stack is
14919      * a '!", the complement is immediately performed, and the '!' popped.  The
14920      * resulting value is treated as a new operand, and the logic in the
14921      * previous paragraph is executed.  Thus in the expression
14922      *      [a] + ! [b]
14923      * the stack looks like
14924      *
14925      * !
14926      * a
14927      * +
14928      *
14929      * as 'b' gets parsed, the latter gets evaluated to '!b', and the stack
14930      * becomes
14931      *
14932      * !b
14933      * a
14934      * +
14935      *
14936      * A ')' is treated as an operator with lower precedence than all the
14937      * aforementioned ones, which causes all operations on the stack above the
14938      * corresponding '(' to be evaluated down to a single resultant operand.
14939      * Then the fence for the '(' is removed, and the operand goes through the
14940      * algorithm above, without the fence.
14941      *
14942      * A separate stack is kept of the fence positions, so that the position of
14943      * the latest so-far unbalanced '(' is at the top of it.
14944      *
14945      * The ']' ending the construct is treated as the lowest operator of all,
14946      * so that everything gets evaluated down to a single operand, which is the
14947      * result */
14948
14949     sv_2mortal((SV *)(stack = newAV()));
14950     sv_2mortal((SV *)(fence_stack = newAV()));
14951
14952     while (RExC_parse < RExC_end) {
14953         I32 top_index;              /* Index of top-most element in 'stack' */
14954         SV** top_ptr;               /* Pointer to top 'stack' element */
14955         SV* current = NULL;         /* To contain the current inversion list
14956                                        operand */
14957         SV* only_to_avoid_leaks;
14958
14959         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
14960                                 TRUE /* Force /x */ );
14961         if (RExC_parse >= RExC_end) {
14962             Perl_croak(aTHX_ "panic: Read past end of '(?[ ])'");
14963         }
14964
14965         curchar = UCHARAT(RExC_parse);
14966
14967 redo_curchar:
14968
14969 #ifdef ENABLE_REGEX_SETS_DEBUGGING
14970                     /* Enable with -Accflags=-DENABLE_REGEX_SETS_DEBUGGING */
14971         DEBUG_U(dump_regex_sets_structures(pRExC_state,
14972                                            stack, fence, fence_stack));
14973 #endif
14974
14975         top_index = av_tindex_nomg(stack);
14976
14977         switch (curchar) {
14978             SV** stacked_ptr;       /* Ptr to something already on 'stack' */
14979             char stacked_operator;  /* The topmost operator on the 'stack'. */
14980             SV* lhs;                /* Operand to the left of the operator */
14981             SV* rhs;                /* Operand to the right of the operator */
14982             SV* fence_ptr;          /* Pointer to top element of the fence
14983                                        stack */
14984
14985             case '(':
14986
14987                 if (   RExC_parse < RExC_end - 1
14988                     && (UCHARAT(RExC_parse + 1) == '?'))
14989                 {
14990                     /* If is a '(?', could be an embedded '(?flags:(?[...])'.
14991                      * This happens when we have some thing like
14992                      *
14993                      *   my $thai_or_lao = qr/(?[ \p{Thai} + \p{Lao} ])/;
14994                      *   ...
14995                      *   qr/(?[ \p{Digit} & $thai_or_lao ])/;
14996                      *
14997                      * Here we would be handling the interpolated
14998                      * '$thai_or_lao'.  We handle this by a recursive call to
14999                      * ourselves which returns the inversion list the
15000                      * interpolated expression evaluates to.  We use the flags
15001                      * from the interpolated pattern. */
15002                     U32 save_flags = RExC_flags;
15003                     const char * save_parse;
15004
15005                     RExC_parse += 2;        /* Skip past the '(?' */
15006                     save_parse = RExC_parse;
15007
15008                     /* Parse any flags for the '(?' */
15009                     parse_lparen_question_flags(pRExC_state);
15010
15011                     if (RExC_parse == save_parse  /* Makes sure there was at
15012                                                      least one flag (or else
15013                                                      this embedding wasn't
15014                                                      compiled) */
15015                         || RExC_parse >= RExC_end - 4
15016                         || UCHARAT(RExC_parse) != ':'
15017                         || UCHARAT(++RExC_parse) != '('
15018                         || UCHARAT(++RExC_parse) != '?'
15019                         || UCHARAT(++RExC_parse) != '[')
15020                     {
15021
15022                         /* In combination with the above, this moves the
15023                          * pointer to the point just after the first erroneous
15024                          * character (or if there are no flags, to where they
15025                          * should have been) */
15026                         if (RExC_parse >= RExC_end - 4) {
15027                             RExC_parse = RExC_end;
15028                         }
15029                         else if (RExC_parse != save_parse) {
15030                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15031                         }
15032                         vFAIL("Expecting '(?flags:(?[...'");
15033                     }
15034
15035                     /* Recurse, with the meat of the embedded expression */
15036                     RExC_parse++;
15037                     (void) handle_regex_sets(pRExC_state, &current, flagp,
15038                                                     depth+1, oregcomp_parse);
15039
15040                     /* Here, 'current' contains the embedded expression's
15041                      * inversion list, and RExC_parse points to the trailing
15042                      * ']'; the next character should be the ')' */
15043                     RExC_parse++;
15044                     assert(UCHARAT(RExC_parse) == ')');
15045
15046                     /* Then the ')' matching the original '(' handled by this
15047                      * case: statement */
15048                     RExC_parse++;
15049                     assert(UCHARAT(RExC_parse) == ')');
15050
15051                     RExC_parse++;
15052                     RExC_flags = save_flags;
15053                     goto handle_operand;
15054                 }
15055
15056                 /* A regular '('.  Look behind for illegal syntax */
15057                 if (top_index - fence >= 0) {
15058                     /* If the top entry on the stack is an operator, it had
15059                      * better be a '!', otherwise the entry below the top
15060                      * operand should be an operator */
15061                     if (   ! (top_ptr = av_fetch(stack, top_index, FALSE))
15062                         || (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) != '!')
15063                         || (   IS_OPERAND(*top_ptr)
15064                             && (   top_index - fence < 1
15065                                 || ! (stacked_ptr = av_fetch(stack,
15066                                                              top_index - 1,
15067                                                              FALSE))
15068                                 || ! IS_OPERATOR(*stacked_ptr))))
15069                     {
15070                         RExC_parse++;
15071                         vFAIL("Unexpected '(' with no preceding operator");
15072                     }
15073                 }
15074
15075                 /* Stack the position of this undealt-with left paren */
15076                 av_push(fence_stack, newSViv(fence));
15077                 fence = top_index + 1;
15078                 break;
15079
15080             case '\\':
15081                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15082                  * multi-char folds are allowed.  */
15083                 if (!regclass(pRExC_state, flagp,depth+1,
15084                               TRUE, /* means parse just the next thing */
15085                               FALSE, /* don't allow multi-char folds */
15086                               FALSE, /* don't silence non-portable warnings.  */
15087                               TRUE,  /* strict */
15088                               FALSE, /* Require return to be an ANYOF */
15089                               &current,
15090                               NULL))
15091                 {
15092                     FAIL2("panic: regclass returned NULL to handle_sets, "
15093                           "flags=%#" UVxf, (UV) *flagp);
15094                 }
15095
15096                 /* regclass() will return with parsing just the \ sequence,
15097                  * leaving the parse pointer at the next thing to parse */
15098                 RExC_parse--;
15099                 goto handle_operand;
15100
15101             case '[':   /* Is a bracketed character class */
15102             {
15103                 /* See if this is a [:posix:] class. */
15104                 bool is_posix_class = (OOB_NAMEDCLASS
15105                             < handle_possible_posix(pRExC_state,
15106                                                 RExC_parse + 1,
15107                                                 NULL,
15108                                                 NULL,
15109                                                 TRUE /* checking only */));
15110                 /* If it is a posix class, leave the parse pointer at the '['
15111                  * to fool regclass() into thinking it is part of a
15112                  * '[[:posix:]]'. */
15113                 if (! is_posix_class) {
15114                     RExC_parse++;
15115                 }
15116
15117                 /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if
15118                  * multi-char folds are allowed.  */
15119                 if (!regclass(pRExC_state, flagp,depth+1,
15120                                 is_posix_class, /* parse the whole char
15121                                                     class only if not a
15122                                                     posix class */
15123                                 FALSE, /* don't allow multi-char folds */
15124                                 TRUE, /* silence non-portable warnings. */
15125                                 TRUE, /* strict */
15126                                 FALSE, /* Require return to be an ANYOF */
15127                                 &current,
15128                                 NULL
15129                                 ))
15130                 {
15131                     FAIL2("panic: regclass returned NULL to handle_sets, "
15132                           "flags=%#" UVxf, (UV) *flagp);
15133                 }
15134
15135                 /* function call leaves parse pointing to the ']', except if we
15136                  * faked it */
15137                 if (is_posix_class) {
15138                     RExC_parse--;
15139                 }
15140
15141                 goto handle_operand;
15142             }
15143
15144             case ']':
15145                 if (top_index >= 1) {
15146                     goto join_operators;
15147                 }
15148
15149                 /* Only a single operand on the stack: are done */
15150                 goto done;
15151
15152             case ')':
15153                 if (av_tindex_nomg(fence_stack) < 0) {
15154                     RExC_parse++;
15155                     vFAIL("Unexpected ')'");
15156                 }
15157
15158                 /* If nothing after the fence, is missing an operand */
15159                 if (top_index - fence < 0) {
15160                     RExC_parse++;
15161                     goto bad_syntax;
15162                 }
15163                 /* If at least two things on the stack, treat this as an
15164                   * operator */
15165                 if (top_index - fence >= 1) {
15166                     goto join_operators;
15167                 }
15168
15169                 /* Here only a single thing on the fenced stack, and there is a
15170                  * fence.  Get rid of it */
15171                 fence_ptr = av_pop(fence_stack);
15172                 assert(fence_ptr);
15173                 fence = SvIV(fence_ptr) - 1;
15174                 SvREFCNT_dec_NN(fence_ptr);
15175                 fence_ptr = NULL;
15176
15177                 if (fence < 0) {
15178                     fence = 0;
15179                 }
15180
15181                 /* Having gotten rid of the fence, we pop the operand at the
15182                  * stack top and process it as a newly encountered operand */
15183                 current = av_pop(stack);
15184                 if (IS_OPERAND(current)) {
15185                     goto handle_operand;
15186                 }
15187
15188                 RExC_parse++;
15189                 goto bad_syntax;
15190
15191             case '&':
15192             case '|':
15193             case '+':
15194             case '-':
15195             case '^':
15196
15197                 /* These binary operators should have a left operand already
15198                  * parsed */
15199                 if (   top_index - fence < 0
15200                     || top_index - fence == 1
15201                     || ( ! (top_ptr = av_fetch(stack, top_index, FALSE)))
15202                     || ! IS_OPERAND(*top_ptr))
15203                 {
15204                     goto unexpected_binary;
15205                 }
15206
15207                 /* If only the one operand is on the part of the stack visible
15208                  * to us, we just place this operator in the proper position */
15209                 if (top_index - fence < 2) {
15210
15211                     /* Place the operator before the operand */
15212
15213                     SV* lhs = av_pop(stack);
15214                     av_push(stack, newSVuv(curchar));
15215                     av_push(stack, lhs);
15216                     break;
15217                 }
15218
15219                 /* But if there is something else on the stack, we need to
15220                  * process it before this new operator if and only if the
15221                  * stacked operation has equal or higher precedence than the
15222                  * new one */
15223
15224              join_operators:
15225
15226                 /* The operator on the stack is supposed to be below both its
15227                  * operands */
15228                 if (   ! (stacked_ptr = av_fetch(stack, top_index - 2, FALSE))
15229                     || IS_OPERAND(*stacked_ptr))
15230                 {
15231                     /* But if not, it's legal and indicates we are completely
15232                      * done if and only if we're currently processing a ']',
15233                      * which should be the final thing in the expression */
15234                     if (curchar == ']') {
15235                         goto done;
15236                     }
15237
15238                   unexpected_binary:
15239                     RExC_parse++;
15240                     vFAIL2("Unexpected binary operator '%c' with no "
15241                            "preceding operand", curchar);
15242                 }
15243                 stacked_operator = (char) SvUV(*stacked_ptr);
15244
15245                 if (regex_set_precedence(curchar)
15246                     > regex_set_precedence(stacked_operator))
15247                 {
15248                     /* Here, the new operator has higher precedence than the
15249                      * stacked one.  This means we need to add the new one to
15250                      * the stack to await its rhs operand (and maybe more
15251                      * stuff).  We put it before the lhs operand, leaving
15252                      * untouched the stacked operator and everything below it
15253                      * */
15254                     lhs = av_pop(stack);
15255                     assert(IS_OPERAND(lhs));
15256
15257                     av_push(stack, newSVuv(curchar));
15258                     av_push(stack, lhs);
15259                     break;
15260                 }
15261
15262                 /* Here, the new operator has equal or lower precedence than
15263                  * what's already there.  This means the operation already
15264                  * there should be performed now, before the new one. */
15265
15266                 rhs = av_pop(stack);
15267                 if (! IS_OPERAND(rhs)) {
15268
15269                     /* This can happen when a ! is not followed by an operand,
15270                      * like in /(?[\t &!])/ */
15271                     goto bad_syntax;
15272                 }
15273
15274                 lhs = av_pop(stack);
15275
15276                 if (! IS_OPERAND(lhs)) {
15277
15278                     /* This can happen when there is an empty (), like in
15279                      * /(?[[0]+()+])/ */
15280                     goto bad_syntax;
15281                 }
15282
15283                 switch (stacked_operator) {
15284                     case '&':
15285                         _invlist_intersection(lhs, rhs, &rhs);
15286                         break;
15287
15288                     case '|':
15289                     case '+':
15290                         _invlist_union(lhs, rhs, &rhs);
15291                         break;
15292
15293                     case '-':
15294                         _invlist_subtract(lhs, rhs, &rhs);
15295                         break;
15296
15297                     case '^':   /* The union minus the intersection */
15298                     {
15299                         SV* i = NULL;
15300                         SV* u = NULL;
15301
15302                         _invlist_union(lhs, rhs, &u);
15303                         _invlist_intersection(lhs, rhs, &i);
15304                         _invlist_subtract(u, i, &rhs);
15305                         SvREFCNT_dec_NN(i);
15306                         SvREFCNT_dec_NN(u);
15307                         break;
15308                     }
15309                 }
15310                 SvREFCNT_dec(lhs);
15311
15312                 /* Here, the higher precedence operation has been done, and the
15313                  * result is in 'rhs'.  We overwrite the stacked operator with
15314                  * the result.  Then we redo this code to either push the new
15315                  * operator onto the stack or perform any higher precedence
15316                  * stacked operation */
15317                 only_to_avoid_leaks = av_pop(stack);
15318                 SvREFCNT_dec(only_to_avoid_leaks);
15319                 av_push(stack, rhs);
15320                 goto redo_curchar;
15321
15322             case '!':   /* Highest priority, right associative */
15323
15324                 /* If what's already at the top of the stack is another '!",
15325                  * they just cancel each other out */
15326                 if (   (top_ptr = av_fetch(stack, top_index, FALSE))
15327                     && (IS_OPERATOR(*top_ptr) && SvUV(*top_ptr) == '!'))
15328                 {
15329                     only_to_avoid_leaks = av_pop(stack);
15330                     SvREFCNT_dec(only_to_avoid_leaks);
15331                 }
15332                 else { /* Otherwise, since it's right associative, just push
15333                           onto the stack */
15334                     av_push(stack, newSVuv(curchar));
15335                 }
15336                 break;
15337
15338             default:
15339                 RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15340                 vFAIL("Unexpected character");
15341
15342           handle_operand:
15343
15344             /* Here 'current' is the operand.  If something is already on the
15345              * stack, we have to check if it is a !.  But first, the code above
15346              * may have altered the stack in the time since we earlier set
15347              * 'top_index'.  */
15348
15349             top_index = av_tindex_nomg(stack);
15350             if (top_index - fence >= 0) {
15351                 /* If the top entry on the stack is an operator, it had better
15352                  * be a '!', otherwise the entry below the top operand should
15353                  * be an operator */
15354                 top_ptr = av_fetch(stack, top_index, FALSE);
15355                 assert(top_ptr);
15356                 if (IS_OPERATOR(*top_ptr)) {
15357
15358                     /* The only permissible operator at the top of the stack is
15359                      * '!', which is applied immediately to this operand. */
15360                     curchar = (char) SvUV(*top_ptr);
15361                     if (curchar != '!') {
15362                         SvREFCNT_dec(current);
15363                         vFAIL2("Unexpected binary operator '%c' with no "
15364                                 "preceding operand", curchar);
15365                     }
15366
15367                     _invlist_invert(current);
15368
15369                     only_to_avoid_leaks = av_pop(stack);
15370                     SvREFCNT_dec(only_to_avoid_leaks);
15371
15372                     /* And we redo with the inverted operand.  This allows
15373                      * handling multiple ! in a row */
15374                     goto handle_operand;
15375                 }
15376                           /* Single operand is ok only for the non-binary ')'
15377                            * operator */
15378                 else if ((top_index - fence == 0 && curchar != ')')
15379                          || (top_index - fence > 0
15380                              && (! (stacked_ptr = av_fetch(stack,
15381                                                            top_index - 1,
15382                                                            FALSE))
15383                                  || IS_OPERAND(*stacked_ptr))))
15384                 {
15385                     SvREFCNT_dec(current);
15386                     vFAIL("Operand with no preceding operator");
15387                 }
15388             }
15389
15390             /* Here there was nothing on the stack or the top element was
15391              * another operand.  Just add this new one */
15392             av_push(stack, current);
15393
15394         } /* End of switch on next parse token */
15395
15396         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
15397     } /* End of loop parsing through the construct */
15398
15399   done:
15400     if (av_tindex_nomg(fence_stack) >= 0) {
15401         vFAIL("Unmatched (");
15402     }
15403
15404     if (av_tindex_nomg(stack) < 0   /* Was empty */
15405         || ((final = av_pop(stack)) == NULL)
15406         || ! IS_OPERAND(final)
15407         || SvTYPE(final) != SVt_INVLIST
15408         || av_tindex_nomg(stack) >= 0)  /* More left on stack */
15409     {
15410       bad_syntax:
15411         SvREFCNT_dec(final);
15412         vFAIL("Incomplete expression within '(?[ ])'");
15413     }
15414
15415     /* Here, 'final' is the resultant inversion list from evaluating the
15416      * expression.  Return it if so requested */
15417     if (return_invlist) {
15418         *return_invlist = final;
15419         return END;
15420     }
15421
15422     /* Otherwise generate a resultant node, based on 'final'.  regclass() is
15423      * expecting a string of ranges and individual code points */
15424     invlist_iterinit(final);
15425     result_string = newSVpvs("");
15426     while (invlist_iternext(final, &start, &end)) {
15427         if (start == end) {
15428             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}", start);
15429         }
15430         else {
15431             Perl_sv_catpvf(aTHX_ result_string, "\\x{%" UVXf "}-\\x{%" UVXf "}",
15432                                                      start,          end);
15433         }
15434     }
15435
15436     /* About to generate an ANYOF (or similar) node from the inversion list we
15437      * have calculated */
15438     save_parse = RExC_parse;
15439     RExC_parse = SvPV(result_string, len);
15440     save_end = RExC_end;
15441     RExC_end = RExC_parse + len;
15442
15443     /* We turn off folding around the call, as the class we have constructed
15444      * already has all folding taken into consideration, and we don't want
15445      * regclass() to add to that */
15446     RExC_flags &= ~RXf_PMf_FOLD;
15447     /* regclass() can only return RESTART_PASS1 and NEED_UTF8 if multi-char
15448      * folds are allowed.  */
15449     node = regclass(pRExC_state, flagp,depth+1,
15450                     FALSE, /* means parse the whole char class */
15451                     FALSE, /* don't allow multi-char folds */
15452                     TRUE, /* silence non-portable warnings.  The above may very
15453                              well have generated non-portable code points, but
15454                              they're valid on this machine */
15455                     FALSE, /* similarly, no need for strict */
15456                     FALSE, /* Require return to be an ANYOF */
15457                     NULL,
15458                     NULL
15459                 );
15460     if (!node)
15461         FAIL2("panic: regclass returned NULL to handle_sets, flags=%#" UVxf,
15462                     PTR2UV(flagp));
15463
15464     /* Fix up the node type if we are in locale.  (We have pretended we are
15465      * under /u for the purposes of regclass(), as this construct will only
15466      * work under UTF-8 locales.  But now we change the opcode to be ANYOFL (so
15467      * as to cause any warnings about bad locales to be output in regexec.c),
15468      * and add the flag that indicates to check if not in a UTF-8 locale.  The
15469      * reason we above forbid optimization into something other than an ANYOF
15470      * node is simply to minimize the number of code changes in regexec.c.
15471      * Otherwise we would have to create new EXACTish node types and deal with
15472      * them.  This decision could be revisited should this construct become
15473      * popular.
15474      *
15475      * (One might think we could look at the resulting ANYOF node and suppress
15476      * the flag if everything is above 255, as those would be UTF-8 only,
15477      * but this isn't true, as the components that led to that result could
15478      * have been locale-affected, and just happen to cancel each other out
15479      * under UTF-8 locales.) */
15480     if (in_locale) {
15481         set_regex_charset(&RExC_flags, REGEX_LOCALE_CHARSET);
15482
15483         assert(OP(node) == ANYOF);
15484
15485         OP(node) = ANYOFL;
15486         ANYOF_FLAGS(node)
15487                 |= ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
15488     }
15489
15490     if (save_fold) {
15491         RExC_flags |= RXf_PMf_FOLD;
15492     }
15493
15494     RExC_parse = save_parse + 1;
15495     RExC_end = save_end;
15496     SvREFCNT_dec_NN(final);
15497     SvREFCNT_dec_NN(result_string);
15498
15499     nextchar(pRExC_state);
15500     Set_Node_Length(node, RExC_parse - oregcomp_parse + 1); /* MJD */
15501     return node;
15502 }
15503
15504 #ifdef ENABLE_REGEX_SETS_DEBUGGING
15505
15506 STATIC void
15507 S_dump_regex_sets_structures(pTHX_ RExC_state_t *pRExC_state,
15508                              AV * stack, const IV fence, AV * fence_stack)
15509 {   /* Dumps the stacks in handle_regex_sets() */
15510
15511     const SSize_t stack_top = av_tindex_nomg(stack);
15512     const SSize_t fence_stack_top = av_tindex_nomg(fence_stack);
15513     SSize_t i;
15514
15515     PERL_ARGS_ASSERT_DUMP_REGEX_SETS_STRUCTURES;
15516
15517     PerlIO_printf(Perl_debug_log, "\nParse position is:%s\n", RExC_parse);
15518
15519     if (stack_top < 0) {
15520         PerlIO_printf(Perl_debug_log, "Nothing on stack\n");
15521     }
15522     else {
15523         PerlIO_printf(Perl_debug_log, "Stack: (fence=%d)\n", (int) fence);
15524         for (i = stack_top; i >= 0; i--) {
15525             SV ** element_ptr = av_fetch(stack, i, FALSE);
15526             if (! element_ptr) {
15527             }
15528
15529             if (IS_OPERATOR(*element_ptr)) {
15530                 PerlIO_printf(Perl_debug_log, "[%d]: %c\n",
15531                                             (int) i, (int) SvIV(*element_ptr));
15532             }
15533             else {
15534                 PerlIO_printf(Perl_debug_log, "[%d] ", (int) i);
15535                 sv_dump(*element_ptr);
15536             }
15537         }
15538     }
15539
15540     if (fence_stack_top < 0) {
15541         PerlIO_printf(Perl_debug_log, "Nothing on fence_stack\n");
15542     }
15543     else {
15544         PerlIO_printf(Perl_debug_log, "Fence_stack: \n");
15545         for (i = fence_stack_top; i >= 0; i--) {
15546             SV ** element_ptr = av_fetch(fence_stack, i, FALSE);
15547             if (! element_ptr) {
15548             }
15549
15550             PerlIO_printf(Perl_debug_log, "[%d]: %d\n",
15551                                             (int) i, (int) SvIV(*element_ptr));
15552         }
15553     }
15554 }
15555
15556 #endif
15557
15558 #undef IS_OPERATOR
15559 #undef IS_OPERAND
15560
15561 STATIC void
15562 S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invlist)
15563 {
15564     /* This hard-codes the Latin1/above-Latin1 folding rules, so that an
15565      * innocent-looking character class, like /[ks]/i won't have to go out to
15566      * disk to find the possible matches.
15567      *
15568      * This should be called only for a Latin1-range code points, cp, which is
15569      * known to be involved in a simple fold with other code points above
15570      * Latin1.  It would give false results if /aa has been specified.
15571      * Multi-char folds are outside the scope of this, and must be handled
15572      * specially.
15573      *
15574      * XXX It would be better to generate these via regen, in case a new
15575      * version of the Unicode standard adds new mappings, though that is not
15576      * really likely, and may be caught by the default: case of the switch
15577      * below. */
15578
15579     PERL_ARGS_ASSERT_ADD_ABOVE_LATIN1_FOLDS;
15580
15581     assert(HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(cp));
15582
15583     switch (cp) {
15584         case 'k':
15585         case 'K':
15586           *invlist =
15587              add_cp_to_invlist(*invlist, KELVIN_SIGN);
15588             break;
15589         case 's':
15590         case 'S':
15591           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_LONG_S);
15592             break;
15593         case MICRO_SIGN:
15594           *invlist = add_cp_to_invlist(*invlist, GREEK_CAPITAL_LETTER_MU);
15595           *invlist = add_cp_to_invlist(*invlist, GREEK_SMALL_LETTER_MU);
15596             break;
15597         case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
15598         case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
15599           *invlist = add_cp_to_invlist(*invlist, ANGSTROM_SIGN);
15600             break;
15601         case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
15602           *invlist = add_cp_to_invlist(*invlist,
15603                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
15604             break;
15605
15606 #ifdef LATIN_CAPITAL_LETTER_SHARP_S /* not defined in early Unicode releases */
15607
15608         case LATIN_SMALL_LETTER_SHARP_S:
15609           *invlist = add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_SHARP_S);
15610             break;
15611
15612 #endif
15613
15614 #if    UNICODE_MAJOR_VERSION < 3                                        \
15615    || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0)
15616
15617         /* In 3.0 and earlier, U+0130 folded simply to 'i'; and in 3.0.1 so did
15618          * U+0131.  */
15619         case 'i':
15620         case 'I':
15621           *invlist =
15622              add_cp_to_invlist(*invlist, LATIN_CAPITAL_LETTER_I_WITH_DOT_ABOVE);
15623 #   if UNICODE_DOT_DOT_VERSION == 1
15624           *invlist = add_cp_to_invlist(*invlist, LATIN_SMALL_LETTER_DOTLESS_I);
15625 #   endif
15626             break;
15627 #endif
15628
15629         default:
15630             /* Use deprecated warning to increase the chances of this being
15631              * output */
15632             if (PASS2) {
15633                 ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp);
15634             }
15635             break;
15636     }
15637 }
15638
15639 STATIC void
15640 S_output_or_return_posix_warnings(pTHX_ RExC_state_t *pRExC_state, AV* posix_warnings, AV** return_posix_warnings)
15641 {
15642     /* If the final parameter is NULL, output the elements of the array given
15643      * by '*posix_warnings' as REGEXP warnings.  Otherwise, the elements are
15644      * pushed onto it, (creating if necessary) */
15645
15646     SV * msg;
15647     const bool first_is_fatal =  ! return_posix_warnings
15648                                 && ckDEAD(packWARN(WARN_REGEXP));
15649
15650     PERL_ARGS_ASSERT_OUTPUT_OR_RETURN_POSIX_WARNINGS;
15651
15652     while ((msg = av_shift(posix_warnings)) != &PL_sv_undef) {
15653         if (return_posix_warnings) {
15654             if (! *return_posix_warnings) { /* mortalize to not leak if
15655                                                warnings are fatal */
15656                 *return_posix_warnings = (AV *) sv_2mortal((SV *) newAV());
15657             }
15658             av_push(*return_posix_warnings, msg);
15659         }
15660         else {
15661             if (first_is_fatal) {           /* Avoid leaking this */
15662                 av_undef(posix_warnings);   /* This isn't necessary if the
15663                                                array is mortal, but is a
15664                                                fail-safe */
15665                 (void) sv_2mortal(msg);
15666                 if (PASS2) {
15667                     SAVEFREESV(RExC_rx_sv);
15668                 }
15669             }
15670             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s", SvPVX(msg));
15671             SvREFCNT_dec_NN(msg);
15672         }
15673     }
15674 }
15675
15676 STATIC AV *
15677 S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count)
15678 {
15679     /* This adds the string scalar <multi_string> to the array
15680      * <multi_char_matches>.  <multi_string> is known to have exactly
15681      * <cp_count> code points in it.  This is used when constructing a
15682      * bracketed character class and we find something that needs to match more
15683      * than a single character.
15684      *
15685      * <multi_char_matches> is actually an array of arrays.  Each top-level
15686      * element is an array that contains all the strings known so far that are
15687      * the same length.  And that length (in number of code points) is the same
15688      * as the index of the top-level array.  Hence, the [2] element is an
15689      * array, each element thereof is a string containing TWO code points;
15690      * while element [3] is for strings of THREE characters, and so on.  Since
15691      * this is for multi-char strings there can never be a [0] nor [1] element.
15692      *
15693      * When we rewrite the character class below, we will do so such that the
15694      * longest strings are written first, so that it prefers the longest
15695      * matching strings first.  This is done even if it turns out that any
15696      * quantifier is non-greedy, out of this programmer's (khw) laziness.  Tom
15697      * Christiansen has agreed that this is ok.  This makes the test for the
15698      * ligature 'ffi' come before the test for 'ff', for example */
15699
15700     AV* this_array;
15701     AV** this_array_ptr;
15702
15703     PERL_ARGS_ASSERT_ADD_MULTI_MATCH;
15704
15705     if (! multi_char_matches) {
15706         multi_char_matches = newAV();
15707     }
15708
15709     if (av_exists(multi_char_matches, cp_count)) {
15710         this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE);
15711         this_array = *this_array_ptr;
15712     }
15713     else {
15714         this_array = newAV();
15715         av_store(multi_char_matches, cp_count,
15716                  (SV*) this_array);
15717     }
15718     av_push(this_array, multi_string);
15719
15720     return multi_char_matches;
15721 }
15722
15723 /* The names of properties whose definitions are not known at compile time are
15724  * stored in this SV, after a constant heading.  So if the length has been
15725  * changed since initialization, then there is a run-time definition. */
15726 #define HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION                            \
15727                                         (SvCUR(listsv) != initial_listsv_len)
15728
15729 /* There is a restricted set of white space characters that are legal when
15730  * ignoring white space in a bracketed character class.  This generates the
15731  * code to skip them.
15732  *
15733  * There is a line below that uses the same white space criteria but is outside
15734  * this macro.  Both here and there must use the same definition */
15735 #define SKIP_BRACKETED_WHITE_SPACE(do_skip, p)                          \
15736     STMT_START {                                                        \
15737         if (do_skip) {                                                  \
15738             while (isBLANK_A(UCHARAT(p)))                               \
15739             {                                                           \
15740                 p++;                                                    \
15741             }                                                           \
15742         }                                                               \
15743     } STMT_END
15744
15745 STATIC regnode *
15746 S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth,
15747                  const bool stop_at_1,  /* Just parse the next thing, don't
15748                                            look for a full character class */
15749                  bool allow_multi_folds,
15750                  const bool silence_non_portable,   /* Don't output warnings
15751                                                        about too large
15752                                                        characters */
15753                  const bool strict,
15754                  bool optimizable,                  /* ? Allow a non-ANYOF return
15755                                                        node */
15756                  SV** ret_invlist, /* Return an inversion list, not a node */
15757                  AV** return_posix_warnings
15758           )
15759 {
15760     /* parse a bracketed class specification.  Most of these will produce an
15761      * ANYOF node; but something like [a] will produce an EXACT node; [aA], an
15762      * EXACTFish node; [[:ascii:]], a POSIXA node; etc.  It is more complex
15763      * under /i with multi-character folds: it will be rewritten following the
15764      * paradigm of this example, where the <multi-fold>s are characters which
15765      * fold to multiple character sequences:
15766      *      /[abc\x{multi-fold1}def\x{multi-fold2}ghi]/i
15767      * gets effectively rewritten as:
15768      *      /(?:\x{multi-fold1}|\x{multi-fold2}|[abcdefghi]/i
15769      * reg() gets called (recursively) on the rewritten version, and this
15770      * function will return what it constructs.  (Actually the <multi-fold>s
15771      * aren't physically removed from the [abcdefghi], it's just that they are
15772      * ignored in the recursion by means of a flag:
15773      * <RExC_in_multi_char_class>.)
15774      *
15775      * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS
15776      * characters, with the corresponding bit set if that character is in the
15777      * list.  For characters above this, a range list or swash is used.  There
15778      * are extra bits for \w, etc. in locale ANYOFs, as what these match is not
15779      * determinable at compile time
15780      *
15781      * Returns NULL, setting *flagp to RESTART_PASS1 if the sizing scan needs
15782      * to be restarted, or'd with NEED_UTF8 if the pattern needs to be upgraded
15783      * to UTF-8.  This can only happen if ret_invlist is non-NULL.
15784      */
15785
15786     UV prevvalue = OOB_UNICODE, save_prevvalue = OOB_UNICODE;
15787     IV range = 0;
15788     UV value = OOB_UNICODE, save_value = OOB_UNICODE;
15789     regnode *ret;
15790     STRLEN numlen;
15791     int namedclass = OOB_NAMEDCLASS;
15792     char *rangebegin = NULL;
15793     bool need_class = 0;
15794     SV *listsv = NULL;
15795     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
15796                                       than just initialized.  */
15797     SV* properties = NULL;    /* Code points that match \p{} \P{} */
15798     SV* posixes = NULL;     /* Code points that match classes like [:word:],
15799                                extended beyond the Latin1 range.  These have to
15800                                be kept separate from other code points for much
15801                                of this function because their handling  is
15802                                different under /i, and for most classes under
15803                                /d as well */
15804     SV* nposixes = NULL;    /* Similarly for [:^word:].  These are kept
15805                                separate for a while from the non-complemented
15806                                versions because of complications with /d
15807                                matching */
15808     SV* simple_posixes = NULL; /* But under some conditions, the classes can be
15809                                   treated more simply than the general case,
15810                                   leading to less compilation and execution
15811                                   work */
15812     UV element_count = 0;   /* Number of distinct elements in the class.
15813                                Optimizations may be possible if this is tiny */
15814     AV * multi_char_matches = NULL; /* Code points that fold to more than one
15815                                        character; used under /i */
15816     UV n;
15817     char * stop_ptr = RExC_end;    /* where to stop parsing */
15818     const bool skip_white = cBOOL(ret_invlist); /* ignore unescaped white
15819                                                    space? */
15820
15821     /* Unicode properties are stored in a swash; this holds the current one
15822      * being parsed.  If this swash is the only above-latin1 component of the
15823      * character class, an optimization is to pass it directly on to the
15824      * execution engine.  Otherwise, it is set to NULL to indicate that there
15825      * are other things in the class that have to be dealt with at execution
15826      * time */
15827     SV* swash = NULL;           /* Code points that match \p{} \P{} */
15828
15829     /* Set if a component of this character class is user-defined; just passed
15830      * on to the engine */
15831     bool has_user_defined_property = FALSE;
15832
15833     /* inversion list of code points this node matches only when the target
15834      * string is in UTF-8.  These are all non-ASCII, < 256.  (Because is under
15835      * /d) */
15836     SV* has_upper_latin1_only_utf8_matches = NULL;
15837
15838     /* Inversion list of code points this node matches regardless of things
15839      * like locale, folding, utf8ness of the target string */
15840     SV* cp_list = NULL;
15841
15842     /* Like cp_list, but code points on this list need to be checked for things
15843      * that fold to/from them under /i */
15844     SV* cp_foldable_list = NULL;
15845
15846     /* Like cp_list, but code points on this list are valid only when the
15847      * runtime locale is UTF-8 */
15848     SV* only_utf8_locale_list = NULL;
15849
15850     /* In a range, if one of the endpoints is non-character-set portable,
15851      * meaning that it hard-codes a code point that may mean a different
15852      * charactger in ASCII vs. EBCDIC, as opposed to, say, a literal 'A' or a
15853      * mnemonic '\t' which each mean the same character no matter which
15854      * character set the platform is on. */
15855     unsigned int non_portable_endpoint = 0;
15856
15857     /* Is the range unicode? which means on a platform that isn't 1-1 native
15858      * to Unicode (i.e. non-ASCII), each code point in it should be considered
15859      * to be a Unicode value.  */
15860     bool unicode_range = FALSE;
15861     bool invert = FALSE;    /* Is this class to be complemented */
15862
15863     bool warn_super = ALWAYS_WARN_SUPER;
15864
15865     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
15866         case we need to change the emitted regop to an EXACT. */
15867     const char * orig_parse = RExC_parse;
15868     const SSize_t orig_size = RExC_size;
15869     bool posixl_matches_all = FALSE; /* Does /l class have both e.g. \W,\w ? */
15870
15871     /* This variable is used to mark where the end in the input is of something
15872      * that looks like a POSIX construct but isn't.  During the parse, when
15873      * something looks like it could be such a construct is encountered, it is
15874      * checked for being one, but not if we've already checked this area of the
15875      * input.  Only after this position is reached do we check again */
15876     char *not_posix_region_end = RExC_parse - 1;
15877
15878     AV* posix_warnings = NULL;
15879     const bool do_posix_warnings =     return_posix_warnings
15880                                    || (PASS2 && ckWARN(WARN_REGEXP));
15881
15882     GET_RE_DEBUG_FLAGS_DECL;
15883
15884     PERL_ARGS_ASSERT_REGCLASS;
15885 #ifndef DEBUGGING
15886     PERL_UNUSED_ARG(depth);
15887 #endif
15888
15889     DEBUG_PARSE("clas");
15890
15891 #if UNICODE_MAJOR_VERSION < 3 /* no multifolds in early Unicode */      \
15892     || (UNICODE_MAJOR_VERSION == 3 && UNICODE_DOT_VERSION == 0          \
15893                                    && UNICODE_DOT_DOT_VERSION == 0)
15894     allow_multi_folds = FALSE;
15895 #endif
15896
15897     /* Assume we are going to generate an ANYOF node. */
15898     ret = reganode(pRExC_state,
15899                    (LOC)
15900                     ? ANYOFL
15901                     : ANYOF,
15902                    0);
15903
15904     if (SIZE_ONLY) {
15905         RExC_size += ANYOF_SKIP;
15906         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
15907     }
15908     else {
15909         ANYOF_FLAGS(ret) = 0;
15910
15911         RExC_emit += ANYOF_SKIP;
15912         listsv = newSVpvs_flags("# comment\n", SVs_TEMP);
15913         initial_listsv_len = SvCUR(listsv);
15914         SvTEMP_off(listsv); /* Grr, TEMPs and mortals are conflated.  */
15915     }
15916
15917     SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15918
15919     assert(RExC_parse <= RExC_end);
15920
15921     if (UCHARAT(RExC_parse) == '^') {   /* Complement the class */
15922         RExC_parse++;
15923         invert = TRUE;
15924         allow_multi_folds = FALSE;
15925         MARK_NAUGHTY(1);
15926         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15927     }
15928
15929     /* Check that they didn't say [:posix:] instead of [[:posix:]] */
15930     if (! ret_invlist && MAYBE_POSIXCC(UCHARAT(RExC_parse))) {
15931         int maybe_class = handle_possible_posix(pRExC_state,
15932                                                 RExC_parse,
15933                                                 &not_posix_region_end,
15934                                                 NULL,
15935                                                 TRUE /* checking only */);
15936         if (PASS2 && maybe_class >= OOB_NAMEDCLASS && do_posix_warnings) {
15937             SAVEFREESV(RExC_rx_sv);
15938             ckWARN4reg(not_posix_region_end,
15939                     "POSIX syntax [%c %c] belongs inside character classes%s",
15940                     *RExC_parse, *RExC_parse,
15941                     (maybe_class == OOB_NAMEDCLASS)
15942                     ? ((POSIXCC_NOTYET(*RExC_parse))
15943                         ? " (but this one isn't implemented)"
15944                         : " (but this one isn't fully valid)")
15945                     : ""
15946                     );
15947             (void)ReREFCNT_inc(RExC_rx_sv);
15948         }
15949     }
15950
15951     /* If the caller wants us to just parse a single element, accomplish this
15952      * by faking the loop ending condition */
15953     if (stop_at_1 && RExC_end > RExC_parse) {
15954         stop_ptr = RExC_parse + 1;
15955     }
15956
15957     /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */
15958     if (UCHARAT(RExC_parse) == ']')
15959         goto charclassloop;
15960
15961     while (1) {
15962
15963         if (   posix_warnings
15964             && av_tindex_nomg(posix_warnings) >= 0
15965             && RExC_parse > not_posix_region_end)
15966         {
15967             /* Warnings about posix class issues are considered tentative until
15968              * we are far enough along in the parse that we can no longer
15969              * change our mind, at which point we either output them or add
15970              * them, if it has so specified, to what gets returned to the
15971              * caller.  This is done each time through the loop so that a later
15972              * class won't zap them before they have been dealt with. */
15973             output_or_return_posix_warnings(pRExC_state, posix_warnings,
15974                                             return_posix_warnings);
15975         }
15976
15977         if  (RExC_parse >= stop_ptr) {
15978             break;
15979         }
15980
15981         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
15982
15983         if  (UCHARAT(RExC_parse) == ']') {
15984             break;
15985         }
15986
15987       charclassloop:
15988
15989         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
15990         save_value = value;
15991         save_prevvalue = prevvalue;
15992
15993         if (!range) {
15994             rangebegin = RExC_parse;
15995             element_count++;
15996             non_portable_endpoint = 0;
15997         }
15998         if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) {
15999             value = utf8n_to_uvchr((U8*)RExC_parse,
16000                                    RExC_end - RExC_parse,
16001                                    &numlen, UTF8_ALLOW_DEFAULT);
16002             RExC_parse += numlen;
16003         }
16004         else
16005             value = UCHARAT(RExC_parse++);
16006
16007         if (value == '[') {
16008             char * posix_class_end;
16009             namedclass = handle_possible_posix(pRExC_state,
16010                                                RExC_parse,
16011                                                &posix_class_end,
16012                                                do_posix_warnings ? &posix_warnings : NULL,
16013                                                FALSE    /* die if error */);
16014             if (namedclass > OOB_NAMEDCLASS) {
16015
16016                 /* If there was an earlier attempt to parse this particular
16017                  * posix class, and it failed, it was a false alarm, as this
16018                  * successful one proves */
16019                 if (   posix_warnings
16020                     && av_tindex_nomg(posix_warnings) >= 0
16021                     && not_posix_region_end >= RExC_parse
16022                     && not_posix_region_end <= posix_class_end)
16023                 {
16024                     av_undef(posix_warnings);
16025                 }
16026
16027                 RExC_parse = posix_class_end;
16028             }
16029             else if (namedclass == OOB_NAMEDCLASS) {
16030                 not_posix_region_end = posix_class_end;
16031             }
16032             else {
16033                 namedclass = OOB_NAMEDCLASS;
16034             }
16035         }
16036         else if (   RExC_parse - 1 > not_posix_region_end
16037                  && MAYBE_POSIXCC(value))
16038         {
16039             (void) handle_possible_posix(
16040                         pRExC_state,
16041                         RExC_parse - 1,  /* -1 because parse has already been
16042                                             advanced */
16043                         &not_posix_region_end,
16044                         do_posix_warnings ? &posix_warnings : NULL,
16045                         TRUE /* checking only */);
16046         }
16047         else if (value == '\\') {
16048             /* Is a backslash; get the code point of the char after it */
16049
16050             if (RExC_parse >= RExC_end) {
16051                 vFAIL("Unmatched [");
16052             }
16053
16054             if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) {
16055                 value = utf8n_to_uvchr((U8*)RExC_parse,
16056                                    RExC_end - RExC_parse,
16057                                    &numlen, UTF8_ALLOW_DEFAULT);
16058                 RExC_parse += numlen;
16059             }
16060             else
16061                 value = UCHARAT(RExC_parse++);
16062
16063             /* Some compilers cannot handle switching on 64-bit integer
16064              * values, therefore value cannot be an UV.  Yes, this will
16065              * be a problem later if we want switch on Unicode.
16066              * A similar issue a little bit later when switching on
16067              * namedclass. --jhi */
16068
16069             /* If the \ is escaping white space when white space is being
16070              * skipped, it means that that white space is wanted literally, and
16071              * is already in 'value'.  Otherwise, need to translate the escape
16072              * into what it signifies. */
16073             if (! skip_white || ! isBLANK_A(value)) switch ((I32)value) {
16074
16075             case 'w':   namedclass = ANYOF_WORDCHAR;    break;
16076             case 'W':   namedclass = ANYOF_NWORDCHAR;   break;
16077             case 's':   namedclass = ANYOF_SPACE;       break;
16078             case 'S':   namedclass = ANYOF_NSPACE;      break;
16079             case 'd':   namedclass = ANYOF_DIGIT;       break;
16080             case 'D':   namedclass = ANYOF_NDIGIT;      break;
16081             case 'v':   namedclass = ANYOF_VERTWS;      break;
16082             case 'V':   namedclass = ANYOF_NVERTWS;     break;
16083             case 'h':   namedclass = ANYOF_HORIZWS;     break;
16084             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
16085             case 'N':  /* Handle \N{NAME} in class */
16086                 {
16087                     const char * const backslash_N_beg = RExC_parse - 2;
16088                     int cp_count;
16089
16090                     if (! grok_bslash_N(pRExC_state,
16091                                         NULL,      /* No regnode */
16092                                         &value,    /* Yes single value */
16093                                         &cp_count, /* Multiple code pt count */
16094                                         flagp,
16095                                         strict,
16096                                         depth)
16097                     ) {
16098
16099                         if (*flagp & NEED_UTF8)
16100                             FAIL("panic: grok_bslash_N set NEED_UTF8");
16101                         if (*flagp & RESTART_PASS1)
16102                             return NULL;
16103
16104                         if (cp_count < 0) {
16105                             vFAIL("\\N in a character class must be a named character: \\N{...}");
16106                         }
16107                         else if (cp_count == 0) {
16108                             if (PASS2) {
16109                                 ckWARNreg(RExC_parse,
16110                                         "Ignoring zero length \\N{} in character class");
16111                             }
16112                         }
16113                         else { /* cp_count > 1 */
16114                             if (! RExC_in_multi_char_class) {
16115                                 if (invert || range || *RExC_parse == '-') {
16116                                     if (strict) {
16117                                         RExC_parse--;
16118                                         vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character");
16119                                     }
16120                                     else if (PASS2) {
16121                                         ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class");
16122                                     }
16123                                     break; /* <value> contains the first code
16124                                               point. Drop out of the switch to
16125                                               process it */
16126                                 }
16127                                 else {
16128                                     SV * multi_char_N = newSVpvn(backslash_N_beg,
16129                                                  RExC_parse - backslash_N_beg);
16130                                     multi_char_matches
16131                                         = add_multi_match(multi_char_matches,
16132                                                           multi_char_N,
16133                                                           cp_count);
16134                                 }
16135                             }
16136                         } /* End of cp_count != 1 */
16137
16138                         /* This element should not be processed further in this
16139                          * class */
16140                         element_count--;
16141                         value = save_value;
16142                         prevvalue = save_prevvalue;
16143                         continue;   /* Back to top of loop to get next char */
16144                     }
16145
16146                     /* Here, is a single code point, and <value> contains it */
16147                     unicode_range = TRUE;   /* \N{} are Unicode */
16148                 }
16149                 break;
16150             case 'p':
16151             case 'P':
16152                 {
16153                 char *e;
16154
16155                 /* We will handle any undefined properties ourselves */
16156                 U8 swash_init_flags = _CORE_SWASH_INIT_RETURN_IF_UNDEF
16157                                        /* And we actually would prefer to get
16158                                         * the straight inversion list of the
16159                                         * swash, since we will be accessing it
16160                                         * anyway, to save a little time */
16161                                       |_CORE_SWASH_INIT_ACCEPT_INVLIST;
16162
16163                 if (RExC_parse >= RExC_end)
16164                     vFAIL2("Empty \\%c", (U8)value);
16165                 if (*RExC_parse == '{') {
16166                     const U8 c = (U8)value;
16167                     e = strchr(RExC_parse, '}');
16168                     if (!e) {
16169                         RExC_parse++;
16170                         vFAIL2("Missing right brace on \\%c{}", c);
16171                     }
16172
16173                     RExC_parse++;
16174                     while (isSPACE(*RExC_parse)) {
16175                          RExC_parse++;
16176                     }
16177
16178                     if (UCHARAT(RExC_parse) == '^') {
16179
16180                         /* toggle.  (The rhs xor gets the single bit that
16181                          * differs between P and p; the other xor inverts just
16182                          * that bit) */
16183                         value ^= 'P' ^ 'p';
16184
16185                         RExC_parse++;
16186                         while (isSPACE(*RExC_parse)) {
16187                             RExC_parse++;
16188                         }
16189                     }
16190
16191                     if (e == RExC_parse)
16192                         vFAIL2("Empty \\%c{}", c);
16193
16194                     n = e - RExC_parse;
16195                     while (isSPACE(*(RExC_parse + n - 1)))
16196                         n--;
16197                 }   /* The \p isn't immediately followed by a '{' */
16198                 else if (! isALPHA(*RExC_parse)) {
16199                     RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16200                     vFAIL2("Character following \\%c must be '{' or a "
16201                            "single-character Unicode property name",
16202                            (U8) value);
16203                 }
16204                 else {
16205                     e = RExC_parse;
16206                     n = 1;
16207                 }
16208                 if (!SIZE_ONLY) {
16209                     SV* invlist;
16210                     char* name;
16211                     char* base_name;    /* name after any packages are stripped */
16212                     char* lookup_name = NULL;
16213                     const char * const colon_colon = "::";
16214
16215                     /* Try to get the definition of the property into
16216                      * <invlist>.  If /i is in effect, the effective property
16217                      * will have its name be <__NAME_i>.  The design is
16218                      * discussed in commit
16219                      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
16220                     name = savepv(Perl_form(aTHX_ "%.*s", (int)n, RExC_parse));
16221                     SAVEFREEPV(name);
16222                     if (FOLD) {
16223                         lookup_name = savepv(Perl_form(aTHX_ "__%s_i", name));
16224
16225                         /* The function call just below that uses this can fail
16226                          * to return, leaking memory if we don't do this */
16227                         SAVEFREEPV(lookup_name);
16228                     }
16229
16230                     /* Look up the property name, and get its swash and
16231                      * inversion list, if the property is found  */
16232                     SvREFCNT_dec(swash); /* Free any left-overs */
16233                     swash = _core_swash_init("utf8",
16234                                              (lookup_name)
16235                                               ? lookup_name
16236                                               : name,
16237                                              &PL_sv_undef,
16238                                              1, /* binary */
16239                                              0, /* not tr/// */
16240                                              NULL, /* No inversion list */
16241                                              &swash_init_flags
16242                                             );
16243                     if (! swash || ! (invlist = _get_swash_invlist(swash))) {
16244                         HV* curpkg = (IN_PERL_COMPILETIME)
16245                                       ? PL_curstash
16246                                       : CopSTASH(PL_curcop);
16247                         UV final_n = n;
16248                         bool has_pkg;
16249
16250                         if (swash) {    /* Got a swash but no inversion list.
16251                                            Something is likely wrong that will
16252                                            be sorted-out later */
16253                             SvREFCNT_dec_NN(swash);
16254                             swash = NULL;
16255                         }
16256
16257                         /* Here didn't find it.  It could be a an error (like a
16258                          * typo) in specifying a Unicode property, or it could
16259                          * be a user-defined property that will be available at
16260                          * run-time.  The names of these must begin with 'In'
16261                          * or 'Is' (after any packages are stripped off).  So
16262                          * if not one of those, or if we accept only
16263                          * compile-time properties, is an error; otherwise add
16264                          * it to the list for run-time look up. */
16265                         if ((base_name = rninstr(name, name + n,
16266                                                  colon_colon, colon_colon + 2)))
16267                         { /* Has ::.  We know this must be a user-defined
16268                              property */
16269                             base_name += 2;
16270                             final_n -= base_name - name;
16271                             has_pkg = TRUE;
16272                         }
16273                         else {
16274                             base_name = name;
16275                             has_pkg = FALSE;
16276                         }
16277
16278                         if (   final_n < 3
16279                             || base_name[0] != 'I'
16280                             || (base_name[1] != 's' && base_name[1] != 'n')
16281                             || ret_invlist)
16282                         {
16283                             const char * const msg
16284                                 = (has_pkg)
16285                                   ? "Illegal user-defined property name"
16286                                   : "Can't find Unicode property definition";
16287                             RExC_parse = e + 1;
16288
16289                             /* diag_listed_as: Can't find Unicode property definition "%s" */
16290                             vFAIL3utf8f("%s \"%" UTF8f "\"",
16291                                 msg, UTF8fARG(UTF, n, name));
16292                         }
16293
16294                         /* If the property name doesn't already have a package
16295                          * name, add the current one to it so that it can be
16296                          * referred to outside it. [perl #121777] */
16297                         if (! has_pkg && curpkg) {
16298                             char* pkgname = HvNAME(curpkg);
16299                             if (strNE(pkgname, "main")) {
16300                                 char* full_name = Perl_form(aTHX_
16301                                                             "%s::%s",
16302                                                             pkgname,
16303                                                             name);
16304                                 n = strlen(full_name);
16305                                 name = savepvn(full_name, n);
16306                                 SAVEFREEPV(name);
16307                             }
16308                         }
16309                         Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%" UTF8f "%s\n",
16310                                         (value == 'p' ? '+' : '!'),
16311                                         (FOLD) ? "__" : "",
16312                                         UTF8fARG(UTF, n, name),
16313                                         (FOLD) ? "_i" : "");
16314                         has_user_defined_property = TRUE;
16315                         optimizable = FALSE;    /* Will have to leave this an
16316                                                    ANYOF node */
16317
16318                         /* We don't know yet what this matches, so have to flag
16319                          * it */
16320                         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
16321                     }
16322                     else {
16323
16324                         /* Here, did get the swash and its inversion list.  If
16325                          * the swash is from a user-defined property, then this
16326                          * whole character class should be regarded as such */
16327                         if (swash_init_flags
16328                             & _CORE_SWASH_INIT_USER_DEFINED_PROPERTY)
16329                         {
16330                             has_user_defined_property = TRUE;
16331                         }
16332                         else if
16333                             /* We warn on matching an above-Unicode code point
16334                              * if the match would return true, except don't
16335                              * warn for \p{All}, which has exactly one element
16336                              * = 0 */
16337                             (_invlist_contains_cp(invlist, 0x110000)
16338                                 && (! (_invlist_len(invlist) == 1
16339                                        && *invlist_array(invlist) == 0)))
16340                         {
16341                             warn_super = TRUE;
16342                         }
16343
16344
16345                         /* Invert if asking for the complement */
16346                         if (value == 'P') {
16347                             _invlist_union_complement_2nd(properties,
16348                                                           invlist,
16349                                                           &properties);
16350
16351                             /* The swash can't be used as-is, because we've
16352                              * inverted things; delay removing it to here after
16353                              * have copied its invlist above */
16354                             SvREFCNT_dec_NN(swash);
16355                             swash = NULL;
16356                         }
16357                         else {
16358                             _invlist_union(properties, invlist, &properties);
16359                         }
16360                     }
16361                 }
16362                 RExC_parse = e + 1;
16363                 namedclass = ANYOF_UNIPROP;  /* no official name, but it's
16364                                                 named */
16365
16366                 /* \p means they want Unicode semantics */
16367                 REQUIRE_UNI_RULES(flagp, NULL);
16368                 }
16369                 break;
16370             case 'n':   value = '\n';                   break;
16371             case 'r':   value = '\r';                   break;
16372             case 't':   value = '\t';                   break;
16373             case 'f':   value = '\f';                   break;
16374             case 'b':   value = '\b';                   break;
16375             case 'e':   value = ESC_NATIVE;             break;
16376             case 'a':   value = '\a';                   break;
16377             case 'o':
16378                 RExC_parse--;   /* function expects to be pointed at the 'o' */
16379                 {
16380                     const char* error_msg;
16381                     bool valid = grok_bslash_o(&RExC_parse,
16382                                                &value,
16383                                                &error_msg,
16384                                                PASS2,   /* warnings only in
16385                                                            pass 2 */
16386                                                strict,
16387                                                silence_non_portable,
16388                                                UTF);
16389                     if (! valid) {
16390                         vFAIL(error_msg);
16391                     }
16392                 }
16393                 non_portable_endpoint++;
16394                 break;
16395             case 'x':
16396                 RExC_parse--;   /* function expects to be pointed at the 'x' */
16397                 {
16398                     const char* error_msg;
16399                     bool valid = grok_bslash_x(&RExC_parse,
16400                                                &value,
16401                                                &error_msg,
16402                                                PASS2, /* Output warnings */
16403                                                strict,
16404                                                silence_non_portable,
16405                                                UTF);
16406                     if (! valid) {
16407                         vFAIL(error_msg);
16408                     }
16409                 }
16410                 non_portable_endpoint++;
16411                 break;
16412             case 'c':
16413                 value = grok_bslash_c(*RExC_parse++, PASS2);
16414                 non_portable_endpoint++;
16415                 break;
16416             case '0': case '1': case '2': case '3': case '4':
16417             case '5': case '6': case '7':
16418                 {
16419                     /* Take 1-3 octal digits */
16420                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
16421                     numlen = (strict) ? 4 : 3;
16422                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
16423                     RExC_parse += numlen;
16424                     if (numlen != 3) {
16425                         if (strict) {
16426                             RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
16427                             vFAIL("Need exactly 3 octal digits");
16428                         }
16429                         else if (! SIZE_ONLY /* like \08, \178 */
16430                                  && numlen < 3
16431                                  && RExC_parse < RExC_end
16432                                  && isDIGIT(*RExC_parse)
16433                                  && ckWARN(WARN_REGEXP))
16434                         {
16435                             SAVEFREESV(RExC_rx_sv);
16436                             reg_warn_non_literal_string(
16437                                  RExC_parse + 1,
16438                                  form_short_octal_warning(RExC_parse, numlen));
16439                             (void)ReREFCNT_inc(RExC_rx_sv);
16440                         }
16441                     }
16442                     non_portable_endpoint++;
16443                     break;
16444                 }
16445             default:
16446                 /* Allow \_ to not give an error */
16447                 if (!SIZE_ONLY && isWORDCHAR(value) && value != '_') {
16448                     if (strict) {
16449                         vFAIL2("Unrecognized escape \\%c in character class",
16450                                (int)value);
16451                     }
16452                     else {
16453                         SAVEFREESV(RExC_rx_sv);
16454                         ckWARN2reg(RExC_parse,
16455                             "Unrecognized escape \\%c in character class passed through",
16456                             (int)value);
16457                         (void)ReREFCNT_inc(RExC_rx_sv);
16458                     }
16459                 }
16460                 break;
16461             }   /* End of switch on char following backslash */
16462         } /* end of handling backslash escape sequences */
16463
16464         /* Here, we have the current token in 'value' */
16465
16466         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
16467             U8 classnum;
16468
16469             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
16470              * literal, as is the character that began the false range, i.e.
16471              * the 'a' in the examples */
16472             if (range) {
16473                 if (!SIZE_ONLY) {
16474                     const int w = (RExC_parse >= rangebegin)
16475                                   ? RExC_parse - rangebegin
16476                                   : 0;
16477                     if (strict) {
16478                         vFAIL2utf8f(
16479                             "False [] range \"%" UTF8f "\"",
16480                             UTF8fARG(UTF, w, rangebegin));
16481                     }
16482                     else {
16483                         SAVEFREESV(RExC_rx_sv); /* in case of fatal warnings */
16484                         ckWARN2reg(RExC_parse,
16485                             "False [] range \"%" UTF8f "\"",
16486                             UTF8fARG(UTF, w, rangebegin));
16487                         (void)ReREFCNT_inc(RExC_rx_sv);
16488                         cp_list = add_cp_to_invlist(cp_list, '-');
16489                         cp_foldable_list = add_cp_to_invlist(cp_foldable_list,
16490                                                              prevvalue);
16491                     }
16492                 }
16493
16494                 range = 0; /* this was not a true range */
16495                 element_count += 2; /* So counts for three values */
16496             }
16497
16498             classnum = namedclass_to_classnum(namedclass);
16499
16500             if (LOC && namedclass < ANYOF_POSIXL_MAX
16501 #ifndef HAS_ISASCII
16502                 && classnum != _CC_ASCII
16503 #endif
16504             ) {
16505                 /* What the Posix classes (like \w, [:space:]) match in locale
16506                  * isn't knowable under locale until actual match time.  Room
16507                  * must be reserved (one time per outer bracketed class) to
16508                  * store such classes.  The space will contain a bit for each
16509                  * named class that is to be matched against.  This isn't
16510                  * needed for \p{} and pseudo-classes, as they are not affected
16511                  * by locale, and hence are dealt with separately */
16512                 if (! need_class) {
16513                     need_class = 1;
16514                     if (SIZE_ONLY) {
16515                         RExC_size += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16516                     }
16517                     else {
16518                         RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP;
16519                     }
16520                     ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL;
16521                     ANYOF_POSIXL_ZERO(ret);
16522
16523                     /* We can't change this into some other type of node
16524                      * (unless this is the only element, in which case there
16525                      * are nodes that mean exactly this) as has runtime
16526                      * dependencies */
16527                     optimizable = FALSE;
16528                 }
16529
16530                 /* Coverity thinks it is possible for this to be negative; both
16531                  * jhi and khw think it's not, but be safer */
16532                 assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16533                        || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0);
16534
16535                 /* See if it already matches the complement of this POSIX
16536                  * class */
16537                 if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL)
16538                     && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2)
16539                                                             ? -1
16540                                                             : 1)))
16541                 {
16542                     posixl_matches_all = TRUE;
16543                     break;  /* No need to continue.  Since it matches both
16544                                e.g., \w and \W, it matches everything, and the
16545                                bracketed class can be optimized into qr/./s */
16546                 }
16547
16548                 /* Add this class to those that should be checked at runtime */
16549                 ANYOF_POSIXL_SET(ret, namedclass);
16550
16551                 /* The above-Latin1 characters are not subject to locale rules.
16552                  * Just add them, in the second pass, to the
16553                  * unconditionally-matched list */
16554                 if (! SIZE_ONLY) {
16555                     SV* scratch_list = NULL;
16556
16557                     /* Get the list of the above-Latin1 code points this
16558                      * matches */
16559                     _invlist_intersection_maybe_complement_2nd(PL_AboveLatin1,
16560                                           PL_XPosix_ptrs[classnum],
16561
16562                                           /* Odd numbers are complements, like
16563                                            * NDIGIT, NASCII, ... */
16564                                           namedclass % 2 != 0,
16565                                           &scratch_list);
16566                     /* Checking if 'cp_list' is NULL first saves an extra
16567                      * clone.  Its reference count will be decremented at the
16568                      * next union, etc, or if this is the only instance, at the
16569                      * end of the routine */
16570                     if (! cp_list) {
16571                         cp_list = scratch_list;
16572                     }
16573                     else {
16574                         _invlist_union(cp_list, scratch_list, &cp_list);
16575                         SvREFCNT_dec_NN(scratch_list);
16576                     }
16577                     continue;   /* Go get next character */
16578                 }
16579             }
16580             else if (! SIZE_ONLY) {
16581
16582                 /* Here, not in pass1 (in that pass we skip calculating the
16583                  * contents of this class), and is not /l, or is a POSIX class
16584                  * for which /l doesn't matter (or is a Unicode property, which
16585                  * is skipped here). */
16586                 if (namedclass >= ANYOF_POSIXL_MAX) {  /* If a special class */
16587                     if (namedclass != ANYOF_UNIPROP) { /* UNIPROP = \p and \P */
16588
16589                         /* Here, should be \h, \H, \v, or \V.  None of /d, /i
16590                          * nor /l make a difference in what these match,
16591                          * therefore we just add what they match to cp_list. */
16592                         if (classnum != _CC_VERTSPACE) {
16593                             assert(   namedclass == ANYOF_HORIZWS
16594                                    || namedclass == ANYOF_NHORIZWS);
16595
16596                             /* It turns out that \h is just a synonym for
16597                              * XPosixBlank */
16598                             classnum = _CC_BLANK;
16599                         }
16600
16601                         _invlist_union_maybe_complement_2nd(
16602                                 cp_list,
16603                                 PL_XPosix_ptrs[classnum],
16604                                 namedclass % 2 != 0,    /* Complement if odd
16605                                                           (NHORIZWS, NVERTWS)
16606                                                         */
16607                                 &cp_list);
16608                     }
16609                 }
16610                 else if (  UNI_SEMANTICS
16611                         || classnum == _CC_ASCII
16612                         || (DEPENDS_SEMANTICS && (   classnum == _CC_DIGIT
16613                                                   || classnum == _CC_XDIGIT)))
16614                 {
16615                     /* We usually have to worry about /d and /a affecting what
16616                      * POSIX classes match, with special code needed for /d
16617                      * because we won't know until runtime what all matches.
16618                      * But there is no extra work needed under /u, and
16619                      * [:ascii:] is unaffected by /a and /d; and :digit: and
16620                      * :xdigit: don't have runtime differences under /d.  So we
16621                      * can special case these, and avoid some extra work below,
16622                      * and at runtime. */
16623                     _invlist_union_maybe_complement_2nd(
16624                                                      simple_posixes,
16625                                                      PL_XPosix_ptrs[classnum],
16626                                                      namedclass % 2 != 0,
16627                                                      &simple_posixes);
16628                 }
16629                 else {  /* Garden variety class.  If is NUPPER, NALPHA, ...
16630                            complement and use nposixes */
16631                     SV** posixes_ptr = namedclass % 2 == 0
16632                                        ? &posixes
16633                                        : &nposixes;
16634                     _invlist_union_maybe_complement_2nd(
16635                                                      *posixes_ptr,
16636                                                      PL_XPosix_ptrs[classnum],
16637                                                      namedclass % 2 != 0,
16638                                                      posixes_ptr);
16639                 }
16640             }
16641         } /* end of namedclass \blah */
16642
16643         SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse);
16644
16645         /* If 'range' is set, 'value' is the ending of a range--check its
16646          * validity.  (If value isn't a single code point in the case of a
16647          * range, we should have figured that out above in the code that
16648          * catches false ranges).  Later, we will handle each individual code
16649          * point in the range.  If 'range' isn't set, this could be the
16650          * beginning of a range, so check for that by looking ahead to see if
16651          * the next real character to be processed is the range indicator--the
16652          * minus sign */
16653
16654         if (range) {
16655 #ifdef EBCDIC
16656             /* For unicode ranges, we have to test that the Unicode as opposed
16657              * to the native values are not decreasing.  (Above 255, there is
16658              * no difference between native and Unicode) */
16659             if (unicode_range && prevvalue < 255 && value < 255) {
16660                 if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) {
16661                     goto backwards_range;
16662                 }
16663             }
16664             else
16665 #endif
16666             if (prevvalue > value) /* b-a */ {
16667                 int w;
16668 #ifdef EBCDIC
16669               backwards_range:
16670 #endif
16671                 w = RExC_parse - rangebegin;
16672                 vFAIL2utf8f(
16673                     "Invalid [] range \"%" UTF8f "\"",
16674                     UTF8fARG(UTF, w, rangebegin));
16675                 NOT_REACHED; /* NOTREACHED */
16676             }
16677         }
16678         else {
16679             prevvalue = value; /* save the beginning of the potential range */
16680             if (! stop_at_1     /* Can't be a range if parsing just one thing */
16681                 && *RExC_parse == '-')
16682             {
16683                 char* next_char_ptr = RExC_parse + 1;
16684
16685                 /* Get the next real char after the '-' */
16686                 SKIP_BRACKETED_WHITE_SPACE(skip_white, next_char_ptr);
16687
16688                 /* If the '-' is at the end of the class (just before the ']',
16689                  * it is a literal minus; otherwise it is a range */
16690                 if (next_char_ptr < RExC_end && *next_char_ptr != ']') {
16691                     RExC_parse = next_char_ptr;
16692
16693                     /* a bad range like \w-, [:word:]- ? */
16694                     if (namedclass > OOB_NAMEDCLASS) {
16695                         if (strict || (PASS2 && ckWARN(WARN_REGEXP))) {
16696                             const int w = RExC_parse >= rangebegin
16697                                           ?  RExC_parse - rangebegin
16698                                           : 0;
16699                             if (strict) {
16700                                 vFAIL4("False [] range \"%*.*s\"",
16701                                     w, w, rangebegin);
16702                             }
16703                             else if (PASS2) {
16704                                 vWARN4(RExC_parse,
16705                                     "False [] range \"%*.*s\"",
16706                                     w, w, rangebegin);
16707                             }
16708                         }
16709                         if (!SIZE_ONLY) {
16710                             cp_list = add_cp_to_invlist(cp_list, '-');
16711                         }
16712                         element_count++;
16713                     } else
16714                         range = 1;      /* yeah, it's a range! */
16715                     continue;   /* but do it the next time */
16716                 }
16717             }
16718         }
16719
16720         if (namedclass > OOB_NAMEDCLASS) {
16721             continue;
16722         }
16723
16724         /* Here, we have a single value this time through the loop, and
16725          * <prevvalue> is the beginning of the range, if any; or <value> if
16726          * not. */
16727
16728         /* non-Latin1 code point implies unicode semantics.  Must be set in
16729          * pass1 so is there for the whole of pass 2 */
16730         if (value > 255) {
16731             REQUIRE_UNI_RULES(flagp, NULL);
16732         }
16733
16734         /* Ready to process either the single value, or the completed range.
16735          * For single-valued non-inverted ranges, we consider the possibility
16736          * of multi-char folds.  (We made a conscious decision to not do this
16737          * for the other cases because it can often lead to non-intuitive
16738          * results.  For example, you have the peculiar case that:
16739          *  "s s" =~ /^[^\xDF]+$/i => Y
16740          *  "ss"  =~ /^[^\xDF]+$/i => N
16741          *
16742          * See [perl #89750] */
16743         if (FOLD && allow_multi_folds && value == prevvalue) {
16744             if (value == LATIN_SMALL_LETTER_SHARP_S
16745                 || (value > 255 && _invlist_contains_cp(PL_HasMultiCharFold,
16746                                                         value)))
16747             {
16748                 /* Here <value> is indeed a multi-char fold.  Get what it is */
16749
16750                 U8 foldbuf[UTF8_MAXBYTES_CASE];
16751                 STRLEN foldlen;
16752
16753                 UV folded = _to_uni_fold_flags(
16754                                 value,
16755                                 foldbuf,
16756                                 &foldlen,
16757                                 FOLD_FLAGS_FULL | (ASCII_FOLD_RESTRICTED
16758                                                    ? FOLD_FLAGS_NOMIX_ASCII
16759                                                    : 0)
16760                                 );
16761
16762                 /* Here, <folded> should be the first character of the
16763                  * multi-char fold of <value>, with <foldbuf> containing the
16764                  * whole thing.  But, if this fold is not allowed (because of
16765                  * the flags), <fold> will be the same as <value>, and should
16766                  * be processed like any other character, so skip the special
16767                  * handling */
16768                 if (folded != value) {
16769
16770                     /* Skip if we are recursed, currently parsing the class
16771                      * again.  Otherwise add this character to the list of
16772                      * multi-char folds. */
16773                     if (! RExC_in_multi_char_class) {
16774                         STRLEN cp_count = utf8_length(foldbuf,
16775                                                       foldbuf + foldlen);
16776                         SV* multi_fold = sv_2mortal(newSVpvs(""));
16777
16778                         Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%" UVXf "}", value);
16779
16780                         multi_char_matches
16781                                         = add_multi_match(multi_char_matches,
16782                                                           multi_fold,
16783                                                           cp_count);
16784
16785                     }
16786
16787                     /* This element should not be processed further in this
16788                      * class */
16789                     element_count--;
16790                     value = save_value;
16791                     prevvalue = save_prevvalue;
16792                     continue;
16793                 }
16794             }
16795         }
16796
16797         if (strict && PASS2 && ckWARN(WARN_REGEXP)) {
16798             if (range) {
16799
16800                 /* If the range starts above 255, everything is portable and
16801                  * likely to be so for any forseeable character set, so don't
16802                  * warn. */
16803                 if (unicode_range && non_portable_endpoint && prevvalue < 256) {
16804                     vWARN(RExC_parse, "Both or neither range ends should be Unicode");
16805                 }
16806                 else if (prevvalue != value) {
16807
16808                     /* Under strict, ranges that stop and/or end in an ASCII
16809                      * printable should have each end point be a portable value
16810                      * for it (preferably like 'A', but we don't warn if it is
16811                      * a (portable) Unicode name or code point), and the range
16812                      * must be be all digits or all letters of the same case.
16813                      * Otherwise, the range is non-portable and unclear as to
16814                      * what it contains */
16815                     if ((isPRINT_A(prevvalue) || isPRINT_A(value))
16816                         && (non_portable_endpoint
16817                             || ! ((isDIGIT_A(prevvalue) && isDIGIT_A(value))
16818                                    || (isLOWER_A(prevvalue) && isLOWER_A(value))
16819                                    || (isUPPER_A(prevvalue) && isUPPER_A(value)))))
16820                     {
16821                         vWARN(RExC_parse, "Ranges of ASCII printables should be some subset of \"0-9\", \"A-Z\", or \"a-z\"");
16822                     }
16823                     else if (prevvalue >= 0x660) { /* ARABIC_INDIC_DIGIT_ZERO */
16824
16825                         /* But the nature of Unicode and languages mean we
16826                          * can't do the same checks for above-ASCII ranges,
16827                          * except in the case of digit ones.  These should
16828                          * contain only digits from the same group of 10.  The
16829                          * ASCII case is handled just above.  0x660 is the
16830                          * first digit character beyond ASCII.  Hence here, the
16831                          * range could be a range of digits.  Find out.  */
16832                         IV index_start = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16833                                                          prevvalue);
16834                         IV index_final = _invlist_search(PL_XPosix_ptrs[_CC_DIGIT],
16835                                                          value);
16836
16837                         /* If the range start and final points are in the same
16838                          * inversion list element, it means that either both
16839                          * are not digits, or both are digits in a consecutive
16840                          * sequence of digits.  (So far, Unicode has kept all
16841                          * such sequences as distinct groups of 10, but assert
16842                          * to make sure).  If the end points are not in the
16843                          * same element, neither should be a digit. */
16844                         if (index_start == index_final) {
16845                             assert(! ELEMENT_RANGE_MATCHES_INVLIST(index_start)
16846                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16847                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16848                                == 10)
16849                                /* But actually Unicode did have one group of 11
16850                                 * 'digits' in 5.2, so in case we are operating
16851                                 * on that version, let that pass */
16852                             || (invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start+1]
16853                                - invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16854                                 == 11
16855                                && invlist_array(PL_XPosix_ptrs[_CC_DIGIT])[index_start]
16856                                 == 0x19D0)
16857                             );
16858                         }
16859                         else if ((index_start >= 0
16860                                   && ELEMENT_RANGE_MATCHES_INVLIST(index_start))
16861                                  || (index_final >= 0
16862                                      && ELEMENT_RANGE_MATCHES_INVLIST(index_final)))
16863                         {
16864                             vWARN(RExC_parse, "Ranges of digits should be from the same group of 10");
16865                         }
16866                     }
16867                 }
16868             }
16869             if ((! range || prevvalue == value) && non_portable_endpoint) {
16870                 if (isPRINT_A(value)) {
16871                     char literal[3];
16872                     unsigned d = 0;
16873                     if (isBACKSLASHED_PUNCT(value)) {
16874                         literal[d++] = '\\';
16875                     }
16876                     literal[d++] = (char) value;
16877                     literal[d++] = '\0';
16878
16879                     vWARN4(RExC_parse,
16880                            "\"%.*s\" is more clearly written simply as \"%s\"",
16881                            (int) (RExC_parse - rangebegin),
16882                            rangebegin,
16883                            literal
16884                         );
16885                 }
16886                 else if isMNEMONIC_CNTRL(value) {
16887                     vWARN4(RExC_parse,
16888                            "\"%.*s\" is more clearly written simply as \"%s\"",
16889                            (int) (RExC_parse - rangebegin),
16890                            rangebegin,
16891                            cntrl_to_mnemonic((U8) value)
16892                         );
16893                 }
16894             }
16895         }
16896
16897         /* Deal with this element of the class */
16898         if (! SIZE_ONLY) {
16899
16900 #ifndef EBCDIC
16901             cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16902                                                      prevvalue, value);
16903 #else
16904             /* On non-ASCII platforms, for ranges that span all of 0..255, and
16905              * ones that don't require special handling, we can just add the
16906              * range like we do for ASCII platforms */
16907             if ((UNLIKELY(prevvalue == 0) && value >= 255)
16908                 || ! (prevvalue < 256
16909                       && (unicode_range
16910                           || (! non_portable_endpoint
16911                               && ((isLOWER_A(prevvalue) && isLOWER_A(value))
16912                                   || (isUPPER_A(prevvalue)
16913                                       && isUPPER_A(value)))))))
16914             {
16915                 cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16916                                                          prevvalue, value);
16917             }
16918             else {
16919                 /* Here, requires special handling.  This can be because it is
16920                  * a range whose code points are considered to be Unicode, and
16921                  * so must be individually translated into native, or because
16922                  * its a subrange of 'A-Z' or 'a-z' which each aren't
16923                  * contiguous in EBCDIC, but we have defined them to include
16924                  * only the "expected" upper or lower case ASCII alphabetics.
16925                  * Subranges above 255 are the same in native and Unicode, so
16926                  * can be added as a range */
16927                 U8 start = NATIVE_TO_LATIN1(prevvalue);
16928                 unsigned j;
16929                 U8 end = (value < 256) ? NATIVE_TO_LATIN1(value) : 255;
16930                 for (j = start; j <= end; j++) {
16931                     cp_foldable_list = add_cp_to_invlist(cp_foldable_list, LATIN1_TO_NATIVE(j));
16932                 }
16933                 if (value > 255) {
16934                     cp_foldable_list = _add_range_to_invlist(cp_foldable_list,
16935                                                              256, value);
16936                 }
16937             }
16938 #endif
16939         }
16940
16941         range = 0; /* this range (if it was one) is done now */
16942     } /* End of loop through all the text within the brackets */
16943
16944
16945     if (   posix_warnings && av_tindex_nomg(posix_warnings) >= 0) {
16946         output_or_return_posix_warnings(pRExC_state, posix_warnings,
16947                                         return_posix_warnings);
16948     }
16949
16950     /* If anything in the class expands to more than one character, we have to
16951      * deal with them by building up a substitute parse string, and recursively
16952      * calling reg() on it, instead of proceeding */
16953     if (multi_char_matches) {
16954         SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP);
16955         I32 cp_count;
16956         STRLEN len;
16957         char *save_end = RExC_end;
16958         char *save_parse = RExC_parse;
16959         char *save_start = RExC_start;
16960         STRLEN prefix_end = 0;      /* We copy the character class after a
16961                                        prefix supplied here.  This is the size
16962                                        + 1 of that prefix */
16963         bool first_time = TRUE;     /* First multi-char occurrence doesn't get
16964                                        a "|" */
16965         I32 reg_flags;
16966
16967         assert(! invert);
16968         assert(RExC_precomp_adj == 0); /* Only one level of recursion allowed */
16969
16970 #if 0   /* Have decided not to deal with multi-char folds in inverted classes,
16971            because too confusing */
16972         if (invert) {
16973             sv_catpv(substitute_parse, "(?:");
16974         }
16975 #endif
16976
16977         /* Look at the longest folds first */
16978         for (cp_count = av_tindex_nomg(multi_char_matches);
16979                         cp_count > 0;
16980                         cp_count--)
16981         {
16982
16983             if (av_exists(multi_char_matches, cp_count)) {
16984                 AV** this_array_ptr;
16985                 SV* this_sequence;
16986
16987                 this_array_ptr = (AV**) av_fetch(multi_char_matches,
16988                                                  cp_count, FALSE);
16989                 while ((this_sequence = av_pop(*this_array_ptr)) !=
16990                                                                 &PL_sv_undef)
16991                 {
16992                     if (! first_time) {
16993                         sv_catpv(substitute_parse, "|");
16994                     }
16995                     first_time = FALSE;
16996
16997                     sv_catpv(substitute_parse, SvPVX(this_sequence));
16998                 }
16999             }
17000         }
17001
17002         /* If the character class contains anything else besides these
17003          * multi-character folds, have to include it in recursive parsing */
17004         if (element_count) {
17005             sv_catpv(substitute_parse, "|[");
17006             prefix_end = SvCUR(substitute_parse);
17007             sv_catpvn(substitute_parse, orig_parse, RExC_parse - orig_parse);
17008
17009             /* Put in a closing ']' only if not going off the end, as otherwise
17010              * we are adding something that really isn't there */
17011             if (RExC_parse < RExC_end) {
17012                 sv_catpv(substitute_parse, "]");
17013             }
17014         }
17015
17016         sv_catpv(substitute_parse, ")");
17017 #if 0
17018         if (invert) {
17019             /* This is a way to get the parse to skip forward a whole named
17020              * sequence instead of matching the 2nd character when it fails the
17021              * first */
17022             sv_catpv(substitute_parse, "(*THEN)(*SKIP)(*FAIL)|.)");
17023         }
17024 #endif
17025
17026         /* Set up the data structure so that any errors will be properly
17027          * reported.  See the comments at the definition of
17028          * REPORT_LOCATION_ARGS for details */
17029         RExC_precomp_adj = orig_parse - RExC_precomp;
17030         RExC_start =  RExC_parse = SvPV(substitute_parse, len);
17031         RExC_adjusted_start = RExC_start + prefix_end;
17032         RExC_end = RExC_parse + len;
17033         RExC_in_multi_char_class = 1;
17034         RExC_override_recoding = 1;
17035         RExC_emit = (regnode *)orig_emit;
17036
17037         ret = reg(pRExC_state, 1, &reg_flags, depth+1);
17038
17039         *flagp |= reg_flags&(HASWIDTH|SIMPLE|SPSTART|POSTPONED|RESTART_PASS1|NEED_UTF8);
17040
17041         /* And restore so can parse the rest of the pattern */
17042         RExC_parse = save_parse;
17043         RExC_start = RExC_adjusted_start = save_start;
17044         RExC_precomp_adj = 0;
17045         RExC_end = save_end;
17046         RExC_in_multi_char_class = 0;
17047         RExC_override_recoding = 0;
17048         SvREFCNT_dec_NN(multi_char_matches);
17049         return ret;
17050     }
17051
17052     /* Here, we've gone through the entire class and dealt with multi-char
17053      * folds.  We are now in a position that we can do some checks to see if we
17054      * can optimize this ANYOF node into a simpler one, even in Pass 1.
17055      * Currently we only do two checks:
17056      * 1) is in the unlikely event that the user has specified both, eg. \w and
17057      *    \W under /l, then the class matches everything.  (This optimization
17058      *    is done only to make the optimizer code run later work.)
17059      * 2) if the character class contains only a single element (including a
17060      *    single range), we see if there is an equivalent node for it.
17061      * Other checks are possible */
17062     if (   optimizable
17063         && ! ret_invlist   /* Can't optimize if returning the constructed
17064                               inversion list */
17065         && (UNLIKELY(posixl_matches_all) || element_count == 1))
17066     {
17067         U8 op = END;
17068         U8 arg = 0;
17069
17070         if (UNLIKELY(posixl_matches_all)) {
17071             op = SANY;
17072         }
17073         else if (namedclass > OOB_NAMEDCLASS) { /* this is a single named
17074                                                    class, like \w or [:digit:]
17075                                                    or \p{foo} */
17076
17077             /* All named classes are mapped into POSIXish nodes, with its FLAG
17078              * argument giving which class it is */
17079             switch ((I32)namedclass) {
17080                 case ANYOF_UNIPROP:
17081                     break;
17082
17083                 /* These don't depend on the charset modifiers.  They always
17084                  * match under /u rules */
17085                 case ANYOF_NHORIZWS:
17086                 case ANYOF_HORIZWS:
17087                     namedclass = ANYOF_BLANK + namedclass - ANYOF_HORIZWS;
17088                     /* FALLTHROUGH */
17089
17090                 case ANYOF_NVERTWS:
17091                 case ANYOF_VERTWS:
17092                     op = POSIXU;
17093                     goto join_posix;
17094
17095                 /* The actual POSIXish node for all the rest depends on the
17096                  * charset modifier.  The ones in the first set depend only on
17097                  * ASCII or, if available on this platform, also locale */
17098                 case ANYOF_ASCII:
17099                 case ANYOF_NASCII:
17100 #ifdef HAS_ISASCII
17101                     op = (LOC) ? POSIXL : POSIXA;
17102 #else
17103                     op = POSIXA;
17104 #endif
17105                     goto join_posix;
17106
17107                 /* The following don't have any matches in the upper Latin1
17108                  * range, hence /d is equivalent to /u for them.  Making it /u
17109                  * saves some branches at runtime */
17110                 case ANYOF_DIGIT:
17111                 case ANYOF_NDIGIT:
17112                 case ANYOF_XDIGIT:
17113                 case ANYOF_NXDIGIT:
17114                     if (! DEPENDS_SEMANTICS) {
17115                         goto treat_as_default;
17116                     }
17117
17118                     op = POSIXU;
17119                     goto join_posix;
17120
17121                 /* The following change to CASED under /i */
17122                 case ANYOF_LOWER:
17123                 case ANYOF_NLOWER:
17124                 case ANYOF_UPPER:
17125                 case ANYOF_NUPPER:
17126                     if (FOLD) {
17127                         namedclass = ANYOF_CASED + (namedclass % 2);
17128                     }
17129                     /* FALLTHROUGH */
17130
17131                 /* The rest have more possibilities depending on the charset.
17132                  * We take advantage of the enum ordering of the charset
17133                  * modifiers to get the exact node type, */
17134                 default:
17135                   treat_as_default:
17136                     op = POSIXD + get_regex_charset(RExC_flags);
17137                     if (op > POSIXA) { /* /aa is same as /a */
17138                         op = POSIXA;
17139                     }
17140
17141                   join_posix:
17142                     /* The odd numbered ones are the complements of the
17143                      * next-lower even number one */
17144                     if (namedclass % 2 == 1) {
17145                         invert = ! invert;
17146                         namedclass--;
17147                     }
17148                     arg = namedclass_to_classnum(namedclass);
17149                     break;
17150             }
17151         }
17152         else if (value == prevvalue) {
17153
17154             /* Here, the class consists of just a single code point */
17155
17156             if (invert) {
17157                 if (! LOC && value == '\n') {
17158                     op = REG_ANY; /* Optimize [^\n] */
17159                     *flagp |= HASWIDTH|SIMPLE;
17160                     MARK_NAUGHTY(1);
17161                 }
17162             }
17163             else if (value < 256 || UTF) {
17164
17165                 /* Optimize a single value into an EXACTish node, but not if it
17166                  * would require converting the pattern to UTF-8. */
17167                 op = compute_EXACTish(pRExC_state);
17168             }
17169         } /* Otherwise is a range */
17170         else if (! LOC) {   /* locale could vary these */
17171             if (prevvalue == '0') {
17172                 if (value == '9') {
17173                     arg = _CC_DIGIT;
17174                     op = POSIXA;
17175                 }
17176             }
17177             else if (! FOLD || ASCII_FOLD_RESTRICTED) {
17178                 /* We can optimize A-Z or a-z, but not if they could match
17179                  * something like the KELVIN SIGN under /i. */
17180                 if (prevvalue == 'A') {
17181                     if (value == 'Z'
17182 #ifdef EBCDIC
17183                         && ! non_portable_endpoint
17184 #endif
17185                     ) {
17186                         arg = (FOLD) ? _CC_ALPHA : _CC_UPPER;
17187                         op = POSIXA;
17188                     }
17189                 }
17190                 else if (prevvalue == 'a') {
17191                     if (value == 'z'
17192 #ifdef EBCDIC
17193                         && ! non_portable_endpoint
17194 #endif
17195                     ) {
17196                         arg = (FOLD) ? _CC_ALPHA : _CC_LOWER;
17197                         op = POSIXA;
17198                     }
17199                 }
17200             }
17201         }
17202
17203         /* Here, we have changed <op> away from its initial value iff we found
17204          * an optimization */
17205         if (op != END) {
17206
17207             /* Throw away this ANYOF regnode, and emit the calculated one,
17208              * which should correspond to the beginning, not current, state of
17209              * the parse */
17210             const char * cur_parse = RExC_parse;
17211             RExC_parse = (char *)orig_parse;
17212             if ( SIZE_ONLY) {
17213                 if (! LOC) {
17214
17215                     /* To get locale nodes to not use the full ANYOF size would
17216                      * require moving the code above that writes the portions
17217                      * of it that aren't in other nodes to after this point.
17218                      * e.g.  ANYOF_POSIXL_SET */
17219                     RExC_size = orig_size;
17220                 }
17221             }
17222             else {
17223                 RExC_emit = (regnode *)orig_emit;
17224                 if (PL_regkind[op] == POSIXD) {
17225                     if (op == POSIXL) {
17226                         RExC_contains_locale = 1;
17227                     }
17228                     if (invert) {
17229                         op += NPOSIXD - POSIXD;
17230                     }
17231                 }
17232             }
17233
17234             ret = reg_node(pRExC_state, op);
17235
17236             if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17237                 if (! SIZE_ONLY) {
17238                     FLAGS(ret) = arg;
17239                 }
17240                 *flagp |= HASWIDTH|SIMPLE;
17241             }
17242             else if (PL_regkind[op] == EXACT) {
17243                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17244                                            TRUE /* downgradable to EXACT */
17245                                            );
17246             }
17247
17248             RExC_parse = (char *) cur_parse;
17249
17250             SvREFCNT_dec(posixes);
17251             SvREFCNT_dec(nposixes);
17252             SvREFCNT_dec(simple_posixes);
17253             SvREFCNT_dec(cp_list);
17254             SvREFCNT_dec(cp_foldable_list);
17255             return ret;
17256         }
17257     }
17258
17259     if (SIZE_ONLY)
17260         return ret;
17261     /****** !SIZE_ONLY (Pass 2) AFTER HERE *********/
17262
17263     /* If folding, we calculate all characters that could fold to or from the
17264      * ones already on the list */
17265     if (cp_foldable_list) {
17266         if (FOLD) {
17267             UV start, end;      /* End points of code point ranges */
17268
17269             SV* fold_intersection = NULL;
17270             SV** use_list;
17271
17272             /* Our calculated list will be for Unicode rules.  For locale
17273              * matching, we have to keep a separate list that is consulted at
17274              * runtime only when the locale indicates Unicode rules.  For
17275              * non-locale, we just use the general list */
17276             if (LOC) {
17277                 use_list = &only_utf8_locale_list;
17278             }
17279             else {
17280                 use_list = &cp_list;
17281             }
17282
17283             /* Only the characters in this class that participate in folds need
17284              * be checked.  Get the intersection of this class and all the
17285              * possible characters that are foldable.  This can quickly narrow
17286              * down a large class */
17287             _invlist_intersection(PL_utf8_foldable, cp_foldable_list,
17288                                   &fold_intersection);
17289
17290             /* The folds for all the Latin1 characters are hard-coded into this
17291              * program, but we have to go out to disk to get the others. */
17292             if (invlist_highest(cp_foldable_list) >= 256) {
17293
17294                 /* This is a hash that for a particular fold gives all
17295                  * characters that are involved in it */
17296                 if (! PL_utf8_foldclosures) {
17297                     _load_PL_utf8_foldclosures();
17298                 }
17299             }
17300
17301             /* Now look at the foldable characters in this class individually */
17302             invlist_iterinit(fold_intersection);
17303             while (invlist_iternext(fold_intersection, &start, &end)) {
17304                 UV j;
17305
17306                 /* Look at every character in the range */
17307                 for (j = start; j <= end; j++) {
17308                     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
17309                     STRLEN foldlen;
17310                     SV** listp;
17311
17312                     if (j < 256) {
17313
17314                         if (IS_IN_SOME_FOLD_L1(j)) {
17315
17316                             /* ASCII is always matched; non-ASCII is matched
17317                              * only under Unicode rules (which could happen
17318                              * under /l if the locale is a UTF-8 one */
17319                             if (isASCII(j) || ! DEPENDS_SEMANTICS) {
17320                                 *use_list = add_cp_to_invlist(*use_list,
17321                                                             PL_fold_latin1[j]);
17322                             }
17323                             else {
17324                                 has_upper_latin1_only_utf8_matches
17325                                     = add_cp_to_invlist(
17326                                             has_upper_latin1_only_utf8_matches,
17327                                             PL_fold_latin1[j]);
17328                             }
17329                         }
17330
17331                         if (HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(j)
17332                             && (! isASCII(j) || ! ASCII_FOLD_RESTRICTED))
17333                         {
17334                             add_above_Latin1_folds(pRExC_state,
17335                                                    (U8) j,
17336                                                    use_list);
17337                         }
17338                         continue;
17339                     }
17340
17341                     /* Here is an above Latin1 character.  We don't have the
17342                      * rules hard-coded for it.  First, get its fold.  This is
17343                      * the simple fold, as the multi-character folds have been
17344                      * handled earlier and separated out */
17345                     _to_uni_fold_flags(j, foldbuf, &foldlen,
17346                                                         (ASCII_FOLD_RESTRICTED)
17347                                                         ? FOLD_FLAGS_NOMIX_ASCII
17348                                                         : 0);
17349
17350                     /* Single character fold of above Latin1.  Add everything in
17351                     * its fold closure to the list that this node should match.
17352                     * The fold closures data structure is a hash with the keys
17353                     * being the UTF-8 of every character that is folded to, like
17354                     * 'k', and the values each an array of all code points that
17355                     * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
17356                     * Multi-character folds are not included */
17357                     if ((listp = hv_fetch(PL_utf8_foldclosures,
17358                                         (char *) foldbuf, foldlen, FALSE)))
17359                     {
17360                         AV* list = (AV*) *listp;
17361                         IV k;
17362                         for (k = 0; k <= av_tindex_nomg(list); k++) {
17363                             SV** c_p = av_fetch(list, k, FALSE);
17364                             UV c;
17365                             assert(c_p);
17366
17367                             c = SvUV(*c_p);
17368
17369                             /* /aa doesn't allow folds between ASCII and non- */
17370                             if ((ASCII_FOLD_RESTRICTED
17371                                 && (isASCII(c) != isASCII(j))))
17372                             {
17373                                 continue;
17374                             }
17375
17376                             /* Folds under /l which cross the 255/256 boundary
17377                              * are added to a separate list.  (These are valid
17378                              * only when the locale is UTF-8.) */
17379                             if (c < 256 && LOC) {
17380                                 *use_list = add_cp_to_invlist(*use_list, c);
17381                                 continue;
17382                             }
17383
17384                             if (isASCII(c) || c > 255 || AT_LEAST_UNI_SEMANTICS)
17385                             {
17386                                 cp_list = add_cp_to_invlist(cp_list, c);
17387                             }
17388                             else {
17389                                 /* Similarly folds involving non-ascii Latin1
17390                                 * characters under /d are added to their list */
17391                                 has_upper_latin1_only_utf8_matches
17392                                         = add_cp_to_invlist(
17393                                            has_upper_latin1_only_utf8_matches,
17394                                            c);
17395                             }
17396                         }
17397                     }
17398                 }
17399             }
17400             SvREFCNT_dec_NN(fold_intersection);
17401         }
17402
17403         /* Now that we have finished adding all the folds, there is no reason
17404          * to keep the foldable list separate */
17405         _invlist_union(cp_list, cp_foldable_list, &cp_list);
17406         SvREFCNT_dec_NN(cp_foldable_list);
17407     }
17408
17409     /* And combine the result (if any) with any inversion lists from posix
17410      * classes.  The lists are kept separate up to now because we don't want to
17411      * fold the classes (folding of those is automatically handled by the swash
17412      * fetching code) */
17413     if (simple_posixes) {   /* These are the classes known to be unaffected by
17414                                /a, /aa, and /d */
17415         if (cp_list) {
17416             _invlist_union(cp_list, simple_posixes, &cp_list);
17417             SvREFCNT_dec_NN(simple_posixes);
17418         }
17419         else {
17420             cp_list = simple_posixes;
17421         }
17422     }
17423     if (posixes || nposixes) {
17424
17425         /* We have to adjust /a and /aa */
17426         if (AT_LEAST_ASCII_RESTRICTED) {
17427
17428             /* Under /a and /aa, nothing above ASCII matches these */
17429             if (posixes) {
17430                 _invlist_intersection(posixes,
17431                                     PL_XPosix_ptrs[_CC_ASCII],
17432                                     &posixes);
17433             }
17434
17435             /* Under /a and /aa, everything above ASCII matches these
17436              * complements */
17437             if (nposixes) {
17438                 _invlist_union_complement_2nd(nposixes,
17439                                               PL_XPosix_ptrs[_CC_ASCII],
17440                                               &nposixes);
17441             }
17442         }
17443
17444         if (! DEPENDS_SEMANTICS) {
17445
17446             /* For everything but /d, we can just add the current 'posixes' and
17447              * 'nposixes' to the main list */
17448             if (posixes) {
17449                 if (cp_list) {
17450                     _invlist_union(cp_list, posixes, &cp_list);
17451                     SvREFCNT_dec_NN(posixes);
17452                 }
17453                 else {
17454                     cp_list = posixes;
17455                 }
17456             }
17457             if (nposixes) {
17458                 if (cp_list) {
17459                     _invlist_union(cp_list, nposixes, &cp_list);
17460                     SvREFCNT_dec_NN(nposixes);
17461                 }
17462                 else {
17463                     cp_list = nposixes;
17464                 }
17465             }
17466         }
17467         else {
17468             /* Under /d, things like \w match upper Latin1 characters only if
17469              * the target string is in UTF-8.  But things like \W match all the
17470              * upper Latin1 characters if the target string is not in UTF-8.
17471              *
17472              * Handle the case where there something like \W separately */
17473             if (nposixes) {
17474                 SV* only_non_utf8_list = invlist_clone(PL_UpperLatin1);
17475
17476                 /* A complemented posix class matches all upper Latin1
17477                  * characters if not in UTF-8.  And it matches just certain
17478                  * ones when in UTF-8.  That means those certain ones are
17479                  * matched regardless, so can just be added to the
17480                  * unconditional list */
17481                 if (cp_list) {
17482                     _invlist_union(cp_list, nposixes, &cp_list);
17483                     SvREFCNT_dec_NN(nposixes);
17484                     nposixes = NULL;
17485                 }
17486                 else {
17487                     cp_list = nposixes;
17488                 }
17489
17490                 /* Likewise for 'posixes' */
17491                 _invlist_union(posixes, cp_list, &cp_list);
17492
17493                 /* Likewise for anything else in the range that matched only
17494                  * under UTF-8 */
17495                 if (has_upper_latin1_only_utf8_matches) {
17496                     _invlist_union(cp_list,
17497                                    has_upper_latin1_only_utf8_matches,
17498                                    &cp_list);
17499                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17500                     has_upper_latin1_only_utf8_matches = NULL;
17501                 }
17502
17503                 /* If we don't match all the upper Latin1 characters regardless
17504                  * of UTF-8ness, we have to set a flag to match the rest when
17505                  * not in UTF-8 */
17506                 _invlist_subtract(only_non_utf8_list, cp_list,
17507                                   &only_non_utf8_list);
17508                 if (_invlist_len(only_non_utf8_list) != 0) {
17509                     ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17510                 }
17511             }
17512             else {
17513                 /* Here there were no complemented posix classes.  That means
17514                  * the upper Latin1 characters in 'posixes' match only when the
17515                  * target string is in UTF-8.  So we have to add them to the
17516                  * list of those types of code points, while adding the
17517                  * remainder to the unconditional list.
17518                  *
17519                  * First calculate what they are */
17520                 SV* nonascii_but_latin1_properties = NULL;
17521                 _invlist_intersection(posixes, PL_UpperLatin1,
17522                                       &nonascii_but_latin1_properties);
17523
17524                 /* And add them to the final list of such characters. */
17525                 _invlist_union(has_upper_latin1_only_utf8_matches,
17526                                nonascii_but_latin1_properties,
17527                                &has_upper_latin1_only_utf8_matches);
17528
17529                 /* Remove them from what now becomes the unconditional list */
17530                 _invlist_subtract(posixes, nonascii_but_latin1_properties,
17531                                   &posixes);
17532
17533                 /* And add those unconditional ones to the final list */
17534                 if (cp_list) {
17535                     _invlist_union(cp_list, posixes, &cp_list);
17536                     SvREFCNT_dec_NN(posixes);
17537                     posixes = NULL;
17538                 }
17539                 else {
17540                     cp_list = posixes;
17541                 }
17542
17543                 SvREFCNT_dec(nonascii_but_latin1_properties);
17544
17545                 /* Get rid of any characters that we now know are matched
17546                  * unconditionally from the conditional list, which may make
17547                  * that list empty */
17548                 _invlist_subtract(has_upper_latin1_only_utf8_matches,
17549                                   cp_list,
17550                                   &has_upper_latin1_only_utf8_matches);
17551                 if (_invlist_len(has_upper_latin1_only_utf8_matches) == 0) {
17552                     SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17553                     has_upper_latin1_only_utf8_matches = NULL;
17554                 }
17555             }
17556         }
17557     }
17558
17559     /* And combine the result (if any) with any inversion list from properties.
17560      * The lists are kept separate up to now so that we can distinguish the two
17561      * in regards to matching above-Unicode.  A run-time warning is generated
17562      * if a Unicode property is matched against a non-Unicode code point. But,
17563      * we allow user-defined properties to match anything, without any warning,
17564      * and we also suppress the warning if there is a portion of the character
17565      * class that isn't a Unicode property, and which matches above Unicode, \W
17566      * or [\x{110000}] for example.
17567      * (Note that in this case, unlike the Posix one above, there is no
17568      * <has_upper_latin1_only_utf8_matches>, because having a Unicode property
17569      * forces Unicode semantics */
17570     if (properties) {
17571         if (cp_list) {
17572
17573             /* If it matters to the final outcome, see if a non-property
17574              * component of the class matches above Unicode.  If so, the
17575              * warning gets suppressed.  This is true even if just a single
17576              * such code point is specified, as, though not strictly correct if
17577              * another such code point is matched against, the fact that they
17578              * are using above-Unicode code points indicates they should know
17579              * the issues involved */
17580             if (warn_super) {
17581                 warn_super = ! (invert
17582                                ^ (invlist_highest(cp_list) > PERL_UNICODE_MAX));
17583             }
17584
17585             _invlist_union(properties, cp_list, &cp_list);
17586             SvREFCNT_dec_NN(properties);
17587         }
17588         else {
17589             cp_list = properties;
17590         }
17591
17592         if (warn_super) {
17593             ANYOF_FLAGS(ret)
17594              |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
17595
17596             /* Because an ANYOF node is the only one that warns, this node
17597              * can't be optimized into something else */
17598             optimizable = FALSE;
17599         }
17600     }
17601
17602     /* Here, we have calculated what code points should be in the character
17603      * class.
17604      *
17605      * Now we can see about various optimizations.  Fold calculation (which we
17606      * did above) needs to take place before inversion.  Otherwise /[^k]/i
17607      * would invert to include K, which under /i would match k, which it
17608      * shouldn't.  Therefore we can't invert folded locale now, as it won't be
17609      * folded until runtime */
17610
17611     /* If we didn't do folding, it's because some information isn't available
17612      * until runtime; set the run-time fold flag for these.  (We don't have to
17613      * worry about properties folding, as that is taken care of by the swash
17614      * fetching).  We know to set the flag if we have a non-NULL list for UTF-8
17615      * locales, or the class matches at least one 0-255 range code point */
17616     if (LOC && FOLD) {
17617
17618         /* Some things on the list might be unconditionally included because of
17619          * other components.  Remove them, and clean up the list if it goes to
17620          * 0 elements */
17621         if (only_utf8_locale_list && cp_list) {
17622             _invlist_subtract(only_utf8_locale_list, cp_list,
17623                               &only_utf8_locale_list);
17624
17625             if (_invlist_len(only_utf8_locale_list) == 0) {
17626                 SvREFCNT_dec_NN(only_utf8_locale_list);
17627                 only_utf8_locale_list = NULL;
17628             }
17629         }
17630         if (only_utf8_locale_list) {
17631             ANYOF_FLAGS(ret)
17632                  |=  ANYOFL_FOLD
17633                     |ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
17634         }
17635         else if (cp_list) { /* Look to see if a 0-255 code point is in list */
17636             UV start, end;
17637             invlist_iterinit(cp_list);
17638             if (invlist_iternext(cp_list, &start, &end) && start < 256) {
17639                 ANYOF_FLAGS(ret) |= ANYOFL_FOLD;
17640             }
17641             invlist_iterfinish(cp_list);
17642         }
17643     }
17644     else if (   DEPENDS_SEMANTICS
17645              && (    has_upper_latin1_only_utf8_matches
17646                  || (ANYOF_FLAGS(ret) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)))
17647     {
17648         OP(ret) = ANYOFD;
17649         optimizable = FALSE;
17650     }
17651
17652
17653     /* Optimize inverted simple patterns (e.g. [^a-z]) when everything is known
17654      * at compile time.  Besides not inverting folded locale now, we can't
17655      * invert if there are things such as \w, which aren't known until runtime
17656      * */
17657     if (cp_list
17658         && invert
17659         && OP(ret) != ANYOFD
17660         && ! (ANYOF_FLAGS(ret) & (ANYOF_LOCALE_FLAGS))
17661         && ! HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17662     {
17663         _invlist_invert(cp_list);
17664
17665         /* Any swash can't be used as-is, because we've inverted things */
17666         if (swash) {
17667             SvREFCNT_dec_NN(swash);
17668             swash = NULL;
17669         }
17670
17671         /* Clear the invert flag since have just done it here */
17672         invert = FALSE;
17673     }
17674
17675     if (ret_invlist) {
17676         assert(cp_list);
17677
17678         *ret_invlist = cp_list;
17679         SvREFCNT_dec(swash);
17680
17681         /* Discard the generated node */
17682         if (SIZE_ONLY) {
17683             RExC_size = orig_size;
17684         }
17685         else {
17686             RExC_emit = orig_emit;
17687         }
17688         return orig_emit;
17689     }
17690
17691     /* Some character classes are equivalent to other nodes.  Such nodes take
17692      * up less room and generally fewer operations to execute than ANYOF nodes.
17693      * Above, we checked for and optimized into some such equivalents for
17694      * certain common classes that are easy to test.  Getting to this point in
17695      * the code means that the class didn't get optimized there.  Since this
17696      * code is only executed in Pass 2, it is too late to save space--it has
17697      * been allocated in Pass 1, and currently isn't given back.  But turning
17698      * things into an EXACTish node can allow the optimizer to join it to any
17699      * adjacent such nodes.  And if the class is equivalent to things like /./,
17700      * expensive run-time swashes can be avoided.  Now that we have more
17701      * complete information, we can find things necessarily missed by the
17702      * earlier code.  Another possible "optimization" that isn't done is that
17703      * something like [Ee] could be changed into an EXACTFU.  khw tried this
17704      * and found that the ANYOF is faster, including for code points not in the
17705      * bitmap.  This still might make sense to do, provided it got joined with
17706      * an adjacent node(s) to create a longer EXACTFU one.  This could be
17707      * accomplished by creating a pseudo ANYOF_EXACTFU node type that the join
17708      * routine would know is joinable.  If that didn't happen, the node type
17709      * could then be made a straight ANYOF */
17710
17711     if (optimizable && cp_list && ! invert) {
17712         UV start, end;
17713         U8 op = END;  /* The optimzation node-type */
17714         int posix_class = -1;   /* Illegal value */
17715         const char * cur_parse= RExC_parse;
17716
17717         invlist_iterinit(cp_list);
17718         if (! invlist_iternext(cp_list, &start, &end)) {
17719
17720             /* Here, the list is empty.  This happens, for example, when a
17721              * Unicode property that doesn't match anything is the only element
17722              * in the character class (perluniprops.pod notes such properties).
17723              * */
17724             op = OPFAIL;
17725             *flagp |= HASWIDTH|SIMPLE;
17726         }
17727         else if (start == end) {    /* The range is a single code point */
17728             if (! invlist_iternext(cp_list, &start, &end)
17729
17730                     /* Don't do this optimization if it would require changing
17731                      * the pattern to UTF-8 */
17732                 && (start < 256 || UTF))
17733             {
17734                 /* Here, the list contains a single code point.  Can optimize
17735                  * into an EXACTish node */
17736
17737                 value = start;
17738
17739                 if (! FOLD) {
17740                     op = (LOC)
17741                          ? EXACTL
17742                          : EXACT;
17743                 }
17744                 else if (LOC) {
17745
17746                     /* A locale node under folding with one code point can be
17747                      * an EXACTFL, as its fold won't be calculated until
17748                      * runtime */
17749                     op = EXACTFL;
17750                 }
17751                 else {
17752
17753                     /* Here, we are generally folding, but there is only one
17754                      * code point to match.  If we have to, we use an EXACT
17755                      * node, but it would be better for joining with adjacent
17756                      * nodes in the optimization pass if we used the same
17757                      * EXACTFish node that any such are likely to be.  We can
17758                      * do this iff the code point doesn't participate in any
17759                      * folds.  For example, an EXACTF of a colon is the same as
17760                      * an EXACT one, since nothing folds to or from a colon. */
17761                     if (value < 256) {
17762                         if (IS_IN_SOME_FOLD_L1(value)) {
17763                             op = EXACT;
17764                         }
17765                     }
17766                     else {
17767                         if (_invlist_contains_cp(PL_utf8_foldable, value)) {
17768                             op = EXACT;
17769                         }
17770                     }
17771
17772                     /* If we haven't found the node type, above, it means we
17773                      * can use the prevailing one */
17774                     if (op == END) {
17775                         op = compute_EXACTish(pRExC_state);
17776                     }
17777                 }
17778             }
17779         }   /* End of first range contains just a single code point */
17780         else if (start == 0) {
17781             if (end == UV_MAX) {
17782                 op = SANY;
17783                 *flagp |= HASWIDTH|SIMPLE;
17784                 MARK_NAUGHTY(1);
17785             }
17786             else if (end == '\n' - 1
17787                     && invlist_iternext(cp_list, &start, &end)
17788                     && start == '\n' + 1 && end == UV_MAX)
17789             {
17790                 op = REG_ANY;
17791                 *flagp |= HASWIDTH|SIMPLE;
17792                 MARK_NAUGHTY(1);
17793             }
17794         }
17795         invlist_iterfinish(cp_list);
17796
17797         if (op == END) {
17798             const UV cp_list_len = _invlist_len(cp_list);
17799             const UV* cp_list_array = invlist_array(cp_list);
17800
17801             /* Here, didn't find an optimization.  See if this matches any of
17802              * the POSIX classes.  These run slightly faster for above-Unicode
17803              * code points, so don't bother with POSIXA ones nor the 2 that
17804              * have no above-Unicode matches.  We can avoid these checks unless
17805              * the ANYOF matches at least as high as the lowest POSIX one
17806              * (which was manually found to be \v.  The actual code point may
17807              * increase in later Unicode releases, if a higher code point is
17808              * assigned to be \v, but this code will never break.  It would
17809              * just mean we could execute the checks for posix optimizations
17810              * unnecessarily) */
17811
17812             if (cp_list_array[cp_list_len-1] > 0x2029) {
17813                 for (posix_class = 0;
17814                      posix_class <= _HIGHEST_REGCOMP_DOT_H_SYNC;
17815                      posix_class++)
17816                 {
17817                     int try_inverted;
17818                     if (posix_class == _CC_ASCII || posix_class == _CC_CNTRL) {
17819                         continue;
17820                     }
17821                     for (try_inverted = 0; try_inverted < 2; try_inverted++) {
17822
17823                         /* Check if matches normal or inverted */
17824                         if (_invlistEQ(cp_list,
17825                                        PL_XPosix_ptrs[posix_class],
17826                                        try_inverted))
17827                         {
17828                             op = (try_inverted)
17829                                  ? NPOSIXU
17830                                  : POSIXU;
17831                             *flagp |= HASWIDTH|SIMPLE;
17832                             goto found_posix;
17833                         }
17834                     }
17835                 }
17836               found_posix: ;
17837             }
17838         }
17839
17840         if (op != END) {
17841             RExC_parse = (char *)orig_parse;
17842             RExC_emit = (regnode *)orig_emit;
17843
17844             if (regarglen[op]) {
17845                 ret = reganode(pRExC_state, op, 0);
17846             } else {
17847                 ret = reg_node(pRExC_state, op);
17848             }
17849
17850             RExC_parse = (char *)cur_parse;
17851
17852             if (PL_regkind[op] == EXACT) {
17853                 alloc_maybe_populate_EXACT(pRExC_state, ret, flagp, 0, value,
17854                                            TRUE /* downgradable to EXACT */
17855                                           );
17856             }
17857             else if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
17858                 FLAGS(ret) = posix_class;
17859             }
17860
17861             SvREFCNT_dec_NN(cp_list);
17862             return ret;
17863         }
17864     }
17865
17866     /* Here, <cp_list> contains all the code points we can determine at
17867      * compile time that match under all conditions.  Go through it, and
17868      * for things that belong in the bitmap, put them there, and delete from
17869      * <cp_list>.  While we are at it, see if everything above 255 is in the
17870      * list, and if so, set a flag to speed up execution */
17871
17872     populate_ANYOF_from_invlist(ret, &cp_list);
17873
17874     if (invert) {
17875         ANYOF_FLAGS(ret) |= ANYOF_INVERT;
17876     }
17877
17878     /* Here, the bitmap has been populated with all the Latin1 code points that
17879      * always match.  Can now add to the overall list those that match only
17880      * when the target string is UTF-8 (<has_upper_latin1_only_utf8_matches>).
17881      * */
17882     if (has_upper_latin1_only_utf8_matches) {
17883         if (cp_list) {
17884             _invlist_union(cp_list,
17885                            has_upper_latin1_only_utf8_matches,
17886                            &cp_list);
17887             SvREFCNT_dec_NN(has_upper_latin1_only_utf8_matches);
17888         }
17889         else {
17890             cp_list = has_upper_latin1_only_utf8_matches;
17891         }
17892         ANYOF_FLAGS(ret) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP;
17893     }
17894
17895     /* If there is a swash and more than one element, we can't use the swash in
17896      * the optimization below. */
17897     if (swash && element_count > 1) {
17898         SvREFCNT_dec_NN(swash);
17899         swash = NULL;
17900     }
17901
17902     /* Note that the optimization of using 'swash' if it is the only thing in
17903      * the class doesn't have us change swash at all, so it can include things
17904      * that are also in the bitmap; otherwise we have purposely deleted that
17905      * duplicate information */
17906     set_ANYOF_arg(pRExC_state, ret, cp_list,
17907                   (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION)
17908                    ? listsv : NULL,
17909                   only_utf8_locale_list,
17910                   swash, has_user_defined_property);
17911
17912     *flagp |= HASWIDTH|SIMPLE;
17913
17914     if (ANYOF_FLAGS(ret) & ANYOF_LOCALE_FLAGS) {
17915         RExC_contains_locale = 1;
17916     }
17917
17918     return ret;
17919 }
17920
17921 #undef HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION
17922
17923 STATIC void
17924 S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state,
17925                 regnode* const node,
17926                 SV* const cp_list,
17927                 SV* const runtime_defns,
17928                 SV* const only_utf8_locale_list,
17929                 SV* const swash,
17930                 const bool has_user_defined_property)
17931 {
17932     /* Sets the arg field of an ANYOF-type node 'node', using information about
17933      * the node passed-in.  If there is nothing outside the node's bitmap, the
17934      * arg is set to ANYOF_ONLY_HAS_BITMAP.  Otherwise, it sets the argument to
17935      * the count returned by add_data(), having allocated and stored an array,
17936      * av, that that count references, as follows:
17937      *  av[0] stores the character class description in its textual form.
17938      *        This is used later (regexec.c:Perl_regclass_swash()) to
17939      *        initialize the appropriate swash, and is also useful for dumping
17940      *        the regnode.  This is set to &PL_sv_undef if the textual
17941      *        description is not needed at run-time (as happens if the other
17942      *        elements completely define the class)
17943      *  av[1] if &PL_sv_undef, is a placeholder to later contain the swash
17944      *        computed from av[0].  But if no further computation need be done,
17945      *        the swash is stored here now (and av[0] is &PL_sv_undef).
17946      *  av[2] stores the inversion list of code points that match only if the
17947      *        current locale is UTF-8
17948      *  av[3] stores the cp_list inversion list for use in addition or instead
17949      *        of av[0]; used only if cp_list exists and av[1] is &PL_sv_undef.
17950      *        (Otherwise everything needed is already in av[0] and av[1])
17951      *  av[4] is set if any component of the class is from a user-defined
17952      *        property; used only if av[3] exists */
17953
17954     UV n;
17955
17956     PERL_ARGS_ASSERT_SET_ANYOF_ARG;
17957
17958     if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) {
17959         assert(! (ANYOF_FLAGS(node)
17960                 & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP));
17961         ARG_SET(node, ANYOF_ONLY_HAS_BITMAP);
17962     }
17963     else {
17964         AV * const av = newAV();
17965         SV *rv;
17966
17967         av_store(av, 0, (runtime_defns)
17968                         ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef);
17969         if (swash) {
17970             assert(cp_list);
17971             av_store(av, 1, swash);
17972             SvREFCNT_dec_NN(cp_list);
17973         }
17974         else {
17975             av_store(av, 1, &PL_sv_undef);
17976             if (cp_list) {
17977                 av_store(av, 3, cp_list);
17978                 av_store(av, 4, newSVuv(has_user_defined_property));
17979             }
17980         }
17981
17982         if (only_utf8_locale_list) {
17983             av_store(av, 2, only_utf8_locale_list);
17984         }
17985         else {
17986             av_store(av, 2, &PL_sv_undef);
17987         }
17988
17989         rv = newRV_noinc(MUTABLE_SV(av));
17990         n = add_data(pRExC_state, STR_WITH_LEN("s"));
17991         RExC_rxi->data->data[n] = (void*)rv;
17992         ARG_SET(node, n);
17993     }
17994 }
17995
17996 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
17997 SV *
17998 Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog,
17999                                         const regnode* node,
18000                                         bool doinit,
18001                                         SV** listsvp,
18002                                         SV** only_utf8_locale_ptr,
18003                                         SV** output_invlist)
18004
18005 {
18006     /* For internal core use only.
18007      * Returns the swash for the input 'node' in the regex 'prog'.
18008      * If <doinit> is 'true', will attempt to create the swash if not already
18009      *    done.
18010      * If <listsvp> is non-null, will return the printable contents of the
18011      *    swash.  This can be used to get debugging information even before the
18012      *    swash exists, by calling this function with 'doinit' set to false, in
18013      *    which case the components that will be used to eventually create the
18014      *    swash are returned  (in a printable form).
18015      * If <only_utf8_locale_ptr> is not NULL, it is where this routine is to
18016      *    store an inversion list of code points that should match only if the
18017      *    execution-time locale is a UTF-8 one.
18018      * If <output_invlist> is not NULL, it is where this routine is to store an
18019      *    inversion list of the code points that would be instead returned in
18020      *    <listsvp> if this were NULL.  Thus, what gets output in <listsvp>
18021      *    when this parameter is used, is just the non-code point data that
18022      *    will go into creating the swash.  This currently should be just
18023      *    user-defined properties whose definitions were not known at compile
18024      *    time.  Using this parameter allows for easier manipulation of the
18025      *    swash's data by the caller.  It is illegal to call this function with
18026      *    this parameter set, but not <listsvp>
18027      *
18028      * Tied intimately to how S_set_ANYOF_arg sets up the data structure.  Note
18029      * that, in spite of this function's name, the swash it returns may include
18030      * the bitmap data as well */
18031
18032     SV *sw  = NULL;
18033     SV *si  = NULL;         /* Input swash initialization string */
18034     SV* invlist = NULL;
18035
18036     RXi_GET_DECL(prog,progi);
18037     const struct reg_data * const data = prog ? progi->data : NULL;
18038
18039     PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA;
18040     assert(! output_invlist || listsvp);
18041
18042     if (data && data->count) {
18043         const U32 n = ARG(node);
18044
18045         if (data->what[n] == 's') {
18046             SV * const rv = MUTABLE_SV(data->data[n]);
18047             AV * const av = MUTABLE_AV(SvRV(rv));
18048             SV **const ary = AvARRAY(av);
18049             U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
18050
18051             si = *ary;  /* ary[0] = the string to initialize the swash with */
18052
18053             if (av_tindex_nomg(av) >= 2) {
18054                 if (only_utf8_locale_ptr
18055                     && ary[2]
18056                     && ary[2] != &PL_sv_undef)
18057                 {
18058                     *only_utf8_locale_ptr = ary[2];
18059                 }
18060                 else {
18061                     assert(only_utf8_locale_ptr);
18062                     *only_utf8_locale_ptr = NULL;
18063                 }
18064
18065                 /* Elements 3 and 4 are either both present or both absent. [3]
18066                  * is any inversion list generated at compile time; [4]
18067                  * indicates if that inversion list has any user-defined
18068                  * properties in it. */
18069                 if (av_tindex_nomg(av) >= 3) {
18070                     invlist = ary[3];
18071                     if (SvUV(ary[4])) {
18072                         swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
18073                     }
18074                 }
18075                 else {
18076                     invlist = NULL;
18077                 }
18078             }
18079
18080             /* Element [1] is reserved for the set-up swash.  If already there,
18081              * return it; if not, create it and store it there */
18082             if (ary[1] && SvROK(ary[1])) {
18083                 sw = ary[1];
18084             }
18085             else if (doinit && ((si && si != &PL_sv_undef)
18086                                  || (invlist && invlist != &PL_sv_undef))) {
18087                 assert(si);
18088                 sw = _core_swash_init("utf8", /* the utf8 package */
18089                                       "", /* nameless */
18090                                       si,
18091                                       1, /* binary */
18092                                       0, /* not from tr/// */
18093                                       invlist,
18094                                       &swash_init_flags);
18095                 (void)av_store(av, 1, sw);
18096             }
18097         }
18098     }
18099
18100     /* If requested, return a printable version of what this swash matches */
18101     if (listsvp) {
18102         SV* matches_string = NULL;
18103
18104         /* The swash should be used, if possible, to get the data, as it
18105          * contains the resolved data.  But this function can be called at
18106          * compile-time, before everything gets resolved, in which case we
18107          * return the currently best available information, which is the string
18108          * that will eventually be used to do that resolving, 'si' */
18109         if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
18110             && (si && si != &PL_sv_undef))
18111         {
18112             /* Here, we only have 'si' (and possibly some passed-in data in
18113              * 'invlist', which is handled below)  If the caller only wants
18114              * 'si', use that.  */
18115             if (! output_invlist) {
18116                 matches_string = newSVsv(si);
18117             }
18118             else {
18119                 /* But if the caller wants an inversion list of the node, we
18120                  * need to parse 'si' and place as much as possible in the
18121                  * desired output inversion list, making 'matches_string' only
18122                  * contain the currently unresolvable things */
18123                 const char *si_string = SvPVX(si);
18124                 STRLEN remaining = SvCUR(si);
18125                 UV prev_cp = 0;
18126                 U8 count = 0;
18127
18128                 /* Ignore everything before the first new-line */
18129                 while (*si_string != '\n' && remaining > 0) {
18130                     si_string++;
18131                     remaining--;
18132                 }
18133                 assert(remaining > 0);
18134
18135                 si_string++;
18136                 remaining--;
18137
18138                 while (remaining > 0) {
18139
18140                     /* The data consists of just strings defining user-defined
18141                      * property names, but in prior incarnations, and perhaps
18142                      * somehow from pluggable regex engines, it could still
18143                      * hold hex code point definitions.  Each component of a
18144                      * range would be separated by a tab, and each range by a
18145                      * new-line.  If these are found, instead add them to the
18146                      * inversion list */
18147                     I32 grok_flags =  PERL_SCAN_SILENT_ILLDIGIT
18148                                      |PERL_SCAN_SILENT_NON_PORTABLE;
18149                     STRLEN len = remaining;
18150                     UV cp = grok_hex(si_string, &len, &grok_flags, NULL);
18151
18152                     /* If the hex decode routine found something, it should go
18153                      * up to the next \n */
18154                     if (   *(si_string + len) == '\n') {
18155                         if (count) {    /* 2nd code point on line */
18156                             *output_invlist = _add_range_to_invlist(*output_invlist, prev_cp, cp);
18157                         }
18158                         else {
18159                             *output_invlist = add_cp_to_invlist(*output_invlist, cp);
18160                         }
18161                         count = 0;
18162                         goto prepare_for_next_iteration;
18163                     }
18164
18165                     /* If the hex decode was instead for the lower range limit,
18166                      * save it, and go parse the upper range limit */
18167                     if (*(si_string + len) == '\t') {
18168                         assert(count == 0);
18169
18170                         prev_cp = cp;
18171                         count = 1;
18172                       prepare_for_next_iteration:
18173                         si_string += len + 1;
18174                         remaining -= len + 1;
18175                         continue;
18176                     }
18177
18178                     /* Here, didn't find a legal hex number.  Just add it from
18179                      * here to the next \n */
18180
18181                     remaining -= len;
18182                     while (*(si_string + len) != '\n' && remaining > 0) {
18183                         remaining--;
18184                         len++;
18185                     }
18186                     if (*(si_string + len) == '\n') {
18187                         len++;
18188                         remaining--;
18189                     }
18190                     if (matches_string) {
18191                         sv_catpvn(matches_string, si_string, len - 1);
18192                     }
18193                     else {
18194                         matches_string = newSVpvn(si_string, len - 1);
18195                     }
18196                     si_string += len;
18197                     sv_catpvs(matches_string, " ");
18198                 } /* end of loop through the text */
18199
18200                 assert(matches_string);
18201                 if (SvCUR(matches_string)) {  /* Get rid of trailing blank */
18202                     SvCUR_set(matches_string, SvCUR(matches_string) - 1);
18203                 }
18204             } /* end of has an 'si' but no swash */
18205         }
18206
18207         /* If we have a swash in place, its equivalent inversion list was above
18208          * placed into 'invlist'.  If not, this variable may contain a stored
18209          * inversion list which is information beyond what is in 'si' */
18210         if (invlist) {
18211
18212             /* Again, if the caller doesn't want the output inversion list, put
18213              * everything in 'matches-string' */
18214             if (! output_invlist) {
18215                 if ( ! matches_string) {
18216                     matches_string = newSVpvs("\n");
18217                 }
18218                 sv_catsv(matches_string, invlist_contents(invlist,
18219                                                   TRUE /* traditional style */
18220                                                   ));
18221             }
18222             else if (! *output_invlist) {
18223                 *output_invlist = invlist_clone(invlist);
18224             }
18225             else {
18226                 _invlist_union(*output_invlist, invlist, output_invlist);
18227             }
18228         }
18229
18230         *listsvp = matches_string;
18231     }
18232
18233     return sw;
18234 }
18235 #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */
18236
18237 /* reg_skipcomment()
18238
18239    Absorbs an /x style # comment from the input stream,
18240    returning a pointer to the first character beyond the comment, or if the
18241    comment terminates the pattern without anything following it, this returns
18242    one past the final character of the pattern (in other words, RExC_end) and
18243    sets the REG_RUN_ON_COMMENT_SEEN flag.
18244
18245    Note it's the callers responsibility to ensure that we are
18246    actually in /x mode
18247
18248 */
18249
18250 PERL_STATIC_INLINE char*
18251 S_reg_skipcomment(RExC_state_t *pRExC_state, char* p)
18252 {
18253     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
18254
18255     assert(*p == '#');
18256
18257     while (p < RExC_end) {
18258         if (*(++p) == '\n') {
18259             return p+1;
18260         }
18261     }
18262
18263     /* we ran off the end of the pattern without ending the comment, so we have
18264      * to add an \n when wrapping */
18265     RExC_seen |= REG_RUN_ON_COMMENT_SEEN;
18266     return p;
18267 }
18268
18269 STATIC void
18270 S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state,
18271                                 char ** p,
18272                                 const bool force_to_xmod
18273                          )
18274 {
18275     /* If the text at the current parse position '*p' is a '(?#...)' comment,
18276      * or if we are under /x or 'force_to_xmod' is TRUE, and the text at '*p'
18277      * is /x whitespace, advance '*p' so that on exit it points to the first
18278      * byte past all such white space and comments */
18279
18280     const bool use_xmod = force_to_xmod || (RExC_flags & RXf_PMf_EXTENDED);
18281
18282     PERL_ARGS_ASSERT_SKIP_TO_BE_IGNORED_TEXT;
18283
18284     assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p));
18285
18286     for (;;) {
18287         if (RExC_end - (*p) >= 3
18288             && *(*p)     == '('
18289             && *(*p + 1) == '?'
18290             && *(*p + 2) == '#')
18291         {
18292             while (*(*p) != ')') {
18293                 if ((*p) == RExC_end)
18294                     FAIL("Sequence (?#... not terminated");
18295                 (*p)++;
18296             }
18297             (*p)++;
18298             continue;
18299         }
18300
18301         if (use_xmod) {
18302             const char * save_p = *p;
18303             while ((*p) < RExC_end) {
18304                 STRLEN len;
18305                 if ((len = is_PATWS_safe((*p), RExC_end, UTF))) {
18306                     (*p) += len;
18307                 }
18308                 else if (*(*p) == '#') {
18309                     (*p) = reg_skipcomment(pRExC_state, (*p));
18310                 }
18311                 else {
18312                     break;
18313                 }
18314             }
18315             if (*p != save_p) {
18316                 continue;
18317             }
18318         }
18319
18320         break;
18321     }
18322
18323     return;
18324 }
18325
18326 /* nextchar()
18327
18328    Advances the parse position by one byte, unless that byte is the beginning
18329    of a '(?#...)' style comment, or is /x whitespace and /x is in effect.  In
18330    those two cases, the parse position is advanced beyond all such comments and
18331    white space.
18332
18333    This is the UTF, (?#...), and /x friendly way of saying RExC_parse++.
18334 */
18335
18336 STATIC void
18337 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
18338 {
18339     PERL_ARGS_ASSERT_NEXTCHAR;
18340
18341     if (RExC_parse < RExC_end) {
18342         assert(   ! UTF
18343                || UTF8_IS_INVARIANT(*RExC_parse)
18344                || UTF8_IS_START(*RExC_parse));
18345
18346         RExC_parse += (UTF) ? UTF8SKIP(RExC_parse) : 1;
18347
18348         skip_to_be_ignored_text(pRExC_state, &RExC_parse,
18349                                 FALSE /* Don't force /x */ );
18350     }
18351 }
18352
18353 STATIC regnode *
18354 S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_size, const char* const name)
18355 {
18356     /* Allocate a regnode for 'op' and returns it, with 'extra_size' extra
18357      * space.  In pass1, it aligns and increments RExC_size; in pass2,
18358      * RExC_emit */
18359
18360     regnode * const ret = RExC_emit;
18361     GET_RE_DEBUG_FLAGS_DECL;
18362
18363     PERL_ARGS_ASSERT_REGNODE_GUTS;
18364
18365     assert(extra_size >= regarglen[op]);
18366
18367     if (SIZE_ONLY) {
18368         SIZE_ALIGN(RExC_size);
18369         RExC_size += 1 + extra_size;
18370         return(ret);
18371     }
18372     if (RExC_emit >= RExC_emit_bound)
18373         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
18374                    op, (void*)RExC_emit, (void*)RExC_emit_bound);
18375
18376     NODE_ALIGN_FILL(ret);
18377 #ifndef RE_TRACK_PATTERN_OFFSETS
18378     PERL_UNUSED_ARG(name);
18379 #else
18380     if (RExC_offsets) {         /* MJD */
18381         MJD_OFFSET_DEBUG(
18382               ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n",
18383               name, __LINE__,
18384               PL_reg_name[op],
18385               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
18386                 ? "Overwriting end of array!\n" : "OK",
18387               (UV)(RExC_emit - RExC_emit_start),
18388               (UV)(RExC_parse - RExC_start),
18389               (UV)RExC_offsets[0]));
18390         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
18391     }
18392 #endif
18393     return(ret);
18394 }
18395
18396 /*
18397 - reg_node - emit a node
18398 */
18399 STATIC regnode *                        /* Location. */
18400 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
18401 {
18402     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg_node");
18403
18404     PERL_ARGS_ASSERT_REG_NODE;
18405
18406     assert(regarglen[op] == 0);
18407
18408     if (PASS2) {
18409         regnode *ptr = ret;
18410         FILL_ADVANCE_NODE(ptr, op);
18411         RExC_emit = ptr;
18412     }
18413     return(ret);
18414 }
18415
18416 /*
18417 - reganode - emit a node with an argument
18418 */
18419 STATIC regnode *                        /* Location. */
18420 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
18421 {
18422     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reganode");
18423
18424     PERL_ARGS_ASSERT_REGANODE;
18425
18426     assert(regarglen[op] == 1);
18427
18428     if (PASS2) {
18429         regnode *ptr = ret;
18430         FILL_ADVANCE_NODE_ARG(ptr, op, arg);
18431         RExC_emit = ptr;
18432     }
18433     return(ret);
18434 }
18435
18436 STATIC regnode *
18437 S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const I32 arg2)
18438 {
18439     /* emit a node with U32 and I32 arguments */
18440
18441     regnode * const ret = regnode_guts(pRExC_state, op, regarglen[op], "reg2Lanode");
18442
18443     PERL_ARGS_ASSERT_REG2LANODE;
18444
18445     assert(regarglen[op] == 2);
18446
18447     if (PASS2) {
18448         regnode *ptr = ret;
18449         FILL_ADVANCE_NODE_2L_ARG(ptr, op, arg1, arg2);
18450         RExC_emit = ptr;
18451     }
18452     return(ret);
18453 }
18454
18455 /*
18456 - reginsert - insert an operator in front of already-emitted operand
18457 *
18458 * Means relocating the operand.
18459 */
18460 STATIC void
18461 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
18462 {
18463     regnode *src;
18464     regnode *dst;
18465     regnode *place;
18466     const int offset = regarglen[(U8)op];
18467     const int size = NODE_STEP_REGNODE + offset;
18468     GET_RE_DEBUG_FLAGS_DECL;
18469
18470     PERL_ARGS_ASSERT_REGINSERT;
18471     PERL_UNUSED_CONTEXT;
18472     PERL_UNUSED_ARG(depth);
18473 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
18474     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
18475     if (SIZE_ONLY) {
18476         RExC_size += size;
18477         return;
18478     }
18479     assert(!RExC_study_started); /* I believe we should never use reginsert once we have started
18480                                     studying. If this is wrong then we need to adjust RExC_recurse
18481                                     below like we do with RExC_open_parens/RExC_close_parens. */
18482     src = RExC_emit;
18483     RExC_emit += size;
18484     dst = RExC_emit;
18485     if (RExC_open_parens) {
18486         int paren;
18487         /*DEBUG_PARSE_FMT("inst"," - %" IVdf, (IV)RExC_npar);*/
18488         /* remember that RExC_npar is rex->nparens + 1,
18489          * iow it is 1 more than the number of parens seen in
18490          * the pattern so far. */
18491         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
18492             /* note, RExC_open_parens[0] is the start of the
18493              * regex, it can't move. RExC_close_parens[0] is the end
18494              * of the regex, it *can* move. */
18495             if ( paren && RExC_open_parens[paren] >= opnd ) {
18496                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
18497                 RExC_open_parens[paren] += size;
18498             } else {
18499                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
18500             }
18501             if ( RExC_close_parens[paren] >= opnd ) {
18502                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
18503                 RExC_close_parens[paren] += size;
18504             } else {
18505                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
18506             }
18507         }
18508     }
18509     if (RExC_end_op)
18510         RExC_end_op += size;
18511
18512     while (src > opnd) {
18513         StructCopy(--src, --dst, regnode);
18514 #ifdef RE_TRACK_PATTERN_OFFSETS
18515         if (RExC_offsets) {     /* MJD 20010112 */
18516             MJD_OFFSET_DEBUG(
18517                  ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n",
18518                   "reg_insert",
18519                   __LINE__,
18520                   PL_reg_name[op],
18521                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
18522                     ? "Overwriting end of array!\n" : "OK",
18523                   (UV)(src - RExC_emit_start),
18524                   (UV)(dst - RExC_emit_start),
18525                   (UV)RExC_offsets[0]));
18526             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
18527             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
18528         }
18529 #endif
18530     }
18531
18532
18533     place = opnd;               /* Op node, where operand used to be. */
18534 #ifdef RE_TRACK_PATTERN_OFFSETS
18535     if (RExC_offsets) {         /* MJD */
18536         MJD_OFFSET_DEBUG(
18537               ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n",
18538               "reginsert",
18539               __LINE__,
18540               PL_reg_name[op],
18541               (UV)(place - RExC_emit_start) > RExC_offsets[0]
18542               ? "Overwriting end of array!\n" : "OK",
18543               (UV)(place - RExC_emit_start),
18544               (UV)(RExC_parse - RExC_start),
18545               (UV)RExC_offsets[0]));
18546         Set_Node_Offset(place, RExC_parse);
18547         Set_Node_Length(place, 1);
18548     }
18549 #endif
18550     src = NEXTOPER(place);
18551     FILL_ADVANCE_NODE(place, op);
18552     Zero(src, offset, regnode);
18553 }
18554
18555 /*
18556 - regtail - set the next-pointer at the end of a node chain of p to val.
18557 - SEE ALSO: regtail_study
18558 */
18559 STATIC void
18560 S_regtail(pTHX_ RExC_state_t * pRExC_state,
18561                 const regnode * const p,
18562                 const regnode * const val,
18563                 const U32 depth)
18564 {
18565     regnode *scan;
18566     GET_RE_DEBUG_FLAGS_DECL;
18567
18568     PERL_ARGS_ASSERT_REGTAIL;
18569 #ifndef DEBUGGING
18570     PERL_UNUSED_ARG(depth);
18571 #endif
18572
18573     if (SIZE_ONLY)
18574         return;
18575
18576     /* Find last node. */
18577     scan = (regnode *) p;
18578     for (;;) {
18579         regnode * const temp = regnext(scan);
18580         DEBUG_PARSE_r({
18581             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
18582             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18583             Perl_re_printf( aTHX_  "~ %s (%d) %s %s\n",
18584                 SvPV_nolen_const(RExC_mysv), REG_NODE_NUM(scan),
18585                     (temp == NULL ? "->" : ""),
18586                     (temp == NULL ? PL_reg_name[OP(val)] : "")
18587             );
18588         });
18589         if (temp == NULL)
18590             break;
18591         scan = temp;
18592     }
18593
18594     if (reg_off_by_arg[OP(scan)]) {
18595         ARG_SET(scan, val - scan);
18596     }
18597     else {
18598         NEXT_OFF(scan) = val - scan;
18599     }
18600 }
18601
18602 #ifdef DEBUGGING
18603 /*
18604 - regtail_study - set the next-pointer at the end of a node chain of p to val.
18605 - Look for optimizable sequences at the same time.
18606 - currently only looks for EXACT chains.
18607
18608 This is experimental code. The idea is to use this routine to perform
18609 in place optimizations on branches and groups as they are constructed,
18610 with the long term intention of removing optimization from study_chunk so
18611 that it is purely analytical.
18612
18613 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
18614 to control which is which.
18615
18616 */
18617 /* TODO: All four parms should be const */
18618
18619 STATIC U8
18620 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p,
18621                       const regnode *val,U32 depth)
18622 {
18623     regnode *scan;
18624     U8 exact = PSEUDO;
18625 #ifdef EXPERIMENTAL_INPLACESCAN
18626     I32 min = 0;
18627 #endif
18628     GET_RE_DEBUG_FLAGS_DECL;
18629
18630     PERL_ARGS_ASSERT_REGTAIL_STUDY;
18631
18632
18633     if (SIZE_ONLY)
18634         return exact;
18635
18636     /* Find last node. */
18637
18638     scan = p;
18639     for (;;) {
18640         regnode * const temp = regnext(scan);
18641 #ifdef EXPERIMENTAL_INPLACESCAN
18642         if (PL_regkind[OP(scan)] == EXACT) {
18643             bool unfolded_multi_char;   /* Unexamined in this routine */
18644             if (join_exact(pRExC_state, scan, &min,
18645                            &unfolded_multi_char, 1, val, depth+1))
18646                 return EXACT;
18647         }
18648 #endif
18649         if ( exact ) {
18650             switch (OP(scan)) {
18651                 case EXACT:
18652                 case EXACTL:
18653                 case EXACTF:
18654                 case EXACTFA_NO_TRIE:
18655                 case EXACTFA:
18656                 case EXACTFU:
18657                 case EXACTFLU8:
18658                 case EXACTFU_SS:
18659                 case EXACTFL:
18660                         if( exact == PSEUDO )
18661                             exact= OP(scan);
18662                         else if ( exact != OP(scan) )
18663                             exact= 0;
18664                 case NOTHING:
18665                     break;
18666                 default:
18667                     exact= 0;
18668             }
18669         }
18670         DEBUG_PARSE_r({
18671             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
18672             regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);
18673             Perl_re_printf( aTHX_  "~ %s (%d) -> %s\n",
18674                 SvPV_nolen_const(RExC_mysv),
18675                 REG_NODE_NUM(scan),
18676                 PL_reg_name[exact]);
18677         });
18678         if (temp == NULL)
18679             break;
18680         scan = temp;
18681     }
18682     DEBUG_PARSE_r({
18683         DEBUG_PARSE_MSG("");
18684         regprop(RExC_rx, RExC_mysv, val, NULL, pRExC_state);
18685         Perl_re_printf( aTHX_
18686                       "~ attach to %s (%" IVdf ") offset to %" IVdf "\n",
18687                       SvPV_nolen_const(RExC_mysv),
18688                       (IV)REG_NODE_NUM(val),
18689                       (IV)(val - scan)
18690         );
18691     });
18692     if (reg_off_by_arg[OP(scan)]) {
18693         ARG_SET(scan, val - scan);
18694     }
18695     else {
18696         NEXT_OFF(scan) = val - scan;
18697     }
18698
18699     return exact;
18700 }
18701 #endif
18702
18703 /*
18704  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
18705  */
18706 #ifdef DEBUGGING
18707
18708 static void
18709 S_regdump_intflags(pTHX_ const char *lead, const U32 flags)
18710 {
18711     int bit;
18712     int set=0;
18713
18714     ASSUME(REG_INTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18715
18716     for (bit=0; bit<REG_INTFLAGS_NAME_SIZE; bit++) {
18717         if (flags & (1<<bit)) {
18718             if (!set++ && lead)
18719                 Perl_re_printf( aTHX_  "%s",lead);
18720             Perl_re_printf( aTHX_  "%s ",PL_reg_intflags_name[bit]);
18721         }
18722     }
18723     if (lead)  {
18724         if (set)
18725             Perl_re_printf( aTHX_  "\n");
18726         else
18727             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18728     }
18729 }
18730
18731 static void
18732 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
18733 {
18734     int bit;
18735     int set=0;
18736     regex_charset cs;
18737
18738     ASSUME(REG_EXTFLAGS_NAME_SIZE <= sizeof(flags)*8);
18739
18740     for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) {
18741         if (flags & (1<<bit)) {
18742             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
18743                 continue;
18744             }
18745             if (!set++ && lead)
18746                 Perl_re_printf( aTHX_  "%s",lead);
18747             Perl_re_printf( aTHX_  "%s ",PL_reg_extflags_name[bit]);
18748         }
18749     }
18750     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
18751             if (!set++ && lead) {
18752                 Perl_re_printf( aTHX_  "%s",lead);
18753             }
18754             switch (cs) {
18755                 case REGEX_UNICODE_CHARSET:
18756                     Perl_re_printf( aTHX_  "UNICODE");
18757                     break;
18758                 case REGEX_LOCALE_CHARSET:
18759                     Perl_re_printf( aTHX_  "LOCALE");
18760                     break;
18761                 case REGEX_ASCII_RESTRICTED_CHARSET:
18762                     Perl_re_printf( aTHX_  "ASCII-RESTRICTED");
18763                     break;
18764                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
18765                     Perl_re_printf( aTHX_  "ASCII-MORE_RESTRICTED");
18766                     break;
18767                 default:
18768                     Perl_re_printf( aTHX_  "UNKNOWN CHARACTER SET");
18769                     break;
18770             }
18771     }
18772     if (lead)  {
18773         if (set)
18774             Perl_re_printf( aTHX_  "\n");
18775         else
18776             Perl_re_printf( aTHX_  "%s[none-set]\n",lead);
18777     }
18778 }
18779 #endif
18780
18781 void
18782 Perl_regdump(pTHX_ const regexp *r)
18783 {
18784 #ifdef DEBUGGING
18785     SV * const sv = sv_newmortal();
18786     SV *dsv= sv_newmortal();
18787     RXi_GET_DECL(r,ri);
18788     GET_RE_DEBUG_FLAGS_DECL;
18789
18790     PERL_ARGS_ASSERT_REGDUMP;
18791
18792     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
18793
18794     /* Header fields of interest. */
18795     if (r->anchored_substr) {
18796         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
18797             RE_SV_DUMPLEN(r->anchored_substr), 30);
18798         Perl_re_printf( aTHX_
18799                       "anchored %s%s at %" IVdf " ",
18800                       s, RE_SV_TAIL(r->anchored_substr),
18801                       (IV)r->anchored_offset);
18802     } else if (r->anchored_utf8) {
18803         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
18804             RE_SV_DUMPLEN(r->anchored_utf8), 30);
18805         Perl_re_printf( aTHX_
18806                       "anchored utf8 %s%s at %" IVdf " ",
18807                       s, RE_SV_TAIL(r->anchored_utf8),
18808                       (IV)r->anchored_offset);
18809     }
18810     if (r->float_substr) {
18811         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
18812             RE_SV_DUMPLEN(r->float_substr), 30);
18813         Perl_re_printf( aTHX_
18814                       "floating %s%s at %" IVdf "..%" UVuf " ",
18815                       s, RE_SV_TAIL(r->float_substr),
18816                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18817     } else if (r->float_utf8) {
18818         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
18819             RE_SV_DUMPLEN(r->float_utf8), 30);
18820         Perl_re_printf( aTHX_
18821                       "floating utf8 %s%s at %" IVdf "..%" UVuf " ",
18822                       s, RE_SV_TAIL(r->float_utf8),
18823                       (IV)r->float_min_offset, (UV)r->float_max_offset);
18824     }
18825     if (r->check_substr || r->check_utf8)
18826         Perl_re_printf( aTHX_
18827                       (const char *)
18828                       (r->check_substr == r->float_substr
18829                        && r->check_utf8 == r->float_utf8
18830                        ? "(checking floating" : "(checking anchored"));
18831     if (r->intflags & PREGf_NOSCAN)
18832         Perl_re_printf( aTHX_  " noscan");
18833     if (r->extflags & RXf_CHECK_ALL)
18834         Perl_re_printf( aTHX_  " isall");
18835     if (r->check_substr || r->check_utf8)
18836         Perl_re_printf( aTHX_  ") ");
18837
18838     if (ri->regstclass) {
18839         regprop(r, sv, ri->regstclass, NULL, NULL);
18840         Perl_re_printf( aTHX_  "stclass %s ", SvPVX_const(sv));
18841     }
18842     if (r->intflags & PREGf_ANCH) {
18843         Perl_re_printf( aTHX_  "anchored");
18844         if (r->intflags & PREGf_ANCH_MBOL)
18845             Perl_re_printf( aTHX_  "(MBOL)");
18846         if (r->intflags & PREGf_ANCH_SBOL)
18847             Perl_re_printf( aTHX_  "(SBOL)");
18848         if (r->intflags & PREGf_ANCH_GPOS)
18849             Perl_re_printf( aTHX_  "(GPOS)");
18850         Perl_re_printf( aTHX_ " ");
18851     }
18852     if (r->intflags & PREGf_GPOS_SEEN)
18853         Perl_re_printf( aTHX_  "GPOS:%" UVuf " ", (UV)r->gofs);
18854     if (r->intflags & PREGf_SKIP)
18855         Perl_re_printf( aTHX_  "plus ");
18856     if (r->intflags & PREGf_IMPLICIT)
18857         Perl_re_printf( aTHX_  "implicit ");
18858     Perl_re_printf( aTHX_  "minlen %" IVdf " ", (IV)r->minlen);
18859     if (r->extflags & RXf_EVAL_SEEN)
18860         Perl_re_printf( aTHX_  "with eval ");
18861     Perl_re_printf( aTHX_  "\n");
18862     DEBUG_FLAGS_r({
18863         regdump_extflags("r->extflags: ",r->extflags);
18864         regdump_intflags("r->intflags: ",r->intflags);
18865     });
18866 #else
18867     PERL_ARGS_ASSERT_REGDUMP;
18868     PERL_UNUSED_CONTEXT;
18869     PERL_UNUSED_ARG(r);
18870 #endif  /* DEBUGGING */
18871 }
18872
18873 /* Should be synchronized with ANYOF_ #defines in regcomp.h */
18874 #ifdef DEBUGGING
18875
18876 #  if   _CC_WORDCHAR != 0 || _CC_DIGIT != 1        || _CC_ALPHA != 2    \
18877      || _CC_LOWER != 3    || _CC_UPPER != 4        || _CC_PUNCT != 5    \
18878      || _CC_PRINT != 6    || _CC_ALPHANUMERIC != 7 || _CC_GRAPH != 8    \
18879      || _CC_CASED != 9    || _CC_SPACE != 10       || _CC_BLANK != 11   \
18880      || _CC_XDIGIT != 12  || _CC_CNTRL != 13       || _CC_ASCII != 14   \
18881      || _CC_VERTSPACE != 15
18882 #   error Need to adjust order of anyofs[]
18883 #  endif
18884 static const char * const anyofs[] = {
18885     "\\w",
18886     "\\W",
18887     "\\d",
18888     "\\D",
18889     "[:alpha:]",
18890     "[:^alpha:]",
18891     "[:lower:]",
18892     "[:^lower:]",
18893     "[:upper:]",
18894     "[:^upper:]",
18895     "[:punct:]",
18896     "[:^punct:]",
18897     "[:print:]",
18898     "[:^print:]",
18899     "[:alnum:]",
18900     "[:^alnum:]",
18901     "[:graph:]",
18902     "[:^graph:]",
18903     "[:cased:]",
18904     "[:^cased:]",
18905     "\\s",
18906     "\\S",
18907     "[:blank:]",
18908     "[:^blank:]",
18909     "[:xdigit:]",
18910     "[:^xdigit:]",
18911     "[:cntrl:]",
18912     "[:^cntrl:]",
18913     "[:ascii:]",
18914     "[:^ascii:]",
18915     "\\v",
18916     "\\V"
18917 };
18918 #endif
18919
18920 /*
18921 - regprop - printable representation of opcode, with run time support
18922 */
18923
18924 void
18925 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_info *reginfo, const RExC_state_t *pRExC_state)
18926 {
18927 #ifdef DEBUGGING
18928     int k;
18929     RXi_GET_DECL(prog,progi);
18930     GET_RE_DEBUG_FLAGS_DECL;
18931
18932     PERL_ARGS_ASSERT_REGPROP;
18933
18934     SvPVCLEAR(sv);
18935
18936     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
18937         /* It would be nice to FAIL() here, but this may be called from
18938            regexec.c, and it would be hard to supply pRExC_state. */
18939         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
18940                                               (int)OP(o), (int)REGNODE_MAX);
18941     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
18942
18943     k = PL_regkind[OP(o)];
18944
18945     if (k == EXACT) {
18946         sv_catpvs(sv, " ");
18947         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
18948          * is a crude hack but it may be the best for now since
18949          * we have no flag "this EXACTish node was UTF-8"
18950          * --jhi */
18951         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
18952                   PERL_PV_ESCAPE_UNI_DETECT |
18953                   PERL_PV_ESCAPE_NONASCII   |
18954                   PERL_PV_PRETTY_ELLIPSES   |
18955                   PERL_PV_PRETTY_LTGT       |
18956                   PERL_PV_PRETTY_NOCLEAR
18957                   );
18958     } else if (k == TRIE) {
18959         /* print the details of the trie in dumpuntil instead, as
18960          * progi->data isn't available here */
18961         const char op = OP(o);
18962         const U32 n = ARG(o);
18963         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
18964                (reg_ac_data *)progi->data->data[n] :
18965                NULL;
18966         const reg_trie_data * const trie
18967             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
18968
18969         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
18970         DEBUG_TRIE_COMPILE_r({
18971           if (trie->jump)
18972             sv_catpvs(sv, "(JUMP)");
18973           Perl_sv_catpvf(aTHX_ sv,
18974             "<S:%" UVuf "/%" IVdf " W:%" UVuf " L:%" UVuf "/%" UVuf " C:%" UVuf "/%" UVuf ">",
18975             (UV)trie->startstate,
18976             (IV)trie->statecount-1, /* -1 because of the unused 0 element */
18977             (UV)trie->wordcount,
18978             (UV)trie->minlen,
18979             (UV)trie->maxlen,
18980             (UV)TRIE_CHARCOUNT(trie),
18981             (UV)trie->uniquecharcount
18982           );
18983         });
18984         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
18985             sv_catpvs(sv, "[");
18986             (void) put_charclass_bitmap_innards(sv,
18987                                                 ((IS_ANYOF_TRIE(op))
18988                                                  ? ANYOF_BITMAP(o)
18989                                                  : TRIE_BITMAP(trie)),
18990                                                 NULL,
18991                                                 NULL,
18992                                                 NULL,
18993                                                 FALSE
18994                                                );
18995             sv_catpvs(sv, "]");
18996         }
18997     } else if (k == CURLY) {
18998         U32 lo = ARG1(o), hi = ARG2(o);
18999         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
19000             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
19001         Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo);
19002         if (hi == REG_INFTY)
19003             sv_catpvs(sv, "INFTY");
19004         else
19005             Perl_sv_catpvf(aTHX_ sv, "%u", (unsigned) hi);
19006         sv_catpvs(sv, "}");
19007     }
19008     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
19009         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
19010     else if (k == REF || k == OPEN || k == CLOSE
19011              || k == GROUPP || OP(o)==ACCEPT)
19012     {
19013         AV *name_list= NULL;
19014         U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o);
19015         Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno);        /* Parenth number */
19016         if ( RXp_PAREN_NAMES(prog) ) {
19017             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19018         } else if ( pRExC_state ) {
19019             name_list= RExC_paren_name_list;
19020         }
19021         if (name_list) {
19022             if ( k != REF || (OP(o) < NREF)) {
19023                 SV **name= av_fetch(name_list, parno, 0 );
19024                 if (name)
19025                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19026             }
19027             else {
19028                 SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]);
19029                 I32 *nums=(I32*)SvPVX(sv_dat);
19030                 SV **name= av_fetch(name_list, nums[0], 0 );
19031                 I32 n;
19032                 if (name) {
19033                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
19034                         Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf,
19035                                     (n ? "," : ""), (IV)nums[n]);
19036                     }
19037                     Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19038                 }
19039             }
19040         }
19041         if ( k == REF && reginfo) {
19042             U32 n = ARG(o);  /* which paren pair */
19043             I32 ln = prog->offs[n].start;
19044             if (prog->lastparen < n || ln == -1)
19045                 Perl_sv_catpvf(aTHX_ sv, ": FAIL");
19046             else if (ln == prog->offs[n].end)
19047                 Perl_sv_catpvf(aTHX_ sv, ": ACCEPT - EMPTY STRING");
19048             else {
19049                 const char *s = reginfo->strbeg + ln;
19050                 Perl_sv_catpvf(aTHX_ sv, ": ");
19051                 Perl_pv_pretty( aTHX_ sv, s, prog->offs[n].end - prog->offs[n].start, 32, 0, 0,
19052                     PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_NOCLEAR|PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE );
19053             }
19054         }
19055     } else if (k == GOSUB) {
19056         AV *name_list= NULL;
19057         if ( RXp_PAREN_NAMES(prog) ) {
19058             name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
19059         } else if ( pRExC_state ) {
19060             name_list= RExC_paren_name_list;
19061         }
19062
19063         /* Paren and offset */
19064         Perl_sv_catpvf(aTHX_ sv, "%d[%+d:%d]", (int)ARG(o),(int)ARG2L(o),
19065                 (int)((o + (int)ARG2L(o)) - progi->program) );
19066         if (name_list) {
19067             SV **name= av_fetch(name_list, ARG(o), 0 );
19068             if (name)
19069                 Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
19070         }
19071     }
19072     else if (k == LOGICAL)
19073         /* 2: embedded, otherwise 1 */
19074         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);
19075     else if (k == ANYOF) {
19076         const U8 flags = ANYOF_FLAGS(o);
19077         bool do_sep = FALSE;    /* Do we need to separate various components of
19078                                    the output? */
19079         /* Set if there is still an unresolved user-defined property */
19080         SV *unresolved                = NULL;
19081
19082         /* Things that are ignored except when the runtime locale is UTF-8 */
19083         SV *only_utf8_locale_invlist = NULL;
19084
19085         /* Code points that don't fit in the bitmap */
19086         SV *nonbitmap_invlist = NULL;
19087
19088         /* And things that aren't in the bitmap, but are small enough to be */
19089         SV* bitmap_range_not_in_bitmap = NULL;
19090
19091         const bool inverted = flags & ANYOF_INVERT;
19092
19093         if (OP(o) == ANYOFL) {
19094             if (ANYOFL_UTF8_LOCALE_REQD(flags)) {
19095                 sv_catpvs(sv, "{utf8-locale-reqd}");
19096             }
19097             if (flags & ANYOFL_FOLD) {
19098                 sv_catpvs(sv, "{i}");
19099             }
19100         }
19101
19102         /* If there is stuff outside the bitmap, get it */
19103         if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) {
19104             (void) _get_regclass_nonbitmap_data(prog, o, FALSE,
19105                                                 &unresolved,
19106                                                 &only_utf8_locale_invlist,
19107                                                 &nonbitmap_invlist);
19108             /* The non-bitmap data may contain stuff that could fit in the
19109              * bitmap.  This could come from a user-defined property being
19110              * finally resolved when this call was done; or much more likely
19111              * because there are matches that require UTF-8 to be valid, and so
19112              * aren't in the bitmap.  This is teased apart later */
19113             _invlist_intersection(nonbitmap_invlist,
19114                                   PL_InBitmap,
19115                                   &bitmap_range_not_in_bitmap);
19116             /* Leave just the things that don't fit into the bitmap */
19117             _invlist_subtract(nonbitmap_invlist,
19118                               PL_InBitmap,
19119                               &nonbitmap_invlist);
19120         }
19121
19122         /* Obey this flag to add all above-the-bitmap code points */
19123         if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
19124             nonbitmap_invlist = _add_range_to_invlist(nonbitmap_invlist,
19125                                                       NUM_ANYOF_CODE_POINTS,
19126                                                       UV_MAX);
19127         }
19128
19129         /* Ready to start outputting.  First, the initial left bracket */
19130         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
19131
19132         /* Then all the things that could fit in the bitmap */
19133         do_sep = put_charclass_bitmap_innards(sv,
19134                                               ANYOF_BITMAP(o),
19135                                               bitmap_range_not_in_bitmap,
19136                                               only_utf8_locale_invlist,
19137                                               o,
19138
19139                                               /* Can't try inverting for a
19140                                                * better display if there are
19141                                                * things that haven't been
19142                                                * resolved */
19143                                               unresolved != NULL);
19144         SvREFCNT_dec(bitmap_range_not_in_bitmap);
19145
19146         /* If there are user-defined properties which haven't been defined yet,
19147          * output them.  If the result is not to be inverted, it is clearest to
19148          * output them in a separate [] from the bitmap range stuff.  If the
19149          * result is to be complemented, we have to show everything in one [],
19150          * as the inversion applies to the whole thing.  Use {braces} to
19151          * separate them from anything in the bitmap and anything above the
19152          * bitmap. */
19153         if (unresolved) {
19154             if (inverted) {
19155                 if (! do_sep) { /* If didn't output anything in the bitmap */
19156                     sv_catpvs(sv, "^");
19157                 }
19158                 sv_catpvs(sv, "{");
19159             }
19160             else if (do_sep) {
19161                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19162             }
19163             sv_catsv(sv, unresolved);
19164             if (inverted) {
19165                 sv_catpvs(sv, "}");
19166             }
19167             do_sep = ! inverted;
19168         }
19169
19170         /* And, finally, add the above-the-bitmap stuff */
19171         if (nonbitmap_invlist && _invlist_len(nonbitmap_invlist)) {
19172             SV* contents;
19173
19174             /* See if truncation size is overridden */
19175             const STRLEN dump_len = (PL_dump_re_max_len)
19176                                     ? PL_dump_re_max_len
19177                                     : 256;
19178
19179             /* This is output in a separate [] */
19180             if (do_sep) {
19181                 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]);
19182             }
19183
19184             /* And, for easy of understanding, it is shown in the
19185              * uncomplemented form if possible.  The one exception being if
19186              * there are unresolved items, where the inversion has to be
19187              * delayed until runtime */
19188             if (inverted && ! unresolved) {
19189                 _invlist_invert(nonbitmap_invlist);
19190                 _invlist_subtract(nonbitmap_invlist, PL_InBitmap, &nonbitmap_invlist);
19191             }
19192
19193             contents = invlist_contents(nonbitmap_invlist,
19194                                         FALSE /* output suitable for catsv */
19195                                        );
19196
19197             /* If the output is shorter than the permissible maximum, just do it. */
19198             if (SvCUR(contents) <= dump_len) {
19199                 sv_catsv(sv, contents);
19200             }
19201             else {
19202                 const char * contents_string = SvPVX(contents);
19203                 STRLEN i = dump_len;
19204
19205                 /* Otherwise, start at the permissible max and work back to the
19206                  * first break possibility */
19207                 while (i > 0 && contents_string[i] != ' ') {
19208                     i--;
19209                 }
19210                 if (i == 0) {       /* Fail-safe.  Use the max if we couldn't
19211                                        find a legal break */
19212                     i = dump_len;
19213                 }
19214
19215                 sv_catpvn(sv, contents_string, i);
19216                 sv_catpvs(sv, "...");
19217             }
19218
19219             SvREFCNT_dec_NN(contents);
19220             SvREFCNT_dec_NN(nonbitmap_invlist);
19221         }
19222
19223         /* And finally the matching, closing ']' */
19224         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
19225
19226         SvREFCNT_dec(unresolved);
19227     }
19228     else if (k == POSIXD || k == NPOSIXD) {
19229         U8 index = FLAGS(o) * 2;
19230         if (index < C_ARRAY_LENGTH(anyofs)) {
19231             if (*anyofs[index] != '[')  {
19232                 sv_catpv(sv, "[");
19233             }
19234             sv_catpv(sv, anyofs[index]);
19235             if (*anyofs[index] != '[')  {
19236                 sv_catpv(sv, "]");
19237             }
19238         }
19239         else {
19240             Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
19241         }
19242     }
19243     else if (k == BOUND || k == NBOUND) {
19244         /* Must be synced with order of 'bound_type' in regcomp.h */
19245         const char * const bounds[] = {
19246             "",      /* Traditional */
19247             "{gcb}",
19248             "{lb}",
19249             "{sb}",
19250             "{wb}"
19251         };
19252         assert(FLAGS(o) < C_ARRAY_LENGTH(bounds));
19253         sv_catpv(sv, bounds[FLAGS(o)]);
19254     }
19255     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
19256         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
19257     else if (OP(o) == SBOL)
19258         Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^");
19259
19260     /* add on the verb argument if there is one */
19261     if ( ( k == VERB || OP(o) == ACCEPT || OP(o) == OPFAIL ) && o->flags) {
19262         Perl_sv_catpvf(aTHX_ sv, ":%" SVf,
19263                        SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
19264     }
19265 #else
19266     PERL_UNUSED_CONTEXT;
19267     PERL_UNUSED_ARG(sv);
19268     PERL_UNUSED_ARG(o);
19269     PERL_UNUSED_ARG(prog);
19270     PERL_UNUSED_ARG(reginfo);
19271     PERL_UNUSED_ARG(pRExC_state);
19272 #endif  /* DEBUGGING */
19273 }
19274
19275
19276
19277 SV *
19278 Perl_re_intuit_string(pTHX_ REGEXP * const r)
19279 {                               /* Assume that RE_INTUIT is set */
19280     struct regexp *const prog = ReANY(r);
19281     GET_RE_DEBUG_FLAGS_DECL;
19282
19283     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
19284     PERL_UNUSED_CONTEXT;
19285
19286     DEBUG_COMPILE_r(
19287         {
19288             const char * const s = SvPV_nolen_const(RX_UTF8(r)
19289                       ? prog->check_utf8 : prog->check_substr);
19290
19291             if (!PL_colorset) reginitcolors();
19292             Perl_re_printf( aTHX_
19293                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
19294                       PL_colors[4],
19295                       RX_UTF8(r) ? "utf8 " : "",
19296                       PL_colors[5],PL_colors[0],
19297                       s,
19298                       PL_colors[1],
19299                       (strlen(s) > 60 ? "..." : ""));
19300         } );
19301
19302     /* use UTF8 check substring if regexp pattern itself is in UTF8 */
19303     return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr;
19304 }
19305
19306 /*
19307    pregfree()
19308
19309    handles refcounting and freeing the perl core regexp structure. When
19310    it is necessary to actually free the structure the first thing it
19311    does is call the 'free' method of the regexp_engine associated to
19312    the regexp, allowing the handling of the void *pprivate; member
19313    first. (This routine is not overridable by extensions, which is why
19314    the extensions free is called first.)
19315
19316    See regdupe and regdupe_internal if you change anything here.
19317 */
19318 #ifndef PERL_IN_XSUB_RE
19319 void
19320 Perl_pregfree(pTHX_ REGEXP *r)
19321 {
19322     SvREFCNT_dec(r);
19323 }
19324
19325 void
19326 Perl_pregfree2(pTHX_ REGEXP *rx)
19327 {
19328     struct regexp *const r = ReANY(rx);
19329     GET_RE_DEBUG_FLAGS_DECL;
19330
19331     PERL_ARGS_ASSERT_PREGFREE2;
19332
19333     if (r->mother_re) {
19334         ReREFCNT_dec(r->mother_re);
19335     } else {
19336         CALLREGFREE_PVT(rx); /* free the private data */
19337         SvREFCNT_dec(RXp_PAREN_NAMES(r));
19338         Safefree(r->xpv_len_u.xpvlenu_pv);
19339     }
19340     if (r->substrs) {
19341         SvREFCNT_dec(r->anchored_substr);
19342         SvREFCNT_dec(r->anchored_utf8);
19343         SvREFCNT_dec(r->float_substr);
19344         SvREFCNT_dec(r->float_utf8);
19345         Safefree(r->substrs);
19346     }
19347     RX_MATCH_COPY_FREE(rx);
19348 #ifdef PERL_ANY_COW
19349     SvREFCNT_dec(r->saved_copy);
19350 #endif
19351     Safefree(r->offs);
19352     SvREFCNT_dec(r->qr_anoncv);
19353     if (r->recurse_locinput)
19354         Safefree(r->recurse_locinput);
19355     rx->sv_u.svu_rx = 0;
19356 }
19357
19358 /*  reg_temp_copy()
19359
19360     This is a hacky workaround to the structural issue of match results
19361     being stored in the regexp structure which is in turn stored in
19362     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
19363     could be PL_curpm in multiple contexts, and could require multiple
19364     result sets being associated with the pattern simultaneously, such
19365     as when doing a recursive match with (??{$qr})
19366
19367     The solution is to make a lightweight copy of the regexp structure
19368     when a qr// is returned from the code executed by (??{$qr}) this
19369     lightweight copy doesn't actually own any of its data except for
19370     the starp/end and the actual regexp structure itself.
19371
19372 */
19373
19374
19375 REGEXP *
19376 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
19377 {
19378     struct regexp *ret;
19379     struct regexp *const r = ReANY(rx);
19380     const bool islv = ret_x && SvTYPE(ret_x) == SVt_PVLV;
19381
19382     PERL_ARGS_ASSERT_REG_TEMP_COPY;
19383
19384     if (!ret_x)
19385         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
19386     else {
19387         SvOK_off((SV *)ret_x);
19388         if (islv) {
19389             /* For PVLVs, SvANY points to the xpvlv body while sv_u points
19390                to the regexp.  (For SVt_REGEXPs, sv_upgrade has already
19391                made both spots point to the same regexp body.) */
19392             REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP);
19393             assert(!SvPVX(ret_x));
19394             ret_x->sv_u.svu_rx = temp->sv_any;
19395             temp->sv_any = NULL;
19396             SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL;
19397             SvREFCNT_dec_NN(temp);
19398             /* SvCUR still resides in the xpvlv struct, so the regexp copy-
19399                ing below will not set it. */
19400             SvCUR_set(ret_x, SvCUR(rx));
19401         }
19402     }
19403     /* This ensures that SvTHINKFIRST(sv) is true, and hence that
19404        sv_force_normal(sv) is called.  */
19405     SvFAKE_on(ret_x);
19406     ret = ReANY(ret_x);
19407
19408     SvFLAGS(ret_x) |= SvUTF8(rx);
19409     /* We share the same string buffer as the original regexp, on which we
19410        hold a reference count, incremented when mother_re is set below.
19411        The string pointer is copied here, being part of the regexp struct.
19412      */
19413     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
19414            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
19415     if (r->offs) {
19416         const I32 npar = r->nparens+1;
19417         Newx(ret->offs, npar, regexp_paren_pair);
19418         Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19419     }
19420     if (r->substrs) {
19421         Newx(ret->substrs, 1, struct reg_substr_data);
19422         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19423
19424         SvREFCNT_inc_void(ret->anchored_substr);
19425         SvREFCNT_inc_void(ret->anchored_utf8);
19426         SvREFCNT_inc_void(ret->float_substr);
19427         SvREFCNT_inc_void(ret->float_utf8);
19428
19429         /* check_substr and check_utf8, if non-NULL, point to either their
19430            anchored or float namesakes, and don't hold a second reference.  */
19431     }
19432     RX_MATCH_COPIED_off(ret_x);
19433 #ifdef PERL_ANY_COW
19434     ret->saved_copy = NULL;
19435 #endif
19436     ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
19437     SvREFCNT_inc_void(ret->qr_anoncv);
19438     if (r->recurse_locinput)
19439         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19440
19441     return ret_x;
19442 }
19443 #endif
19444
19445 /* regfree_internal()
19446
19447    Free the private data in a regexp. This is overloadable by
19448    extensions. Perl takes care of the regexp structure in pregfree(),
19449    this covers the *pprivate pointer which technically perl doesn't
19450    know about, however of course we have to handle the
19451    regexp_internal structure when no extension is in use.
19452
19453    Note this is called before freeing anything in the regexp
19454    structure.
19455  */
19456
19457 void
19458 Perl_regfree_internal(pTHX_ REGEXP * const rx)
19459 {
19460     struct regexp *const r = ReANY(rx);
19461     RXi_GET_DECL(r,ri);
19462     GET_RE_DEBUG_FLAGS_DECL;
19463
19464     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
19465
19466     DEBUG_COMPILE_r({
19467         if (!PL_colorset)
19468             reginitcolors();
19469         {
19470             SV *dsv= sv_newmortal();
19471             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
19472                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
19473             Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n",
19474                 PL_colors[4],PL_colors[5],s);
19475         }
19476     });
19477 #ifdef RE_TRACK_PATTERN_OFFSETS
19478     if (ri->u.offsets)
19479         Safefree(ri->u.offsets);             /* 20010421 MJD */
19480 #endif
19481     if (ri->code_blocks) {
19482         int n;
19483         for (n = 0; n < ri->num_code_blocks; n++)
19484             SvREFCNT_dec(ri->code_blocks[n].src_regex);
19485         Safefree(ri->code_blocks);
19486     }
19487
19488     if (ri->data) {
19489         int n = ri->data->count;
19490
19491         while (--n >= 0) {
19492           /* If you add a ->what type here, update the comment in regcomp.h */
19493             switch (ri->data->what[n]) {
19494             case 'a':
19495             case 'r':
19496             case 's':
19497             case 'S':
19498             case 'u':
19499                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
19500                 break;
19501             case 'f':
19502                 Safefree(ri->data->data[n]);
19503                 break;
19504             case 'l':
19505             case 'L':
19506                 break;
19507             case 'T':
19508                 { /* Aho Corasick add-on structure for a trie node.
19509                      Used in stclass optimization only */
19510                     U32 refcount;
19511                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
19512 #ifdef USE_ITHREADS
19513                     dVAR;
19514 #endif
19515                     OP_REFCNT_LOCK;
19516                     refcount = --aho->refcount;
19517                     OP_REFCNT_UNLOCK;
19518                     if ( !refcount ) {
19519                         PerlMemShared_free(aho->states);
19520                         PerlMemShared_free(aho->fail);
19521                          /* do this last!!!! */
19522                         PerlMemShared_free(ri->data->data[n]);
19523                         /* we should only ever get called once, so
19524                          * assert as much, and also guard the free
19525                          * which /might/ happen twice. At the least
19526                          * it will make code anlyzers happy and it
19527                          * doesn't cost much. - Yves */
19528                         assert(ri->regstclass);
19529                         if (ri->regstclass) {
19530                             PerlMemShared_free(ri->regstclass);
19531                             ri->regstclass = 0;
19532                         }
19533                     }
19534                 }
19535                 break;
19536             case 't':
19537                 {
19538                     /* trie structure. */
19539                     U32 refcount;
19540                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
19541 #ifdef USE_ITHREADS
19542                     dVAR;
19543 #endif
19544                     OP_REFCNT_LOCK;
19545                     refcount = --trie->refcount;
19546                     OP_REFCNT_UNLOCK;
19547                     if ( !refcount ) {
19548                         PerlMemShared_free(trie->charmap);
19549                         PerlMemShared_free(trie->states);
19550                         PerlMemShared_free(trie->trans);
19551                         if (trie->bitmap)
19552                             PerlMemShared_free(trie->bitmap);
19553                         if (trie->jump)
19554                             PerlMemShared_free(trie->jump);
19555                         PerlMemShared_free(trie->wordinfo);
19556                         /* do this last!!!! */
19557                         PerlMemShared_free(ri->data->data[n]);
19558                     }
19559                 }
19560                 break;
19561             default:
19562                 Perl_croak(aTHX_ "panic: regfree data code '%c'",
19563                                                     ri->data->what[n]);
19564             }
19565         }
19566         Safefree(ri->data->what);
19567         Safefree(ri->data);
19568     }
19569
19570     Safefree(ri);
19571 }
19572
19573 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
19574 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
19575 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
19576
19577 /*
19578    re_dup_guts - duplicate a regexp.
19579
19580    This routine is expected to clone a given regexp structure. It is only
19581    compiled under USE_ITHREADS.
19582
19583    After all of the core data stored in struct regexp is duplicated
19584    the regexp_engine.dupe method is used to copy any private data
19585    stored in the *pprivate pointer. This allows extensions to handle
19586    any duplication it needs to do.
19587
19588    See pregfree() and regfree_internal() if you change anything here.
19589 */
19590 #if defined(USE_ITHREADS)
19591 #ifndef PERL_IN_XSUB_RE
19592 void
19593 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
19594 {
19595     dVAR;
19596     I32 npar;
19597     const struct regexp *r = ReANY(sstr);
19598     struct regexp *ret = ReANY(dstr);
19599
19600     PERL_ARGS_ASSERT_RE_DUP_GUTS;
19601
19602     npar = r->nparens+1;
19603     Newx(ret->offs, npar, regexp_paren_pair);
19604     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
19605
19606     if (ret->substrs) {
19607         /* Do it this way to avoid reading from *r after the StructCopy().
19608            That way, if any of the sv_dup_inc()s dislodge *r from the L1
19609            cache, it doesn't matter.  */
19610         const bool anchored = r->check_substr
19611             ? r->check_substr == r->anchored_substr
19612             : r->check_utf8 == r->anchored_utf8;
19613         Newx(ret->substrs, 1, struct reg_substr_data);
19614         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
19615
19616         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
19617         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
19618         ret->float_substr = sv_dup_inc(ret->float_substr, param);
19619         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
19620
19621         /* check_substr and check_utf8, if non-NULL, point to either their
19622            anchored or float namesakes, and don't hold a second reference.  */
19623
19624         if (ret->check_substr) {
19625             if (anchored) {
19626                 assert(r->check_utf8 == r->anchored_utf8);
19627                 ret->check_substr = ret->anchored_substr;
19628                 ret->check_utf8 = ret->anchored_utf8;
19629             } else {
19630                 assert(r->check_substr == r->float_substr);
19631                 assert(r->check_utf8 == r->float_utf8);
19632                 ret->check_substr = ret->float_substr;
19633                 ret->check_utf8 = ret->float_utf8;
19634             }
19635         } else if (ret->check_utf8) {
19636             if (anchored) {
19637                 ret->check_utf8 = ret->anchored_utf8;
19638             } else {
19639                 ret->check_utf8 = ret->float_utf8;
19640             }
19641         }
19642     }
19643
19644     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
19645     ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
19646     if (r->recurse_locinput)
19647         Newxz(ret->recurse_locinput,r->nparens + 1,char *);
19648
19649     if (ret->pprivate)
19650         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
19651
19652     if (RX_MATCH_COPIED(dstr))
19653         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
19654     else
19655         ret->subbeg = NULL;
19656 #ifdef PERL_ANY_COW
19657     ret->saved_copy = NULL;
19658 #endif
19659
19660     /* Whether mother_re be set or no, we need to copy the string.  We
19661        cannot refrain from copying it when the storage points directly to
19662        our mother regexp, because that's
19663                1: a buffer in a different thread
19664                2: something we no longer hold a reference on
19665                so we need to copy it locally.  */
19666     RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED(sstr), SvCUR(sstr)+1);
19667     ret->mother_re   = NULL;
19668 }
19669 #endif /* PERL_IN_XSUB_RE */
19670
19671 /*
19672    regdupe_internal()
19673
19674    This is the internal complement to regdupe() which is used to copy
19675    the structure pointed to by the *pprivate pointer in the regexp.
19676    This is the core version of the extension overridable cloning hook.
19677    The regexp structure being duplicated will be copied by perl prior
19678    to this and will be provided as the regexp *r argument, however
19679    with the /old/ structures pprivate pointer value. Thus this routine
19680    may override any copying normally done by perl.
19681
19682    It returns a pointer to the new regexp_internal structure.
19683 */
19684
19685 void *
19686 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
19687 {
19688     dVAR;
19689     struct regexp *const r = ReANY(rx);
19690     regexp_internal *reti;
19691     int len;
19692     RXi_GET_DECL(r,ri);
19693
19694     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
19695
19696     len = ProgLen(ri);
19697
19698     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode),
19699           char, regexp_internal);
19700     Copy(ri->program, reti->program, len+1, regnode);
19701
19702
19703     reti->num_code_blocks = ri->num_code_blocks;
19704     if (ri->code_blocks) {
19705         int n;
19706         Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
19707                 struct reg_code_block);
19708         Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
19709                 struct reg_code_block);
19710         for (n = 0; n < ri->num_code_blocks; n++)
19711              reti->code_blocks[n].src_regex = (REGEXP*)
19712                     sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
19713     }
19714     else
19715         reti->code_blocks = NULL;
19716
19717     reti->regstclass = NULL;
19718
19719     if (ri->data) {
19720         struct reg_data *d;
19721         const int count = ri->data->count;
19722         int i;
19723
19724         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
19725                 char, struct reg_data);
19726         Newx(d->what, count, U8);
19727
19728         d->count = count;
19729         for (i = 0; i < count; i++) {
19730             d->what[i] = ri->data->what[i];
19731             switch (d->what[i]) {
19732                 /* see also regcomp.h and regfree_internal() */
19733             case 'a': /* actually an AV, but the dup function is identical.  */
19734             case 'r':
19735             case 's':
19736             case 'S':
19737             case 'u': /* actually an HV, but the dup function is identical.  */
19738                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
19739                 break;
19740             case 'f':
19741                 /* This is cheating. */
19742                 Newx(d->data[i], 1, regnode_ssc);
19743                 StructCopy(ri->data->data[i], d->data[i], regnode_ssc);
19744                 reti->regstclass = (regnode*)d->data[i];
19745                 break;
19746             case 'T':
19747                 /* Trie stclasses are readonly and can thus be shared
19748                  * without duplication. We free the stclass in pregfree
19749                  * when the corresponding reg_ac_data struct is freed.
19750                  */
19751                 reti->regstclass= ri->regstclass;
19752                 /* FALLTHROUGH */
19753             case 't':
19754                 OP_REFCNT_LOCK;
19755                 ((reg_trie_data*)ri->data->data[i])->refcount++;
19756                 OP_REFCNT_UNLOCK;
19757                 /* FALLTHROUGH */
19758             case 'l':
19759             case 'L':
19760                 d->data[i] = ri->data->data[i];
19761                 break;
19762             default:
19763                 Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'",
19764                                                            ri->data->what[i]);
19765             }
19766         }
19767
19768         reti->data = d;
19769     }
19770     else
19771         reti->data = NULL;
19772
19773     reti->name_list_idx = ri->name_list_idx;
19774
19775 #ifdef RE_TRACK_PATTERN_OFFSETS
19776     if (ri->u.offsets) {
19777         Newx(reti->u.offsets, 2*len+1, U32);
19778         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
19779     }
19780 #else
19781     SetProgLen(reti,len);
19782 #endif
19783
19784     return (void*)reti;
19785 }
19786
19787 #endif    /* USE_ITHREADS */
19788
19789 #ifndef PERL_IN_XSUB_RE
19790
19791 /*
19792  - regnext - dig the "next" pointer out of a node
19793  */
19794 regnode *
19795 Perl_regnext(pTHX_ regnode *p)
19796 {
19797     I32 offset;
19798
19799     if (!p)
19800         return(NULL);
19801
19802     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
19803         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d",
19804                                                 (int)OP(p), (int)REGNODE_MAX);
19805     }
19806
19807     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
19808     if (offset == 0)
19809         return(NULL);
19810
19811     return(p+offset);
19812 }
19813 #endif
19814
19815 STATIC void
19816 S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...)
19817 {
19818     va_list args;
19819     STRLEN l1 = strlen(pat1);
19820     STRLEN l2 = strlen(pat2);
19821     char buf[512];
19822     SV *msv;
19823     const char *message;
19824
19825     PERL_ARGS_ASSERT_RE_CROAK2;
19826
19827     if (l1 > 510)
19828         l1 = 510;
19829     if (l1 + l2 > 510)
19830         l2 = 510 - l1;
19831     Copy(pat1, buf, l1 , char);
19832     Copy(pat2, buf + l1, l2 , char);
19833     buf[l1 + l2] = '\n';
19834     buf[l1 + l2 + 1] = '\0';
19835     va_start(args, pat2);
19836     msv = vmess(buf, &args);
19837     va_end(args);
19838     message = SvPV_const(msv,l1);
19839     if (l1 > 512)
19840         l1 = 512;
19841     Copy(message, buf, l1 , char);
19842     /* l1-1 to avoid \n */
19843     Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, l1-1, buf));
19844 }
19845
19846 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
19847
19848 #ifndef PERL_IN_XSUB_RE
19849 void
19850 Perl_save_re_context(pTHX)
19851 {
19852     I32 nparens = -1;
19853     I32 i;
19854
19855     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
19856
19857     if (PL_curpm) {
19858         const REGEXP * const rx = PM_GETRE(PL_curpm);
19859         if (rx)
19860             nparens = RX_NPARENS(rx);
19861     }
19862
19863     /* RT #124109. This is a complete hack; in the SWASHNEW case we know
19864      * that PL_curpm will be null, but that utf8.pm and the modules it
19865      * loads will only use $1..$3.
19866      * The t/porting/re_context.t test file checks this assumption.
19867      */
19868     if (nparens == -1)
19869         nparens = 3;
19870
19871     for (i = 1; i <= nparens; i++) {
19872         char digits[TYPE_CHARS(long)];
19873         const STRLEN len = my_snprintf(digits, sizeof(digits),
19874                                        "%lu", (long)i);
19875         GV *const *const gvp
19876             = (GV**)hv_fetch(PL_defstash, digits, len, 0);
19877
19878         if (gvp) {
19879             GV * const gv = *gvp;
19880             if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
19881                 save_scalar(gv);
19882         }
19883     }
19884 }
19885 #endif
19886
19887 #ifdef DEBUGGING
19888
19889 STATIC void
19890 S_put_code_point(pTHX_ SV *sv, UV c)
19891 {
19892     PERL_ARGS_ASSERT_PUT_CODE_POINT;
19893
19894     if (c > 255) {
19895         Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c);
19896     }
19897     else if (isPRINT(c)) {
19898         const char string = (char) c;
19899
19900         /* We use {phrase} as metanotation in the class, so also escape literal
19901          * braces */
19902         if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}')
19903             sv_catpvs(sv, "\\");
19904         sv_catpvn(sv, &string, 1);
19905     }
19906     else if (isMNEMONIC_CNTRL(c)) {
19907         Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c));
19908     }
19909     else {
19910         Perl_sv_catpvf(aTHX_ sv, "\\x%02X", (U8) c);
19911     }
19912 }
19913
19914 #define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C
19915
19916 STATIC void
19917 S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals)
19918 {
19919     /* Appends to 'sv' a displayable version of the range of code points from
19920      * 'start' to 'end'.  Mnemonics (like '\r') are used for the few controls
19921      * that have them, when they occur at the beginning or end of the range.
19922      * It uses hex to output the remaining code points, unless 'allow_literals'
19923      * is true, in which case the printable ASCII ones are output as-is (though
19924      * some of these will be escaped by put_code_point()).
19925      *
19926      * NOTE:  This is designed only for printing ranges of code points that fit
19927      *        inside an ANYOF bitmap.  Higher code points are simply suppressed
19928      */
19929
19930     const unsigned int min_range_count = 3;
19931
19932     assert(start <= end);
19933
19934     PERL_ARGS_ASSERT_PUT_RANGE;
19935
19936     while (start <= end) {
19937         UV this_end;
19938         const char * format;
19939
19940         if (end - start < min_range_count) {
19941
19942             /* Output chars individually when they occur in short ranges */
19943             for (; start <= end; start++) {
19944                 put_code_point(sv, start);
19945             }
19946             break;
19947         }
19948
19949         /* If permitted by the input options, and there is a possibility that
19950          * this range contains a printable literal, look to see if there is
19951          * one. */
19952         if (allow_literals && start <= MAX_PRINT_A) {
19953
19954             /* If the character at the beginning of the range isn't an ASCII
19955              * printable, effectively split the range into two parts:
19956              *  1) the portion before the first such printable,
19957              *  2) the rest
19958              * and output them separately. */
19959             if (! isPRINT_A(start)) {
19960                 UV temp_end = start + 1;
19961
19962                 /* There is no point looking beyond the final possible
19963                  * printable, in MAX_PRINT_A */
19964                 UV max = MIN(end, MAX_PRINT_A);
19965
19966                 while (temp_end <= max && ! isPRINT_A(temp_end)) {
19967                     temp_end++;
19968                 }
19969
19970                 /* Here, temp_end points to one beyond the first printable if
19971                  * found, or to one beyond 'max' if not.  If none found, make
19972                  * sure that we use the entire range */
19973                 if (temp_end > MAX_PRINT_A) {
19974                     temp_end = end + 1;
19975                 }
19976
19977                 /* Output the first part of the split range: the part that
19978                  * doesn't have printables, with the parameter set to not look
19979                  * for literals (otherwise we would infinitely recurse) */
19980                 put_range(sv, start, temp_end - 1, FALSE);
19981
19982                 /* The 2nd part of the range (if any) starts here. */
19983                 start = temp_end;
19984
19985                 /* We do a continue, instead of dropping down, because even if
19986                  * the 2nd part is non-empty, it could be so short that we want
19987                  * to output it as individual characters, as tested for at the
19988                  * top of this loop.  */
19989                 continue;
19990             }
19991
19992             /* Here, 'start' is a printable ASCII.  If it is an alphanumeric,
19993              * output a sub-range of just the digits or letters, then process
19994              * the remaining portion as usual. */
19995             if (isALPHANUMERIC_A(start)) {
19996                 UV mask = (isDIGIT_A(start))
19997                            ? _CC_DIGIT
19998                              : isUPPER_A(start)
19999                                ? _CC_UPPER
20000                                : _CC_LOWER;
20001                 UV temp_end = start + 1;
20002
20003                 /* Find the end of the sub-range that includes just the
20004                  * characters in the same class as the first character in it */
20005                 while (temp_end <= end && _generic_isCC_A(temp_end, mask)) {
20006                     temp_end++;
20007                 }
20008                 temp_end--;
20009
20010                 /* For short ranges, don't duplicate the code above to output
20011                  * them; just call recursively */
20012                 if (temp_end - start < min_range_count) {
20013                     put_range(sv, start, temp_end, FALSE);
20014                 }
20015                 else {  /* Output as a range */
20016                     put_code_point(sv, start);
20017                     sv_catpvs(sv, "-");
20018                     put_code_point(sv, temp_end);
20019                 }
20020                 start = temp_end + 1;
20021                 continue;
20022             }
20023
20024             /* We output any other printables as individual characters */
20025             if (isPUNCT_A(start) || isSPACE_A(start)) {
20026                 while (start <= end && (isPUNCT_A(start)
20027                                         || isSPACE_A(start)))
20028                 {
20029                     put_code_point(sv, start);
20030                     start++;
20031                 }
20032                 continue;
20033             }
20034         } /* End of looking for literals */
20035
20036         /* Here is not to output as a literal.  Some control characters have
20037          * mnemonic names.  Split off any of those at the beginning and end of
20038          * the range to print mnemonically.  It isn't possible for many of
20039          * these to be in a row, so this won't overwhelm with output */
20040         if (   start <= end
20041             && (isMNEMONIC_CNTRL(start) || isMNEMONIC_CNTRL(end)))
20042         {
20043             while (isMNEMONIC_CNTRL(start) && start <= end) {
20044                 put_code_point(sv, start);
20045                 start++;
20046             }
20047
20048             /* If this didn't take care of the whole range ... */
20049             if (start <= end) {
20050
20051                 /* Look backwards from the end to find the final non-mnemonic
20052                  * */
20053                 UV temp_end = end;
20054                 while (isMNEMONIC_CNTRL(temp_end)) {
20055                     temp_end--;
20056                 }
20057
20058                 /* And separately output the interior range that doesn't start
20059                  * or end with mnemonics */
20060                 put_range(sv, start, temp_end, FALSE);
20061
20062                 /* Then output the mnemonic trailing controls */
20063                 start = temp_end + 1;
20064                 while (start <= end) {
20065                     put_code_point(sv, start);
20066                     start++;
20067                 }
20068                 break;
20069             }
20070         }
20071
20072         /* As a final resort, output the range or subrange as hex. */
20073
20074         this_end = (end < NUM_ANYOF_CODE_POINTS)
20075                     ? end
20076                     : NUM_ANYOF_CODE_POINTS - 1;
20077 #if NUM_ANYOF_CODE_POINTS > 256
20078         format = (this_end < 256)
20079                  ? "\\x%02" UVXf "-\\x%02" UVXf
20080                  : "\\x{%04" UVXf "}-\\x{%04" UVXf "}";
20081 #else
20082         format = "\\x%02" UVXf "-\\x%02" UVXf;
20083 #endif
20084         GCC_DIAG_IGNORE(-Wformat-nonliteral);
20085         Perl_sv_catpvf(aTHX_ sv, format, start, this_end);
20086         GCC_DIAG_RESTORE;
20087         break;
20088     }
20089 }
20090
20091 STATIC void
20092 S_put_charclass_bitmap_innards_invlist(pTHX_ SV *sv, SV* invlist)
20093 {
20094     /* Concatenate onto the PV in 'sv' a displayable form of the inversion list
20095      * 'invlist' */
20096
20097     UV start, end;
20098     bool allow_literals = TRUE;
20099
20100     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_INVLIST;
20101
20102     /* Generally, it is more readable if printable characters are output as
20103      * literals, but if a range (nearly) spans all of them, it's best to output
20104      * it as a single range.  This code will use a single range if all but 2
20105      * ASCII printables are in it */
20106     invlist_iterinit(invlist);
20107     while (invlist_iternext(invlist, &start, &end)) {
20108
20109         /* If the range starts beyond the final printable, it doesn't have any
20110          * in it */
20111         if (start > MAX_PRINT_A) {
20112             break;
20113         }
20114
20115         /* In both ASCII and EBCDIC, a SPACE is the lowest printable.  To span
20116          * all but two, the range must start and end no later than 2 from
20117          * either end */
20118         if (start < ' ' + 2 && end > MAX_PRINT_A - 2) {
20119             if (end > MAX_PRINT_A) {
20120                 end = MAX_PRINT_A;
20121             }
20122             if (start < ' ') {
20123                 start = ' ';
20124             }
20125             if (end - start >= MAX_PRINT_A - ' ' - 2) {
20126                 allow_literals = FALSE;
20127             }
20128             break;
20129         }
20130     }
20131     invlist_iterfinish(invlist);
20132
20133     /* Here we have figured things out.  Output each range */
20134     invlist_iterinit(invlist);
20135     while (invlist_iternext(invlist, &start, &end)) {
20136         if (start >= NUM_ANYOF_CODE_POINTS) {
20137             break;
20138         }
20139         put_range(sv, start, end, allow_literals);
20140     }
20141     invlist_iterfinish(invlist);
20142
20143     return;
20144 }
20145
20146 STATIC SV*
20147 S_put_charclass_bitmap_innards_common(pTHX_
20148         SV* invlist,            /* The bitmap */
20149         SV* posixes,            /* Under /l, things like [:word:], \S */
20150         SV* only_utf8,          /* Under /d, matches iff the target is UTF-8 */
20151         SV* not_utf8,           /* /d, matches iff the target isn't UTF-8 */
20152         SV* only_utf8_locale,   /* Under /l, matches if the locale is UTF-8 */
20153         const bool invert       /* Is the result to be inverted? */
20154 )
20155 {
20156     /* Create and return an SV containing a displayable version of the bitmap
20157      * and associated information determined by the input parameters.  If the
20158      * output would have been only the inversion indicator '^', NULL is instead
20159      * returned. */
20160
20161     SV * output;
20162
20163     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS_COMMON;
20164
20165     if (invert) {
20166         output = newSVpvs("^");
20167     }
20168     else {
20169         output = newSVpvs("");
20170     }
20171
20172     /* First, the code points in the bitmap that are unconditionally there */
20173     put_charclass_bitmap_innards_invlist(output, invlist);
20174
20175     /* Traditionally, these have been placed after the main code points */
20176     if (posixes) {
20177         sv_catsv(output, posixes);
20178     }
20179
20180     if (only_utf8 && _invlist_len(only_utf8)) {
20181         Perl_sv_catpvf(aTHX_ output, "%s{utf8}%s", PL_colors[1], PL_colors[0]);
20182         put_charclass_bitmap_innards_invlist(output, only_utf8);
20183     }
20184
20185     if (not_utf8 && _invlist_len(not_utf8)) {
20186         Perl_sv_catpvf(aTHX_ output, "%s{not utf8}%s", PL_colors[1], PL_colors[0]);
20187         put_charclass_bitmap_innards_invlist(output, not_utf8);
20188     }
20189
20190     if (only_utf8_locale && _invlist_len(only_utf8_locale)) {
20191         Perl_sv_catpvf(aTHX_ output, "%s{utf8 locale}%s", PL_colors[1], PL_colors[0]);
20192         put_charclass_bitmap_innards_invlist(output, only_utf8_locale);
20193
20194         /* This is the only list in this routine that can legally contain code
20195          * points outside the bitmap range.  The call just above to
20196          * 'put_charclass_bitmap_innards_invlist' will simply suppress them, so
20197          * output them here.  There's about a half-dozen possible, and none in
20198          * contiguous ranges longer than 2 */
20199         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20200             UV start, end;
20201             SV* above_bitmap = NULL;
20202
20203             _invlist_subtract(only_utf8_locale, PL_InBitmap, &above_bitmap);
20204
20205             invlist_iterinit(above_bitmap);
20206             while (invlist_iternext(above_bitmap, &start, &end)) {
20207                 UV i;
20208
20209                 for (i = start; i <= end; i++) {
20210                     put_code_point(output, i);
20211                 }
20212             }
20213             invlist_iterfinish(above_bitmap);
20214             SvREFCNT_dec_NN(above_bitmap);
20215         }
20216     }
20217
20218     if (invert && SvCUR(output) == 1) {
20219         return NULL;
20220     }
20221
20222     return output;
20223 }
20224
20225 STATIC bool
20226 S_put_charclass_bitmap_innards(pTHX_ SV *sv,
20227                                      char *bitmap,
20228                                      SV *nonbitmap_invlist,
20229                                      SV *only_utf8_locale_invlist,
20230                                      const regnode * const node,
20231                                      const bool force_as_is_display)
20232 {
20233     /* Appends to 'sv' a displayable version of the innards of the bracketed
20234      * character class defined by the other arguments:
20235      *  'bitmap' points to the bitmap.
20236      *  'nonbitmap_invlist' is an inversion list of the code points that are in
20237      *      the bitmap range, but for some reason aren't in the bitmap; NULL if
20238      *      none.  The reasons for this could be that they require some
20239      *      condition such as the target string being or not being in UTF-8
20240      *      (under /d), or because they came from a user-defined property that
20241      *      was not resolved at the time of the regex compilation (under /u)
20242      *  'only_utf8_locale_invlist' is an inversion list of the code points that
20243      *      are valid only if the runtime locale is a UTF-8 one; NULL if none
20244      *  'node' is the regex pattern node.  It is needed only when the above two
20245      *      parameters are not null, and is passed so that this routine can
20246      *      tease apart the various reasons for them.
20247      *  'force_as_is_display' is TRUE if this routine should definitely NOT try
20248      *      to invert things to see if that leads to a cleaner display.  If
20249      *      FALSE, this routine is free to use its judgment about doing this.
20250      *
20251      * It returns TRUE if there was actually something output.  (It may be that
20252      * the bitmap, etc is empty.)
20253      *
20254      * When called for outputting the bitmap of a non-ANYOF node, just pass the
20255      * bitmap, with the succeeding parameters set to NULL, and the final one to
20256      * FALSE.
20257      */
20258
20259     /* In general, it tries to display the 'cleanest' representation of the
20260      * innards, choosing whether to display them inverted or not, regardless of
20261      * whether the class itself is to be inverted.  However,  there are some
20262      * cases where it can't try inverting, as what actually matches isn't known
20263      * until runtime, and hence the inversion isn't either. */
20264     bool inverting_allowed = ! force_as_is_display;
20265
20266     int i;
20267     STRLEN orig_sv_cur = SvCUR(sv);
20268
20269     SV* invlist;            /* Inversion list we accumulate of code points that
20270                                are unconditionally matched */
20271     SV* only_utf8 = NULL;   /* Under /d, list of matches iff the target is
20272                                UTF-8 */
20273     SV* not_utf8 =  NULL;   /* /d, list of matches iff the target isn't UTF-8
20274                              */
20275     SV* posixes = NULL;     /* Under /l, string of things like [:word:], \D */
20276     SV* only_utf8_locale = NULL;    /* Under /l, list of matches if the locale
20277                                        is UTF-8 */
20278
20279     SV* as_is_display;      /* The output string when we take the inputs
20280                                literally */
20281     SV* inverted_display;   /* The output string when we invert the inputs */
20282
20283     U8 flags = (node) ? ANYOF_FLAGS(node) : 0;
20284
20285     bool invert = cBOOL(flags & ANYOF_INVERT);  /* Is the input to be inverted
20286                                                    to match? */
20287     /* We are biased in favor of displaying things without them being inverted,
20288      * as that is generally easier to understand */
20289     const int bias = 5;
20290
20291     PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS;
20292
20293     /* Start off with whatever code points are passed in.  (We clone, so we
20294      * don't change the caller's list) */
20295     if (nonbitmap_invlist) {
20296         assert(invlist_highest(nonbitmap_invlist) < NUM_ANYOF_CODE_POINTS);
20297         invlist = invlist_clone(nonbitmap_invlist);
20298     }
20299     else {  /* Worst case size is every other code point is matched */
20300         invlist = _new_invlist(NUM_ANYOF_CODE_POINTS / 2);
20301     }
20302
20303     if (flags) {
20304         if (OP(node) == ANYOFD) {
20305
20306             /* This flag indicates that the code points below 0x100 in the
20307              * nonbitmap list are precisely the ones that match only when the
20308              * target is UTF-8 (they should all be non-ASCII). */
20309             if (flags & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)
20310             {
20311                 _invlist_intersection(invlist, PL_UpperLatin1, &only_utf8);
20312                 _invlist_subtract(invlist, only_utf8, &invlist);
20313             }
20314
20315             /* And this flag for matching all non-ASCII 0xFF and below */
20316             if (flags & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER)
20317             {
20318                 not_utf8 = invlist_clone(PL_UpperLatin1);
20319             }
20320         }
20321         else if (OP(node) == ANYOFL) {
20322
20323             /* If either of these flags are set, what matches isn't
20324              * determinable except during execution, so don't know enough here
20325              * to invert */
20326             if (flags & (ANYOFL_FOLD|ANYOF_MATCHES_POSIXL)) {
20327                 inverting_allowed = FALSE;
20328             }
20329
20330             /* What the posix classes match also varies at runtime, so these
20331              * will be output symbolically. */
20332             if (ANYOF_POSIXL_TEST_ANY_SET(node)) {
20333                 int i;
20334
20335                 posixes = newSVpvs("");
20336                 for (i = 0; i < ANYOF_POSIXL_MAX; i++) {
20337                     if (ANYOF_POSIXL_TEST(node,i)) {
20338                         sv_catpv(posixes, anyofs[i]);
20339                     }
20340                 }
20341             }
20342         }
20343     }
20344
20345     /* Accumulate the bit map into the unconditional match list */
20346     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
20347         if (BITMAP_TEST(bitmap, i)) {
20348             int start = i++;
20349             for (; i < NUM_ANYOF_CODE_POINTS && BITMAP_TEST(bitmap, i); i++) {
20350                 /* empty */
20351             }
20352             invlist = _add_range_to_invlist(invlist, start, i-1);
20353         }
20354     }
20355
20356     /* Make sure that the conditional match lists don't have anything in them
20357      * that match unconditionally; otherwise the output is quite confusing.
20358      * This could happen if the code that populates these misses some
20359      * duplication. */
20360     if (only_utf8) {
20361         _invlist_subtract(only_utf8, invlist, &only_utf8);
20362     }
20363     if (not_utf8) {
20364         _invlist_subtract(not_utf8, invlist, &not_utf8);
20365     }
20366
20367     if (only_utf8_locale_invlist) {
20368
20369         /* Since this list is passed in, we have to make a copy before
20370          * modifying it */
20371         only_utf8_locale = invlist_clone(only_utf8_locale_invlist);
20372
20373         _invlist_subtract(only_utf8_locale, invlist, &only_utf8_locale);
20374
20375         /* And, it can get really weird for us to try outputting an inverted
20376          * form of this list when it has things above the bitmap, so don't even
20377          * try */
20378         if (invlist_highest(only_utf8_locale) >= NUM_ANYOF_CODE_POINTS) {
20379             inverting_allowed = FALSE;
20380         }
20381     }
20382
20383     /* Calculate what the output would be if we take the input as-is */
20384     as_is_display = put_charclass_bitmap_innards_common(invlist,
20385                                                     posixes,
20386                                                     only_utf8,
20387                                                     not_utf8,
20388                                                     only_utf8_locale,
20389                                                     invert);
20390
20391     /* If have to take the output as-is, just do that */
20392     if (! inverting_allowed) {
20393         if (as_is_display) {
20394             sv_catsv(sv, as_is_display);
20395             SvREFCNT_dec_NN(as_is_display);
20396         }
20397     }
20398     else { /* But otherwise, create the output again on the inverted input, and
20399               use whichever version is shorter */
20400
20401         int inverted_bias, as_is_bias;
20402
20403         /* We will apply our bias to whichever of the the results doesn't have
20404          * the '^' */
20405         if (invert) {
20406             invert = FALSE;
20407             as_is_bias = bias;
20408             inverted_bias = 0;
20409         }
20410         else {
20411             invert = TRUE;
20412             as_is_bias = 0;
20413             inverted_bias = bias;
20414         }
20415
20416         /* Now invert each of the lists that contribute to the output,
20417          * excluding from the result things outside the possible range */
20418
20419         /* For the unconditional inversion list, we have to add in all the
20420          * conditional code points, so that when inverted, they will be gone
20421          * from it */
20422         _invlist_union(only_utf8, invlist, &invlist);
20423         _invlist_union(not_utf8, invlist, &invlist);
20424         _invlist_union(only_utf8_locale, invlist, &invlist);
20425         _invlist_invert(invlist);
20426         _invlist_intersection(invlist, PL_InBitmap, &invlist);
20427
20428         if (only_utf8) {
20429             _invlist_invert(only_utf8);
20430             _invlist_intersection(only_utf8, PL_UpperLatin1, &only_utf8);
20431         }
20432         else if (not_utf8) {
20433
20434             /* If a code point matches iff the target string is not in UTF-8,
20435              * then complementing the result has it not match iff not in UTF-8,
20436              * which is the same thing as matching iff it is UTF-8. */
20437             only_utf8 = not_utf8;
20438             not_utf8 = NULL;
20439         }
20440
20441         if (only_utf8_locale) {
20442             _invlist_invert(only_utf8_locale);
20443             _invlist_intersection(only_utf8_locale,
20444                                   PL_InBitmap,
20445                                   &only_utf8_locale);
20446         }
20447
20448         inverted_display = put_charclass_bitmap_innards_common(
20449                                             invlist,
20450                                             posixes,
20451                                             only_utf8,
20452                                             not_utf8,
20453                                             only_utf8_locale, invert);
20454
20455         /* Use the shortest representation, taking into account our bias
20456          * against showing it inverted */
20457         if (   inverted_display
20458             && (   ! as_is_display
20459                 || (  SvCUR(inverted_display) + inverted_bias
20460                     < SvCUR(as_is_display)    + as_is_bias)))
20461         {
20462             sv_catsv(sv, inverted_display);
20463         }
20464         else if (as_is_display) {
20465             sv_catsv(sv, as_is_display);
20466         }
20467
20468         SvREFCNT_dec(as_is_display);
20469         SvREFCNT_dec(inverted_display);
20470     }
20471
20472     SvREFCNT_dec_NN(invlist);
20473     SvREFCNT_dec(only_utf8);
20474     SvREFCNT_dec(not_utf8);
20475     SvREFCNT_dec(posixes);
20476     SvREFCNT_dec(only_utf8_locale);
20477
20478     return SvCUR(sv) > orig_sv_cur;
20479 }
20480
20481 #define CLEAR_OPTSTART                                                       \
20482     if (optstart) STMT_START {                                               \
20483         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_                                           \
20484                               " (%" IVdf " nodes)\n", (IV)(node - optstart))); \
20485         optstart=NULL;                                                       \
20486     } STMT_END
20487
20488 #define DUMPUNTIL(b,e)                                                       \
20489                     CLEAR_OPTSTART;                                          \
20490                     node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
20491
20492 STATIC const regnode *
20493 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
20494             const regnode *last, const regnode *plast,
20495             SV* sv, I32 indent, U32 depth)
20496 {
20497     U8 op = PSEUDO;     /* Arbitrary non-END op. */
20498     const regnode *next;
20499     const regnode *optstart= NULL;
20500
20501     RXi_GET_DECL(r,ri);
20502     GET_RE_DEBUG_FLAGS_DECL;
20503
20504     PERL_ARGS_ASSERT_DUMPUNTIL;
20505
20506 #ifdef DEBUG_DUMPUNTIL
20507     Perl_re_printf( aTHX_  "--- %d : %d - %d - %d\n",indent,node-start,
20508         last ? last-start : 0,plast ? plast-start : 0);
20509 #endif
20510
20511     if (plast && plast < last)
20512         last= plast;
20513
20514     while (PL_regkind[op] != END && (!last || node < last)) {
20515         assert(node);
20516         /* While that wasn't END last time... */
20517         NODE_ALIGN(node);
20518         op = OP(node);
20519         if (op == CLOSE || op == WHILEM)
20520             indent--;
20521         next = regnext((regnode *)node);
20522
20523         /* Where, what. */
20524         if (OP(node) == OPTIMIZED) {
20525             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
20526                 optstart = node;
20527             else
20528                 goto after_print;
20529         } else
20530             CLEAR_OPTSTART;
20531
20532         regprop(r, sv, node, NULL, NULL);
20533         Perl_re_printf( aTHX_  "%4" IVdf ":%*s%s", (IV)(node - start),
20534                       (int)(2*indent + 1), "", SvPVX_const(sv));
20535
20536         if (OP(node) != OPTIMIZED) {
20537             if (next == NULL)           /* Next ptr. */
20538                 Perl_re_printf( aTHX_  " (0)");
20539             else if (PL_regkind[(U8)op] == BRANCH
20540                      && PL_regkind[OP(next)] != BRANCH )
20541                 Perl_re_printf( aTHX_  " (FAIL)");
20542             else
20543                 Perl_re_printf( aTHX_  " (%" IVdf ")", (IV)(next - start));
20544             Perl_re_printf( aTHX_ "\n");
20545         }
20546
20547       after_print:
20548         if (PL_regkind[(U8)op] == BRANCHJ) {
20549             assert(next);
20550             {
20551                 const regnode *nnode = (OP(next) == LONGJMP
20552                                        ? regnext((regnode *)next)
20553                                        : next);
20554                 if (last && nnode > last)
20555                     nnode = last;
20556                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
20557             }
20558         }
20559         else if (PL_regkind[(U8)op] == BRANCH) {
20560             assert(next);
20561             DUMPUNTIL(NEXTOPER(node), next);
20562         }
20563         else if ( PL_regkind[(U8)op]  == TRIE ) {
20564             const regnode *this_trie = node;
20565             const char op = OP(node);
20566             const U32 n = ARG(node);
20567             const reg_ac_data * const ac = op>=AHOCORASICK ?
20568                (reg_ac_data *)ri->data->data[n] :
20569                NULL;
20570             const reg_trie_data * const trie =
20571                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
20572 #ifdef DEBUGGING
20573             AV *const trie_words
20574                            = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
20575 #endif
20576             const regnode *nextbranch= NULL;
20577             I32 word_idx;
20578             SvPVCLEAR(sv);
20579             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
20580                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
20581
20582                 Perl_re_indentf( aTHX_  "%s ",
20583                     indent+3,
20584                     elem_ptr
20585                     ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr),
20586                                 SvCUR(*elem_ptr), 60,
20587                                 PL_colors[0], PL_colors[1],
20588                                 (SvUTF8(*elem_ptr)
20589                                  ? PERL_PV_ESCAPE_UNI
20590                                  : 0)
20591                                 | PERL_PV_PRETTY_ELLIPSES
20592                                 | PERL_PV_PRETTY_LTGT
20593                             )
20594                     : "???"
20595                 );
20596                 if (trie->jump) {
20597                     U16 dist= trie->jump[word_idx+1];
20598                     Perl_re_printf( aTHX_  "(%" UVuf ")\n",
20599                                (UV)((dist ? this_trie + dist : next) - start));
20600                     if (dist) {
20601                         if (!nextbranch)
20602                             nextbranch= this_trie + trie->jump[0];
20603                         DUMPUNTIL(this_trie + dist, nextbranch);
20604                     }
20605                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
20606                         nextbranch= regnext((regnode *)nextbranch);
20607                 } else {
20608                     Perl_re_printf( aTHX_  "\n");
20609                 }
20610             }
20611             if (last && next > last)
20612                 node= last;
20613             else
20614                 node= next;
20615         }
20616         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
20617             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
20618                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
20619         }
20620         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
20621             assert(next);
20622             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
20623         }
20624         else if ( op == PLUS || op == STAR) {
20625             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
20626         }
20627         else if (PL_regkind[(U8)op] == ANYOF) {
20628             /* arglen 1 + class block */
20629             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL)
20630                           ? ANYOF_POSIXL_SKIP
20631                           : ANYOF_SKIP);
20632             node = NEXTOPER(node);
20633         }
20634         else if (PL_regkind[(U8)op] == EXACT) {
20635             /* Literal string, where present. */
20636             node += NODE_SZ_STR(node) - 1;
20637             node = NEXTOPER(node);
20638         }
20639         else {
20640             node = NEXTOPER(node);
20641             node += regarglen[(U8)op];
20642         }
20643         if (op == CURLYX || op == OPEN)
20644             indent++;
20645     }
20646     CLEAR_OPTSTART;
20647 #ifdef DEBUG_DUMPUNTIL
20648     Perl_re_printf( aTHX_  "--- %d\n", (int)indent);
20649 #endif
20650     return node;
20651 }
20652
20653 #endif  /* DEBUGGING */
20654
20655 /*
20656  * ex: set ts=8 sts=4 sw=4 et:
20657  */